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.

guix/diagnostics.scm

@@ -19,6 +19,7 @@
 (define-module (guix diagnostics)
   #:use-module (guix colors)
   #:use-module (guix i18n)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
@@ -43,6 +44,11 @@
             error-location?
             error-location
 
+            formatted-message
+            formatted-message?
+            formatted-message-string
+            formatted-message-arguments
+
             &fix-hint
             fix-hint?
             condition-fix-hint
@@ -255,6 +261,65 @@ a location object."
   fix-hint?
   (hint condition-fix-hint))                      ;string
 
+(define-condition-type &formatted-message &error
+  formatted-message?
+  (format    formatted-message-string)
+  (arguments formatted-message-arguments))
+
+(define (check-format-string location format args)
+  "Check that FORMAT, a format string, contains valid escapes, and that the
+number of arguments in ARGS matches the escapes in FORMAT."
+  (define actual-count
+    (length args))
+
+  (define allowed-chars                           ;for 'simple-format'
+    '(#\A #\S #\a #\s #\~ #\%))
+
+  (define (format-chars fmt)
+    (let loop ((chars  (string->list fmt))
+               (result '()))
+      (match chars
+        (()
+         (reverse result))
+        ((#\~ opt rest ...)
+         (loop rest (cons opt result)))
+        ((chr rest ...)
+         (and (memv chr allowed-chars)
+              (loop rest result))))))
+
+  (match (format-chars format)
+    (#f
+     ;; XXX: In this case it could be that FMT contains invalid escapes, or it
+     ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9
+     ;; format).  Instead of implementing '-Wformat', do nothing.
+     #f)
+    (chars
+     (let ((count (fold (lambda (chr count)
+                          (case chr
+                            ((#\~ #\%) count)
+                            (else (+ count 1))))
+                        0
+                        chars)))
+       (unless (= count actual-count)
+         (warning location (G_ "format string got ~a arguments, expected ~a~%")
+                  actual-count count))))))
+
+(define-syntax formatted-message
+  (lambda (s)
+    "Return a '&formatted-message' error condition."
+    (syntax-case s (G_)
+      ((_ (G_ str) args ...)
+       (string? (syntax->datum #'str))
+       (let ((str (syntax->datum #'str)))
+         ;; Implement a subset of '-Wformat'.
+         (check-format-string (source-properties->location
+                               (syntax-source s))
+                              str #'(args ...))
+         (with-syntax ((str (string-append str "\n")))
+           #'(condition
+              (&formatted-message (format str)
+                                  (arguments (list args ...))))))))))
+
 
 (define guix-warning-port
   (make-parameter (current-warning-port)))

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)
+     (cond ((message-condition? obj)
-         (report-error (and (error-location? obj)
+            (report-error (and (error-location? obj)
-                            (error-location obj))
+                               (error-location obj))
-                       (G_ "~a~%")
+                          (G_ "~a~%")
-                       (gettext (condition-message obj) %gettext-domain))
+                          (gettext (condition-message obj) %gettext-domain)))
-         (report-error (G_ "exception thrown: ~s~%") obj))
+           ((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)
+     (cond ((message-condition? obj)
-         (warning (G_ "failed to load '~a': ~a~%")
+            (warning (G_ "failed to load '~a': ~a~%")
-                  file
+                     file
-                  (gettext (condition-message obj) %gettext-domain))
+                     (gettext (condition-message obj) %gettext-domain)))
-         (warning (G_ "failed to load '~a': exception thrown: ~s~%")
+           ((formatted-message? obj)
-                  file 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)
+           (cond ((message-condition? obj)
-               (report-error (G_ "~a~%")
+                  (report-error (G_ "~a~%")
-                             (gettext (condition-message obj)
+                                (gettext (condition-message obj)
-                                      %gettext-domain))
+                                         %gettext-domain)))
-               (report-error (G_ "exception thrown: ~s~%") obj)))
+                 ((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))