370 lines
9.9 KiB
Scheme
370 lines
9.9 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!
|
|
;;---
|
|
table-row-delimiter
|
|
table-row-delimiter/styled
|
|
table-borders-lookup
|
|
)
|
|
|
|
(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 'ascii))
|
|
|
|
;; 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)))))
|
|
|
|
;; Pads all lines of this cell to required width
|
|
(define (table-normalize-cell c w)
|
|
(let loop ((c c)
|
|
(r '()))
|
|
(if (null? c)
|
|
(reverse r)
|
|
(loop (cdr c)
|
|
(cons (let* ((cs (car c))
|
|
(csl (string-length cs)))
|
|
(if (< csl w)
|
|
(string-append cs (make-string (- w csl) #\space))
|
|
cs))
|
|
r)))))
|
|
|
|
;; 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))))))
|
|
|
|
;; Table border styles in visual form
|
|
(define table-borders-lookup-source
|
|
'((ascii
|
|
"/=,\\"
|
|
"] |["
|
|
">-+<"
|
|
"'~^`")
|
|
(unicode
|
|
"┌─┬┐"
|
|
"│ ││"
|
|
"├─┼┤"
|
|
"└─┴┘")))
|
|
|
|
;; 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 cell-separator right-border)
|
|
(if (null? row)
|
|
'()
|
|
(let yloop ((row row)
|
|
(res '()))
|
|
(if (null? (car row))
|
|
(reverse res)
|
|
(yloop (map cdr row)
|
|
(cons
|
|
(string-append left-border
|
|
(string-intersperse
|
|
(map car row)
|
|
cell-separator)
|
|
right-border)
|
|
res))))))
|
|
|
|
;; Creates table row delimiter based on column widths.
|
|
(define (table-row-delimiter cws left line cross right)
|
|
(string-append
|
|
left
|
|
(string-intersperse
|
|
(map
|
|
(lambda (cw)
|
|
(string-repeat line cw))
|
|
cws)
|
|
cross)
|
|
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 cb cws svec srow)
|
|
(define (sref i)
|
|
(vector-ref svec (+ i (* srow 4))))
|
|
(table-row-delimiter cws
|
|
(if tb (sref 0) "")
|
|
(sref 1)
|
|
(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)))
|
|
(border-style (get-keyword #:border-style args (lambda () 'ascii)))
|
|
(stylepair (assq border-style table-borders-lookup))
|
|
(stylevec
|
|
(if stylepair
|
|
(cdr stylepair)
|
|
(cdar table-borders-lookup)))
|
|
(cell-borders
|
|
(if column-border
|
|
(map (lambda (idx)
|
|
(vector-ref stylevec idx))
|
|
'(4 6 7))
|
|
'("" "" ""))))
|
|
(let loop ((rows table)
|
|
(res '())
|
|
(idx 0))
|
|
(if (null? rows)
|
|
(string-intersperse
|
|
(flatten (reverse res))
|
|
"\n")
|
|
(let* ((res0
|
|
(cons
|
|
(apply table-row->lines
|
|
(car rows)
|
|
cell-borders)
|
|
res)))
|
|
(loop (cdr rows)
|
|
res0
|
|
(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") (" ")) "]" "|" "[")
|
|
'("]a |bb|ccc| ["))
|
|
(test-equal? table-row-delimiter
|
|
(table-row-delimiter '(1 2 3 1) "/" "-" "+" "\\")
|
|
"/-+--+---+-\\")
|
|
))
|
|
|
|
)
|
|
|
|
(import table)
|
|
(table-tests!)
|
|
|
|
(print (table-row-delimiter '(1 2 3 1) "/" "-" "+" "\\"))
|
|
(print
|
|
(table->string
|
|
'(("a" "bb" "ccc" "")
|
|
("" "b" "z" "x"))))
|
|
(print (table-row-delimiter/styled #t #t '(1 2 3 1) (cdr (assq 'unicode table-borders-lookup)) 3))
|
|
|
|
(print "************")
|
|
(print
|
|
(table->string
|
|
'(("a" "bb" "ccc" "")
|
|
("" "b" "z" "x"))
|
|
#:table-border #f
|
|
#:col-border #f
|
|
))
|
|
|
|
(print "************")
|
|
(print
|
|
(table->string
|
|
'(("a" "bb" "ccc" "")
|
|
("" "b" "z" "x"))
|
|
#:table-border #f
|
|
#:col-border #t
|
|
))
|
|
|
|
(print "************")
|
|
(print
|
|
(table->string
|
|
'(("a" "bb" "ccc" "")
|
|
("" "b" "z" "x"))
|
|
#:table-border #t
|
|
#:col-border #f
|
|
#:row-border #t
|
|
#:border-style 'unicode
|
|
))
|
|
|
|
(print "************")
|
|
(print
|
|
(table->string
|
|
'(("a" "bb" "ccc" "")
|
|
("" "b" "z" "x"))
|
|
#:table-border #t
|
|
#:row-border #t
|
|
#:col-border #t
|
|
#:border-style 'unicode
|
|
))
|