From 544265acba89a41691c6be5b4af8e3c2237cd5c6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 11 Apr 2019 17:17:38 +0200
Subject: colors: Add 'colorize-matches'.

* guix/colors.scm (colorize-matches): New procedure.
(color-rules): Rewrite in terms of 'colorize-matches'.
---
 guix/colors.scm | 55 ++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 21 deletions(-)

(limited to 'guix/colors.scm')

diff --git a/guix/colors.scm b/guix/colors.scm
index b7d3f6d4ec..30ad231dfe 100644
--- a/guix/colors.scm
+++ b/guix/colors.scm
@@ -132,34 +132,47 @@ that subsequent output will not have any colors in effect."
        (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 (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) ...)
+                         ...)))))
-- 
cgit v1.2.3