diff options
| -rw-r--r-- | guix/colors.scm | 55 |
1 files changed, 34 insertions, 21 deletions
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) ...) + ...))))) |