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) …).

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)