93 lines
3.4 KiB
Scheme
93 lines
3.4 KiB
Scheme
;; ========================= Constants =========================
|
|
|
|
(define +CSI+ "\033[")
|
|
|
|
(define +basic-colors+
|
|
'((black . 0)
|
|
(red . 1)
|
|
(green . 2)
|
|
(yellow . 3)
|
|
(blue . 4)
|
|
(magenta . 5)
|
|
(cyan . 6)
|
|
(white . 7)))
|
|
|
|
(define +basic-bg-colors+
|
|
'((on-black . 0)
|
|
(on-red . 1)
|
|
(on-green . 2)
|
|
(on-yellow . 3)
|
|
(on-blue . 4)
|
|
(on-magenta . 5)
|
|
(on-cyan . 6)
|
|
(on-white . 7)))
|
|
|
|
(define +re-tags+ (irregex "\\[(/?[a-z ]*?)\\]"))
|
|
|
|
|
|
;; ========================= Control sequences =========================
|
|
|
|
(define (cursor-up #!optional (n 1)) (format "~a~aA" +CSI+ n))
|
|
(define (cursor-down #!optional (n 1)) (format "~a~aB" +CSI+ n))
|
|
(define (cursor-forward #!optional (n 1)) (format "~a~aC" +CSI+ n))
|
|
(define (cursor-back #!optional (n 1)) (format "~a~aD" +CSI+ n))
|
|
(define (cursor-next #!optional (n 1)) (format "~a~aE" +CSI+ n))
|
|
(define (cursor-previous #!optional (n 1)) (format "~a~aF" +CSI+ n))
|
|
(define (cursor-hor #!optional (n 1)) (format "~a~aG" +CSI+ n))
|
|
(define (cursor-pos #!optional (n 1) (m 1)) (format "~a~a;~aH" +CSI+ n m))
|
|
(define (erase-in-display #!optional (n 0)) (format "~a~aJ" +CSI+ n))
|
|
(define (erase-in-line #!optional (n 0)) (format "~a~aK" +CSI+ n))
|
|
(define (scroll-up #!optional (n 1)) (format "~a~aS" +CSI+ n))
|
|
(define (scroll-down #!optional (n 1)) (format "~a~aT" +CSI+ n))
|
|
(define (save-pos) (format "~as" +CSI+))
|
|
(define (restore-pos) (format "~au" +CSI+))
|
|
|
|
|
|
;; ========================= Graphics rendition parameters =========================
|
|
|
|
(define (graphics-rendition-code tag)
|
|
(define basic-color (assoc tag +basic-colors+))
|
|
(define basic-bg-color (assoc tag +basic-bg-colors+))
|
|
(cond
|
|
((eq? tag 'bold) "2")
|
|
((eq? tag 'italic) "3")
|
|
((eq? tag 'underline) "4")
|
|
(basic-color (format "3~a" (cdr basic-color)))
|
|
(basic-bg-color (format "4~a" (cdr basic-bg-color)))))
|
|
|
|
(define (graphics-style #!optional (style '()))
|
|
(define colors (lset-intersection eq? style (map car +basic-colors+)))
|
|
(define bg-colors (lset-intersection eq? style (map car +basic-bg-colors+)))
|
|
(define style-without-colors (lset-difference eq? style
|
|
(map car +basic-colors+)
|
|
(map car +basic-bg-colors+)))
|
|
(define 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 =========================
|
|
|
|
(define (parse-tag contents #!optional (style '()))
|
|
(define closing (eq? #\/ (string-ref contents 0)))
|
|
(define clean-contents (if closing (string-drop contents 1) contents))
|
|
(define clean-contents (irregex-replace/all "on " clean-contents "on-"))
|
|
(define tags (map string->symbol (string-split clean-contents " ")))
|
|
(define new-style (if closing
|
|
(lset-difference eq? style tags)
|
|
(lset-union eq? style tags)))
|
|
(define control-seq (graphics-style new-style))
|
|
(values control-seq new-style))
|
|
|
|
(define (parse-markup text #!optional (style '()))
|
|
(define match (irregex-search +re-tags+ text))
|
|
(if match
|
|
(let-values (((control-seq new-style) (parse-tag (irregex-match-substring match 1) style)))
|
|
(parse-markup (irregex-replace +re-tags+ text control-seq) new-style))
|
|
(string-append text (graphics-style '()))))
|
|
|
|
(define (remove-markup text)
|
|
(irregex-replace/all +re-tags+ text ""))
|
|
|