From 9067c8b5d556a12069c3573652381282bd0f9ba3 Mon Sep 17 00:00:00 2001 From: krzygorz Date: Mon, 24 Aug 2020 13:52:29 +0200 Subject: [PATCH] text attribute resetting fix --- lib/srfi/166/color.scm | 80 +++++++++++++++++++++++------------------- lib/srfi/166/color.sld | 3 -- lib/srfi/166/test.sld | 12 ++++--- 3 files changed, 52 insertions(+), 43 deletions(-) diff --git a/lib/srfi/166/color.scm b/lib/srfi/166/color.scm index c20a5f62..4235705f 100644 --- a/lib/srfi/166/color.scm +++ b/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") - (else "0"))) + ((default-bg) "49"))) (define (ansi-escape color) (if (string? color) color (string-append "\x1B;[" (color->ansi color) "m"))) -(define (colored new-color . args) - (fn ((orig-color color)) - (with ((color new-color)) - (each (ansi-escape new-color) - (each-in-list args) - (if (or (memq new-color '(bold underline)) - (memq orig-color '(bold underline))) - (ansi-escape 'reset) - nothing) - (ansi-escape orig-color))))) +(define color (make-state-variable 'color 'default-fg #f)) +(define background (make-state-variable 'background 'default-bg #f)) +(define bold (make-state-variable 'bold 'bold-off #f)) +(define italic (make-state-variable 'bold 'italic-off #f)) +(define underline (make-state-variable 'bold 'underline-off #f)) -(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-italic . args) (colored 'italic (each-in-list args))) -(define (as-underline . args) (colored 'underline (each-in-list args))) +(define (with-attr var new-attr . args) + (fn ((orig-attr var)) + (with ((var new-attr)) + (each (ansi-escape new-attr) + (each-in-list args) + (ansi-escape orig-attr))))) -(define (on-red . args) (colored 'on-red (each-in-list args))) -(define (on-blue . args) (colored 'on-blue (each-in-list args))) -(define (on-green . args) (colored 'on-green (each-in-list args))) -(define (on-cyan . args) (colored 'on-cyan (each-in-list args))) -(define (on-yellow . args) (colored 'on-yellow (each-in-list args))) -(define (on-magenta . args) (colored 'on-magenta (each-in-list args))) -(define (on-white . args) (colored 'on-white (each-in-list args))) -(define (on-black . args) (colored 'on-black (each-in-list args))) +(define (as-bold . args) (with-attr bold 'bold (each-in-list args))) +(define (as-italic . args) (with-attr italic 'italic (each-in-list args))) +(define (as-underline . args) (with-attr underline 'underline (each-in-list args))) + +(define (as-red . args) (with-attr color 'red (each-in-list args))) +(define (as-blue . args) (with-attr color 'blue (each-in-list args))) +(define (as-green . args) (with-attr color 'green (each-in-list args))) +(define (as-cyan . args) (with-attr color 'cyan (each-in-list args))) +(define (as-yellow . args) (with-attr color 'yellow (each-in-list args))) +(define (as-magenta . args) (with-attr color 'magenta (each-in-list args))) +(define (as-white . args) (with-attr color 'white (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))) diff --git a/lib/srfi/166/color.sld b/lib/srfi/166/color.sld index b093b473..c64c32d5 100644 --- a/lib/srfi/166/color.sld +++ b/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")) diff --git a/lib/srfi/166/test.sld b/lib/srfi/166/test.sld index c76b6739..47134ae5 100644 --- a/lib/srfi/166/test.sld +++ b/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;[34mblue\x1B;[31mred\x1B;[0m" + (test "\x1B;[31mred\x1B;[39m" (show #f (as-red "red"))) + (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 "日本語"