summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-04-10 16:12:54 +0200
committerLudovic Courtès <ludo@gnu.org>2019-04-10 17:09:47 +0200
commit238589e566013a36df0347b200f8a6059398666c (patch)
tree0a62e4e978f7617aeac5e46445b7e8149c66c1af
parenta7ae18b1b9a083a1fbc6c2037e45df2447f704ed (diff)
ui: Highlight diagnostic format string arguments.
* guix/ui.scm (highlight-argument): New macro. (%highlight-argument): New procedure. (define-diagnostic): Use 'highlight-argument'.
-rw-r--r--guix/ui.scm47
1 files changed, 45 insertions, 2 deletions
diff --git a/guix/ui.scm b/guix/ui.scm
index 63977f3aec..c3612d92b4 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -125,6 +125,48 @@
;;;
;;; Code:
+(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.
+ (syntax-case s ()
+ ((_ "~a~%" arg) ;don't highlight whole messages
+ #'arg)
+ ((_ fmt arg)
+ (trivial-format-string? (syntax->datum #'fmt))
+ #'(%highlight-argument arg))
+ ((_ fmt arg)
+ #'arg))))
+
+(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
+ "Highlight ARG, a format string argument, if PORT supports colors."
+ (define highlight
+ (if (color-output? port)
+ (lambda (str)
+ (apply colorize-string str %highlight-colors))
+ identity))
+
+ (cond ((string? arg)
+ (highlight arg))
+ ((symbol? arg)
+ (highlight (symbol->string arg)))
+ (else arg)))
+
(define-syntax define-diagnostic
(syntax-rules ()
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
@@ -140,7 +182,7 @@ messages."
(print-diagnostic-prefix prefix location
#:colors colors)
(format (guix-warning-port) (gettext fmt %gettext-domain)
- args (... ...))))
+ (highlight-argument fmt args) (... ...))))
((name location (N-underscore singular plural n)
args (... ...))
(and (string? (syntax->datum #'singular))
@@ -151,7 +193,7 @@ messages."
#:colors colors)
(format (guix-warning-port)
(ngettext singular plural n %gettext-domain)
- args (... ...))))
+ (highlight-argument singular args) (... ...))))
((name (underscore fmt) args (... ...))
(free-identifier=? #'underscore #'G_)
#'(name #f (underscore fmt) args (... ...)))
@@ -178,6 +220,7 @@ messages."
(define %info-colors '(BOLD))
(define %error-colors '(BOLD RED))
(define %hint-colors '(BOLD CYAN))
+(define %highlight-colors '(BOLD))
(define* (print-diagnostic-prefix prefix #:optional location
#:key (colors '()))