blob: 11c3cddf30cda2351aea1efcaa94da4945dde129 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
(define-module (fmt-stack)
#:export (get-attr
set-fg set-bg set-style
get-bg get-fg get-style
make-fmt-frame empty-fmt-frame
get-frame
fmt-frame->ansi-esc)
#:use-module (monad)
#:use-module (monad state)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu))
(define-immutable-record-type fmt-frame
(make-fmt-frame style fg bg)
fmt-frame?
(style get-style set-style)
(fg get-fg set-fg)
(bg get-bg set-bg))
(define (empty-fmt-frame)
(make-fmt-frame #f #f #f))
;; B - blue
;; BL - black
;; C - cyan
;; G - green
;; M - magenta
;; R - red
;; W - white
;; Y - yellow
(define (fmt-frame->ansi-esc frame)
(string-append
"\x1b[m"
(case (get-fg frame)
((B) "\x1b[0;34m")
((BL) "\x1b[0;30m")
((C) "\x1b[0;96m")
((G) "\x1b[0;32m")
((M) "\x1b[0;35m")
((R) "\x1b[0;31m")
((W) "\x1b[0;97m")
((Y) "\x1b[0;93m")
(else ""))
(case (get-bg frame)
((B) "\x1b[44m")
((BL) "\x1b[40m")
((C) "\x1b[106m")
((G) "\x1b[42m")
((M) "\x1b[45m")
((R) "\x1b[41m")
((W) "\x1b[107m")
((Y) "\x1b[103m")
(else ""))
(case (get-style frame)
((underline) "\x1b[4m")
((italic) "\x1b[3m")
((bold) "\x1b[1m")
(else ""))))
(define (get-frame)
(do stack <- (get)
(return-state
(make-fmt-frame
(get-style (find get-style stack))
(get-fg (find get-fg stack))
(get-bg (find get-bg stack))))
))
(define (get-attr)
(<$> fmt-frame->ansi-esc (get-frame)))
|
