aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/ui.scm64
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)