gnu: r-rgraphviz: Move to (gnu packages bioconductor).

[jackhill/guix/guix.git] / guix / colors.scm

diff --git a/guix/colors.scm b/guix/colors.scm
index b7d3f6d..3031f54 100644 (file)
--- a/guix/colors.scm
+++ b/guix/colors.scm
@@ -30,6 +30,9 @@
             color?
 
             colorize-string
+            highlight
+            dim
+
             color-rules
             color-output?
             isatty?*))
@@ -128,38 +131,61 @@ that subsequent output will not have any colors in effect."
 
 (define (color-output? port)
   "Return true if we should write colored output to PORT."
-  (and (not (getenv "INSIDE_EMACS"))
-       (not (getenv "NO_COLOR"))
+  (and (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:
+(define (coloring-procedure color)
+  "Return a procedure that applies COLOR to the given string."
+  (lambda* (str #:optional (port (current-output-port)))
+    "Return STR with extra ANSI color attributes if PORT supports it."
+    (if (color-output? port)
+        (colorize-string str color)
+        str)))
+
+(define highlight (coloring-procedure (color BOLD)))
+(define dim (coloring-procedure (color DARK)))
+
+(define (colorize-matches rules)
+  "Return a procedure that, when passed a string, returns that string
+colorized according to RULES.  RULES must be a list of tuples like:
 
   (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))
+  (lambda (str)
+    (if (string-index str #\nul)
+        str
+        (let loop ((rules rules))
+          (match rules
+            (()
+             str)
+            (((regexp . colors) . rest)
+             (match (regexp-exec regexp str)
+               (#f (loop rest))
                (m  (let loop ((n 1)
-                              (c (list (color colors) ...))
-                              (result '()))
-                     (match c
+                              (colors colors)
+                              (result (list (match:prefix m))))
+                     (match colors
                        (()
-                        (string-concatenate-reverse result))
+                        (string-concatenate-reverse
+                         (cons (match:suffix m) result)))
                        ((first . tail)
-                        (loop (+ n 1) tail
+                        (loop (+ n 1)
+                              tail
                               (cons (colorize-string (match:substring m n)
                                                      first)
-                                    result)))))))))))
-    ((_)
-     (lambda (str)
-       str))))
+                                    result)))))))))))))
+
+(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 ...) ...)
+     (colorize-matches `((,(make-regexp regexp) ,(color colors) ...)
+                         ...)))))