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             color-rules
  35             color-output?
  36             isatty?*))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module provides tools to produce colored output using ANSI escapes.
  41 ;;;
  42 ;;; Code:
  43
  44 ;; Record type for "colors", which are actually lists of color attributes.
  45 (define-record-type <color>
  46   (make-color symbols ansi)
  47   color?
  48   (symbols  color-symbols)
  49   (ansi     color-ansi))
  50
  51 (define (print-color color port)
  52   (format port "#<color ~a>"
  53           (string-join (map symbol->string
  54                             (color-symbols color)))))
  55
  56 (set-record-type-printer! <color> print-color)
  57
  58 (define-syntax define-color-table
  59   (syntax-rules ()
  60     "Define NAME as a macro that builds a list of color attributes."
  61     ((_ name (color escape) ...)
  62      (begin
  63        (define-syntax color-codes
  64          (syntax-rules (color ...)
  65            ((_)
  66             '())
  67            ((_ color rest (... ...))
  68             `(escape ,@(color-codes rest (... ...))))
  69            ...))
  70
  71        (define-syntax-rule (name colors (... ...))
  72          "Return a list of color attributes that can be passed to
  73 'colorize-string'."
  74          (make-color '(colors (... ...))
  75                      (color-codes->ansi (color-codes colors (... ...)))))))))
  76
  77 (define-color-table color
  78   (CLEAR        "0")
  79   (RESET        "0")
  80   (BOLD         "1")
  81   (DARK         "2")
  82   (UNDERLINE    "4")
  83   (UNDERSCORE   "4")
  84   (BLINK        "5")
  85   (REVERSE      "6")
  86   (CONCEALED    "8")
  87   (BLACK       "30")
  88   (RED         "31")
  89   (GREEN       "32")
  90   (YELLOW      "33")
  91   (BLUE        "34")
  92   (MAGENTA     "35")
  93   (CYAN        "36")
  94   (WHITE       "37")
  95   (ON-BLACK    "40")
  96   (ON-RED      "41")
  97   (ON-GREEN    "42")
  98   (ON-YELLOW   "43")
  99   (ON-BLUE     "44")
 100   (ON-MAGENTA  "45")
 101   (ON-CYAN     "46")
 102   (ON-WHITE    "47"))
 103
 104 (define (color-codes->ansi codes)
 105   "Convert CODES, a list of color attribute codes, to a ANSI escape string."
 106   (match codes
 107     (()
 108      "")
 109     (_
 110      (string-append (string #\esc #\[)
 111                     (string-join codes ";" 'infix)
 112                     "m"))))
 113
 114 (define %reset
 115   (color RESET))
 116
 117 (define (colorize-string str color)
 118   "Return a copy of STR colorized using ANSI escape sequences according to
 119 COLOR.  At the end of the returned string, the color attributes are reset such
 120 that subsequent output will not have any colors in effect."
 121   (string-append (color-ansi color)
 122                  str
 123                  (color-ansi %reset)))
 124
 125 (define isatty?*
 126   (mlambdaq (port)
 127     "Return true if PORT is a tty.  Memoize the result."
 128     (isatty? port)))
 129
 130 (define (color-output? port)
 131   "Return true if we should write colored output to PORT."
 132   (and (not (getenv "INSIDE_EMACS"))
 133        (not (getenv "NO_COLOR"))
 134        (isatty?* port)))
 135
 136 (define %highlight-color (color BOLD))
 137
 138 (define* (highlight str #:optional (port (current-output-port)))
 139   "Return STR with extra ANSI color attributes to highlight it if PORT
 140 supports it."
 141   (if (color-output? port)
 142       (colorize-string str %highlight-color)
 143       str))
 144
 145 (define (colorize-matches rules)
 146   "Return a procedure that, when passed a string, returns that string
 147 colorized according to RULES.  RULES must be a list of tuples like:
 148
 149   (REGEXP COLOR1 COLOR2 ...)
 150
 151 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 152 on."
 153   (lambda (str)
 154     (if (string-index str #\nul)
 155         str
 156         (let loop ((rules rules))
 157           (match rules
 158             (()
 159              str)
 160             (((regexp . colors) . rest)
 161              (match (regexp-exec regexp str)
 162                (#f (loop rest))
 163                (m  (let loop ((n 1)
 164                               (colors colors)
 165                               (result (list (match:prefix m))))
 166                      (match colors
 167                        (()
 168                         (string-concatenate-reverse
 169                          (cons (match:suffix m) result)))
 170                        ((first . tail)
 171                         (loop (+ n 1)
 172                               tail
 173                               (cons (colorize-string (match:substring m n)
 174                                                      first)
 175                                     result)))))))))))))
 176
 177 (define-syntax color-rules
 178   (syntax-rules ()
 179     "Return a procedure that colorizes the string it is passed according to
 180 the given rules.  Each rule has the form:
 181
 182   (REGEXP COLOR1 COLOR2 ...)
 183
 184 where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
 185 on."
 186     ((_ (regexp colors ...) ...)
 187      (colorize-matches `((,(make-regexp regexp) ,(color colors) ...)
 188                          ...)))))