07/09: diagnostics: Add '&formatted-message'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 252a1926bc7d7aa0b39d89a484c0c1b82e945fcd
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Jul 25 17:59:13 2020 +0200

    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 | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 guix/ui.scm          | 62 +++++++++++++++++++++++++++++++++++--------------
 2 files changed, 110 insertions(+), 17 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 3b536d8..7b9ffc6 100644
--- a/guix/diagnostics.scm
+++ b/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)))
diff --git a/guix/ui.scm b/guix/ui.scm
index 588eb84..162eb35 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))