Move sources to separate directory.
This commit is contained in:
parent
aa7a340d51
commit
69d0b8ee10
25 changed files with 0 additions and 0 deletions
394
src/table.scm
Normal file
394
src/table.scm
Normal file
|
|
@ -0,0 +1,394 @@
|
|||
;;
|
||||
;; 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 (or (null? lst)
|
||||
(null? (cdr 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) "/" "-" "+" "+" "\\")
|
||||
"/-+--+---+-\\")
|
||||
))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue