guix/diagnostics.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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   #:autoload   (guix utils) (<location>)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (ice-9 format)
  25   #:use-module (ice-9 match)
  26   #:export (warning
  27             info
  28             report-error
  29             leave
  30
  31             location->string
  32
  33             guix-warning-port
  34             program-name))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; This module provides the tools to report diagnostics to the user in a
  39 ;;; consistent way: errors, warnings, and notes.
  40 ;;;
  41 ;;; Code:
  42
  43 (define-syntax highlight-argument
  44   (lambda (s)
  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)
  48       (define len
  49         (string-length fmt))
  50
  51       (let loop ((start 0))
  52         (or (>= (+ 1 start) len)
  53             (let ((tilde (string-index fmt #\~ start)))
  54               (or (not tilde)
  55                   (case (string-ref fmt (+ tilde 1))
  56                     ((#\a #\A #\%) (loop (+ tilde 2)))
  57                     (else          #f)))))))
  58
  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.
  62     (syntax-case s ()
  63       ((_ "~a~%" arg)                          ;don't highlight whole messages
  64        #'arg)
  65       ((_ fmt arg)
  66        (trivial-format-string? (syntax->datum #'fmt))
  67        #'(%highlight-argument arg))
  68       ((_ fmt arg)
  69        #'arg))))
  70
  71 (define* (%highlight-argument arg #:optional (port (guix-warning-port)))
  72   "Highlight ARG, a format string argument, if PORT supports colors."
  73   (cond ((string? arg)
  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
  76          ;; by 'guix lint.
  77          (if (string-any char-set:whitespace arg)
  78              arg
  79              (highlight arg port)))
  80         ((symbol? arg)
  81          (highlight (symbol->string arg) port))
  82         (else arg)))
  83
  84 (define-syntax define-diagnostic
  85   (syntax-rules ()
  86     "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
  87 messages."
  88     ((_ name (G_ prefix) colors)
  89      (define-syntax name
  90        (lambda (x)
  91          (syntax-case x ()
  92            ((name location (underscore fmt) args (... ...))
  93             (and (string? (syntax->datum #'fmt))
  94                  (free-identifier=? #'underscore #'G_))
  95             #'(begin
  96                 (print-diagnostic-prefix prefix location
  97                                          #:colors colors)
  98                 (format (guix-warning-port) (gettext fmt %gettext-domain)
  99                         (highlight-argument fmt args) (... ...))))
 100            ((name location (N-underscore singular plural n)
 101                   args (... ...))
 102             (and (string? (syntax->datum #'singular))
 103                  (string? (syntax->datum #'plural))
 104                  (free-identifier=? #'N-underscore #'N_))
 105             #'(begin
 106                 (print-diagnostic-prefix prefix location
 107                                          #:colors colors)
 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)
 115                   args (... ...))
 116             (free-identifier=? #'N-underscore #'N_)
 117             #'(name #f (N-underscore singular plural n)
 118                     args (... ...)))))))))
 119
 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)
 126
 127 (define-syntax-rule (leave args ...)
 128   "Emit an error message and exit."
 129   (begin
 130     (report-error args ...)
 131     (exit 1)))
 132
 133 (define %warning-color (color BOLD MAGENTA))
 134 (define %info-color (color BOLD))
 135 (define %error-color (color BOLD RED))
 136
 137 (define* (print-diagnostic-prefix prefix #:optional location
 138                                   #:key (colors (color)))
 139   "Print PREFIX as a diagnostic line prefix."
 140   (define color?
 141     (color-output? (guix-warning-port)))
 142
 143   (define location-color
 144     (if color?
 145         (cut colorize-string <> (color BOLD))
 146         identity))
 147
 148   (define prefix-color
 149     (if color?
 150         (lambda (prefix)
 151           (colorize-string prefix colors))
 152         identity))
 153
 154   (let ((prefix (if (string-null? prefix)
 155                     prefix
 156                     (gettext prefix %gettext-domain))))
 157     (if location
 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)))))
 164
 165 (define (location->string loc)
 166   "Return a human-friendly, GNU-standard representation of LOC."
 167   (match loc
 168     (#f (G_ "<unknown location>"))
 169     (($ <location> file line column)
 170      (format #f "~a:~a:~a" file line column))))
 171
 172 \f
 173 (define guix-warning-port
 174   (make-parameter (current-warning-port)))
 175
 176 (define program-name
 177   ;; Name of the command-line program currently executing, or #f.
 178   (make-parameter #f))