1 files changed, 87 insertions, 0 deletions

@@ -0,0 +1,87 @@
+;;; (yolk attrs) --- text attributes
+
+(import (scheme base)
+        (scheme write)
+        (chicken string)
+        (yolk common))
+
+(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 (prop? x)
+  (let ((x? (memq x (map car %props-alist))))
+    (if x? x #f)))
+
+(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 (color? x)
+  (let ((x? (memq x (map car %colors-alist))))
+    (if x? x #f)))
+
+(define (attrs as)
+  (let loop ((as as)
+             (acc '()))
+    (cond
+     ((null? as)
+      (attr-list->escape (reverse acc)))
+     ((eq? as 'reset)
+      (csi "0m"))
+     (else
+      (loop (cdr as)
+           (cons (attr->code (car as))
+                 acc))))))
+
+(define (attr-list->escape al)
+  (let ((code-string (string-intersperse (map ->string al) ";")))
+    (csi code-string "m")))
+
+(define (attr->code attr)
+  (cond
+   ((number? attr) attr)
+   ((or (color? attr)
+        (and (pair? attr)
+             (eq? (car attr) 'fg)
+             (or (color? (cdr attr))
+                 (color? (cadr attr)))))
+    => (lambda (clr)
+         (cadr (assq clr %colors-alist))))
+   ((and (pair? attr)
+         (eq? (car attr) 'bg)
+         (or (color? (cdr attr))
+             (color? (cadr attr))))
+    => (lambda (clr)
+         (cddr (assq clr %colors-alist))))
+   ((or (prop? attr)
+        (and (pair? attr)
+             (eq? (car attr) 'set)
+             (or (prop? (cdr attr))
+                 (prop? (cadr attr)))))
+    => (lambda (prop)
+         (cadr (assq prop %props-alist))))
+   ((and (pair? attr)
+         (eq? (car attr) 'reset)
+         (or (prop? (cdr attr))
+             (prop? (cadr attr))))
+    => (lambda (prop)
+         (cddr (assq prop %props-alist))))
+   (else (error "Bad attribute" attr))))