text attribute resetting fix

lib/srfi/166/color.scm

@@ -8,6 +8,11 @@
     ((dark) "2")
     ((italic) "3")
     ((underline) "4")
+
+    ((bold-off) "22")
+    ((italic-off) "23")
+    ((underline-off) "24")
+
     ((black) "30")
     ((red) "31")
     ((green) "32")
@@ -16,7 +21,8 @@
     ((magenta) "35")
     ((cyan) "36")
     ((white) "37")
-    ((reset) "39")
+    ((default-fg) "39")
+
     ((on-black) "40")
     ((on-red) "41")
     ((on-green) "42")
@@ -25,45 +31,47 @@
     ((on-magenta) "45")
     ((on-cyan) "46")
     ((on-white) "47")
-    ((on-reset) "49")
+    ((default-bg) "49")))
-    (else "0")))
 
 (define (ansi-escape color)
   (if (string? color)
       color
       (string-append "\x1B;[" (color->ansi color) "m")))
 
-(define (colored new-color . args)
+(define color (make-state-variable 'color 'default-fg #f))
-  (fn ((orig-color color))
+(define background (make-state-variable 'background 'default-bg #f))
-    (with ((color new-color))
+(define bold (make-state-variable 'bold 'bold-off #f))
-      (each (ansi-escape new-color)
+(define italic (make-state-variable 'bold 'italic-off #f))
+(define underline (make-state-variable 'bold 'underline-off #f))
+
+(define (with-attr var new-attr . args)
+  (fn ((orig-attr var))
+      (with ((var new-attr))
+            (each (ansi-escape new-attr)
                   (each-in-list args)
-            (if (or (memq new-color '(bold underline))
+                  (ansi-escape orig-attr)))))
-                    (memq orig-color '(bold underline)))
-                (ansi-escape 'reset)
-                nothing)
-            (ansi-escape orig-color)))))
 
-(define (as-red . args) (colored 'red (each-in-list args)))
+(define (as-bold . args) (with-attr bold 'bold (each-in-list args)))
-(define (as-blue . args) (colored 'blue (each-in-list args)))
+(define (as-italic . args) (with-attr italic 'italic (each-in-list args)))
-(define (as-green . args) (colored 'green (each-in-list args)))
+(define (as-underline . args) (with-attr underline 'underline (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-italic . args) (colored 'italic (each-in-list args)))
-(define (as-underline . args) (colored 'underline (each-in-list args)))
 
-(define (on-red . args) (colored 'on-red (each-in-list args)))
+(define (as-red . args) (with-attr color 'red (each-in-list args)))
-(define (on-blue . args) (colored 'on-blue (each-in-list args)))
+(define (as-blue . args) (with-attr color 'blue (each-in-list args)))
-(define (on-green . args) (colored 'on-green (each-in-list args)))
+(define (as-green . args) (with-attr color 'green (each-in-list args)))
-(define (on-cyan . args) (colored 'on-cyan (each-in-list args)))
+(define (as-cyan . args) (with-attr color 'cyan (each-in-list args)))
-(define (on-yellow . args) (colored 'on-yellow (each-in-list args)))
+(define (as-yellow . args) (with-attr color 'yellow (each-in-list args)))
-(define (on-magenta . args) (colored 'on-magenta (each-in-list args)))
+(define (as-magenta . args) (with-attr color 'magenta (each-in-list args)))
-(define (on-white . args) (colored 'on-white (each-in-list args)))
+(define (as-white . args) (with-attr color 'white (each-in-list args)))
-(define (on-black . args) (colored 'on-black (each-in-list args)))
+(define (as-black . args) (with-attr color 'black (each-in-list args)))
+
+(define (on-red . args) (with-attr background 'on-red (each-in-list args)))
+(define (on-blue . args) (with-attr background 'on-blue (each-in-list args)))
+(define (on-green . args) (with-attr background 'on-green (each-in-list args)))
+(define (on-cyan . args) (with-attr background 'on-cyan (each-in-list args)))
+(define (on-yellow . args) (with-attr background 'on-yellow (each-in-list args)))
+(define (on-magenta . args) (with-attr background 'on-magenta (each-in-list args)))
+(define (on-white . args) (with-attr background 'on-white (each-in-list args)))
+(define (on-black . args) (with-attr background 'on-black (each-in-list args)))
 
 (define (rgb-escape red-level green-level blue-level bg?)
   (when (not (and (exact-integer? red-level) (<= 0 red-level 5)))
@@ -92,13 +100,13 @@
    "m"))
 
 (define (as-color red green blue . fmt)
-  (colored (rgb-escape red green blue #f) (each-in-list fmt)))
+  (with-attr color (rgb-escape red green blue #f) (each-in-list fmt)))
 
 (define (as-true-color red green blue . fmt)
-  (colored (rgb24-escape red green blue #f) (each-in-list fmt)))
+  (with-attr color (rgb24-escape red green blue #f) (each-in-list fmt)))
 
 (define (on-color red green blue . fmt)
-  (colored (rgb-escape red green blue #t) (each-in-list fmt)))
+  (with-attr background (rgb-escape red green blue #t) (each-in-list fmt)))
 
 (define (on-true-color red green blue . fmt)
-  (colored (rgb24-escape red green blue #t) (each-in-list fmt)))
+  (with-attr background (rgb24-escape red green blue #t) (each-in-list fmt)))

lib/srfi/166/color.sld

@@ -12,7 +12,4 @@
    on-magenta on-white on-black
    on-color on-true-color
    )
-  (begin
-    (define color
-      (make-state-variable 'color #f #f)))
   (include "color.scm"))

lib/srfi/166/test.sld

@@ -749,11 +749,15 @@ def | 6
                              (each "123\n45\n6\n")))))
 
       ;; color
-      (test "\x1B;[31mred\x1B;[0m" (show #f (as-red "red")))
+      (test "\x1B;[31mred\x1B;[39m" (show #f (as-red "red")))
-      (test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[0m"
+      (test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[39m"
           (show #f (as-red "red" (as-blue "blue") "red")))
-      (test "\x1b;[31m1234567\x1b;[0m col: 7"
+      (test "\x1b;[31m1234567\x1b;[39m col: 7"
             (show #f (terminal-aware (as-red "1234567") (fn (col) (each " col: " col)))))
+      (test "\x1b;[31m\x1b;[4m\x1b;[1mabc\x1b;[22mdef\x1b;[24mghi\x1b;[39m"
+            (show #f (as-red (each (as-underline (as-bold "abc") "def") "ghi"))))
+      (test "\x1b;[44m\x1b;[33mabc\x1b;[39mdef\x1b;[49m"
+            (show #f (on-blue (each (as-yellow "abc") "def"))))
 
       ;; unicode
       (test "〜日本語〜"
@@ -768,7 +772,7 @@ def | 6
           (show #f (trimmed/right 2 "日本語")))
       (test "日"
           (show #f (terminal-aware (trimmed/right 2 "日本語"))))
-      (test "\x1B;[31m日\x1B;[46m\x1B;[31m\x1B;[0m"
+      (test "\x1B;[31m日\x1B;[46m\x1B;[49m\x1B;[39m"
           (show #f (terminal-aware
                     (trimmed/right 2 (as-red "日本語" (on-cyan "!!!!"))))))
       (test "日本語"