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          (highlight arg port))
  75         ((symbol? arg)
  76          (highlight (symbol->string arg) port))
  77         (else arg)))
  78
  79 (define-syntax define-diagnostic
  80   (syntax-rules ()
  81     "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
  82 messages."
  83     ((_ name (G_ prefix) colors)
  84      (define-syntax name
  85        (lambda (x)
  86          (syntax-case x ()
  87            ((name location (underscore fmt) args (... ...))
  88             (and (string? (syntax->datum #'fmt))
  89                  (free-identifier=? #'underscore #'G_))
  90             #'(begin
  91                 (print-diagnostic-prefix prefix location
  92                                          #:colors colors)
  93                 (format (guix-warning-port) (gettext fmt %gettext-domain)
  94                         (highlight-argument fmt args) (... ...))))
  95            ((name location (N-underscore singular plural n)
  96                   args (... ...))
  97             (and (string? (syntax->datum #'singular))
  98                  (string? (syntax->datum #'plural))
  99                  (free-identifier=? #'N-underscore #'N_))
 100             #'(begin
 101                 (print-diagnostic-prefix prefix location
 102                                          #:colors colors)
 103                 (format (guix-warning-port)
 104                         (ngettext singular plural n %gettext-domain)
 105                         (highlight-argument singular args) (... ...))))
 106            ((name (underscore fmt) args (... ...))
 107             (free-identifier=? #'underscore #'G_)
 108             #'(name #f (underscore fmt) args (... ...)))
 109            ((name (N-underscore singular plural n)
 110                   args (... ...))
 111             (free-identifier=? #'N-underscore #'N_)
 112             #'(name #f (N-underscore singular plural n)
 113                     args (... ...)))))))))
 114
 115 ;; XXX: This doesn't work well for right-to-left languages.
 116 ;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
 117 ;; "~a" is a placeholder for that phrase.
 118 (define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
 119 (define-diagnostic info (G_ "") %info-color)
 120 (define-diagnostic report-error (G_ "error: ") %error-color)
 121
 122 (define-syntax-rule (leave args ...)
 123   "Emit an error message and exit."
 124   (begin
 125     (report-error args ...)
 126     (exit 1)))
 127
 128 (define %warning-color (color BOLD MAGENTA))
 129 (define %info-color (color BOLD))
 130 (define %error-color (color BOLD RED))
 131
 132 (define* (print-diagnostic-prefix prefix #:optional location
 133                                   #:key (colors (color)))
 134   "Print PREFIX as a diagnostic line prefix."
 135   (define color?
 136     (color-output? (guix-warning-port)))
 137
 138   (define location-color
 139     (if color?
 140         (cut colorize-string <> (color BOLD))
 141         identity))
 142
 143   (define prefix-color
 144     (if color?
 145         (lambda (prefix)
 146           (colorize-string prefix colors))
 147         identity))
 148
 149   (let ((prefix (if (string-null? prefix)
 150                     prefix
 151                     (gettext prefix %gettext-domain))))
 152     (if location
 153         (format (guix-warning-port) "~a: ~a"
 154                 (location-color (location->string location))
 155                 (prefix-color prefix))
 156         (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
 157                 (program-name) (program-name)
 158                 (prefix-color prefix)))))
 159
 160 (define (location->string loc)
 161   "Return a human-friendly, GNU-standard representation of LOC."
 162   (match loc
 163     (#f (G_ "<unknown location>"))
 164     (($ <location> file line column)
 165      (format #f "~a:~a:~a" file line column))))
 166
 167 \f
 168 (define guix-warning-port
 169   (make-parameter (current-warning-port)))
 170
 171 (define program-name
 172   ;; Name of the command-line program currently executing, or #f.
 173   (make-parameter #f))