From 5d9f9ad63191646a22dc80624227aa413a4894f0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Apr 2019 22:39:26 +0200 Subject: Add (guix colors). * guix/colors.scm: New file. * Makefile.am (MODULES): Add it. * guix/ui.scm (color-table, color, colorize-string): Remove. * guix/status.scm (isatty?*, color-output? color-rules): Remove. --- guix/status.scm | 44 +------------------------------------------- 1 file changed, 1 insertion(+), 43 deletions(-) (limited to 'guix/status.scm') diff --git a/guix/status.scm b/guix/status.scm index bddaa003db..7edb558ee7 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -20,7 +20,7 @@ (define-module (guix status) #:use-module (guix records) #:use-module (guix i18n) - #:use-module ((guix ui) #:select (colorize-string)) + #:use-module (guix colors) #:use-module (guix progress) #:autoload (guix build syscalls) (terminal-columns) #:use-module ((guix build download) @@ -339,10 +339,6 @@ build-log\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) -(define isatty?* - (mlambdaq (port) - (isatty? port))) - (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (phase port) @@ -362,44 +358,6 @@ the current build phase." (format port (G_ "'~a' phase") phase)) (force-output port))))))) -(define (color-output? port) - "Return true if we should write colored output to PORT." - (and (not (getenv "INSIDE_EMACS")) - (not (getenv "NO_COLOR")) - (isatty?* port))) - -(define-syntax color-rules - (syntax-rules () - "Return a procedure that colorizes the string it is passed according to -the given rules. Each rule has the form: - - (REGEXP COLOR1 COLOR2 ...) - -where COLOR1 specifies how to colorize the first submatch of REGEXP, and so -on." - ((_ (regexp colors ...) rest ...) - (let ((next (color-rules rest ...)) - (rx (make-regexp regexp))) - (lambda (str) - (if (string-index str #\nul) - str - (match (regexp-exec rx str) - (#f (next str)) - (m (let loop ((n 1) - (c '(colors ...)) - (result '())) - (match c - (() - (string-concatenate-reverse result)) - ((first . tail) - (loop (+ n 1) tail - (cons (colorize-string (match:substring m n) - first) - result))))))))))) - ((_) - (lambda (str) - str)))) - (define colorize-log-line ;; Take a string and return a possibly colorized string according to the ;; rules below. -- cgit v1.2.3 From 2569ef9dab4f796a75b8cdddd57d3be37b142036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Apr 2019 16:57:38 +0200 Subject: colors: Introduce a disjoint type and pre-compute ANSI escapes. * guix/colors.scm (color-table, color): Remove. (): 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(-) (limited to 'guix/status.scm') 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 + (make-color symbols ansi) + color? + (symbols color-symbols) + (ansi color-ansi)) + +(define (print-color color port) + (format port "#" + (string-join (map symbol->string + (color-symbols color))))) + +(set-record-type-printer! 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) -- cgit v1.2.3