1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (guix diagnostics)
20 #:use-module (guix colors)
21 #:use-module (guix i18n)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-9)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-35)
26 #:use-module (ice-9 format)
27 #:use-module (ice-9 match)
39 source-properties->location
40 location->source-properties
49 formatted-message-string
50 formatted-message-arguments
61 ;;; This module provides the tools to report diagnostics to the user in a
62 ;;; consistent way: errors, warnings, and notes.
66 (define (trivial-format-string? fmt)
71 (or (>= (+ 1 start) len)
72 (let ((tilde (string-index fmt #\~ start)))
74 (case (string-ref fmt (+ tilde 1))
75 ((#\a #\A #\%) (loop (+ tilde 2)))
78 (define-syntax highlight-argument
80 "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
81 is a trivial format string."
82 ;; Be conservative: limit format argument highlighting to cases where the
83 ;; format string contains nothing but ~a escapes. If it contained ~s
84 ;; escapes, this strategy wouldn't work.
86 ((_ "~a~%" arg) ;don't highlight whole messages
89 (trivial-format-string? (syntax->datum #'fmt))
90 #'(%highlight-argument arg))
94 (define* (%highlight-argument arg #:optional (port (guix-warning-port)))
95 "Highlight ARG, a format string argument, if PORT supports colors."
97 ;; If ARG contains white space, don't highlight it, on the grounds
98 ;; that it may be a complete message in its own, like those produced
100 (if (string-any char-set:whitespace arg)
102 (highlight arg port)))
104 (highlight (symbol->string arg) port))
107 (define-syntax define-diagnostic
109 "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
111 ((_ name (G_ prefix) colors)
115 ((name location (underscore fmt) args (... ...))
116 (and (string? (syntax->datum #'fmt))
117 (free-identifier=? #'underscore #'G_))
119 (print-diagnostic-prefix prefix location
121 (format (guix-warning-port) (gettext fmt %gettext-domain)
122 (highlight-argument fmt args) (... ...))))
123 ((name location (N-underscore singular plural n)
125 (and (string? (syntax->datum #'singular))
126 (string? (syntax->datum #'plural))
127 (free-identifier=? #'N-underscore #'N_))
129 (print-diagnostic-prefix prefix location
131 (format (guix-warning-port)
132 (ngettext singular plural n %gettext-domain)
133 (highlight-argument singular args) (... ...))))
134 ((name (underscore fmt) args (... ...))
135 (free-identifier=? #'underscore #'G_)
136 #'(name #f (underscore fmt) args (... ...)))
137 ((name (N-underscore singular plural n)
139 (free-identifier=? #'N-underscore #'N_)
140 #'(name #f (N-underscore singular plural n)
145 #'(lambda (location fmt . args)
146 (emit-diagnostic fmt args
149 #:colors colors)))))))))
151 ;; XXX: This doesn't work well for right-to-left languages.
152 ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
153 ;; "~a" is a placeholder for that phrase.
154 (define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
155 (define-diagnostic info (G_ "") %info-color)
156 (define-diagnostic report-error (G_ "error: ") %error-color)
158 (define-syntax-rule (leave args ...)
159 "Emit an error message and exit."
161 (report-error args ...)
164 (define* (emit-diagnostic fmt args
165 #:key location (colors (color)) (prefix ""))
166 "Report diagnostic message FMT with the given ARGS and the specified
167 LOCATION, COLORS, and PREFIX.
169 This procedure is used as a last resort when the format string is not known at
170 macro-expansion time."
171 (print-diagnostic-prefix (gettext prefix %gettext-domain)
172 location #:colors colors)
173 (apply format (guix-warning-port) fmt
174 (if (trivial-format-string? fmt)
175 (map %highlight-argument args)
178 (define %warning-color (color BOLD MAGENTA))
179 (define %info-color (color BOLD))
180 (define %error-color (color BOLD RED))
182 (define* (print-diagnostic-prefix prefix #:optional location
183 #:key (colors (color)))
184 "Print PREFIX as a diagnostic line prefix."
186 (color-output? (guix-warning-port)))
188 (define location-color
190 (cut colorize-string <> (color BOLD))
196 (colorize-string prefix colors))
199 (let ((prefix (if (string-null? prefix)
201 (gettext prefix %gettext-domain))))
203 (format (guix-warning-port) "~a: ~a"
204 (location-color (location->string location))
205 (prefix-color prefix))
206 (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
207 (program-name) (program-name)
208 (prefix-color prefix)))))
211 ;; A source location.
212 (define-record-type <location>
213 (make-location file line column)
215 (file location-file) ; file name
216 (line location-line) ; 1-indexed line
217 (column location-column)) ; 0-indexed column
219 (define (location file line column)
220 "Return the <location> object for the given FILE, LINE, and COLUMN."
221 (and line column file
222 (make-location file line column)))
224 (define (source-properties->location loc)
225 "Return a location object based on the info in LOC, an alist as returned
226 by Guile's `source-properties', `frame-source', `current-source-location',
228 ;; In accordance with the GCS, start line and column numbers at 1. Note
229 ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
231 ((('line . line) ('column . col) ('filename . file)) ;common case
233 (make-location file (+ line 1) col)))
237 (let ((file (assq-ref loc 'filename))
238 (line (assq-ref loc 'line))
239 (col (assq-ref loc 'column)))
240 (location file (and line (+ line 1)) col)))))
242 (define (location->source-properties loc)
243 "Return the source property association list based on the info in LOC,
245 `((line . ,(and=> (location-line loc) 1-))
246 (column . ,(location-column loc))
247 (filename . ,(location-file loc))))
249 (define (location->string loc)
250 "Return a human-friendly, GNU-standard representation of LOC."
252 (#f (G_ "<unknown location>"))
253 (($ <location> file line column)
254 (format #f "~a:~a:~a" file line column))))
256 (define-condition-type &error-location &error
258 (location error-location)) ;<location>
260 (define-condition-type &fix-hint &condition
262 (hint condition-fix-hint)) ;string
264 (define-condition-type &formatted-message &error
266 (format formatted-message-string)
267 (arguments formatted-message-arguments))
269 (define (check-format-string location format args)
270 "Check that FORMAT, a format string, contains valid escapes, and that the
271 number of arguments in ARGS matches the escapes in FORMAT."
275 (define allowed-chars ;for 'simple-format'
276 '(#\A #\S #\a #\s #\~ #\%))
278 (define (format-chars fmt)
279 (let loop ((chars (string->list fmt))
285 (loop rest (cons opt result)))
287 (and (memv chr allowed-chars)
288 (loop rest result))))))
290 (match (format-chars format)
292 ;; XXX: In this case it could be that FMT contains invalid escapes, or it
293 ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9
294 ;; format). Instead of implementing '-Wformat', do nothing.
297 (let ((count (fold (lambda (chr count)
303 (unless (= count actual-count)
304 (warning location (G_ "format string got ~a arguments, expected ~a~%")
305 actual-count count))))))
307 (define-syntax formatted-message
309 "Return a '&formatted-message' error condition."
311 ((_ (G_ str) args ...)
312 (string? (syntax->datum #'str))
313 (let ((str (syntax->datum #'str)))
314 ;; Implement a subset of '-Wformat'.
315 (check-format-string (source-properties->location
318 (with-syntax ((str (string-append str "\n")))
320 (&formatted-message (format str)
321 (arguments (list args ...))))))))))
324 (define guix-warning-port
325 (make-parameter (current-warning-port)))
328 ;; Name of the command-line program currently executing, or #f.