92 lines
2.8 KiB
Scheme
92 lines
2.8 KiB
Scheme
(define-module (termenv style)
|
|
#:use-module (termenv)
|
|
#:use-module (termenv color)
|
|
#:use-module (termenv unix)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:export (foreground
|
|
background
|
|
bold
|
|
faint
|
|
italic
|
|
underline
|
|
overline
|
|
blink
|
|
invert
|
|
cross-out))
|
|
|
|
(define %RESET "0")
|
|
(define %BOLD "1")
|
|
(define %FAINT "2")
|
|
(define %ITALIC "3")
|
|
(define %UNDERLINE "4")
|
|
(define %BLINK "5")
|
|
(define %REVERSE "7")
|
|
(define %CROSS-OUT "9")
|
|
(define %OVERLINE "53")
|
|
|
|
;; Leaf node of style tree
|
|
(define-immutable-record-type <style>
|
|
(make-style string sequences)
|
|
style?
|
|
(string style-string)
|
|
(sequences style-sequences set-style-sequences))
|
|
|
|
;; Non-leaf nodes
|
|
(define-immutable-record-type <style-node>
|
|
(make-style-node children)
|
|
style-node?
|
|
(children style-node-children set-style-node-children))
|
|
|
|
(define (style-node->sequence node port)
|
|
(for-each
|
|
(λ (n)
|
|
(if (style? n)
|
|
(style->sequence n port)
|
|
(style-node->sequence n port)))
|
|
(style-node-children node)))
|
|
|
|
(set-record-type-printer! <style-node> style-node->sequence)
|
|
|
|
(define (style->sequence style port)
|
|
(define str (style-string style))
|
|
(define (just-str) (format port "~a" str))
|
|
|
|
;; Color sequences aren't strings, so handle them specially
|
|
;; Colors don't get resolved until we have the port because we don't know the color profile until then.
|
|
(define (sequence->str seq)
|
|
(if (color? seq)
|
|
(color->sequence seq)
|
|
seq))
|
|
|
|
(cond
|
|
((eq? 0 (length (style-sequences style))) (just-str))
|
|
(else
|
|
(let ((seq (string-join (map sequence->str (style-sequences style)) ";")))
|
|
(if (equal? seq "")
|
|
(just-str)
|
|
(format port "~a~am~a~a~am" %CSI seq str %CSI %RESET))))))
|
|
|
|
(set-record-type-printer! <style> style->sequence)
|
|
|
|
(define (cons-seq stylish sequence)
|
|
(match stylish
|
|
((? string? str) (make-style str (list sequence)))
|
|
((style) (cons-seq style sequence))
|
|
((? list? l) (make-style-node (map (cut cons-seq <> sequence) l)))
|
|
((? style? style) (set-style-sequences style (cons* sequence (style-sequences style))))
|
|
((? style-node? node)
|
|
(set-style-node-children node (map (cut cons-seq <> sequence) (style-node-children node))))))
|
|
|
|
(define (bold . s) (cons-seq s %BOLD))
|
|
(define (faint . s) (cons-seq s %FAINT))
|
|
(define (italic . s) (cons-seq s %ITALIC))
|
|
(define (underline . s) (cons-seq s %UNDERLINE))
|
|
(define (overline . s) (cons-seq s %OVERLINE))
|
|
(define (blink . s) (cons-seq s %BLINK))
|
|
(define (invert . s) (cons-seq s %REVERSE))
|
|
(define (cross-out . s) (cons-seq s %CROSS-OUT))
|
|
(define (foreground c . s) (cons-seq s (make-foreground c)))
|
|
(define (background c . s) (cons-seq s (make-background c)))
|