Refactor graphics rendition function

build.ss

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

fancy/format.ss

@@ -1,27 +1,35 @@
-(export cursor-up
+(export
-	cursor-down
+  ;; Control sequences
-	cursor-forward
+  cursor-up
-	cursor-back
+  cursor-down
-	cursor-next
+  cursor-forward
-	cursor-previous
+  cursor-back
-	cursor-hor
+  cursor-next
-	cursor-pos
+  cursor-previous
-	erase-in-display
+  cursor-hor
-	scroll-up
+  cursor-pos
-	scroll-down
+  erase-in-display
-	save-pos
+  erase-in-line
-	restore-pos
+  scroll-up
-	set-graphics-mode
+  scroll-down
-	set-color
+  save-pos
-	parse-markup
+  restore-pos
-	remove-markup)
+  ;; 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))
+;; ========================= Graphics rendition parameters =========================
-  (set-graphics-mode #t #f #f #f col #f))
 
-(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
+  (def control-seq (graphics-style new-style))
-		    #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)))))
   (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 ""))