From 1b5ee3bdaacf665ad1e7c6142122389fd7033ea2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 3 Jun 2019 22:58:36 +0200 Subject: Add (guix diagnostics). * guix/ui.scm (warning, info, report-error, leave) (location->string, guix-warning-port, program-name) (highlight-argument, %highlight-argument, define-diagnostic) (%warning-color, %info-color, %error-color) (print-diagnostic-prefix): Move to... * guix/diagnostics.scm: ... here. New file. * Makefile.am (MODULES): Add it. --- guix/diagnostics.scm | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 173 insertions(+) create mode 100644 guix/diagnostics.scm (limited to 'guix/diagnostics.scm') diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm new file mode 100644 index 0000000000..380cfbb613 --- /dev/null +++ b/guix/diagnostics.scm @@ -0,0 +1,173 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix diagnostics) + #:use-module (guix colors) + #:use-module (guix i18n) + #:autoload (guix utils) () + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (warning + info + report-error + leave + + location->string + + guix-warning-port + program-name)) + +;;; Commentary: +;;; +;;; This module provides the tools to report diagnostics to the user in a +;;; consistent way: errors, warnings, and notes. +;;; +;;; Code: + +(define-syntax highlight-argument + (lambda (s) + "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT +is a trivial format string." + (define (trivial-format-string? fmt) + (define len + (string-length fmt)) + + (let loop ((start 0)) + (or (>= (+ 1 start) len) + (let ((tilde (string-index fmt #\~ start))) + (or (not tilde) + (case (string-ref fmt (+ tilde 1)) + ((#\a #\A #\%) (loop (+ tilde 2))) + (else #f))))))) + + ;; Be conservative: limit format argument highlighting to cases where the + ;; format string contains nothing but ~a escapes. If it contained ~s + ;; escapes, this strategy wouldn't work. + (syntax-case s () + ((_ "~a~%" arg) ;don't highlight whole messages + #'arg) + ((_ fmt arg) + (trivial-format-string? (syntax->datum #'fmt)) + #'(%highlight-argument arg)) + ((_ fmt arg) + #'arg)))) + +(define* (%highlight-argument arg #:optional (port (guix-warning-port))) + "Highlight ARG, a format string argument, if PORT supports colors." + (cond ((string? arg) + (highlight arg port)) + ((symbol? arg) + (highlight (symbol->string arg) port)) + (else arg))) + +(define-syntax define-diagnostic + (syntax-rules () + "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all +messages." + ((_ name (G_ prefix) colors) + (define-syntax name + (lambda (x) + (syntax-case x () + ((name location (underscore fmt) args (... ...)) + (and (string? (syntax->datum #'fmt)) + (free-identifier=? #'underscore #'G_)) + #'(begin + (print-diagnostic-prefix prefix location + #:colors colors) + (format (guix-warning-port) (gettext fmt %gettext-domain) + (highlight-argument fmt args) (... ...)))) + ((name location (N-underscore singular plural n) + args (... ...)) + (and (string? (syntax->datum #'singular)) + (string? (syntax->datum #'plural)) + (free-identifier=? #'N-underscore #'N_)) + #'(begin + (print-diagnostic-prefix prefix location + #:colors colors) + (format (guix-warning-port) + (ngettext singular plural n %gettext-domain) + (highlight-argument singular args) (... ...)))) + ((name (underscore fmt) args (... ...)) + (free-identifier=? #'underscore #'G_) + #'(name #f (underscore fmt) args (... ...))) + ((name (N-underscore singular plural n) + args (... ...)) + (free-identifier=? #'N-underscore #'N_) + #'(name #f (N-underscore singular plural n) + args (... ...))))))))) + +;; XXX: This doesn't work well for right-to-left languages. +;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase; +;; "~a" is a placeholder for that phrase. +(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning +(define-diagnostic info (G_ "") %info-color) +(define-diagnostic report-error (G_ "error: ") %error-color) + +(define-syntax-rule (leave args ...) + "Emit an error message and exit." + (begin + (report-error args ...) + (exit 1))) + +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) + +(define* (print-diagnostic-prefix prefix #:optional location + #:key (colors (color))) + "Print PREFIX as a diagnostic line prefix." + (define color? + (color-output? (guix-warning-port))) + + (define location-color + (if color? + (cut colorize-string <> (color BOLD)) + identity)) + + (define prefix-color + (if color? + (lambda (prefix) + (colorize-string prefix colors)) + identity)) + + (let ((prefix (if (string-null? prefix) + prefix + (gettext prefix %gettext-domain)))) + (if location + (format (guix-warning-port) "~a: ~a" + (location-color (location->string location)) + (prefix-color prefix)) + (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a" + (program-name) (program-name) + (prefix-color prefix))))) + +(define (location->string loc) + "Return a human-friendly, GNU-standard representation of LOC." + (match loc + (#f (G_ "")) + (($ file line column) + (format #f "~a:~a:~a" file line column)))) + + +(define guix-warning-port + (make-parameter (current-warning-port))) + +(define program-name + ;; Name of the command-line program currently executing, or #f. + (make-parameter #f)) -- cgit v1.2.3