me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2020-07-25 17:54:20 +02:00
parent efe037fc5c
commit 860f3d7749
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 35 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
guix/diagnostics.scm
View File

@ -57,22 +57,22 @@
;;; ;;;
;;; Code: ;;; 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 (define-syntax highlight-argument
(lambda (s) (lambda (s)
"Given FMT and ARG, expand ARG to a call that highlights it, provided FMT "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
is a trivial format string." 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 ;; Be conservative: limit format argument highlighting to cases where the
;; format string contains nothing but ~a escapes. If it contained ~s ;; format string contains nothing but ~a escapes. If it contained ~s
;; escapes, this strategy wouldn't work. ;; escapes, this strategy wouldn't work.
@ -132,7 +132,15 @@ messages."
args (... ...)) args (... ...))
(free-identifier=? #'N-underscore #'N_) (free-identifier=? #'N-underscore #'N_)
#'(name #f (N-underscore singular plural 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. ;; XXX: This doesn't work well for right-to-left languages.
;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
@ -147,6 +155,20 @@ messages."
(report-error args ...) (report-error args ...)
(exit 1))) (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 %warning-color (color BOLD MAGENTA))
(define %info-color (color BOLD)) (define %info-color (color BOLD))
(define %error-color (color BOLD RED)) (define %error-color (color BOLD RED))