04/09: Add (guix colors).

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5d9f9ad63191646a22dc80624227aa413a4894f0
Author: Ludovic Courtès <address@hidden>
Date:   Tue Apr 9 22:39:26 2019 +0200

    Add (guix colors).
    
    * guix/colors.scm: New file.
    * Makefile.am (MODULES): Add it.
    * guix/ui.scm (color-table, color, colorize-string): Remove.
    * guix/status.scm (isatty?*, color-output? color-rules): Remove.
---
 Makefile.am     |   1 +
 guix/colors.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 guix/status.scm |  44 +------------------
 guix/ui.scm     |  55 +-----------------------
 4 files changed, 132 insertions(+), 97 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index c331da7..87682b4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -138,6 +138,7 @@ MODULES =                                   \
   guix/store.scm                               \
   guix/cvs-download.scm                                \
   guix/svn-download.scm                                \
+  guix/colors.scm                              \
   guix/i18n.scm                                        \
   guix/ui.scm                                  \
   guix/status.scm                              \
diff --git a/guix/colors.scm b/guix/colors.scm
new file mode 100644
index 0000000..fad0bd2
--- /dev/null
+++ b/guix/colors.scm
@@ -0,0 +1,129 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
+;;; Copyright © 2018 Sahithi Yarlagadda <address@hidden>
+;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
+;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix colors)
+  #:use-module (guix memoization)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:export (colorize-string
+            color-rules
+            color-output?
+            isatty?*))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to produce colored output using ANSI escapes.
+;;;
+;;; Code:
+
+(define color-table
+  `((CLEAR       .   "0")
+    (RESET       .   "0")
+    (BOLD        .   "1")
+    (DARK        .   "2")
+    (UNDERLINE   .   "4")
+    (UNDERSCORE  .   "4")
+    (BLINK       .   "5")
+    (REVERSE     .   "6")
+    (CONCEALED   .   "8")
+    (BLACK       .  "30")
+    (RED         .  "31")
+    (GREEN       .  "32")
+    (YELLOW      .  "33")
+    (BLUE        .  "34")
+    (MAGENTA     .  "35")
+    (CYAN        .  "36")
+    (WHITE       .  "37")
+    (ON-BLACK    .  "40")
+    (ON-RED      .  "41")
+    (ON-GREEN    .  "42")
+    (ON-YELLOW   .  "43")
+    (ON-BLUE     .  "44")
+    (ON-MAGENTA  .  "45")
+    (ON-CYAN     .  "46")
+    (ON-WHITE    .  "47")))
+
+(define (color . lst)
+  "Return a string containing the ANSI escape sequence for producing the
+requested set of attributes in LST.  Unknown attributes are ignored."
+  (let ((color-list
+         (remove not
+                 (map (lambda (color) (assq-ref color-table color))
+                      lst))))
+    (if (null? color-list)
+        ""
+        (string-append
+         (string #\esc #\[)
+         (string-join color-list ";" 'infix)
+         "m"))))
+
+(define (colorize-string str . color-list)
+  "Return a copy of STR colorized using ANSI escape sequences according to the
+attributes STR.  At the end of the returned string, the color attributes will
+be reset such that subsequent output will not have any colors in effect."
+  (string-append
+   (apply color color-list)
+   str
+   (color 'RESET)))
+
+(define isatty?*
+  (mlambdaq (port)
+    "Return true if PORT is a tty.  Memoize the result."
+    (isatty? port)))
+
+(define (color-output? port)
+  "Return true if we should write colored output to PORT."
+  (and (not (getenv "INSIDE_EMACS"))
+       (not (getenv "NO_COLOR"))
+       (isatty?* port)))
+
+(define-syntax color-rules
+  (syntax-rules ()
+    "Return a procedure that colorizes the string it is passed according to
+the given rules.  Each rule has the form:
+
+  (REGEXP COLOR1 COLOR2 ...)
+
+where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
+on."
+    ((_ (regexp colors ...) rest ...)
+     (let ((next (color-rules rest ...))
+           (rx   (make-regexp regexp)))
+       (lambda (str)
+         (if (string-index str #\nul)
+             str
+             (match (regexp-exec rx str)
+               (#f (next str))
+               (m  (let loop ((n 1)
+                              (c '(colors ...))
+                              (result '()))
+                     (match c
+                       (()
+                        (string-concatenate-reverse result))
+                       ((first . tail)
+                        (loop (+ n 1) tail
+                              (cons (colorize-string (match:substring m n)
+                                                     first)
+                                    result)))))))))))
+    ((_)
+     (lambda (str)
+       str))))
diff --git a/guix/status.scm b/guix/status.scm
index bddaa00..7edb558 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -20,7 +20,7 @@
 (define-module (guix status)
   #:use-module (guix records)
   #:use-module (guix i18n)
-  #:use-module ((guix ui) #:select (colorize-string))
+  #:use-module (guix colors)
   #:use-module (guix progress)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module ((guix build download)
@@ -339,10 +339,6 @@ build-log\" traces."
   (and (current-store-protocol-version)
        (>= (current-store-protocol-version) #x163)))
 
-(define isatty?*
-  (mlambdaq (port)
-    (isatty? port)))
-
 (define spin!
   (let ((steps (circular-list "\\" "|" "/" "-")))
     (lambda (phase port)
@@ -362,44 +358,6 @@ the current build phase."
              (format port (G_ "'~a' phase") phase))
            (force-output port)))))))
 
-(define (color-output? port)
-  "Return true if we should write colored output to PORT."
-  (and (not (getenv "INSIDE_EMACS"))
-       (not (getenv "NO_COLOR"))
-       (isatty?* port)))
-
-(define-syntax color-rules
-  (syntax-rules ()
-    "Return a procedure that colorizes the string it is passed according to
-the given rules.  Each rule has the form:
-
-  (REGEXP COLOR1 COLOR2 ...)
-
-where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
-on."
-    ((_ (regexp colors ...) rest ...)
-     (let ((next (color-rules rest ...))
-           (rx   (make-regexp regexp)))
-       (lambda (str)
-         (if (string-index str #\nul)
-             str
-             (match (regexp-exec rx str)
-               (#f (next str))
-               (m  (let loop ((n 1)
-                              (c '(colors ...))
-                              (result '()))
-                     (match c
-                       (()
-                        (string-concatenate-reverse result))
-                       ((first . tail)
-                        (loop (+ n 1) tail
-                              (cons (colorize-string (match:substring m n)
-                                                     first)
-                                    result)))))))))))
-    ((_)
-     (lambda (str)
-       str))))
-
 (define colorize-log-line
   ;; Take a string and return a possibly colorized string according to the
   ;; rules below.
diff --git a/guix/ui.scm b/guix/ui.scm
index 0070301..c2807b7 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -10,8 +10,6 @@
 ;;; Copyright © 2016 Roel Janssen <address@hidden>
 ;;; Copyright © 2016 Benz Schenk <address@hidden>
 ;;; Copyright © 2018 Kyle Meyer <address@hidden>
-;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
-;;; Copyright © 2018 Sahithi Yarlagadda <address@hidden>
 ;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -118,8 +116,7 @@
             guix-warning-port
             warning
             info
-            guix-main
-            colorize-string))
+            guix-main))
 
 ;;; Commentary:
 ;;;
@@ -1703,54 +1700,4 @@ and signal handling has already been set up."
   (initialize-guix)
   (apply run-guix args))
 
-(define color-table
-  `((CLEAR       .   "0")
-    (RESET       .   "0")
-    (BOLD        .   "1")
-    (DARK        .   "2")
-    (UNDERLINE   .   "4")
-    (UNDERSCORE  .   "4")
-    (BLINK       .   "5")
-    (REVERSE     .   "6")
-    (CONCEALED   .   "8")
-    (BLACK       .  "30")
-    (RED         .  "31")
-    (GREEN       .  "32")
-    (YELLOW      .  "33")
-    (BLUE        .  "34")
-    (MAGENTA     .  "35")
-    (CYAN        .  "36")
-    (WHITE       .  "37")
-    (ON-BLACK    .  "40")
-    (ON-RED      .  "41")
-    (ON-GREEN    .  "42")
-    (ON-YELLOW   .  "43")
-    (ON-BLUE     .  "44")
-    (ON-MAGENTA  .  "45")
-    (ON-CYAN     .  "46")
-    (ON-WHITE    .  "47")))
-
-(define (color . lst)
-  "Return a string containing the ANSI escape sequence for producing the
-requested set of attributes in LST.  Unknown attributes are ignored."
-  (let ((color-list
-         (remove not
-                 (map (lambda (color) (assq-ref color-table color))
-                      lst))))
-    (if (null? color-list)
-        ""
-        (string-append
-         (string #\esc #\[)
-         (string-join color-list ";" 'infix)
-         "m"))))
-
-(define (colorize-string str . color-list)
-  "Return a copy of STR colorized using ANSI escape sequences according to the
-attributes STR.  At the end of the returned string, the color attributes will
-be reset such that subsequent output will not have any colors in effect."
-  (string-append
-   (apply color color-list)
-   str
-   (color 'RESET)))
-
 ;;; ui.scm ends here