[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/03: colors: Introduce a disjoint type and pre-compute ANSI escapes.
|
From: |
guix-commits |
|
Subject: |
02/03: colors: Introduce a disjoint type and pre-compute ANSI escapes. |
|
Date: |
Thu, 11 Apr 2019 12:19:53 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 2569ef9dab4f796a75b8cdddd57d3be37b142036
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 11 16:57:38 2019 +0200
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 | 138 +++++++++++++++++++++++++++++++++++---------------------
guix/status.scm | 6 +--
guix/ui.scm | 26 +++++------
3 files changed, 103 insertions(+), 67 deletions(-)
diff --git a/guix/colors.scm b/guix/colors.scm
index fad0bd2..b7d3f6d 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 7edb558..cbea415 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 c3612d9..2481a1b 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)