nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui: Diagnostic procedures can display error location. 

* guix/ui.scm (define-diagnostic): Add optional 'location' parameter.
Pass it to 'print-diagnostic-prefix'.
(print-diagnostic-prefix): Add optional 'location' parameter and honor
it.
(report-load-error): Use 'report-error' and 'warning' instead
of (format (current-error-port) …).
This commit is contained in:
Ludovic Courtès 2019-04-10 11:14:25 +02:00
parent cc3697d543
commit 402627714b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 33 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
guix/ui.scm
View File

@ -132,22 +132,31 @@ messages."
(define-syntax name (define-syntax name
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((name (underscore fmt) args (... ...)) ((name location (underscore fmt) args (... ...))
(and (string? (syntax->datum #'fmt)) (and (string? (syntax->datum #'fmt))
(free-identifier=? #'underscore #'G_)) (free-identifier=? #'underscore #'G_))
#'(begin #'(begin
(print-diagnostic-prefix prefix) (print-diagnostic-prefix prefix location)
(format (guix-warning-port) (gettext fmt %gettext-domain) (format (guix-warning-port) (gettext fmt %gettext-domain)
args (... ...)))) args (... ...))))
((name (N-underscore singular plural n) args (... ...)) ((name location (N-underscore singular plural n)
args (... ...))
(and (string? (syntax->datum #'singular)) (and (string? (syntax->datum #'singular))
(string? (syntax->datum #'plural)) (string? (syntax->datum #'plural))
(free-identifier=? #'N-underscore #'N_)) (free-identifier=? #'N-underscore #'N_))
#'(begin #'(begin
(print-diagnostic-prefix prefix) (print-diagnostic-prefix prefix location)
(format (guix-warning-port) (format (guix-warning-port)
(ngettext singular plural n %gettext-domain) (ngettext singular plural n %gettext-domain)
args (... ...)))))))))) 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. ;; XXX: This doesn't work well for right-to-left languages.
;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
@ -162,13 +171,16 @@ messages."
(report-error args ...) (report-error args ...)
(exit 1))) (exit 1)))
(define (print-diagnostic-prefix prefix) (define* (print-diagnostic-prefix prefix #:optional location)
"Print PREFIX as a diagnostic line prefix." "Print PREFIX as a diagnostic line prefix."
(format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" (let ((prefix (if (string-null? prefix)
(program-name) (program-name) prefix
(if (string-null? prefix) (gettext prefix %gettext-domain))))
prefix (if location
(gettext prefix %gettext-domain)))) (format (guix-warning-port) "~a: ~a"
(location->string location) prefix)
(format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
(program-name) (program-name) prefix))))
(define (print-unbound-variable-error port key args default-printer) (define (print-unbound-variable-error port key args default-printer)
;; Print unbound variable errors more nicely, and in the right language. ;; Print unbound variable errors more nicely, and in the right language.
@ -360,21 +372,15 @@ ARGS is the list of arguments received by the 'throw' handler."
(apply throw args))) (apply throw args)))
(('syntax-error proc message properties form . rest) (('syntax-error proc message properties form . rest)
(let ((loc (source-properties->location properties))) (let ((loc (source-properties->location properties)))
(format (current-error-port) (G_ "~a: error: ~a~%") (report-error loc (G_ "~a~%") message)))
(location->string loc) message)))
(('unbound-variable _ ...) (('unbound-variable _ ...)
(report-unbound-variable-error args #:frame frame)) (report-unbound-variable-error args #:frame frame))
(('srfi-34 obj) (('srfi-34 obj)
(if (message-condition? obj) (if (message-condition? obj)
(if (error-location? obj) (report-error (and (error-location? obj)
(format (current-error-port) (error-location obj))
(G_ "~a: error: ~a~%") (G_ "~a~%")
(location->string (error-location obj)) (gettext (condition-message obj) %gettext-domain))
(gettext (condition-message obj)
%gettext-domain))
(report-error (G_ "~a~%")
(gettext (condition-message obj)
%gettext-domain)))
(report-error (G_ "exception thrown: ~s~%") obj)) (report-error (G_ "exception thrown: ~s~%") obj))
(when (fix-hint? obj) (when (fix-hint? obj)
(display-hint (condition-fix-hint obj)))) (display-hint (condition-fix-hint obj))))
@ -398,8 +404,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler."
(warning (G_ "failed to load '~a': ~a~%") file (strerror err)))) (warning (G_ "failed to load '~a': ~a~%") file (strerror err))))
(('syntax-error proc message properties form . rest) (('syntax-error proc message properties form . rest)
(let ((loc (source-properties->location properties))) (let ((loc (source-properties->location properties)))
(format (current-error-port) (G_ "~a: warning: ~a~%") (warning loc (G_ "~a~%") message)))
(location->string loc) message)))
(('srfi-34 obj) (('srfi-34 obj)
(if (message-condition? obj) (if (message-condition? obj)
(warning (G_ "failed to load '~a': ~a~%") (warning (G_ "failed to load '~a': ~a~%")
@ -731,17 +736,14 @@ directories:~{ ~a~}~%")
(cons (invoke-error-program c) (cons (invoke-error-program c)
(invoke-error-arguments c)))) (invoke-error-arguments c))))
((and (error-location? c) (message-condition? c)) ((and (error-location? c) (message-condition? c))
(format (current-error-port) (report-error (error-location c) (G_ "~a~%")
(G_ "~a: error: ~a~%") (gettext (condition-message c) %gettext-domain))
(location->string (error-location c))
(gettext (condition-message c) %gettext-domain))
(when (fix-hint? c) (when (fix-hint? c)
(display-hint (condition-fix-hint c))) (display-hint (condition-fix-hint c)))
(exit 1)) (exit 1))
((and (message-condition? c) (fix-hint? c)) ((and (message-condition? c) (fix-hint? c))
(format (current-error-port) "~a: error: ~a~%" (report-error (G_ "~a~%")
(program-name) (gettext (condition-message c) %gettext-domain))
(gettext (condition-message c) %gettext-domain))
(display-hint (condition-fix-hint c)) (display-hint (condition-fix-hint c))
(exit 1)) (exit 1))
((message-condition? c) ((message-condition? c)