ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add (guix diagnostics).

Browse source 
* guix/ui.scm (warning, info, report-error, leave)
(location->string, guix-warning-port, program-name)
(highlight-argument, %highlight-argument, define-diagnostic)
(%warning-color, %info-color, %error-color)
(print-diagnostic-prefix): Move to...
* guix/diagnostics.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.
This commit is contained in:
Ludovic Courtès 2019-06-03 22:58:36 +02:00
parent ee2691fa33
commit 1b5ee3bdaa
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 185 additions and 141 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -144,6 +144,7 @@ MODULES = \
guix/svn-download.scm \
guix/colors.scm \
guix/i18n.scm \
guix/diagnostics.scm \
guix/ui.scm \
guix/status.scm \
guix/build/android-ndk-build-system.scm \

173
guix/diagnostics.scm Normal file
View file

@ -0,0 +1,173 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix diagnostics)
#:use-module (guix colors)
#:use-module (guix i18n)
#:autoload (guix utils) (<location>)
#:use-module (srfi srfi-26)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (warning
info
report-error
leave
location->string
guix-warning-port
program-name))
;;; Commentary:
;;;
;;; This module provides the tools to report diagnostics to the user in a
;;; consistent way: errors, warnings, and notes.
;;;
;;; Code:
(define-syntax highlight-argument
(lambda (s)
"Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
is a trivial format string."
(define (trivial-format-string? fmt)
(define len
(string-length fmt))
(let loop ((start 0))
(or (>= (+ 1 start) len)
(let ((tilde (string-index fmt #\~ start)))
(or (not tilde)
(case (string-ref fmt (+ tilde 1))
((#\a #\A #\%) (loop (+ tilde 2)))
(else #f)))))))
;; Be conservative: limit format argument highlighting to cases where the
;; format string contains nothing but ~a escapes. If it contained ~s
;; escapes, this strategy wouldn't work.
(syntax-case s ()
((_ "~a~%" arg) ;don't highlight whole messages
#'arg)
((_ fmt arg)
(trivial-format-string? (syntax->datum #'fmt))
#'(%highlight-argument arg))
((_ fmt arg)
#'arg))))
(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
"Highlight ARG, a format string argument, if PORT supports colors."
(cond ((string? arg)
(highlight arg port))
((symbol? arg)
(highlight (symbol->string arg) port))
(else arg)))
(define-syntax define-diagnostic
(syntax-rules ()
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
messages."
((_ name (G_ prefix) colors)
(define-syntax name
(lambda (x)
(syntax-case x ()
((name location (underscore fmt) args (... ...))
(and (string? (syntax->datum #'fmt))
(free-identifier=? #'underscore #'G_))
#'(begin
(print-diagnostic-prefix prefix location
#:colors colors)
(format (guix-warning-port) (gettext fmt %gettext-domain)
(highlight-argument fmt args) (... ...))))
((name location (N-underscore singular plural n)
args (... ...))
(and (string? (syntax->datum #'singular))
(string? (syntax->datum #'plural))
(free-identifier=? #'N-underscore #'N_))
#'(begin
(print-diagnostic-prefix prefix location
#:colors colors)
(format (guix-warning-port)
(ngettext singular plural n %gettext-domain)
(highlight-argument singular args) (... ...))))
((name (underscore fmt) args (... ...))
(free-identifier=? #'underscore #'G_)
#'(name #f (underscore fmt) args (... ...)))
((name (N-underscore singular plural n)
args (... ...))
(free-identifier=? #'N-underscore #'N_)
#'(name #f (N-underscore singular plural n)
args (... ...)))))))))
;; XXX: This doesn't work well for right-to-left languages.
;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
;; "~a" is a placeholder for that phrase.
(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
(define-diagnostic info (G_ "") %info-color)
(define-diagnostic report-error (G_ "error: ") %error-color)
(define-syntax-rule (leave args ...)
"Emit an error message and exit."
(begin
(report-error args ...)
(exit 1)))
(define %warning-color (color BOLD MAGENTA))
(define %info-color (color BOLD))
(define %error-color (color BOLD RED))
(define* (print-diagnostic-prefix prefix #:optional location
#:key (colors (color)))
"Print PREFIX as a diagnostic line prefix."
(define color?
(color-output? (guix-warning-port)))
(define location-color
(if color?
(cut colorize-string <> (color BOLD))
identity))
(define prefix-color
(if color?
(lambda (prefix)
(colorize-string prefix colors))
identity))
(let ((prefix (if (string-null? prefix)
prefix
(gettext prefix %gettext-domain))))
(if location
(format (guix-warning-port) "~a: ~a"
(location-color (location->string location))
(prefix-color prefix))
(format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
(program-name) (program-name)
(prefix-color prefix)))))
(define (location->string loc)
"Return a human-friendly, GNU-standard representation of LOC."
(match loc
(#f (G_ "<unknown location>"))
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
(define guix-warning-port
(make-parameter (current-warning-port)))
(define program-name
;; Name of the command-line program currently executing, or #f.
(make-parameter #f))

152
guix/ui.scm
View file

@ -32,6 +32,7 @@
(define-module (guix ui)
#:use-module (guix i18n)
#:use-module (guix colors)
#:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (guix utils)
@ -70,10 +71,14 @@ (define-module (guix ui)
#:use-module (texinfo)
#:use-module (texinfo plain-text)
#:use-module (texinfo string-utils)
#:re-export (G_ N_ P_) ;backward compatibility
#:export (report-error
display-hint
leave
;; Re-exports for backward compatibility.
#:re-export (G_ N_ P_ ;now in (guix i18n)
warning info report-error leave ;now in (guix diagnostics)
location->string
guix-warning-port program-name)
#:export (display-hint
make-user-module
load*
warn-about-load-error
@ -93,7 +98,6 @@ (define-module (guix ui)
read/eval
read/eval-package-expression
check-available-space
location->string
fill-paragraph
%text-width
texi->plain-text
@ -115,10 +119,6 @@ (define-module (guix ui)
delete-generation*
run-guix-command
run-guix
program-name
guix-warning-port
warning
info
guix-main))
;;; Commentary:
@ -127,124 +127,6 @@ (define-module (guix ui)
;;;
;;; Code:
(define-syntax highlight-argument
(lambda (s)
"Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
is a trivial format string."
(define (trivial-format-string? fmt)
(define len
(string-length fmt))
(let loop ((start 0))
(or (>= (+ 1 start) len)
(let ((tilde (string-index fmt #\~ start)))
(or (not tilde)
(case (string-ref fmt (+ tilde 1))
((#\a #\A #\%) (loop (+ tilde 2)))
(else #f)))))))
;; Be conservative: limit format argument highlighting to cases where the
;; format string contains nothing but ~a escapes. If it contained ~s
;; escapes, this strategy wouldn't work.
(syntax-case s ()
((_ "~a~%" arg) ;don't highlight whole messages
#'arg)
((_ fmt arg)
(trivial-format-string? (syntax->datum #'fmt))
#'(%highlight-argument arg))
((_ fmt arg)
#'arg))))
(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
"Highlight ARG, a format string argument, if PORT supports colors."
(cond ((string? arg)
(highlight arg port))
((symbol? arg)
(highlight (symbol->string arg) port))
(else arg)))
(define-syntax define-diagnostic
(syntax-rules ()
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
messages."
((_ name (G_ prefix) colors)
(define-syntax name
(lambda (x)
(syntax-case x ()
((name location (underscore fmt) args (... ...))
(and (string? (syntax->datum #'fmt))
(free-identifier=? #'underscore #'G_))
#'(begin
(print-diagnostic-prefix prefix location
#:colors colors)
(format (guix-warning-port) (gettext fmt %gettext-domain)
(highlight-argument fmt args) (... ...))))
((name location (N-underscore singular plural n)
args (... ...))
(and (string? (syntax->datum #'singular))
(string? (syntax->datum #'plural))
(free-identifier=? #'N-underscore #'N_))
#'(begin
(print-diagnostic-prefix prefix location
#:colors colors)
(format (guix-warning-port)
(ngettext singular plural n %gettext-domain)
(highlight-argument singular args) (... ...))))
((name (underscore fmt) args (... ...))
(free-identifier=? #'underscore #'G_)
#'(name #f (underscore fmt) args (... ...)))
((name (N-underscore singular plural n)
args (... ...))
(free-identifier=? #'N-underscore #'N_)
#'(name #f (N-underscore singular plural n)
args (... ...)))))))))
;; XXX: This doesn't work well for right-to-left languages.
;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
;; "~a" is a placeholder for that phrase.
(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
(define-diagnostic info (G_ "") %info-color)
(define-diagnostic report-error (G_ "error: ") %error-color)
(define-syntax-rule (leave args ...)
"Emit an error message and exit."
(begin
(report-error args ...)
(exit 1)))
(define %warning-color (color BOLD MAGENTA))
(define %info-color (color BOLD))
(define %error-color (color BOLD RED))
(define %hint-color (color BOLD CYAN))
(define* (print-diagnostic-prefix prefix #:optional location
#:key (colors (color)))
"Print PREFIX as a diagnostic line prefix."
(define color?
(color-output? (guix-warning-port)))
(define location-color
(if color?
(cut colorize-string <> (color BOLD))
identity))
(define prefix-color
(if color?
(lambda (prefix)
(colorize-string prefix colors))
identity))
(let ((prefix (if (string-null? prefix)
prefix
(gettext prefix %gettext-domain))))
(if location
(format (guix-warning-port) "~a: ~a"
(location-color (location->string location))
(prefix-color prefix))
(format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
(program-name) (program-name)
(prefix-color prefix)))))
(define (print-unbound-variable-error port key args default-printer)
;; Print unbound variable errors more nicely, and in the right language.
(match args
@ -393,6 +275,8 @@ (define (module<? m1 m2)
(('gnu _ ...) head) ;must be that one
(_ (loop next (cons head suggestions) visited)))))))))))
(define %hint-color (color BOLD CYAN))
(define* (display-hint message #:optional (port (current-error-port)))
"Display MESSAGE, a l10n message possibly containing Texinfo markup, to
PORT."
@ -1192,13 +1076,6 @@ (define-syntax with-error-handling
(lambda ()
body ...)))))
(define (location->string loc)
"Return a human-friendly, GNU-standard representation of LOC."
(match loc
(#f (G_ "<unknown location>"))
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
@ -1720,10 +1597,6 @@ (define (internal? command)
string<?))
(show-bug-report-information))
(define program-name
;; Name of the command-line program currently executing, or #f.
(make-parameter #f))
(define (run-guix-command command . args)
"Run COMMAND with the given ARGS. Report an error when COMMAND is not
found."
@ -1783,9 +1656,6 @@ (define option? (cut string-prefix? "-" <>))
(string->symbol command)
args))))
(define guix-warning-port
(make-parameter (current-warning-port)))
(define (guix-main arg0 . args)
(initialize-guix)
(apply run-guix args))