Commit | Line | Data |
---|---|---|
5d9f9ad6 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2013, 2014 Free Software Foundation, Inc. | |
3 | ;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> | |
4 | ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> | |
5 | ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> | |
6 | ;;; | |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (guix colors) | |
23 | #:use-module (guix memoization) | |
24 | #:use-module (srfi srfi-1) | |
2569ef9d LC |
25 | #:use-module (srfi srfi-9) |
26 | #:use-module (srfi srfi-9 gnu) | |
5d9f9ad6 LC |
27 | #:use-module (ice-9 match) |
28 | #:use-module (ice-9 regex) | |
2569ef9d LC |
29 | #:export (color |
30 | color? | |
31 | ||
32 | colorize-string | |
c1c5d68a | 33 | highlight |
0876e9c1 LC |
34 | dim |
35 | ||
5d9f9ad6 LC |
36 | color-rules |
37 | color-output? | |
38 | isatty?*)) | |
39 | ||
40 | ;;; Commentary: | |
41 | ;;; | |
42 | ;;; This module provides tools to produce colored output using ANSI escapes. | |
43 | ;;; | |
44 | ;;; Code: | |
45 | ||
2569ef9d LC |
46 | ;; Record type for "colors", which are actually lists of color attributes. |
47 | (define-record-type <color> | |
48 | (make-color symbols ansi) | |
49 | color? | |
50 | (symbols color-symbols) | |
51 | (ansi color-ansi)) | |
52 | ||
53 | (define (print-color color port) | |
54 | (format port "#<color ~a>" | |
55 | (string-join (map symbol->string | |
56 | (color-symbols color))))) | |
57 | ||
58 | (set-record-type-printer! <color> print-color) | |
59 | ||
60 | (define-syntax define-color-table | |
61 | (syntax-rules () | |
62 | "Define NAME as a macro that builds a list of color attributes." | |
63 | ((_ name (color escape) ...) | |
64 | (begin | |
65 | (define-syntax color-codes | |
66 | (syntax-rules (color ...) | |
67 | ((_) | |
68 | '()) | |
69 | ((_ color rest (... ...)) | |
70 | `(escape ,@(color-codes rest (... ...)))) | |
71 | ...)) | |
72 | ||
73 | (define-syntax-rule (name colors (... ...)) | |
74 | "Return a list of color attributes that can be passed to | |
75 | 'colorize-string'." | |
76 | (make-color '(colors (... ...)) | |
77 | (color-codes->ansi (color-codes colors (... ...))))))))) | |
78 | ||
79 | (define-color-table color | |
80 | (CLEAR "0") | |
81 | (RESET "0") | |
82 | (BOLD "1") | |
83 | (DARK "2") | |
84 | (UNDERLINE "4") | |
85 | (UNDERSCORE "4") | |
86 | (BLINK "5") | |
87 | (REVERSE "6") | |
88 | (CONCEALED "8") | |
89 | (BLACK "30") | |
90 | (RED "31") | |
91 | (GREEN "32") | |
92 | (YELLOW "33") | |
93 | (BLUE "34") | |
94 | (MAGENTA "35") | |
95 | (CYAN "36") | |
96 | (WHITE "37") | |
97 | (ON-BLACK "40") | |
98 | (ON-RED "41") | |
99 | (ON-GREEN "42") | |
100 | (ON-YELLOW "43") | |
101 | (ON-BLUE "44") | |
102 | (ON-MAGENTA "45") | |
103 | (ON-CYAN "46") | |
104 | (ON-WHITE "47")) | |
105 | ||
106 | (define (color-codes->ansi codes) | |
107 | "Convert CODES, a list of color attribute codes, to a ANSI escape string." | |
108 | (match codes | |
109 | (() | |
110 | "") | |
111 | (_ | |
112 | (string-append (string #\esc #\[) | |
113 | (string-join codes ";" 'infix) | |
114 | "m")))) | |
115 | ||
116 | (define %reset | |
117 | (color RESET)) | |
118 | ||
119 | (define (colorize-string str color) | |
120 | "Return a copy of STR colorized using ANSI escape sequences according to | |
121 | COLOR. At the end of the returned string, the color attributes are reset such | |
122 | that subsequent output will not have any colors in effect." | |
123 | (string-append (color-ansi color) | |
124 | str | |
125 | (color-ansi %reset))) | |
5d9f9ad6 LC |
126 | |
127 | (define isatty?* | |
128 | (mlambdaq (port) | |
129 | "Return true if PORT is a tty. Memoize the result." | |
130 | (isatty? port))) | |
131 | ||
132 | (define (color-output? port) | |
133 | "Return true if we should write colored output to PORT." | |
672d3d4a | 134 | (and (not (getenv "NO_COLOR")) |
5d9f9ad6 LC |
135 | (isatty?* port))) |
136 | ||
0876e9c1 LC |
137 | (define (coloring-procedure color) |
138 | "Return a procedure that applies COLOR to the given string." | |
139 | (lambda* (str #:optional (port (current-output-port))) | |
140 | "Return STR with extra ANSI color attributes if PORT supports it." | |
141 | (if (color-output? port) | |
142 | (colorize-string str color) | |
143 | str))) | |
c1c5d68a | 144 | |
0876e9c1 LC |
145 | (define highlight (coloring-procedure (color BOLD))) |
146 | (define dim (coloring-procedure (color DARK))) | |
c1c5d68a | 147 | |
544265ac LC |
148 | (define (colorize-matches rules) |
149 | "Return a procedure that, when passed a string, returns that string | |
150 | colorized according to RULES. RULES must be a list of tuples like: | |
5d9f9ad6 LC |
151 | |
152 | (REGEXP COLOR1 COLOR2 ...) | |
153 | ||
154 | where COLOR1 specifies how to colorize the first submatch of REGEXP, and so | |
155 | on." | |
544265ac LC |
156 | (lambda (str) |
157 | (if (string-index str #\nul) | |
158 | str | |
159 | (let loop ((rules rules)) | |
160 | (match rules | |
161 | (() | |
162 | str) | |
163 | (((regexp . colors) . rest) | |
164 | (match (regexp-exec regexp str) | |
165 | (#f (loop rest)) | |
5d9f9ad6 | 166 | (m (let loop ((n 1) |
544265ac LC |
167 | (colors colors) |
168 | (result (list (match:prefix m)))) | |
169 | (match colors | |
5d9f9ad6 | 170 | (() |
544265ac LC |
171 | (string-concatenate-reverse |
172 | (cons (match:suffix m) result))) | |
5d9f9ad6 | 173 | ((first . tail) |
544265ac LC |
174 | (loop (+ n 1) |
175 | tail | |
5d9f9ad6 LC |
176 | (cons (colorize-string (match:substring m n) |
177 | first) | |
544265ac LC |
178 | result))))))))))))) |
179 | ||
180 | (define-syntax color-rules | |
181 | (syntax-rules () | |
182 | "Return a procedure that colorizes the string it is passed according to | |
183 | the given rules. Each rule has the form: | |
184 | ||
185 | (REGEXP COLOR1 COLOR2 ...) | |
186 | ||
187 | where COLOR1 specifies how to colorize the first submatch of REGEXP, and so | |
188 | on." | |
189 | ((_ (regexp colors ...) ...) | |
190 | (colorize-matches `((,(make-regexp regexp) ,(color colors) ...) | |
191 | ...))))) |