From 860f3d77495aad0061c4ee9b6de73d6fe9fc40e9 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 25 Jul 2020 17:54:20 +0200
Subject: diagnostics: Add a procedural variant of diagnostic procedures.

Callers can pass 'report-error', 'warning', etc. to 'apply'.

* guix/diagnostics.scm (trivial-format-string?): New procedure, moved
from...
(highlight-argument): ... here.
(define-diagnostic): Add 'identifier?' clause.
(emit-diagnostic): New procedure.
---
 guix/diagnostics.scm | 48 +++++++++++++++++++++++++++++++++++-------------
 1 file changed, 35 insertions(+), 13 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 3096d384d8..3b536d8e96 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -57,22 +57,22 @@ (define-module (guix diagnostics)
 ;;;
 ;;; 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 +132,15 @@ (define-syntax name
                   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 +155,20 @@ (define-syntax-rule (leave args ...)
     (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))
-- 
cgit v1.2.3