summaryrefslogtreecommitdiff
path: root/guix/ui.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-04-10 12:00:55 +0200
committerLudovic Courtès <ludo@gnu.org>2019-04-10 12:40:59 +0200
commit9e1e046040182d8c4bb6e847bcd331862f9015bb (patch)
treeab9a69d70eda71906fb7df76b0ea0aba3c10ae50 /guix/ui.scm
parent402627714b8ba75be48b1c8fbd46cfd4cfe8238f (diff)
ui: Colorize diagnostics.
* guix/ui.scm (define-diagnostic): Add 'colors' parameter and pass it to 'print-diagnostic-prefix'. (warning, info, report-error): Add extra argument. (%warning-colors, %info-colors, %error-colors): New variables. (print-diagnostic-prefix): Add #:colors parameter and honor it.
Diffstat (limited to 'guix/ui.scm')
-rw-r--r--guix/ui.scm42
1 files changed, 33 insertions, 9 deletions
diff --git a/guix/ui.scm b/guix/ui.scm
index 9c8f943ef1..3869f77c15 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -29,6 +29,7 @@
(define-module (guix ui)
#:use-module (guix i18n)
+ #:use-module (guix colors)
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (guix utils)
@@ -128,7 +129,7 @@
(syntax-rules ()
"Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
messages."
- ((_ name (G_ prefix))
+ ((_ name (G_ prefix) colors)
(define-syntax name
(lambda (x)
(syntax-case x ()
@@ -136,7 +137,8 @@ messages."
(and (string? (syntax->datum #'fmt))
(free-identifier=? #'underscore #'G_))
#'(begin
- (print-diagnostic-prefix prefix location)
+ (print-diagnostic-prefix prefix location
+ #:colors colors)
(format (guix-warning-port) (gettext fmt %gettext-domain)
args (... ...))))
((name location (N-underscore singular plural n)
@@ -145,7 +147,8 @@ messages."
(string? (syntax->datum #'plural))
(free-identifier=? #'N-underscore #'N_))
#'(begin
- (print-diagnostic-prefix prefix location)
+ (print-diagnostic-prefix prefix location
+ #:colors colors)
(format (guix-warning-port)
(ngettext singular plural n %gettext-domain)
args (... ...))))
@@ -161,26 +164,47 @@ messages."
;; 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: ")) ;emit a warning
-(define-diagnostic info (G_ ""))
+(define-diagnostic warning (G_ "warning: ") %warning-colors) ;emit a warning
+(define-diagnostic info (G_ "") %info-colors)
+(define-diagnostic report-error (G_ "error: ") %error-colors)
-(define-diagnostic report-error (G_ "error: "))
(define-syntax-rule (leave args ...)
"Emit an error message and exit."
(begin
(report-error args ...)
(exit 1)))
-(define* (print-diagnostic-prefix prefix #:optional location)
+(define %warning-colors '(BOLD MAGENTA))
+(define %info-colors '(BOLD CYAN))
+(define %error-colors '(BOLD RED))
+
+(define* (print-diagnostic-prefix prefix #:optional location
+ #:key (colors '()))
"Print PREFIX as a diagnostic line prefix."
+ (define color?
+ (color-output? (guix-warning-port)))
+
+ (define location-color
+ (if color?
+ (cut colorize-string <> 'BOLD)
+ identity))
+
+ (define prefix-color
+ (if color?
+ (lambda (prefix)
+ (apply 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->string location) prefix)
+ (location-color (location->string location))
+ (prefix-color prefix))
(format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
- (program-name) (program-name) prefix))))
+ (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.