[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/05: Add (guix diagnostics).
|
From: |
guix-commits |
|
Subject: |
04/05: Add (guix diagnostics). |
|
Date: |
Mon, 3 Jun 2019 17:18:57 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 1b5ee3bdaacf665ad1e7c6142122389fd7033ea2
Author: Ludovic Courtès <address@hidden>
Date: Mon Jun 3 22:58:36 2019 +0200
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.
---
Makefile.am | 1 +
guix/diagnostics.scm | 173 +++++++++++++++++++++++++++++++++++++++++++++++++++
guix/ui.scm | 152 ++++----------------------------------------
3 files changed, 185 insertions(+), 141 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index ba4528c..80be73e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -144,6 +144,7 @@ MODULES = \
guix/svn-download.scm \
guix/colors.scm \
guix/i18n.scm \
+ guix/diagnostics.scm \
guix/ui.scm \
guix/status.scm \
guix/build/android-ndk-build-system.scm \
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
new file mode 100644
index 0000000..380cfbb
--- /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
<address@hidden>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix diagnostics)
+ #:use-module (guix colors)
+ #:use-module (guix i18n)
+ #:autoload (guix utils) (<location>)
+ #: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_ "<unknown location>"))
+ (($ <location> 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))
diff --git a/guix/ui.scm b/guix/ui.scm
index 529401e..0b4fe14 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -32,6 +32,7 @@
(define-module (guix ui)
#:use-module (guix i18n)
#:use-module (guix colors)
+ #:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (guix utils)
@@ -70,10 +71,14 @@
#:use-module (texinfo)
#:use-module (texinfo plain-text)
#:use-module (texinfo string-utils)
- #:re-export (G_ N_ P_) ;backward compatibility
- #:export (report-error
- display-hint
- leave
+
+ ;; Re-exports for backward compatibility.
+ #:re-export (G_ N_ P_ ;now in (guix i18n)
+
+ warning info report-error leave ;now in (guix diagnostics)
+ location->string
+ guix-warning-port program-name)
+ #:export (display-hint
make-user-module
load*
warn-about-load-error
@@ -93,7 +98,6 @@
read/eval
read/eval-package-expression
check-available-space
- location->string
fill-paragraph
%text-width
texi->plain-text
@@ -115,10 +119,6 @@
delete-generation*
run-guix-command
run-guix
- program-name
- guix-warning-port
- warning
- info
guix-main))
;;; Commentary:
@@ -127,124 +127,6 @@
;;;
;;; 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 %hint-color (color BOLD CYAN))
-
-(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 (print-unbound-variable-error port key args default-printer)
;; Print unbound variable errors more nicely, and in the right language.
(match args
@@ -393,6 +275,8 @@ VARIABLE and return it, or #f if none was found."
(('gnu _ ...) head) ;must be that one
(_ (loop next (cons head suggestions) visited)))))))))))
+(define %hint-color (color BOLD CYAN))
+
(define* (display-hint message #:optional (port (current-error-port)))
"Display MESSAGE, a l10n message possibly containing Texinfo markup, to
PORT."
@@ -1192,13 +1076,6 @@ replacement if PORT is not Unicode-capable."
(lambda ()
body ...)))))
-(define (location->string loc)
- "Return a human-friendly, GNU-standard representation of LOC."
- (match loc
- (#f (G_ "<unknown location>"))
- (($ <location> file line column)
- (format #f "~a:~a:~a" file line column))))
-
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.
@@ -1720,10 +1597,6 @@ Run COMMAND with ARGS.\n"))
string<?))
(show-bug-report-information))
-(define program-name
- ;; Name of the command-line program currently executing, or #f.
- (make-parameter #f))
-
(define (run-guix-command command . args)
"Run COMMAND with the given ARGS. Report an error when COMMAND is not
found."
@@ -1783,9 +1656,6 @@ and signal handling has already been set up."
(string->symbol command)
args))))
-(define guix-warning-port
- (make-parameter (current-warning-port)))
-
(define (guix-main arg0 . args)
(initialize-guix)
(apply run-guix args))