guix/diagnostics.scm

   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>
   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)
  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)
  28   #:export (warning
  29             info
  30             report-error
  31             leave
  32
  33             <location>
  34             location
  35             location?
  36             location-file
  37             location-line
  38             location-column
  39             source-properties->location
  40             location->source-properties
  41             location->string
  42
  43             &error-location
  44             error-location?
  45             error-location
  46
  47             formatted-message
  48             formatted-message?
  49             formatted-message-string
  50             formatted-message-arguments
  51
  52             &fix-hint
  53             fix-hint?
  54             condition-fix-hint
  55
  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
  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
  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."
  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)
  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)))
 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)
 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)))))))))
 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
 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
 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
 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
 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
 256 (define-condition-type &error-location &error
 257   error-location?
 258   (location  error-location))                     ;<location>
 259
 260 (define-condition-type &fix-hint &condition
 261   fix-hint?
 262   (hint condition-fix-hint))                      ;string
 263
 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
 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))