about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--.repl2
-rw-r--r--readme28
-rw-r--r--yolk.attrs.sld6
-rw-r--r--yolk.attrs.ss87
-rw-r--r--yolk.egg4
5 files changed, 122 insertions, 5 deletions
diff --git a/.repl b/.repl index 8adbefe..1c161d1 100644 --- a/.repl +++ b/.repl
@@ -7,7 +7,7 @@
7;;; Load libraries 7;;; Load libraries
8 8
9(let loop ((load-files '("yolk.common" 9(let loop ((load-files '("yolk.common"
10 "yolk.colors" 10 "yolk.attrs"
11 "yolk.cursor" 11 "yolk.cursor"
12 "yolk.erase" 12 "yolk.erase"
13 "yolk.xterm"))) 13 "yolk.xterm")))
diff --git a/readme b/readme index 5eaa9f6..baa3bbc 100644 --- a/readme +++ b/readme
@@ -49,9 +49,28 @@ macro defines a parameter named PARAM-NAME and a procedure named
49WRAPPER-PROC-NAME that will call PARAM-NAME with ARGS ... . The user can change 49WRAPPER-PROC-NAME that will call PARAM-NAME with ARGS ... . The user can change
50which procedure to call by calling (PARAM-NAME new-proc). 50which procedure to call by calling (PARAM-NAME new-proc).
51 51
52(yolk colors) --- NOT FINISHED 52(yolk attrs) --- text attributes
53 53
54There's a bug in this library. 54-- (prop? x)
55
56Returns X if X is a text property (non-color); otherwise returns #f.
57
58-- (color? x)
59
60Returns X if X is a terminal color name; otherwise returns #f.
61
62-- (attrs as)
63
64AS is a list of attributes, each of one of the following forms:
65
66- [number] -- returned directly
67- [color], (fg [color]), (fg . [color]) -- set the foreground to [color]
68- (bg [color]), (bg . [color]) -- set the background to [color]
69- [property], (set [property]), (set . [property]) -- turn [property] on
70- (reset [property]), (reset . [property]) -- turn [property] off
71- 'reset -- reset the text attributes
72
73Anything else is an error. `attrs' returns a string ready to be displayed on the terminal.
55 74
56(yolk cursor) --- cursor movement 75(yolk cursor) --- cursor movement
57 76
@@ -133,6 +152,11 @@ Save or restore the screen's state.
133 152
134Enable or disable the "alternate buffer." 153Enable or disable the "alternate buffer."
135 154
155REFERENCES.
156
136[1]: http://wiki.call-cc.org/eggref/5/ansi-escape-sequences 157[1]: http://wiki.call-cc.org/eggref/5/ansi-escape-sequences
137[2]: https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797 158[2]: https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797
138[3]: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html 159[3]: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html
160
161- https://xn--rpa.cc/irl/term.html
162- (man "console_codes")
diff --git a/yolk.attrs.sld b/yolk.attrs.sld new file mode 100644 index 0000000..07fd0ad --- /dev/null +++ b/yolk.attrs.sld
@@ -0,0 +1,6 @@
1(define-library (yolk attrs)
2 (export prop?
3 color?
4 attrs)
5
6 (include "yolk.attrs.ss"))
diff --git a/yolk.attrs.ss b/yolk.attrs.ss new file mode 100644 index 0000000..6a06034 --- /dev/null +++ b/yolk.attrs.ss
@@ -0,0 +1,87 @@
1;;; (yolk attrs) --- text attributes
2
3(import (scheme base)
4 (scheme write)
5 (chicken string)
6 (yolk common))
7
8(define %props-alist
9 '((reset . "0")
10 ;; name . (on . off)
11 (bold . ("1" . "22"))
12 (dim . ("2" . "22"))
13 (italic . ("3" . "23"))
14 (underline . ("4" . "24"))
15 (blink . ("5" . "25"))
16 (inverse . ("7" . "27"))
17 (hidden . ("8" . "28"))
18 (strikethrough . ("9" . "29"))))
19
20(define (prop? x)
21 (let ((x? (memq x (map car %props-alist))))
22 (if x? x #f)))
23
24(define %colors-alist
25 '((reset . "0")
26 ;; color . (fg . bg)
27 (black . ("30" . "40"))
28 (red . ("31" . "41"))
29 (green . ("32" . "42"))
30 (yellow . ("33" . "43"))
31 (blue . ("34" . "44"))
32 (magenta . ("35" . "45"))
33 (cyan . ("36" . "46"))
34 (white . ("37" . "47"))
35 (default . ("39" . "49"))))
36
37(define (color? x)
38 (let ((x? (memq x (map car %colors-alist))))
39 (if x? x #f)))
40
41(define (attrs as)
42 (let loop ((as as)
43 (acc '()))
44 (cond
45 ((null? as)
46 (attr-list->escape (reverse acc)))
47 ((eq? as 'reset)
48 (csi "0m"))
49 (else
50 (loop (cdr as)
51 (cons (attr->code (car as))
52 acc))))))
53
54(define (attr-list->escape al)
55 (let ((code-string (string-intersperse (map ->string al) ";")))
56 (csi code-string "m")))
57
58(define (attr->code attr)
59 (cond
60 ((number? attr) attr)
61 ((or (color? attr)
62 (and (pair? attr)
63 (eq? (car attr) 'fg)
64 (or (color? (cdr attr))
65 (color? (cadr attr)))))
66 => (lambda (clr)
67 (cadr (assq clr %colors-alist))))
68 ((and (pair? attr)
69 (eq? (car attr) 'bg)
70 (or (color? (cdr attr))
71 (color? (cadr attr))))
72 => (lambda (clr)
73 (cddr (assq clr %colors-alist))))
74 ((or (prop? attr)
75 (and (pair? attr)
76 (eq? (car attr) 'set)
77 (or (prop? (cdr attr))
78 (prop? (cadr attr)))))
79 => (lambda (prop)
80 (cadr (assq prop %props-alist))))
81 ((and (pair? attr)
82 (eq? (car attr) 'reset)
83 (or (prop? (cdr attr))
84 (prop? (cadr attr))))
85 => (lambda (prop)
86 (cddr (assq prop %props-alist))))
87 (else (error "Bad attribute" attr))))
diff --git a/yolk.egg b/yolk.egg index 4e77939..b0ae841 100644 --- a/yolk.egg +++ b/yolk.egg
@@ -9,8 +9,8 @@
9 (extension yolk.common 9 (extension yolk.common
10 (source "yolk.common.sld") 10 (source "yolk.common.sld")
11 (csc-options "-R" "r7rs" "-X" "r7rs")) 11 (csc-options "-R" "r7rs" "-X" "r7rs"))
12 #;(extension yolk.colors 12 (extension yolk.attrs
13 (source "yolk.colors.sld") 13 (source "yolk.attrs.sld")
14 (csc-options "-R" "r7rs" "-X" "r7rs") 14 (csc-options "-R" "r7rs" "-X" "r7rs")
15 (component-dependencies yolk.common)) 15 (component-dependencies yolk.common))
16 (extension yolk.cursor 16 (extension yolk.cursor