gnu: waybar: Fix build.

[jackhill/guix/guix.git] / guix / diagnostics.scm

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 3096d38..7b9ffc6 100644 (file)
--- 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
@@ -57,22 +63,22 @@
 ;;;
 ;;; Code:
 
+(define (trivial-format-string? fmt)
+  (define len
+    (string-length fmt))
+
+  (let loop ((start 0))
+    (or (>= (+ 1 start) len)
+        (let ((tilde (string-index fmt #\~ start)))
+          (or (not tilde)
+              (case (string-ref fmt (+ tilde 1))
+                ((#\a #\A #\%) (loop (+ tilde 2)))
+                (else          #f)))))))
+
 (define-syntax highlight-argument
   (lambda (s)
     "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
 is a trivial format string."
-    (define (trivial-format-string? fmt)
-      (define len
-        (string-length fmt))
-
-      (let loop ((start 0))
-        (or (>= (+ 1 start) len)
-            (let ((tilde (string-index fmt #\~ start)))
-              (or (not tilde)
-                  (case (string-ref fmt (+ tilde 1))
-                    ((#\a #\A #\%) (loop (+ tilde 2)))
-                    (else          #f)))))))
-
     ;; Be conservative: limit format argument highlighting to cases where the
     ;; format string contains nothing but ~a escapes.  If it contained ~s
     ;; escapes, this strategy wouldn't work.
@@ -132,7 +138,15 @@ messages."
                   args (... ...))
             (free-identifier=? #'N-underscore #'N_)
             #'(name #f (N-underscore singular plural n)
-                    args (... ...)))))))))
+                    args (... ...)))
+           (id
+            (identifier? #'id)
+            ;; Run-time variant.
+            #'(lambda (location fmt . args)
+                (emit-diagnostic fmt args
+                                 #:location location
+                                 #:prefix prefix
+                                 #:colors colors)))))))))
 
 ;; XXX: This doesn't work well for right-to-left languages.
 ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
@@ -147,6 +161,20 @@ messages."
     (report-error args ...)
     (exit 1)))
 
+(define* (emit-diagnostic fmt args
+                          #:key location (colors (color)) (prefix ""))
+  "Report diagnostic message FMT with the given ARGS and the specified
+LOCATION, COLORS, and PREFIX.
+
+This procedure is used as a last resort when the format string is not known at
+macro-expansion time."
+  (print-diagnostic-prefix (gettext prefix %gettext-domain)
+                           location #:colors colors)
+  (apply format (guix-warning-port) fmt
+         (if (trivial-format-string? fmt)
+             (map %highlight-argument args)
+             args)))
+
 (define %warning-color (color BOLD MAGENTA))
 (define %info-color (color BOLD))
 (define %error-color (color BOLD RED))
@@ -233,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 ...))))))))))
+
 \f
 (define guix-warning-port
   (make-parameter (current-warning-port)))