colors: Introduce a disjoint type and pre-compute ANSI escapes.

* guix/colors.scm (color-table, color): Remove.
(<color>): New record type.
(print-color): New procedure.
(define-color-table, color): New macros.
(color-codes->ansi): New procedure.
(%reset): New variable.
(colorize-string): Rewrite accordingly.
(color-rules): Adjust accordingly.
* guix/status.scm (print-build-event): Adjust to new 'colorize-string'
interface.
* guix/ui.scm (%highlight-argument): Likewise.
(%warning-colors, %info-colors, %error-colors, %hint-colors)
(%highlight-colors): Remove.
(%warning-color, %info-color, %error-color, %hint-color)
(%highlight-color): New variables.

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 @@ (define-module (guix colors)
 ;;;
 ;;; Code:
 
-(define color-table
+;; Record type for "colors", which are actually lists of color attributes.
-  `((CLEAR       .   "0")
+(define-record-type <color>
-    (RESET       .   "0")
+  (make-color symbols ansi)
-    (BOLD        .   "1")
+  color?
-    (DARK        .   "2")
+  (symbols  color-symbols)
-    (UNDERLINE   .   "4")
+  (ansi     color-ansi))
-    (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)
+(define (print-color color port)
-  "Return a string containing the ANSI escape sequence for producing the
+  (format port "#<color ~a>"
-requested set of attributes in LST.  Unknown attributes are ignored."
+          (string-join (map symbol->string
-  (let ((color-list
+                            (color-symbols color)))))
-         (remove not
+
-                 (map (lambda (color) (assq-ref color-table color))
+(set-record-type-printer! <color> print-color)
-                      lst))))
+
-    (if (null? color-list)
+(define-syntax define-color-table
-        ""
+  (syntax-rules ()
-        (string-append
+    "Define NAME as a macro that builds a list of color attributes."
-         (string #\esc #\[)
+    ((_ name (color escape) ...)
-         (string-join color-list ";" 'infix)
+     (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 (colorize-string str . color-list)
+(define %reset
-  "Return a copy of STR colorized using ANSI escape sequences according to the
+  (color RESET))
-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."
+(define (colorize-string str color)
-  (string-append
+  "Return a copy of STR colorized using ANSI escape sequences according to
-   (apply color color-list)
+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 'RESET)))
+                 (color-ansi %reset)))
 
 (define isatty?*
   (mlambdaq (port)
@@ -114,7 +150,7 @@ (define-syntax color-rules
              (match (regexp-exec rx str)
                (#f (next str))
                (m  (let loop ((n 1)
-                              (c '(colors ...))
+                              (c (list (color colors) ...))
                               (result '()))
                      (match c
                        (()

guix/status.scm

@@ -410,17 +410,17 @@ (define* (print-build-event event old-status status
 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 %)

guix/ui.scm

@@ -158,7 +158,7 @@ (define* (%highlight-argument arg #:optional (port (guix-warning-port)))
   (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 @@ (define-syntax name
 ;; 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 warning (G_ "warning: ") %warning-color) ;emit a warning
-(define-diagnostic info (G_ "") %info-colors)
+(define-diagnostic info (G_ "") %info-color)
-(define-diagnostic report-error (G_ "error: ") %error-colors)
+(define-diagnostic report-error (G_ "error: ") %error-color)
 
 (define-syntax-rule (leave args ...)
   "Emit an error message and exit."
@@ -216,27 +216,27 @@ (define-syntax-rule (leave args ...)
     (report-error args ...)
     (exit 1)))
 
-(define %warning-colors '(BOLD MAGENTA))
+(define %warning-color (color BOLD MAGENTA))
-(define %info-colors '(BOLD))
+(define %info-color (color BOLD))
-(define %error-colors '(BOLD RED))
+(define %error-color (color BOLD RED))
-(define %hint-colors '(BOLD CYAN))
+(define %hint-color (color BOLD CYAN))
-(define %highlight-colors '(BOLD))
+(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 @@ (define* (display-hint message #:optional (port (current-error-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)