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) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (ice-9 regex) | |
27 | #:export (colorize-string | |
28 | color-rules | |
29 | color-output? | |
30 | isatty?*)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; This module provides tools to produce colored output using ANSI escapes. | |
35 | ;;; | |
36 | ;;; Code: | |
37 | ||
38 | (define color-table | |
39 | `((CLEAR . "0") | |
40 | (RESET . "0") | |
41 | (BOLD . "1") | |
42 | (DARK . "2") | |
43 | (UNDERLINE . "4") | |
44 | (UNDERSCORE . "4") | |
45 | (BLINK . "5") | |
46 | (REVERSE . "6") | |
47 | (CONCEALED . "8") | |
48 | (BLACK . "30") | |
49 | (RED . "31") | |
50 | (GREEN . "32") | |
51 | (YELLOW . "33") | |
52 | (BLUE . "34") | |
53 | (MAGENTA . "35") | |
54 | (CYAN . "36") | |
55 | (WHITE . "37") | |
56 | (ON-BLACK . "40") | |
57 | (ON-RED . "41") | |
58 | (ON-GREEN . "42") | |
59 | (ON-YELLOW . "43") | |
60 | (ON-BLUE . "44") | |
61 | (ON-MAGENTA . "45") | |
62 | (ON-CYAN . "46") | |
63 | (ON-WHITE . "47"))) | |
64 | ||
65 | (define (color . lst) | |
66 | "Return a string containing the ANSI escape sequence for producing the | |
67 | requested set of attributes in LST. Unknown attributes are ignored." | |
68 | (let ((color-list | |
69 | (remove not | |
70 | (map (lambda (color) (assq-ref color-table color)) | |
71 | lst)))) | |
72 | (if (null? color-list) | |
73 | "" | |
74 | (string-append | |
75 | (string #\esc #\[) | |
76 | (string-join color-list ";" 'infix) | |
77 | "m")))) | |
78 | ||
79 | (define (colorize-string str . color-list) | |
80 | "Return a copy of STR colorized using ANSI escape sequences according to the | |
81 | attributes STR. At the end of the returned string, the color attributes will | |
82 | be reset such that subsequent output will not have any colors in effect." | |
83 | (string-append | |
84 | (apply color color-list) | |
85 | str | |
86 | (color 'RESET))) | |
87 | ||
88 | (define isatty?* | |
89 | (mlambdaq (port) | |
90 | "Return true if PORT is a tty. Memoize the result." | |
91 | (isatty? port))) | |
92 | ||
93 | (define (color-output? port) | |
94 | "Return true if we should write colored output to PORT." | |
95 | (and (not (getenv "INSIDE_EMACS")) | |
96 | (not (getenv "NO_COLOR")) | |
97 | (isatty?* port))) | |
98 | ||
99 | (define-syntax color-rules | |
100 | (syntax-rules () | |
101 | "Return a procedure that colorizes the string it is passed according to | |
102 | the given rules. Each rule has the form: | |
103 | ||
104 | (REGEXP COLOR1 COLOR2 ...) | |
105 | ||
106 | where COLOR1 specifies how to colorize the first submatch of REGEXP, and so | |
107 | on." | |
108 | ((_ (regexp colors ...) rest ...) | |
109 | (let ((next (color-rules rest ...)) | |
110 | (rx (make-regexp regexp))) | |
111 | (lambda (str) | |
112 | (if (string-index str #\nul) | |
113 | str | |
114 | (match (regexp-exec rx str) | |
115 | (#f (next str)) | |
116 | (m (let loop ((n 1) | |
117 | (c '(colors ...)) | |
118 | (result '())) | |
119 | (match c | |
120 | (() | |
121 | (string-concatenate-reverse result)) | |
122 | ((first . tail) | |
123 | (loop (+ n 1) tail | |
124 | (cons (colorize-string (match:substring m n) | |
125 | first) | |
126 | result))))))))))) | |
127 | ((_) | |
128 | (lambda (str) | |
129 | str)))) |