Add ANSI control codes and table formatting

.gitignore

@@ -0,0 +1,2 @@
+*\~
+build-deps

README.org

@@ -2,6 +2,11 @@
 
 Fancy pretty-printing utilities for [[https://cons.io/][Gerbil Scheme]].
 
+** Features
+
+- [[https://en.wikipedia.org/wiki/ANSI_escape_code#CSI_(Control_Sequence_Introducer)_sequences][ANSI control codes]] for styling and cursor movement
+- Table formatting with [[https://unicode-table.com/en/blocks/box-drawing/][Unicode box drawing characters]]
+
 ** References
 
 - [[https://notes.burke.libbey.me/ansi-escape-codes/][Everything you never wanted to know about ANSI escape codes]]

build.ss

@@ -0,0 +1,8 @@
+#!/usr/bin/env gxi
+
+(import :std/build-script)
+
+(defbuild-script
+  '("fancy/format"
+    "fancy/table")
+  optimize: #t)

fancy/format.ss

@@ -0,0 +1,106 @@
+(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
+	spinner)
+
+(import :std/format
+	:std/pregexp
+	:std/misc/string
+	:std/srfi/1)
+
+(def +CSI+ "\033[")
+(def +basic-colors+
+  '((black . 0)
+    (red . 1)
+    (green . 2)
+    (yellow . 3)
+    (blue . 4)
+    (magenta . 5)
+    (cyan . 6)
+    (white . 7)))
+
+(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))
+(def (cursor-back (n 1)) (format "~a~dD" +CSI+ n))
+(def (cursor-next (n 1)) (format "~a~dE" +CSI+ n))
+(def (cursor-previous (n 1)) (format "~a~dF" +CSI+ n))
+(def (cursor-hor (n 1)) (format "~a~dG" +CSI+ n))
+(def (cursor-pos (n 1) (m 1)) (format "~a~d;~dH" +CSI+ n m))
+(def (erase-in-display (n 0)) (format "~a~dJ" +CSI+ n))
+(def (erase-in-line (n 0)) (format "~a~dK" +CSI+ n))
+(def (scroll-up (n 1)) (format "~a~dS" +CSI+ n))
+(def (scroll-down (n 1)) (format "~a~dT" +CSI+ n))
+(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-colors+)))]))
+  (format "~a~am" +CSI+ (string-join args #\;)))
+
+(def (set-color (col #f))
+  (set-graphics-mode #t #f #f #f col #f))
+
+(def +re-tags+ (pregexp "\\[([a-z#\\/].*?)\\]"))
+
+(def (parse-tag contents (style []))
+  (def closing (eq? #\/ (string-ref contents 0)))
+  (def tags (map string->symbol (string-split (string-trim-prefix "/" contents) #\ )))
+  (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?
+						     (map car +basic-colors+)
+						     new-style)))
+		      (if (null? colors) #f (car 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)))))
+
+(def (remove-markup text)
+  (pregexp-replace* +re-tags+ text ""))
+
+(def (spinner i style: (style 'ascii))
+  (str (cursor-back 2)
+       (match style
+	 ('block (string-ref "▖▘▝▗" (modulo i 4)))
+	 ('triangle (string-ref "◢◣◤◥" (modulo i 4)))
+	 ('circle (string-ref "◐◓◑◒" (modulo i 4)))
+	 ('vertical (string-ref "▁▃▄▅▆▇█▇▆▅▄▃" (modulo i 12)))
+	 ('horizontal (string-ref "▉▊▋▌▍▎▏▎▍▌▋▊▉" (modulo i 12)))
+	 ('ascii (string-ref "|/-\\" (modulo i 4))))
+       " "))

fancy/table.ss

@@ -0,0 +1,30 @@
+(export (struct-out table)
+	table-header
+	table-row
+	table-footer)
+
+(import :std/misc/string
+	:dlozeve/fancy/format)
+
+(defstruct table (names widths))
+
+(def (column-text text width)
+  (str " "
+       (parse-markup text)
+       (make-string (- width (string-length (remove-markup text)) 1) #\ )))
+
+(def (table-header tab)
+  (with ((table names widths) tab)
+    (str "┌" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┬) "┐\n"
+	 "│" (string-join (map (lambda (name width) (column-text name (+ 2 width))) names widths) #\│) "│\n"
+	 "├" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┼) "┤\n")))
+
+(def (table-row tab . args)
+  (with ((table names widths) tab)
+    (str "│"
+	 (string-join (map (lambda (text width) (column-text text (+ 2 width))) args widths) #\│)
+	 "│\n")))
+
+(def (table-footer tab)
+  (with ((table names widths) tab)
+    (str "└" (string-join (map (lambda (w) (make-string (+ 2 w) #\─)) widths) #\┴) "┘\n")))

gerbil.pkg

@@ -0,0 +1 @@
+(package: dlozeve)