mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 15:36:20 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
c1df77e215
commit
2569ef9dab
3 changed files with 101 additions and 65 deletions
134
guix/colors.scm
134
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
|
||||
`((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")))
|
||||
;; 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 (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 (print-color color port)
|
||||
(format port "#<color ~a>"
|
||||
(string-join (map symbol->string
|
||||
(color-symbols color)))))
|
||||
|
||||
(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)))
|
||||
(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 @@ (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
|
||||
(()
|
||||
|
|
|
|||
|
|
@ -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 %)
|
||||
|
|
|
|||
26
guix/ui.scm
26
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 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 @@ (define-syntax-rule (leave args ...)
|
|||
(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 @@ (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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue