diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..60edadc --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*\~ +build-deps diff --git a/README.org b/README.org index 0eedd2c..6a5ea93 100644 --- a/README.org +++ b/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]] diff --git a/build.ss b/build.ss new file mode 100755 index 0000000..8358789 --- /dev/null +++ b/build.ss @@ -0,0 +1,8 @@ +#!/usr/bin/env gxi + +(import :std/build-script) + +(defbuild-script + '("fancy/format" + "fancy/table") + optimize: #t) diff --git a/fancy/format.ss b/fancy/format.ss new file mode 100644 index 0000000..4f582f6 --- /dev/null +++ b/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)))) + " ")) diff --git a/fancy/table.ss b/fancy/table.ss new file mode 100644 index 0000000..1beef97 --- /dev/null +++ b/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"))) diff --git a/gerbil.pkg b/gerbil.pkg new file mode 100644 index 0000000..4d0df29 --- /dev/null +++ b/gerbil.pkg @@ -0,0 +1 @@ +(package: dlozeve)