Add (yolk attrs)

5 files changed, 122 insertions, 5 deletions

@@ -7,7 +7,7 @@
 ;;; Load libraries
 
 (let loop ((load-files '("yolk.common"
-                         "yolk.colors"
+                         "yolk.attrs"
                          "yolk.cursor"
                          "yolk.erase"
                          "yolk.xterm")))
@@ -49,9 +49,28 @@ macro defines a parameter named PARAM-NAME and a procedure named
 WRAPPER-PROC-NAME that will call PARAM-NAME with ARGS ... . The user can change
 which procedure to call by calling (PARAM-NAME new-proc).
 
-(yolk colors) --- NOT FINISHED
+(yolk attrs) --- text attributes
 
-There's a bug in this library.
+-- (prop? x)
+
+Returns X if X is a text property (non-color); otherwise returns #f.
+
+-- (color? x)
+
+Returns X if X is a terminal color name; otherwise returns #f.
+
+-- (attrs as)
+
+AS is a list of attributes, each of one of the following forms:
+
+- [number] -- returned directly
+- [color], (fg [color]), (fg . [color]) -- set the foreground to [color]
+- (bg [color]), (bg . [color]) -- set the background to [color]
+- [property], (set [property]), (set . [property]) -- turn [property] on
+- (reset [property]), (reset . [property]) -- turn [property] off
+- 'reset -- reset the text attributes
+
+Anything else is an error.  `attrs' returns a string ready to be displayed on the terminal.
 
 (yolk cursor) --- cursor movement
 
@@ -133,6 +152,11 @@ Save or restore the screen's state.
 
 Enable or disable the "alternate buffer."
 
+REFERENCES.
+
 [1]: http://wiki.call-cc.org/eggref/5/ansi-escape-sequences
 [2]: https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797
 [3]: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
+
+- https://xn--rpa.cc/irl/term.html
+- (man "console_codes")
@@ -0,0 +1,6 @@
+(define-library (yolk attrs)
+  (export prop?
+          color?
+          attrs)
+
+  (include "yolk.attrs.ss"))
@@ -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))))
@@ -9,8 +9,8 @@
   (extension yolk.common
              (source "yolk.common.sld")
              (csc-options "-R" "r7rs" "-X" "r7rs"))
-  #;(extension yolk.colors
-             (source "yolk.colors.sld")
+  (extension yolk.attrs
+             (source "yolk.attrs.sld")
              (csc-options "-R" "r7rs" "-X" "r7rs")
              (component-dependencies yolk.common))
   (extension yolk.cursor