1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 #:autoload (guix utils) (<location>)
23 #:use-module (srfi srfi-26)
24 #:use-module (ice-9 format)
25 #:use-module (ice-9 match)
38 ;;; This module provides the tools to report diagnostics to the user in a
39 ;;; consistent way: errors, warnings, and notes.
43 (define-syntax highlight-argument
45 "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
46 is a trivial format string."
47 (define (trivial-format-string? fmt)
52 (or (>= (+ 1 start) len)
53 (let ((tilde (string-index fmt #\~ start)))
55 (case (string-ref fmt (+ tilde 1))
56 ((#\a #\A #\%) (loop (+ tilde 2)))
59 ;; Be conservative: limit format argument highlighting to cases where the
60 ;; format string contains nothing but ~a escapes. If it contained ~s
61 ;; escapes, this strategy wouldn't work.
63 ((_ "~a~%" arg) ;don't highlight whole messages
66 (trivial-format-string? (syntax->datum #'fmt))
67 #'(%highlight-argument arg))
71 (define* (%highlight-argument arg #:optional (port (guix-warning-port)))
72 "Highlight ARG, a format string argument, if PORT supports colors."
74 ;; If ARG contains white space, don't highlight it, on the grounds
75 ;; that it may be a complete message in its own, like those produced
77 (if (string-any char-set:whitespace arg)
79 (highlight arg port)))
81 (highlight (symbol->string arg) port))
84 (define-syntax define-diagnostic
86 "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
88 ((_ name (G_ prefix) colors)
92 ((name location (underscore fmt) args (... ...))
93 (and (string? (syntax->datum #'fmt))
94 (free-identifier=? #'underscore #'G_))
96 (print-diagnostic-prefix prefix location
98 (format (guix-warning-port) (gettext fmt %gettext-domain)
99 (highlight-argument fmt args) (... ...))))
100 ((name location (N-underscore singular plural n)
102 (and (string? (syntax->datum #'singular))
103 (string? (syntax->datum #'plural))
104 (free-identifier=? #'N-underscore #'N_))
106 (print-diagnostic-prefix prefix location
108 (format (guix-warning-port)
109 (ngettext singular plural n %gettext-domain)
110 (highlight-argument singular args) (... ...))))
111 ((name (underscore fmt) args (... ...))
112 (free-identifier=? #'underscore #'G_)
113 #'(name #f (underscore fmt) args (... ...)))
114 ((name (N-underscore singular plural n)
116 (free-identifier=? #'N-underscore #'N_)
117 #'(name #f (N-underscore singular plural n)
118 args (... ...)))))))))
120 ;; XXX: This doesn't work well for right-to-left languages.
121 ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
122 ;; "~a" is a placeholder for that phrase.
123 (define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
124 (define-diagnostic info (G_ "") %info-color)
125 (define-diagnostic report-error (G_ "error: ") %error-color)
127 (define-syntax-rule (leave args ...)
128 "Emit an error message and exit."
130 (report-error args ...)
133 (define %warning-color (color BOLD MAGENTA))
134 (define %info-color (color BOLD))
135 (define %error-color (color BOLD RED))
137 (define* (print-diagnostic-prefix prefix #:optional location
138 #:key (colors (color)))
139 "Print PREFIX as a diagnostic line prefix."
141 (color-output? (guix-warning-port)))
143 (define location-color
145 (cut colorize-string <> (color BOLD))
151 (colorize-string prefix colors))
154 (let ((prefix (if (string-null? prefix)
156 (gettext prefix %gettext-domain))))
158 (format (guix-warning-port) "~a: ~a"
159 (location-color (location->string location))
160 (prefix-color prefix))
161 (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
162 (program-name) (program-name)
163 (prefix-color prefix)))))
165 (define (location->string loc)
166 "Return a human-friendly, GNU-standard representation of LOC."
168 (#f (G_ "<unknown location>"))
169 (($ <location> file line column)
170 (format #f "~a:~a:~a" file line column))))
173 (define guix-warning-port
174 (make-parameter (current-warning-port)))
177 ;; Name of the command-line program currently executing, or #f.