diff options
| -rw-r--r-- | guix/colors.scm | 138 | ||||
| -rw-r--r-- | guix/status.scm | 6 | ||||
| -rw-r--r-- | guix/ui.scm | 26 |
3 files changed, 103 insertions, 67 deletions
diff --git a/guix/colors.scm b/guix/colors.scm index fad0bd2ab9..b7d3f6d4ec 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -22,9 +22,14 @@ (define-module (guix colors) #:use-module (guix memoization) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:export (colorize-string + #:export (color + color? + + colorize-string color-rules color-output? isatty?*)) @@ -35,55 +40,86 @@ ;;; ;;; Code: -(define color-table - `((CLEAR . "0") - (RESET . "0") - (BOLD . "1") - (DARK . "2") - (UNDERLINE . "4") - (UNDERSCORE . "4") - (BLINK . "5") - (REVERSE . "6") - (CONCEALED . "8") - (BLACK . "30") - (RED . "31") - (GREEN . "32") - (YELLOW . "33") - (BLUE . "34") - (MAGENTA . "35") - (CYAN . "36") - (WHITE . "37") - (ON-BLACK . "40") - (ON-RED . "41") - (ON-GREEN . "42") - (ON-YELLOW . "43") - (ON-BLUE . "44") - (ON-MAGENTA . "45") - (ON-CYAN . "46") - (ON-WHITE . "47"))) - -(define (color . lst) - "Return a string containing the ANSI escape sequence for producing the -requested set of attributes in LST. Unknown attributes are ignored." - (let ((color-list - (remove not - (map (lambda (color) (assq-ref color-table color)) - lst)))) - (if (null? color-list) - "" - (string-append - (string #\esc #\[) - (string-join color-list ";" 'infix) - "m")))) - -(define (colorize-string str . color-list) - "Return a copy of STR colorized using ANSI escape sequences according to the -attributes STR. At the end of the returned string, the color attributes will -be reset such that subsequent output will not have any colors in effect." - (string-append - (apply color color-list) - str - (color 'RESET))) +;; Record type for "colors", which are actually lists of color attributes. +(define-record-type <color> + (make-color symbols ansi) + color? + (symbols color-symbols) + (ansi color-ansi)) + +(define (print-color color port) + (format port "#<color ~a>" + (string-join (map symbol->string + (color-symbols color))))) + +(set-record-type-printer! <color> print-color) + +(define-syntax define-color-table + (syntax-rules () + "Define NAME as a macro that builds a list of color attributes." + ((_ name (color escape) ...) + (begin + (define-syntax color-codes + (syntax-rules (color ...) + ((_) + '()) + ((_ color rest (... ...)) + `(escape ,@(color-codes rest (... ...)))) + ...)) + + (define-syntax-rule (name colors (... ...)) + "Return a list of color attributes that can be passed to +'colorize-string'." + (make-color '(colors (... ...)) + (color-codes->ansi (color-codes colors (... ...))))))))) + +(define-color-table color + (CLEAR "0") + (RESET "0") + (BOLD "1") + (DARK "2") + (UNDERLINE "4") + (UNDERSCORE "4") + (BLINK "5") + (REVERSE "6") + (CONCEALED "8") + (BLACK "30") + (RED "31") + (GREEN "32") + (YELLOW "33") + (BLUE "34") + (MAGENTA "35") + (CYAN "36") + (WHITE "37") + (ON-BLACK "40") + (ON-RED "41") + (ON-GREEN "42") + (ON-YELLOW "43") + (ON-BLUE "44") + (ON-MAGENTA "45") + (ON-CYAN "46") + (ON-WHITE "47")) + +(define (color-codes->ansi codes) + "Convert CODES, a list of color attribute codes, to a ANSI escape string." + (match codes + (() + "") + (_ + (string-append (string #\esc #\[) + (string-join codes ";" 'infix) + "m")))) + +(define %reset + (color RESET)) + +(define (colorize-string str color) + "Return a copy of STR colorized using ANSI escape sequences according to +COLOR. At the end of the returned string, the color attributes are reset such +that subsequent output will not have any colors in effect." + (string-append (color-ansi color) + str + (color-ansi %reset))) (define isatty?* (mlambdaq (port) @@ -114,7 +150,7 @@ on." (match (regexp-exec rx str) (#f (next str)) (m (let loop ((n 1) - (c '(colors ...)) + (c (list (color colors) ...)) (result '())) (match c (() diff --git a/guix/status.scm b/guix/status.scm index 7edb558ee7..cbea4151f2 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -410,17 +410,17 @@ produce colorful output. When PRINT-LOG? is true, display the build log in addition to build events." (define info (if colorize? - (cut colorize-string <> 'BOLD) + (cute colorize-string <> (color BOLD)) identity)) (define success (if colorize? - (cut colorize-string <> 'GREEN 'BOLD) + (cute colorize-string <> (color GREEN BOLD)) identity)) (define failure (if colorize? - (cut colorize-string <> 'RED 'BOLD) + (cute colorize-string <> (color RED BOLD)) identity)) (define (report-build-progress phase %) diff --git a/guix/ui.scm b/guix/ui.scm index c3612d92b4..2481a1b78b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -158,7 +158,7 @@ is a trivial format string." (define highlight (if (color-output? port) (lambda (str) - (apply colorize-string str %highlight-colors)) + (colorize-string str %highlight-color)) identity)) (cond ((string? arg) @@ -206,9 +206,9 @@ 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: ") %warning-colors) ;emit a warning -(define-diagnostic info (G_ "") %info-colors) -(define-diagnostic report-error (G_ "error: ") %error-colors) +(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." @@ -216,27 +216,27 @@ messages." (report-error args ...) (exit 1))) -(define %warning-colors '(BOLD MAGENTA)) -(define %info-colors '(BOLD)) -(define %error-colors '(BOLD RED)) -(define %hint-colors '(BOLD CYAN)) -(define %highlight-colors '(BOLD)) +(define %warning-color (color BOLD MAGENTA)) +(define %info-color (color BOLD)) +(define %error-color (color BOLD RED)) +(define %hint-color (color BOLD CYAN)) +(define %highlight-color (color BOLD)) (define* (print-diagnostic-prefix prefix #:optional location - #:key (colors '())) + #: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 <> 'BOLD) + (cut colorize-string <> (color BOLD)) identity)) (define prefix-color (if color? (lambda (prefix) - (apply colorize-string prefix colors)) + (colorize-string prefix colors)) identity)) (let ((prefix (if (string-null? prefix) @@ -404,7 +404,7 @@ PORT." (define colorize (if (color-output? port) (lambda (str) - (apply colorize-string str %hint-colors)) + (colorize-string str %hint-color)) identity)) (display (colorize (G_ "hint: ")) port) |