diagnostics: Add '&formatted-message'.

This allows 'gettext' to be called on the format string at the site
where the exception is caught (rather than the site where it's thrown).
It also allows for argument highlighting.

* guix/diagnostics.scm (&formatted-message): New condition type.
(check-format-string): New procedure.
(formatted-message): New macro.
* guix/ui.scm (report-load-error): Add clause for 'formatted-message?'.
(warn-about-load-error): Likewise.
(call-with-error-handling): Likewise.
(read/eval): Likewise.

1 files changed, 45 insertions, 17 deletions

diff --git a/guix/ui.scm b/guix/ui.scm
index 588eb8480e..162eb35d26 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -388,12 +388,18 @@ ARGS is the list of arguments received by the 'throw' handler."
     (('unbound-variable _ ...)
      (report-unbound-variable-error args #:frame frame))
     (((or 'srfi-34 '%exception) obj)
-     (if (message-condition? obj)
-         (report-error (and (error-location? obj)
-                            (error-location obj))
-                       (G_ "~a~%")
-                       (gettext (condition-message obj) %gettext-domain))
-         (report-error (G_ "exception thrown: ~s~%") obj))
+     (cond ((message-condition? obj)
+            (report-error (and (error-location? obj)
+                               (error-location obj))
+                          (G_ "~a~%")
+                          (gettext (condition-message obj) %gettext-domain)))
+           ((formatted-message? obj)
+            (apply report-error
+                   (and (error-location? obj) (error-location obj))
+                   (gettext (formatted-message-string obj) %gettext-domain)
+                   (formatted-message-arguments obj)))
+           (else
+            (report-error (G_ "exception thrown: ~s~%") obj)))
      (when (fix-hint? obj)
        (display-hint (condition-fix-hint obj))))
     ((key args ...)
@@ -420,12 +426,19 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
     (('unbound-variable _ ...)
      (report-unbound-variable-error args))
     (((or 'srfi-34 '%exception) obj)
-     (if (message-condition? obj)
-         (warning (G_ "failed to load '~a': ~a~%")
-                  file
-                  (gettext (condition-message obj) %gettext-domain))
-         (warning (G_ "failed to load '~a': exception thrown: ~s~%")
-                  file obj)))
+     (cond ((message-condition? obj)
+            (warning (G_ "failed to load '~a': ~a~%")
+                     file
+                     (gettext (condition-message obj) %gettext-domain)))
+           ((formatted-message? obj)
+            (warning (G_ "failed to load '~a': ~a~%")
+                     (apply format #f
+                            (gettext (formatted-message-string obj)
+                                     %gettext-domain)
+                            (formatted-message-arguments obj))))
+           (else
+            (warning (G_ "failed to load '~a': exception thrown: ~s~%")
+                     file obj))))
     ((error args ...)
      (warning (G_ "failed to load '~a':~%") module)
      (apply display-error #f (current-error-port) args)
@@ -791,6 +804,15 @@ directories:~{ ~a~}~%")
                 (display-hint (condition-fix-hint c)))
               (exit 1))
 
+             ((formatted-message? c)
+              (apply report-error
+                     (and (error-location? c) (error-location c))
+                     (gettext (formatted-message-string c) %gettext-domain)
+                     (formatted-message-arguments c))
+              (when (fix-hint? c)
+                (display-hint (condition-fix-hint c)))
+              (exit 1))
+
              ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
              ;; compound and include a '&message'.  However, that message only
              ;; contains the format string.  Thus, special-case it here to
@@ -854,11 +876,17 @@ similar."
           (('syntax-error proc message properties form . rest)
            (report-error (G_ "syntax error: ~a~%") message))
           (((or 'srfi-34 '%exception) obj)
-           (if (message-condition? obj)
-               (report-error (G_ "~a~%")
-                             (gettext (condition-message obj)
-                                      %gettext-domain))
-               (report-error (G_ "exception thrown: ~s~%") obj)))
+           (cond ((message-condition? obj)
+                  (report-error (G_ "~a~%")
+                                (gettext (condition-message obj)
+                                         %gettext-domain)))
+                 ((formatted-message? obj)
+                  (apply report-error #f
+                         (gettext (formatted-message-string obj)
+                                  %gettext-domain)
+                         (formatted-message-arguments obj)))
+                 (else
+                  (report-error (G_ "exception thrown: ~s~%") obj))))
           ((error args ...)
            (apply display-error #f (current-error-port) args))
           (what? #f))