392 lines
11 KiB
Scheme
392 lines
11 KiB
Scheme
;;
|
|
;; table.scm
|
|
;;
|
|
;; Simple table formatter.
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit table))
|
|
|
|
(module
|
|
table
|
|
(
|
|
*table-border-style*
|
|
table->string
|
|
table-tests!
|
|
)
|
|
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken string)
|
|
(chicken format)
|
|
(chicken keyword)
|
|
(chicken irregex)
|
|
ansi
|
|
testing
|
|
utils)
|
|
|
|
;; Default table border style to use if not explicitly specified.
|
|
(define *table-border-style* (make-parameter 'unicode))
|
|
|
|
;; Table border styles in visual form
|
|
(define table-borders-lookup-source
|
|
'((debug
|
|
"/=,\\"
|
|
"] |["
|
|
">-+<"
|
|
"'~^`")
|
|
(ascii
|
|
"+-++"
|
|
"| ||"
|
|
"+-++"
|
|
"+-++")
|
|
(unicode
|
|
"┌─┬┐"
|
|
"│ ││"
|
|
"├─┼┤"
|
|
"└─┴┘")))
|
|
|
|
;; Returns a list of strings representing the rows in the original
|
|
;; string.
|
|
(define (string->rows str)
|
|
(string-split str "\n" #t))
|
|
|
|
;; Creates procedure that ensures a list has given number of elements
|
|
;; filling the missing elements with given filler (defaults to empty
|
|
;; string).
|
|
(define ((make-list-extender ds . ofl) row)
|
|
(let ((fl (if (null? ofl) "" (car ofl))))
|
|
(let ((rs (length row)))
|
|
(if (< rs ds)
|
|
(let loop ((rrow (reverse row))
|
|
(rs rs))
|
|
(if (eq? rs ds)
|
|
(reverse rrow)
|
|
(loop (cons fl rrow)
|
|
(add1 rs))))
|
|
row))))
|
|
|
|
;; Accepts list of lists and makes sure all rows contain the same
|
|
;; number of elements using empty strings as filler.
|
|
(define (table-rectangularize tbl)
|
|
(let ((mrl (apply max (map length tbl))))
|
|
(map (make-list-extender mrl) tbl)))
|
|
|
|
;; Accepts list of lists of anything and returns a list of lists of
|
|
;; strings.
|
|
(define (table-stringify tbl)
|
|
(map
|
|
(lambda (r)
|
|
(map (lambda (c) (sprintf "~A" c)) r))
|
|
tbl))
|
|
|
|
;; Converts a 2D table - list of list of strings - into a table of
|
|
;; cell lists with cell text lines.
|
|
(define (table-prepare-cells tbl)
|
|
(map
|
|
(lambda (r)
|
|
(map string->rows r))
|
|
tbl))
|
|
|
|
;; Accepts a list of cells which are list of strings and returns a
|
|
;; new list with all cells having the same number of text lines.
|
|
(define (table-normalize-row row)
|
|
(let ((ml (apply max (map length row))))
|
|
(map (make-list-extender ml) row)))
|
|
|
|
;; Normalizes the number of text lines in each table row.
|
|
(define (table-normalize-rows tbl)
|
|
(map table-normalize-row tbl))
|
|
|
|
;; Returns the maximum width of each column of the table.
|
|
(define (table-column-widths tbl)
|
|
(if (null? tbl)
|
|
'()
|
|
(let ((cws (map
|
|
(lambda (r)
|
|
(list->vector
|
|
(map
|
|
(lambda (c)
|
|
(apply max (map ansi-string-length c)))
|
|
r)))
|
|
tbl)))
|
|
(let loop ((ci (sub1 (vector-length (car cws))))
|
|
(rcws '()))
|
|
(if (>= ci 0)
|
|
(loop (sub1 ci)
|
|
(cons (apply max (map (lambda (r) (vector-ref r ci)) cws))
|
|
rcws))
|
|
rcws)))))
|
|
|
|
;; Normalizes cell line to required width and handles leading and
|
|
;; trailing tabs to allow for right and center alignment.
|
|
(define (table-normalize-cell-line line w)
|
|
(let* ((lst (string->list line))
|
|
(first-char (if (null? lst) #f (car lst)))
|
|
(last-char (if (null? lst) #f (car (reverse lst))))
|
|
(first-tab (eq? first-char #\tab))
|
|
(last-tab (eq? last-char #\tab))
|
|
(line0 (if first-tab (substring line 1) line))
|
|
(line1 (if last-tab (substring line0 0 (sub1 (string-length line0))) line0))
|
|
(len (ansi-string-length line1)))
|
|
(if (< len w)
|
|
(let* ((miss (- w len))
|
|
(do-left-pad first-tab)
|
|
(do-right-pad (or (not first-tab) last-tab))
|
|
(left-pad-len (if do-left-pad
|
|
(if do-right-pad
|
|
(- miss (quotient miss 2))
|
|
miss)
|
|
0))
|
|
(right-pad-len (- miss left-pad-len))
|
|
(left-pad (make-string left-pad-len #\space))
|
|
(right-pad (make-string right-pad-len #\space)))
|
|
(string-append left-pad line1 right-pad))
|
|
line1)))
|
|
|
|
;; Pads all lines of this cell to required width
|
|
(define (table-normalize-cell c w)
|
|
(map (lambda (line)
|
|
(table-normalize-cell-line line w))
|
|
c))
|
|
|
|
;; Returns a row (list) of cells (list of strings) with all strings
|
|
;; padded to given column width.
|
|
(define (table-row-normalize-cells row cwidths)
|
|
(let loop ((cwidths cwidths)
|
|
(cells row)
|
|
(res '()))
|
|
(if (null? cells)
|
|
(reverse res)
|
|
(loop (cdr cwidths)
|
|
(cdr cells)
|
|
(cons (table-normalize-cell (car cells) (car cwidths))
|
|
res)))))
|
|
|
|
;; Normalizes cells in all rows to match the widths of the wides cell
|
|
;; in each column.
|
|
(define (table-normalize-columns tbl)
|
|
(let ((cwidths (table-column-widths tbl)))
|
|
(map (lambda (row)
|
|
(table-row-normalize-cells row cwidths))
|
|
tbl)))
|
|
|
|
;; Ensures the table is rectangular and each cell is a list of strings.
|
|
(define (table-prepare tbl)
|
|
(table-normalize-columns
|
|
(table-normalize-rows
|
|
(table-prepare-cells
|
|
(table-stringify
|
|
(table-rectangularize tbl))))))
|
|
|
|
;; Compiled table borders for rendering
|
|
(define table-borders-lookup
|
|
(map (lambda (src)
|
|
(cons (car src)
|
|
(list->vector
|
|
(irregex-extract (irregex "." 'u)
|
|
(string-intersperse (cdr src) "")))))
|
|
table-borders-lookup-source))
|
|
|
|
;; Accepts a table row - list of list of strings - and returns a list
|
|
;; of lines (list of strings).
|
|
(define (table-row->lines row left-border cell0-separator cell-separator right-border ansi?)
|
|
(if (null? row)
|
|
'()
|
|
(let yloop ((row row)
|
|
(res '()))
|
|
(if (null? (car row))
|
|
(reverse res)
|
|
(yloop (map cdr row)
|
|
(cons
|
|
(string-append
|
|
left-border
|
|
(let cloop ((srow (map car row))
|
|
(res "")
|
|
(idx 0))
|
|
(if (null? srow)
|
|
res
|
|
(cloop (cdr srow)
|
|
(string-append res
|
|
(case idx
|
|
((0) "")
|
|
((1) cell0-separator)
|
|
(else cell-separator))
|
|
(car srow)
|
|
(if ansi? (ansi #:default) ""))
|
|
(add1 idx))))
|
|
right-border)
|
|
res))))))
|
|
|
|
;; Creates table row delimiter based on column widths.
|
|
(define (table-row-delimiter cws left line cross0 cross right)
|
|
(string-append
|
|
left
|
|
(let cloop ((cws cws)
|
|
(res "")
|
|
(idx 0))
|
|
(if (null? cws)
|
|
res
|
|
(cloop (cdr cws)
|
|
(string-append res
|
|
(case idx
|
|
((0) "")
|
|
((1) cross0)
|
|
(else cross))
|
|
(string-repeat line (car cws)))
|
|
(add1 idx))))
|
|
right))
|
|
|
|
;; Returns table row delimiter based on column widths, extracting
|
|
;; line style from particular row of border style vector.
|
|
(define (table-row-delimiter/styled tb cb0 cb cws svec srow)
|
|
(define (sref i)
|
|
(vector-ref svec (+ i (* srow 4))))
|
|
(table-row-delimiter cws
|
|
(if tb (sref 0) "")
|
|
(sref 1)
|
|
(if (or cb cb0) (sref 2) "")
|
|
(if cb (sref 2) "")
|
|
(if tb (sref 3) "")))
|
|
|
|
;; Converts given table to a string suitable for printing.
|
|
(define (table->string tbl . args)
|
|
(let ((table (table-prepare tbl)))
|
|
(if (or (null? tbl)
|
|
(null? (car tbl)))
|
|
""
|
|
(let* ((table-border (get-keyword #:table-border args (lambda () #f)))
|
|
(row-border (get-keyword #:row-border args (lambda () #f)))
|
|
(column-border (get-keyword #:col-border args (lambda () #f)))
|
|
(row0-border (get-keyword #:row0-border args (lambda () #f)))
|
|
(col0-border (get-keyword #:col0-border args (lambda () #f)))
|
|
(border-style (get-keyword #:border-style args (lambda () (*table-border-style*))))
|
|
(ansi? (get-keyword #:ansi args (lambda () #f)))
|
|
(stylepair (assq border-style table-borders-lookup))
|
|
(stylevec
|
|
(if stylepair
|
|
(cdr stylepair)
|
|
(cdar table-borders-lookup)))
|
|
(cell-borders (list (if table-border (vector-ref stylevec 4) "")
|
|
(if (or column-border col0-border)
|
|
(vector-ref stylevec 6) "")
|
|
(if column-border (vector-ref stylevec 6) "")
|
|
(if table-border (vector-ref stylevec 7) "")
|
|
ansi?))
|
|
(cws (map (compose ansi-string-length car) (car table))))
|
|
(let loop ((rows table)
|
|
(res (if table-border
|
|
(list (table-row-delimiter/styled table-border
|
|
col0-border
|
|
column-border
|
|
cws
|
|
stylevec
|
|
0))
|
|
'()))
|
|
(idx 0))
|
|
(if (null? rows)
|
|
(let ((res0 (if table-border
|
|
(cons (table-row-delimiter/styled table-border
|
|
col0-border
|
|
column-border
|
|
cws
|
|
stylevec
|
|
3)
|
|
res)
|
|
res)))
|
|
(string-intersperse
|
|
(flatten (reverse res0))
|
|
"\n"))
|
|
(let* ((res0
|
|
(if (or (and row-border
|
|
(> idx 0))
|
|
(and row0-border
|
|
(= idx 1)))
|
|
(cons (table-row-delimiter/styled table-border
|
|
col0-border
|
|
column-border
|
|
cws
|
|
stylevec
|
|
2)
|
|
res)
|
|
res))
|
|
(res1
|
|
(cons
|
|
(apply table-row->lines
|
|
(car rows)
|
|
cell-borders)
|
|
res0)))
|
|
(loop (cdr rows)
|
|
res1
|
|
(add1 idx)))))))))
|
|
|
|
;; Performs module self-tests
|
|
(define (table-tests!)
|
|
(run-tests
|
|
table
|
|
(test-equal? string->rows (string->rows "asdf") '("asdf"))
|
|
(test-equal? string->rows (string->rows "asdf\nqwer") '("asdf" "qwer"))
|
|
(test-equal? string->rows (string->rows "\nasdf\nqwer") '("" "asdf" "qwer"))
|
|
(test-equal? make-list-extender
|
|
((make-list-extender 5) '("test"))
|
|
'("test" "" "" "" ""))
|
|
(test-equal? make-list-extender
|
|
((make-list-extender 5 "x") '("test"))
|
|
'("test" "x" "x" "x" "x"))
|
|
(test-equal? table-rectangularize
|
|
(table-rectangularize '(("x" "y" "z") ("a" "b") ("1" "2" "3" "4")))
|
|
'(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4")))
|
|
(test-equal? table-stringify
|
|
(table-stringify '((1 2 3) (a b c) ("d")))
|
|
'(("1" "2" "3") ("a" "b" "c") ("d")))
|
|
(test-equal? table-prepare-cells
|
|
(table-prepare-cells '(("x" "y" "z" "") ("a" "b" "" "") ("1" "2" "3" "4")))
|
|
'((("x") ("y") ("z") ("")) (("a") ("b") ("") ("")) (("1") ("2") ("3") ("4"))))
|
|
(test-equal? table-normalize-row
|
|
(table-normalize-row '(("") ("a" "b")))
|
|
'(("" "") ("a" "b")))
|
|
(test-equal? table-column-widths
|
|
(table-column-widths
|
|
'((("x") ("y") ("zz") ("")) (("a") ("bcde") ("") ("")) (("123") ("2") ("3") ("4"))))
|
|
'(3 4 2 1))
|
|
(test-equal? table-normalize-cell
|
|
(table-normalize-cell '("a" "bb" "ccc" "") 4)
|
|
'("a " "bb " "ccc " " "))
|
|
(test-equal? table-row-normalize-cells
|
|
(table-row-normalize-cells
|
|
'(("a") ("bb") ("ccc") (""))
|
|
'(1 2 3 4))
|
|
'(("a") ("bb") ("ccc") (" ")))
|
|
(test-equal? table-normalize-columns
|
|
(table-normalize-columns
|
|
'((("a") ("bb") ("ccc") (""))
|
|
(("") ("b") ("z") ("x"))))
|
|
'((("a") ("bb") ("ccc") (" "))
|
|
((" ") ("b ") ("z ") ("x"))))
|
|
(test-equal? table-row->lines
|
|
(table-row->lines '(("a ") ("bb") ("ccc") (" ")) "]" "|" "|" "[" #f)
|
|
'("]a |bb|ccc| ["))
|
|
(test-equal? table-row-delimiter
|
|
(table-row-delimiter '(1 2 3 1) "/" "-" "+" "+" "\\")
|
|
"/-+--+---+-\\")
|
|
))
|
|
|
|
)
|