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 "INSIDE_EMACS"))
 135        (not (getenv "NO_COLOR"))
 136        (isatty?* port)))
 137
 138 (define (coloring-procedure color)
 139   "Return a procedure that applies COLOR to the given string."
 140   (lambda* (str #:optional (port (current-output-port)))
 141     "Return STR with extra ANSI color attributes if PORT supports it."
 142     (if (color-output? port)
 143         (colorize-string str color)
 144         str)))
 145
 146 (define highlight (coloring-procedure (color BOLD)))
 147 (define dim (coloring-procedure (color DARK)))
 148
 149 (define (colorize-matches rules)
 150   "Return a procedure that, when passed a string, returns that string
 151 colorized according to RULES.  RULES must be a list of tuples like:
 152
 153   (REGEXP COLOR1 COLOR2 ...)
 154
 155 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 156 on."
 157   (lambda (str)
 158     (if (string-index str #\nul)
 159         str
 160         (let loop ((rules rules))
 161           (match rules
 162             (()
 163              str)
 164             (((regexp . colors) . rest)
 165              (match (regexp-exec regexp str)
 166                (#f (loop rest))
 167                (m  (let loop ((n 1)
 168                               (colors colors)
 169                               (result (list (match:prefix m))))
 170                      (match colors
 171                        (()
 172                         (string-concatenate-reverse
 173                          (cons (match:suffix m) result)))
 174                        ((first . tail)
 175                         (loop (+ n 1)
 176                               tail
 177                               (cons (colorize-string (match:substring m n)
 178                                                      first)
 179                                     result)))))))))))))
 180
 181 (define-syntax color-rules
 182   (syntax-rules ()
 183     "Return a procedure that colorizes the string it is passed according to
 184 the given rules.  Each rule has the form:
 185
 186   (REGEXP COLOR1 COLOR2 ...)
 187
 188 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 189 on."
 190     ((_ (regexp colors ...) ...)
 191      (colorize-matches `((,(make-regexp regexp) ,(color colors) ...)
 192                          ...)))))