dimitri/fancy
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Refactor graphics rendition function

Browse source
This commit is contained in:
Dimitri Lozeve 2021-04-28 20:33:32 +02:00
parent 7a77895665
commit 9241d2f983
2 changed files with 57 additions and 51 deletions
Download patch file Download diff file Expand all files Collapse all files

3
build.ss
View file

@ -6,5 +6,4 @@
'("fancy/format"
"fancy/table"
"fancy/rule"
"fancy/spinner")
optimize: #t)
"fancy/spinner"))

77
fancy/format.ss
View file

@ -1,4 +1,6 @@
(export cursor-up
(export
;; Control sequences
cursor-up
cursor-down
cursor-forward
cursor-back
@ -7,12 +9,14 @@
cursor-hor
cursor-pos
erase-in-display
erase-in-line
scroll-up
scroll-down
save-pos
restore-pos
set-graphics-mode
set-color
;; Graphics rendition parameters
graphics-style
;; Console markup
parse-markup
remove-markup)
@ -21,7 +25,11 @@
:std/misc/string
:std/srfi/1)
;; ========================= Constants =========================
(def +CSI+ "\033[")
(def +basic-colors+
'((black . 0)
(red . 1)
@ -41,6 +49,11 @@
(on-cyan . 6)
(on-white . 7)))
(def +re-tags+ (pregexp "\\[([a-z#\\/].*?)\\]"))
;; ========================= Control sequences =========================
(def (cursor-up (n 1)) (format "~a~dA" +CSI+ n))
(def (cursor-down (n 1)) (format "~a~dB" +CSI+ n))
(def (cursor-forward (n 1)) (format "~a~dC" +CSI+ n))
@ -56,25 +69,32 @@
(def (save-pos) (format "~as" +CSI+))
(def (restore-pos) (format "~au" +CSI+))
(def (set-graphics-mode (reset #t)
(bold #f)
(italic #f)
(underline #f)
(color #f)
(background #f))
(def args (filter string?
[(when reset "0")
(when bold "1")
(when italic "3")
(when underline "4")
(when color (format "3~d" (assgetq color +basic-colors+)))
(when background (format "4~d" (assgetq background +basic-bg-colors+)))]))
(format "~a~am" +CSI+ (string-join args #\;)))
(def (set-color (col #f))
(set-graphics-mode #t #f #f #f col #f))
;; ========================= Graphics rendition parameters =========================
(def +re-tags+ (pregexp "\\[([a-z#\\/].*?)\\]"))
(def (graphics-rendition-code tag)
(match tag
('bold "2")
('italic "3")
('underline "4")
((? (lambda (t) (assgetq t +basic-colors+)) => code) (format "3~d" code))
((? (lambda (t) (assgetq t +basic-bg-colors+)) => code) (format "4~d" code))
(else #!void)))
(def (graphics-style style)
(def colors (lset-intersection eq? style (map car +basic-colors+)))
(def bg-colors (lset-intersection eq? style (map car +basic-bg-colors+)))
(def style-without-colors (lset-difference eq? style
(map car +basic-colors+)
(map car +basic-bg-colors+)))
(def final-style (cons* (unless (null? colors) (car colors))
(unless (null? bg-colors) (car bg-colors))
style-without-colors))
(format "~a~am" +CSI+
(string-join (filter string? (map graphics-rendition-code final-style)) #\;)))
;; ========================= Console markup =========================
(def (parse-tag contents (style []))
(def closing (eq? #\/ (string-ref contents 0)))
@ -83,27 +103,14 @@
(def new-style (if closing
(lset-difference eq? style tags)
(lset-union eq? style tags)))
(def control-seq (set-graphics-mode
#t
(member 'bold new-style)
(member 'italic new-style)
(member 'underline new-style)
(let ((colors (lset-intersection eq?
new-style
(map car +basic-colors+))))
(if (null? colors) #f (car colors)))
(let ((bg-colors (lset-intersection
eq?
new-style
(map car +basic-bg-colors+))))
(if (null? bg-colors) #f (car bg-colors)))))
(def control-seq (graphics-style new-style))
(values control-seq new-style))
(def (parse-markup text (style []))
(match (pregexp-match +re-tags+ text)
([tag contents] (let-values (((control-seq new-style) (parse-tag contents style)))
(parse-markup (pregexp-replace +re-tags+ text control-seq) new-style)))
(else (str text (set-graphics-mode)))))
(else (str text (graphics-style [])))))
(def (remove-markup text)
(pregexp-replace* +re-tags+ text ""))