diff --git a/build.ss b/build.ss index 37c6060..8971f3e 100755 --- a/build.ss +++ b/build.ss @@ -6,5 +6,4 @@ '("fancy/format" "fancy/table" "fancy/rule" - "fancy/spinner") - optimize: #t) + "fancy/spinner")) diff --git a/fancy/format.ss b/fancy/format.ss index 4c24149..ae83a9f 100644 --- a/fancy/format.ss +++ b/fancy/format.ss @@ -1,27 +1,35 @@ -(export cursor-up - cursor-down - cursor-forward - cursor-back - cursor-next - cursor-previous - cursor-hor - cursor-pos - erase-in-display - scroll-up - scroll-down - save-pos - restore-pos - set-graphics-mode - set-color - parse-markup - remove-markup) +(export + ;; Control sequences + cursor-up + cursor-down + cursor-forward + cursor-back + cursor-next + cursor-previous + cursor-hor + cursor-pos + erase-in-display + erase-in-line + scroll-up + scroll-down + save-pos + restore-pos + ;; Graphics rendition parameters + graphics-style + ;; Console markup + parse-markup + remove-markup) (import :std/format :std/pregexp :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 ""))