aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-07-25 17:54:20 +0200
committerLudovic Courtès <ludo@gnu.org>2020-07-25 19:11:36 +0200
commit860f3d77495aad0061c4ee9b6de73d6fe9fc40e9 (patch)
tree9e876dc8a9c11588229f766fd471d6423b2ff7cf
parentefe037fc5cc3134bbc3ef4e36b49a3f788921b68 (diff)
downloadguix-860f3d77495aad0061c4ee9b6de73d6fe9fc40e9.tar
guix-860f3d77495aad0061c4ee9b6de73d6fe9fc40e9.tar.gz
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.
-rw-r--r--guix/diagnostics.scm48
1 files 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 @@
;;;
;;; 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 @@ 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 +155,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))