Commit | Line | Data |
---|---|---|
1b5ee3bd | 1 | ;;; GNU Guix --- Functional package management for GNU |
a5e2fc73 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 LC |
41 | location->string |
42 | ||
a5e2fc73 LC |
43 | &error-location |
44 | error-location? | |
45 | error-location | |
46 | ||
252a1926 LC |
47 | formatted-message |
48 | formatted-message? | |
49 | formatted-message-string | |
50 | formatted-message-arguments | |
51 | ||
f9a8dd05 LC |
52 | &fix-hint |
53 | fix-hint? | |
54 | condition-fix-hint | |
55 | ||
1b5ee3bd LC |
56 | guix-warning-port |
57 | program-name)) | |
58 | ||
59 | ;;; Commentary: | |
60 | ;;; | |
61 | ;;; This module provides the tools to report diagnostics to the user in a | |
62 | ;;; consistent way: errors, warnings, and notes. | |
63 | ;;; | |
64 | ;;; Code: | |
65 | ||
860f3d77 LC |
66 | (define (trivial-format-string? fmt) |
67 | (define len | |
68 | (string-length fmt)) | |
69 | ||
70 | (let loop ((start 0)) | |
71 | (or (>= (+ 1 start) len) | |
72 | (let ((tilde (string-index fmt #\~ start))) | |
73 | (or (not tilde) | |
74 | (case (string-ref fmt (+ tilde 1)) | |
75 | ((#\a #\A #\%) (loop (+ tilde 2))) | |
76 | (else #f))))))) | |
77 | ||
1b5ee3bd LC |
78 | (define-syntax highlight-argument |
79 | (lambda (s) | |
80 | "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT | |
81 | is a trivial format string." | |
1b5ee3bd LC |
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. | |
85 | (syntax-case s () | |
86 | ((_ "~a~%" arg) ;don't highlight whole messages | |
87 | #'arg) | |
88 | ((_ fmt arg) | |
89 | (trivial-format-string? (syntax->datum #'fmt)) | |
90 | #'(%highlight-argument arg)) | |
91 | ((_ fmt arg) | |
92 | #'arg)))) | |
93 | ||
94 | (define* (%highlight-argument arg #:optional (port (guix-warning-port))) | |
95 | "Highlight ARG, a format string argument, if PORT supports colors." | |
96 | (cond ((string? arg) | |
d2292150 LC |
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 | |
99 | ;; by 'guix lint. | |
100 | (if (string-any char-set:whitespace arg) | |
101 | arg | |
102 | (highlight arg port))) | |
1b5ee3bd LC |
103 | ((symbol? arg) |
104 | (highlight (symbol->string arg) port)) | |
105 | (else arg))) | |
106 | ||
107 | (define-syntax define-diagnostic | |
108 | (syntax-rules () | |
109 | "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all | |
110 | messages." | |
111 | ((_ name (G_ prefix) colors) | |
112 | (define-syntax name | |
113 | (lambda (x) | |
114 | (syntax-case x () | |
115 | ((name location (underscore fmt) args (... ...)) | |
116 | (and (string? (syntax->datum #'fmt)) | |
117 | (free-identifier=? #'underscore #'G_)) | |
118 | #'(begin | |
119 | (print-diagnostic-prefix prefix location | |
120 | #:colors colors) | |
121 | (format (guix-warning-port) (gettext fmt %gettext-domain) | |
122 | (highlight-argument fmt args) (... ...)))) | |
123 | ((name location (N-underscore singular plural n) | |
124 | args (... ...)) | |
125 | (and (string? (syntax->datum #'singular)) | |
126 | (string? (syntax->datum #'plural)) | |
127 | (free-identifier=? #'N-underscore #'N_)) | |
128 | #'(begin | |
129 | (print-diagnostic-prefix prefix location | |
130 | #:colors colors) | |
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) | |
138 | args (... ...)) | |
139 | (free-identifier=? #'N-underscore #'N_) | |
140 | #'(name #f (N-underscore singular plural n) | |
860f3d77 LC |
141 | args (... ...))) |
142 | (id | |
143 | (identifier? #'id) | |
144 | ;; Run-time variant. | |
145 | #'(lambda (location fmt . args) | |
146 | (emit-diagnostic fmt args | |
147 | #:location location | |
148 | #:prefix prefix | |
149 | #:colors colors))))))))) | |
1b5ee3bd LC |
150 | |
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) | |
157 | ||
158 | (define-syntax-rule (leave args ...) | |
159 | "Emit an error message and exit." | |
160 | (begin | |
161 | (report-error args ...) | |
162 | (exit 1))) | |
163 | ||
860f3d77 LC |
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. | |
168 | ||
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) | |
176 | args))) | |
177 | ||
1b5ee3bd LC |
178 | (define %warning-color (color BOLD MAGENTA)) |
179 | (define %info-color (color BOLD)) | |
180 | (define %error-color (color BOLD RED)) | |
181 | ||
182 | (define* (print-diagnostic-prefix prefix #:optional location | |
183 | #:key (colors (color))) | |
184 | "Print PREFIX as a diagnostic line prefix." | |
185 | (define color? | |
186 | (color-output? (guix-warning-port))) | |
187 | ||
188 | (define location-color | |
189 | (if color? | |
190 | (cut colorize-string <> (color BOLD)) | |
191 | identity)) | |
192 | ||
193 | (define prefix-color | |
194 | (if color? | |
195 | (lambda (prefix) | |
196 | (colorize-string prefix colors)) | |
197 | identity)) | |
198 | ||
199 | (let ((prefix (if (string-null? prefix) | |
200 | prefix | |
201 | (gettext prefix %gettext-domain)))) | |
202 | (if location | |
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))))) | |
209 | ||
a5e2fc73 LC |
210 | \f |
211 | ;; A source location. | |
212 | (define-record-type <location> | |
213 | (make-location file line column) | |
214 | location? | |
215 | (file location-file) ; file name | |
216 | (line location-line) ; 1-indexed line | |
217 | (column location-column)) ; 0-indexed column | |
218 | ||
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))) | |
223 | ||
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', | |
227 | etc." | |
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... | |
230 | (match loc | |
231 | ((('line . line) ('column . col) ('filename . file)) ;common case | |
232 | (and file line col | |
233 | (make-location file (+ line 1) col))) | |
234 | (#f | |
235 | #f) | |
236 | (_ | |
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))))) | |
241 | ||
242 | (define (location->source-properties loc) | |
243 | "Return the source property association list based on the info in LOC, | |
244 | a location object." | |
245 | `((line . ,(and=> (location-line loc) 1-)) | |
246 | (column . ,(location-column loc)) | |
247 | (filename . ,(location-file loc)))) | |
248 | ||
1b5ee3bd LC |
249 | (define (location->string loc) |
250 | "Return a human-friendly, GNU-standard representation of LOC." | |
251 | (match loc | |
252 | (#f (G_ "<unknown location>")) | |
253 | (($ <location> file line column) | |
254 | (format #f "~a:~a:~a" file line column)))) | |
255 | ||
a5e2fc73 LC |
256 | (define-condition-type &error-location &error |
257 | error-location? | |
258 | (location error-location)) ;<location> | |
259 | ||
f9a8dd05 LC |
260 | (define-condition-type &fix-hint &condition |
261 | fix-hint? | |
262 | (hint condition-fix-hint)) ;string | |
263 | ||
252a1926 LC |
264 | (define-condition-type &formatted-message &error |
265 | formatted-message? | |
266 | (format formatted-message-string) | |
267 | (arguments formatted-message-arguments)) | |
268 | ||
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." | |
272 | (define actual-count | |
273 | (length args)) | |
274 | ||
275 | (define allowed-chars ;for 'simple-format' | |
276 | '(#\A #\S #\a #\s #\~ #\%)) | |
277 | ||
278 | (define (format-chars fmt) | |
279 | (let loop ((chars (string->list fmt)) | |
280 | (result '())) | |
281 | (match chars | |
282 | (() | |
283 | (reverse result)) | |
284 | ((#\~ opt rest ...) | |
285 | (loop rest (cons opt result))) | |
286 | ((chr rest ...) | |
287 | (and (memv chr allowed-chars) | |
288 | (loop rest result)))))) | |
289 | ||
290 | (match (format-chars format) | |
291 | (#f | |
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. | |
295 | #f) | |
296 | (chars | |
297 | (let ((count (fold (lambda (chr count) | |
298 | (case chr | |
299 | ((#\~ #\%) count) | |
300 | (else (+ count 1)))) | |
301 | 0 | |
302 | chars))) | |
303 | (unless (= count actual-count) | |
304 | (warning location (G_ "format string got ~a arguments, expected ~a~%") | |
305 | actual-count count)))))) | |
306 | ||
307 | (define-syntax formatted-message | |
308 | (lambda (s) | |
309 | "Return a '&formatted-message' error condition." | |
310 | (syntax-case s (G_) | |
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 | |
316 | (syntax-source s)) | |
317 | str #'(args ...)) | |
318 | (with-syntax ((str (string-append str "\n"))) | |
319 | #'(condition | |
320 | (&formatted-message (format str) | |
321 | (arguments (list args ...)))))))))) | |
322 | ||
1b5ee3bd LC |
323 | \f |
324 | (define guix-warning-port | |
325 | (make-parameter (current-warning-port))) | |
326 | ||
327 | (define program-name | |
328 | ;; Name of the command-line program currently executing, or #f. | |
329 | (make-parameter #f)) |