nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
master
Ludovic Courtès 2019-04-11 16:57:38 +02:00
parent c1df77e215
commit 2569ef9dab
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 101 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
guix/colors.scm
View File

@ -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")))
;; 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 @@ on."
(match (regexp-exec rx str)
(#f (next str))
(m (let loop ((n 1)
(c '(colors ...))
(c (list (color colors) ...))
(result '()))
(match c
(()

6
guix/status.scm
View File

@ -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 %)

26
guix/ui.scm
View File

@ -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)