diff options
| -rw-r--r-- | guix/ui.scm | 64 |
1 files changed, 33 insertions, 31 deletions
diff --git a/guix/ui.scm b/guix/ui.scm index 8893cc8eee..9c8f943ef1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -132,22 +132,31 @@ messages." (define-syntax name (lambda (x) (syntax-case x () - ((name (underscore fmt) args (... ...)) + ((name location (underscore fmt) args (... ...)) (and (string? (syntax->datum #'fmt)) (free-identifier=? #'underscore #'G_)) #'(begin - (print-diagnostic-prefix prefix) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (gettext fmt %gettext-domain) args (... ...)))) - ((name (N-underscore singular plural n) 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) + (print-diagnostic-prefix prefix location) (format (guix-warning-port) (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. ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; @@ -162,13 +171,16 @@ messages." (report-error args ...) (exit 1))) -(define (print-diagnostic-prefix prefix) +(define* (print-diagnostic-prefix prefix #:optional location) "Print PREFIX as a diagnostic line prefix." - (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" - (program-name) (program-name) - (if (string-null? prefix) - prefix - (gettext prefix %gettext-domain)))) + (let ((prefix (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (if location + (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) ;; 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))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: error: ~a~%") - (location->string loc) message))) + (report-error loc (G_ "~a~%") message))) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (('srfi-34 obj) (if (message-condition? obj) - (if (error-location? obj) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location obj)) - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain))) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain)) (report-error (G_ "exception thrown: ~s~%") obj)) (when (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)))) (('syntax-error proc message properties form . rest) (let ((loc (source-properties->location properties))) - (format (current-error-port) (G_ "~a: warning: ~a~%") - (location->string loc) message))) + (warning loc (G_ "~a~%") message))) (('srfi-34 obj) (if (message-condition? obj) (warning (G_ "failed to load '~a': ~a~%") @@ -731,17 +736,14 @@ directories:~{ ~a~}~%") (cons (invoke-error-program c) (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) - (format (current-error-port) - (G_ "~a: error: ~a~%") - (location->string (error-location c)) - (gettext (condition-message c) %gettext-domain)) + (report-error (error-location c) (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (when (fix-hint? c) (display-hint (condition-fix-hint c))) (exit 1)) ((and (message-condition? c) (fix-hint? c)) - (format (current-error-port) "~a: error: ~a~%" - (program-name) - (gettext (condition-message c) %gettext-domain)) + (report-error (G_ "~a~%") + (gettext (condition-message c) %gettext-domain)) (display-hint (condition-fix-hint c)) (exit 1)) ((message-condition? c) |