1 files changed, 89 insertions, 0 deletions

@@ -0,0 +1,89 @@
+;;; (yolk colors) --- ansi color escapes
+
+;; "Colors" in this context refers both to actual /colors/, and to text
+;; properties like bold, italic, etc.
+
+(import (scheme base)
+        (scheme write)
+        (chicken string)
+        (matchable)                     ; is this something i want?
+        (yolk common))
+
+(define (%colors . codes)
+  (let ((codestr (string-intersperse (map ->string codes) ";")))
+    (csi codestr "m")))
+
+(define %props-alist
+  '((reset . "0")
+    ;; name . (on . off)
+    (bold . ("1" . "22"))
+    (dim . ("2" . "22"))
+    (italic . ("3" . "23"))
+    (underline . ("4" . "24"))
+    (blink . ("5" . "25"))
+    (inverse . ("7" . "27"))
+    (hidden . ("8" . "28"))
+    (strikethrough . ("9" . "29"))))
+
+(define %colors-alist
+  '((reset . "0")
+    ;; color . (fg . bg)
+    (black . ("30" . "40"))
+    (red . ("31" . "41"))
+    (green . ("32" . "42"))
+    (yellow . ("33" . "43"))
+    (blue . ("34" . "44"))
+    (magenta . ("35" . "45"))
+    (cyan . ("36" . "46"))
+    (white . ("37" . "47"))
+    (default . ("39" . "49"))))
+
+(define (atom? x)
+  (and (not (pair? x))
+       (not (null? x))))
+
+(define (colors-reset . codes)
+  (cond
+   ((null? codes)
+    (%colors 0))
+   (else (apply string-append
+                (map (lambda (code)
+                       (match code
+                         ('fg (%colors (cadr (assq 'default %colors-alist))))
+                         ('bg (%colors (cddr (assq 'default %colors-alist))))
+                         (x (%colors (cddr (assq x %props-alist))))))
+                     codes)))))
+
+(define (color? x)
+  (memq x '(default black red green yellow blue magenta cyan white)))
+
+(define (colors codes)
+  (let loop ((codes codes)
+             (acc '()))
+    (if (null? codes)
+        (apply %colors (reverse acc))
+        (loop (cdr codes)
+              (match (car codes)
+                ((? number? x)
+                 (cons x acc))
+                ((or `(fg ,color)
+                     (? color? color))
+                 (cons (cadr (assq color %colors-alist))
+                       acc))
+                (`(bg ,color)
+                 (cons (cddr (assq color %colors-alist))
+                       acc))
+                ((or `(set ,prop)
+                     `(,prop on)
+                     (? atom? prop))
+                 (cons (cadr (assq prop %props-alist))
+                       acc))
+                ((or `(reset ,prop)
+                     `(,prop off))
+                 (cons (cddr (assq prop %props-alist)))))))))
+
+(define (with-colors codes thunk)
+  (dynamic-wind
+    (lambda () (display (colors codes)))
+    thunk
+    (lambda () (display (colors-reset)))))