guix/colors.scm

   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 (srfi srfi-9)
  26   #:use-module (srfi srfi-9 gnu)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 regex)
  29   #:export (color
  30             color?
  31
  32             colorize-string
  33             highlight
  34             dim
  35
  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
  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)))
 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."
 134   (and (not (getenv "NO_COLOR"))
 135        (isatty?* port)))
 136
 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)))
 144
 145 (define highlight (coloring-procedure (color BOLD)))
 146 (define dim (coloring-procedure (color DARK)))
 147
 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:
 151
 152   (REGEXP COLOR1 COLOR2 ...)
 153
 154 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 155 on."
 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))
 166                (m  (let loop ((n 1)
 167                               (colors colors)
 168                               (result (list (match:prefix m))))
 169                      (match colors
 170                        (()
 171                         (string-concatenate-reverse
 172                          (cons (match:suffix m) result)))
 173                        ((first . tail)
 174                         (loop (+ n 1)
 175                               tail
 176                               (cons (colorize-string (match:substring m n)
 177                                                      first)
 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                          ...)))))