diff options
author | Mathieu Othacehe <othacehe@gnu.org> | 2020-08-26 18:35:14 +0200 |
---|---|---|
committer | Mathieu Othacehe <othacehe@gnu.org> | 2020-08-26 18:35:14 +0200 |
commit | 17dddeeee560527a8f30d37761949d658056cb09 (patch) | |
tree | 15b0b19c55787f556eb9b42c28d173bddc5435db /guix/diagnostics.scm | |
parent | 331a09654eb7e9f6212b7e8469077fa7393e8b11 (diff) | |
parent | 6a9581741e4ee81226aeb2f1c997df76670a6aab (diff) |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix/diagnostics.scm')
-rw-r--r-- | guix/diagnostics.scm | 181 |
1 files changed, 166 insertions, 15 deletions
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 6c0753aef4..7b9ffc61b5 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +19,10 @@ (define-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix i18n) - #:autoload (guix utils) (<location>) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (warning @@ -28,8 +30,29 @@ report-error leave + <location> + location + location? + location-file + location-line + location-column + source-properties->location + location->source-properties location->string + &error-location + error-location? + error-location + + formatted-message + formatted-message? + formatted-message-string + formatted-message-arguments + + &fix-hint + fix-hint? + condition-fix-hint + guix-warning-port program-name)) @@ -40,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. @@ -115,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; @@ -130,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)) @@ -162,6 +207,45 @@ messages." (program-name) (program-name) (prefix-color prefix))))) + +;; A source location. +(define-record-type <location> + (make-location file line column) + location? + (file location-file) ; file name + (line location-line) ; 1-indexed line + (column location-column)) ; 0-indexed column + +(define (location file line column) + "Return the <location> object for the given FILE, LINE, and COLUMN." + (and line column file + (make-location file line column))) + +(define (source-properties->location loc) + "Return a location object based on the info in LOC, an alist as returned +by Guile's `source-properties', `frame-source', `current-source-location', +etc." + ;; In accordance with the GCS, start line and column numbers at 1. Note + ;; that unlike LINE and `port-column', COL is actually 1-indexed here... + (match loc + ((('line . line) ('column . col) ('filename . file)) ;common case + (and file line col + (make-location file (+ line 1) col))) + (#f + #f) + (_ + (let ((file (assq-ref loc 'filename)) + (line (assq-ref loc 'line)) + (col (assq-ref loc 'column))) + (location file (and line (+ line 1)) col))))) + +(define (location->source-properties loc) + "Return the source property association list based on the info in LOC, +a location object." + `((line . ,(and=> (location-line loc) 1-)) + (column . ,(location-column loc)) + (filename . ,(location-file loc)))) + (define (location->string loc) "Return a human-friendly, GNU-standard representation of LOC." (match loc @@ -169,6 +253,73 @@ messages." (($ <location> file line column) (format #f "~a:~a:~a" file line column)))) +(define-condition-type &error-location &error + error-location? + (location error-location)) ;<location> + +(define-condition-type &fix-hint &condition + 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 ...)))))))))) + (define guix-warning-port (make-parameter (current-warning-port))) |