Commit | Line | Data |
---|---|---|
1b5ee3bd | 1 | ;;; GNU Guix --- Functional package management for GNU |
524c9800 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
1b5ee3bd LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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/>. | |
18 | ||
19 | (define-module (guix diagnostics) | |
20 | #:use-module (guix colors) | |
21 | #:use-module (guix i18n) | |
252a1926 | 22 | #:use-module (srfi srfi-1) |
a5e2fc73 | 23 | #:use-module (srfi srfi-9) |
1b5ee3bd | 24 | #:use-module (srfi srfi-26) |
a5e2fc73 | 25 | #:use-module (srfi srfi-35) |
1b5ee3bd LC |
26 | #:use-module (ice-9 format) |
27 | #:use-module (ice-9 match) | |
28 | #:export (warning | |
29 | info | |
30 | report-error | |
31 | leave | |
32 | ||
a5e2fc73 LC |
33 | <location> |
34 | location | |
35 | location? | |
36 | location-file | |
37 | location-line | |
38 | location-column | |
39 | source-properties->location | |
40 | location->source-properties | |
1b5ee3bd | 41 | location->string |
3da62bf5 | 42 | location->hyperlink |
1b5ee3bd | 43 | |
a5e2fc73 LC |
44 | &error-location |
45 | error-location? | |
46 | error-location | |
47 | ||
252a1926 LC |
48 | formatted-message |
49 | formatted-message? | |
50 | formatted-message-string | |
51 | formatted-message-arguments | |
52 | ||
f9a8dd05 LC |
53 | &fix-hint |
54 | fix-hint? | |
55 | condition-fix-hint | |
56 | ||
1b5ee3bd | 57 | guix-warning-port |
346d2f64 JP |
58 | program-name |
59 | ||
60 | define-with-syntax-properties)) | |
1b5ee3bd LC |
61 | |
62 | ;;; Commentary: | |
63 | ;;; | |
64 | ;;; This module provides the tools to report diagnostics to the user in a | |
65 | ;;; consistent way: errors, warnings, and notes. | |
66 | ;;; | |
67 | ;;; Code: | |
68 | ||
860f3d77 LC |
69 | (define (trivial-format-string? fmt) |
70 | (define len | |
71 | (string-length fmt)) | |
72 | ||
73 | (let loop ((start 0)) | |
74 | (or (>= (+ 1 start) len) | |
75 | (let ((tilde (string-index fmt #\~ start))) | |
76 | (or (not tilde) | |
77 | (case (string-ref fmt (+ tilde 1)) | |
78 | ((#\a #\A #\%) (loop (+ tilde 2))) | |
79 | (else #f))))))) | |
80 | ||
1b5ee3bd LC |
81 | (define-syntax highlight-argument |
82 | (lambda (s) | |
83 | "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT | |
84 | is a trivial format string." | |
1b5ee3bd LC |
85 | ;; Be conservative: limit format argument highlighting to cases where the |
86 | ;; format string contains nothing but ~a escapes. If it contained ~s | |
87 | ;; escapes, this strategy wouldn't work. | |
88 | (syntax-case s () | |
89 | ((_ "~a~%" arg) ;don't highlight whole messages | |
90 | #'arg) | |
91 | ((_ fmt arg) | |
92 | (trivial-format-string? (syntax->datum #'fmt)) | |
93 | #'(%highlight-argument arg)) | |
94 | ((_ fmt arg) | |
95 | #'arg)))) | |
96 | ||
97 | (define* (%highlight-argument arg #:optional (port (guix-warning-port))) | |
98 | "Highlight ARG, a format string argument, if PORT supports colors." | |
99 | (cond ((string? arg) | |
d2292150 LC |
100 | ;; If ARG contains white space, don't highlight it, on the grounds |
101 | ;; that it may be a complete message in its own, like those produced | |
102 | ;; by 'guix lint. | |
103 | (if (string-any char-set:whitespace arg) | |
104 | arg | |
105 | (highlight arg port))) | |
1b5ee3bd LC |
106 | ((symbol? arg) |
107 | (highlight (symbol->string arg) port)) | |
108 | (else arg))) | |
109 | ||
110 | (define-syntax define-diagnostic | |
111 | (syntax-rules () | |
112 | "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all | |
113 | messages." | |
114 | ((_ name (G_ prefix) colors) | |
115 | (define-syntax name | |
116 | (lambda (x) | |
117 | (syntax-case x () | |
118 | ((name location (underscore fmt) args (... ...)) | |
119 | (and (string? (syntax->datum #'fmt)) | |
120 | (free-identifier=? #'underscore #'G_)) | |
121 | #'(begin | |
122 | (print-diagnostic-prefix prefix location | |
123 | #:colors colors) | |
124 | (format (guix-warning-port) (gettext fmt %gettext-domain) | |
125 | (highlight-argument fmt args) (... ...)))) | |
126 | ((name location (N-underscore singular plural n) | |
127 | args (... ...)) | |
128 | (and (string? (syntax->datum #'singular)) | |
129 | (string? (syntax->datum #'plural)) | |
130 | (free-identifier=? #'N-underscore #'N_)) | |
131 | #'(begin | |
132 | (print-diagnostic-prefix prefix location | |
133 | #:colors colors) | |
134 | (format (guix-warning-port) | |
135 | (ngettext singular plural n %gettext-domain) | |
136 | (highlight-argument singular args) (... ...)))) | |
137 | ((name (underscore fmt) args (... ...)) | |
138 | (free-identifier=? #'underscore #'G_) | |
139 | #'(name #f (underscore fmt) args (... ...))) | |
140 | ((name (N-underscore singular plural n) | |
141 | args (... ...)) | |
142 | (free-identifier=? #'N-underscore #'N_) | |
143 | #'(name #f (N-underscore singular plural n) | |
860f3d77 LC |
144 | args (... ...))) |
145 | (id | |
146 | (identifier? #'id) | |
147 | ;; Run-time variant. | |
148 | #'(lambda (location fmt . args) | |
149 | (emit-diagnostic fmt args | |
150 | #:location location | |
151 | #:prefix prefix | |
152 | #:colors colors))))))))) | |
1b5ee3bd LC |
153 | |
154 | ;; XXX: This doesn't work well for right-to-left languages. | |
155 | ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; | |
156 | ;; "~a" is a placeholder for that phrase. | |
157 | (define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning | |
158 | (define-diagnostic info (G_ "") %info-color) | |
159 | (define-diagnostic report-error (G_ "error: ") %error-color) | |
160 | ||
161 | (define-syntax-rule (leave args ...) | |
162 | "Emit an error message and exit." | |
163 | (begin | |
164 | (report-error args ...) | |
165 | (exit 1))) | |
166 | ||
860f3d77 LC |
167 | (define* (emit-diagnostic fmt args |
168 | #:key location (colors (color)) (prefix "")) | |
169 | "Report diagnostic message FMT with the given ARGS and the specified | |
170 | LOCATION, COLORS, and PREFIX. | |
171 | ||
172 | This procedure is used as a last resort when the format string is not known at | |
173 | macro-expansion time." | |
174 | (print-diagnostic-prefix (gettext prefix %gettext-domain) | |
175 | location #:colors colors) | |
176 | (apply format (guix-warning-port) fmt | |
177 | (if (trivial-format-string? fmt) | |
178 | (map %highlight-argument args) | |
179 | args))) | |
180 | ||
1b5ee3bd LC |
181 | (define %warning-color (color BOLD MAGENTA)) |
182 | (define %info-color (color BOLD)) | |
183 | (define %error-color (color BOLD RED)) | |
184 | ||
185 | (define* (print-diagnostic-prefix prefix #:optional location | |
186 | #:key (colors (color))) | |
187 | "Print PREFIX as a diagnostic line prefix." | |
188 | (define color? | |
189 | (color-output? (guix-warning-port))) | |
190 | ||
191 | (define location-color | |
192 | (if color? | |
193 | (cut colorize-string <> (color BOLD)) | |
194 | identity)) | |
195 | ||
196 | (define prefix-color | |
197 | (if color? | |
198 | (lambda (prefix) | |
199 | (colorize-string prefix colors)) | |
200 | identity)) | |
201 | ||
202 | (let ((prefix (if (string-null? prefix) | |
203 | prefix | |
204 | (gettext prefix %gettext-domain)))) | |
205 | (if location | |
206 | (format (guix-warning-port) "~a: ~a" | |
13307c19 LC |
207 | (location-color |
208 | (if (supports-hyperlinks? (guix-warning-port)) | |
209 | (location->hyperlink location) | |
210 | (location->string location))) | |
1b5ee3bd LC |
211 | (prefix-color prefix)) |
212 | (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" | |
213 | (program-name) (program-name) | |
214 | (prefix-color prefix))))) | |
215 | ||
a5e2fc73 LC |
216 | \f |
217 | ;; A source location. | |
218 | (define-record-type <location> | |
219 | (make-location file line column) | |
220 | location? | |
221 | (file location-file) ; file name | |
222 | (line location-line) ; 1-indexed line | |
223 | (column location-column)) ; 0-indexed column | |
224 | ||
225 | (define (location file line column) | |
226 | "Return the <location> object for the given FILE, LINE, and COLUMN." | |
227 | (and line column file | |
228 | (make-location file line column))) | |
229 | ||
230 | (define (source-properties->location loc) | |
231 | "Return a location object based on the info in LOC, an alist as returned | |
232 | by Guile's `source-properties', `frame-source', `current-source-location', | |
233 | etc." | |
234 | ;; In accordance with the GCS, start line and column numbers at 1. Note | |
53cd5923 | 235 | ;; that unlike LINE and `port-column', COL is actually 0-indexed here... |
a5e2fc73 LC |
236 | (match loc |
237 | ((('line . line) ('column . col) ('filename . file)) ;common case | |
238 | (and file line col | |
239 | (make-location file (+ line 1) col))) | |
240 | (#f | |
241 | #f) | |
524c9800 LC |
242 | (#(file line column) |
243 | ;; Guile >= 3.0.6 uses vectors instead of alists internally, which can be | |
244 | ;; seen in the arguments to 'syntax-error' exceptions. | |
245 | (location file (+ 1 line) column)) | |
a5e2fc73 LC |
246 | (_ |
247 | (let ((file (assq-ref loc 'filename)) | |
248 | (line (assq-ref loc 'line)) | |
249 | (col (assq-ref loc 'column))) | |
250 | (location file (and line (+ line 1)) col))))) | |
251 | ||
252 | (define (location->source-properties loc) | |
253 | "Return the source property association list based on the info in LOC, | |
254 | a location object." | |
255 | `((line . ,(and=> (location-line loc) 1-)) | |
256 | (column . ,(location-column loc)) | |
257 | (filename . ,(location-file loc)))) | |
258 | ||
1b5ee3bd LC |
259 | (define (location->string loc) |
260 | "Return a human-friendly, GNU-standard representation of LOC." | |
261 | (match loc | |
262 | (#f (G_ "<unknown location>")) | |
263 | (($ <location> file line column) | |
264 | (format #f "~a:~a:~a" file line column)))) | |
265 | ||
3da62bf5 LC |
266 | (define (location->hyperlink location) |
267 | "Return a string corresponding to LOCATION, with escapes for a hyperlink." | |
268 | (let ((str (location->string location)) | |
269 | (file (if (string-prefix? "/" (location-file location)) | |
270 | (location-file location) | |
271 | (search-path %load-path (location-file location))))) | |
272 | (if file | |
273 | (file-hyperlink file str) | |
274 | str))) | |
275 | ||
a5e2fc73 LC |
276 | (define-condition-type &error-location &error |
277 | error-location? | |
278 | (location error-location)) ;<location> | |
279 | ||
f9a8dd05 LC |
280 | (define-condition-type &fix-hint &condition |
281 | fix-hint? | |
282 | (hint condition-fix-hint)) ;string | |
283 | ||
252a1926 LC |
284 | (define-condition-type &formatted-message &error |
285 | formatted-message? | |
286 | (format formatted-message-string) | |
287 | (arguments formatted-message-arguments)) | |
288 | ||
289 | (define (check-format-string location format args) | |
290 | "Check that FORMAT, a format string, contains valid escapes, and that the | |
291 | number of arguments in ARGS matches the escapes in FORMAT." | |
292 | (define actual-count | |
293 | (length args)) | |
294 | ||
295 | (define allowed-chars ;for 'simple-format' | |
296 | '(#\A #\S #\a #\s #\~ #\%)) | |
297 | ||
298 | (define (format-chars fmt) | |
299 | (let loop ((chars (string->list fmt)) | |
300 | (result '())) | |
301 | (match chars | |
302 | (() | |
303 | (reverse result)) | |
304 | ((#\~ opt rest ...) | |
305 | (loop rest (cons opt result))) | |
306 | ((chr rest ...) | |
307 | (and (memv chr allowed-chars) | |
308 | (loop rest result)))))) | |
309 | ||
310 | (match (format-chars format) | |
311 | (#f | |
312 | ;; XXX: In this case it could be that FMT contains invalid escapes, or it | |
313 | ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9 | |
314 | ;; format). Instead of implementing '-Wformat', do nothing. | |
315 | #f) | |
316 | (chars | |
317 | (let ((count (fold (lambda (chr count) | |
318 | (case chr | |
319 | ((#\~ #\%) count) | |
320 | (else (+ count 1)))) | |
321 | 0 | |
322 | chars))) | |
323 | (unless (= count actual-count) | |
324 | (warning location (G_ "format string got ~a arguments, expected ~a~%") | |
325 | actual-count count)))))) | |
326 | ||
327 | (define-syntax formatted-message | |
328 | (lambda (s) | |
329 | "Return a '&formatted-message' error condition." | |
330 | (syntax-case s (G_) | |
331 | ((_ (G_ str) args ...) | |
332 | (string? (syntax->datum #'str)) | |
333 | (let ((str (syntax->datum #'str))) | |
334 | ;; Implement a subset of '-Wformat'. | |
335 | (check-format-string (source-properties->location | |
336 | (syntax-source s)) | |
337 | str #'(args ...)) | |
338 | (with-syntax ((str (string-append str "\n"))) | |
339 | #'(condition | |
340 | (&formatted-message (format str) | |
341 | (arguments (list args ...)))))))))) | |
342 | ||
1b5ee3bd LC |
343 | \f |
344 | (define guix-warning-port | |
345 | (make-parameter (current-warning-port))) | |
346 | ||
347 | (define program-name | |
348 | ;; Name of the command-line program currently executing, or #f. | |
349 | (make-parameter #f)) | |
346d2f64 JP |
350 | |
351 | \f | |
352 | (define-syntax define-with-syntax-properties | |
353 | (lambda (x) | |
354 | "Define BINDING to be a syntax form replacing each VALUE-IDENTIFIER and | |
355 | SYNTAX-PROPERTIES-IDENTIFIER in body by the syntax and syntax-properties, | |
356 | respectively, of each ensuing syntax object." | |
357 | (syntax-case x () | |
358 | ((_ (binding (value-identifier syntax-properties-identifier) | |
359 | ...) | |
360 | body ...) | |
361 | (and (and-map identifier? #'(value-identifier ...)) | |
362 | (and-map identifier? #'(syntax-properties-identifier ...))) | |
363 | #'(define-syntax binding | |
364 | (lambda (y) | |
365 | (with-ellipsis ::: | |
366 | (syntax-case y () | |
367 | ((_ value-identifier ...) | |
368 | (with-syntax ((syntax-properties-identifier | |
369 | #`'#,(datum->syntax y | |
370 | (syntax-source | |
371 | #'value-identifier))) | |
372 | ...) | |
373 | #'(begin body ...))) | |
374 | (_ | |
375 | (syntax-violation #f (format #f | |
376 | "Expected (~a~{ ~a~})" | |
377 | 'binding | |
378 | '(value-identifier ...)) | |
379 | y))))))) | |
380 | (_ | |
381 | (syntax-violation #f "Expected a definition of the form \ | |
382 | (define-with-syntax-properties (binding (value syntax-properties) \ | |
383 | ...) body ...)" x))))) |