Fixed show color/underline/bold nesting bugs and added test cases.

lib/chibi/show/color-test.sld

@@ -0,0 +1,40 @@
+(define-library (chibi show color-test)
+  (import (scheme base) (chibi show) (chibi show color) (chibi test))
+  (export run-tests)
+  (begin
+    (define (run-tests)
+      (test-begin "(chibi show color)")
+
+      ;; Confirm only one attribute setting and one reset when done
+      ;; when nesting with the same attribute value
+      (test "\x1b;[33mfoomoreso\x1b;[0m"
+            (show #f (as-yellow "foo" (as-yellow "moreso"))))
+      (test "\x1b;[4mfoomoreso\x1b;[24m"
+            (show #f (as-underline "foo" (as-underline "moreso"))))
+      (test "\x1b;[1mfoomoreso\x1b;[0m"
+            (show #f (as-bold "foo" (as-bold "moreso"))))
+
+      (test "\x1b;[31mred\n\x1b;[1mred and bold\n\x1b;[4mred bold underline\n\x1b;[34mswitched to blue with a little \x1b;[35mmagenta\x1b;[34m in between\n\x1b;[31m\x1b;[24mback to red and bold\n\x1b;[0m\x1b;[31mjust red\n\x1b;[0mnormal\n"
+            (show #f
+                  (as-red "red" nl
+                          (as-bold "red and bold" nl
+                                   (as-underline "red bold underline" nl
+                                                 (as-blue "switched to blue with a little " (as-magenta "magenta") " in between" nl))
+                                   "back to red and bold" nl)
+                          "just red" nl)
+                  "normal" nl))
+
+      (test "normal\n\x1b;[4munderlined\n\x1b;[32mgreen underlined\n\x1b;[1mgreen underlined bold\n\x1b;[0m\x1b;[32m\x1b;[4mback to green underlined\n\x1b;[0m\x1b;[4mback to underlined\n\x1b;[24mback to normal\n"
+            (show #f
+                  "normal" nl
+                  (as-underline "underlined" nl
+                                (as-green "green underlined" nl
+                                          (as-bold "green underlined bold" nl)
+                                          "back to green underlined" nl)
+                                "back to underlined" nl)
+                  "back to normal" nl))
+
+      (test-end)
+      )
+    )
+  )

lib/chibi/show/color.scm

@@ -2,11 +2,15 @@
 ;; Copyright (c) 2006-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
+;; Uses state variables color-hue color-bold? color-underline?
+;; Assumes defaults for those variables are all #f
+
 (define (color->ansi x)
   (case x
     ((bold) "1")
     ((dark) "2")
     ((underline) "4")
+    ((underline-off) "24")
     ((black) "30")
     ((red) "31")
     ((green) "32")
@@ -20,24 +24,46 @@
 (define (ansi-escape color)
   (each (integer->char 27) "[" (color->ansi color) "m"))
 
-(define (colored new-color . args)
-  (fn (color)
-    (with ((color new-color))
-      (each (ansi-escape new-color)
-            (each-in-list args)
-            (if (or (memq new-color '(bold underline))
-                    (memq color '(bold underline)))
-                (ansi-escape 'reset)
-                nothing)
-            (ansi-escape color)))))
+(define (colored colorkey args)
+  (fn ((old-hue color-hue))
+    (if (eqv? old-hue colorkey)
+        (each-in-list args)
+        (each (ansi-escape colorkey)
+              (with ((color-hue colorkey)) (each-in-list args))
+              (if old-hue
+                  (ansi-escape old-hue)
+                  (fn ((underline? color-underline?)
+                       (bold? color-bold?))
+                    (each (ansi-escape 'reset)
+                          (if underline? (ansi-escape 'underline) nothing)
+                          (if bold? (ansi-escape 'bold) nothing))))))))
+
+(define (as-red . args) (colored 'red args))
+(define (as-blue . args) (colored 'blue args))
+(define (as-green . args) (colored 'green args))
+(define (as-cyan . args) (colored 'cyan args))
+(define (as-yellow . args) (colored 'yellow args))
+(define (as-magenta . args) (colored 'magenta args))
+(define (as-white . args) (colored 'white args))
+(define (as-black . args) (colored 'black args))
+
+(define (as-bold . args)
+  (fn ((old-bold color-bold?))
+    (if old-bold
+        (each-in-list args)
+        (each (ansi-escape 'bold)
+              (with ((color-bold? #t)) (each-in-list args))
+              (ansi-escape 'reset)
+              (fn ((hue color-hue)
+                   (underline? color-underline?))
+                (each
+                 (if hue (ansi-escape hue) nothing)
+                 (if underline? (ansi-escape 'underline) nothing)))))))
 
-(define (as-red . args) (colored 'red (each-in-list args)))
-(define (as-blue . args) (colored 'blue (each-in-list args)))
-(define (as-green . args) (colored 'green (each-in-list args)))
-(define (as-cyan . args) (colored 'cyan (each-in-list args)))
-(define (as-yellow . args) (colored 'yellow (each-in-list args)))
-(define (as-magenta . args) (colored 'magenta (each-in-list args)))
-(define (as-white . args) (colored 'white (each-in-list args)))
-(define (as-black . args) (colored 'black (each-in-list args)))
-(define (as-bold . args) (colored 'bold (each-in-list args)))
-(define (as-underline . args) (colored 'underline (each-in-list args)))
+(define (as-underline . args)
+  (fn ((old-underline color-underline?))
+    (if old-underline
+        (each-in-list args)
+        (each (ansi-escape 'underline)
+              (with ((color-underline? #t)) (each-in-list args))
+              (ansi-escape 'underline-off)))))

tests/lib-tests.scm

@@ -52,6 +52,7 @@
         (rename (chibi scribble-test) (run-tests run-scribble-tests))
         (rename (chibi show-test) (run-tests run-show-tests))
         (rename (chibi show c-test) (run-tests run-show-c-tests))
+        (rename (chibi show color-test) (run-tests run-show-color-tests))
         (rename (chibi string-test) (run-tests run-string-tests))
 	(rename (chibi syntax-case-test) (run-tests run-syntax-case-tests))
         (rename (chibi system-test) (run-tests run-system-tests))
@@ -114,6 +115,7 @@
 (run-sha2-tests)
 (run-show-tests)
 (run-show-c-tests)
+(run-show-color-tests)
 (run-system-tests)
 (run-tar-tests)
 (run-uri-tests)