diff --git a/src/Makefile b/src/Makefile index 9ff92f8..65280dc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -39,11 +39,11 @@ HACKERBASE-DEPS=hackerbase.scm cal-month.import.scm \ mailman.import.scm texts.import.scm tests.import.scm \ notifications.import.scm logging.import.scm \ progress.import.scm cal-period.import.scm \ - util-stdout.import.scm table-old.import.scm + util-stdout.import.scm HACKERBASE-OBJS=hackerbase.o testing.o listing.o cal-month.o \ cal-period.o ansi.o util-dict-list.o command-line.o mbase.o \ - primes.o brmember.o configuration.o progress.o table-old.o \ + primes.o brmember.o configuration.o progress.o \ export-cards.o members-print.o members-fees.o mbase-dir.o \ util-csv.o bank-account.o bank-fio.o members-payments.o \ brmember-parser.o export-wiki-compat.o environment.o \ @@ -132,9 +132,9 @@ MBASE-SOURCES=mbase.scm testing.import.scm util-dict-list.import.scm \ primes.import.scm brmember.import.scm ansi.import.scm \ cal-period.import.scm cal-month.import.scm \ configuration.import.scm progress.import.scm \ - table-old.import.scm mbase-dir.import.scm \ - util-tag.import.scm racket-kwargs.import.scm \ - util-dict-bst.import.scm util-list.import.scm + mbase-dir.import.scm util-tag.import.scm \ + racket-kwargs.import.scm util-dict-bst.import.scm \ + util-list.import.scm mbase.o: mbase.import.scm mbase.import.scm: $(MBASE-SOURCES) @@ -163,13 +163,6 @@ PROGRESS-SOURCES=progress.scm util-time.import.scm progress.o: progress.import.scm progress.import.scm: $(PROGRESS-SOURCES) -TABLE-OLD-SOURCES=table-old.scm ansi.import.scm testing.import.scm \ - util-string.import.scm racket-kwargs.import.scm \ - util-list.import.scm - -table-old.o: table-old.import.scm -table-old.import.scm: $(TABLE-OLD-SOURCES) - EXPORT-CARDS-SOURCES=export-cards.scm util-dict-list.import.scm \ mbase.import.scm brmember.import.scm @@ -303,13 +296,13 @@ texts.import.scm: $(TEXTS-SOURCES) TESTS-SOURCES=tests.scm listing.import.scm util-dict-list.import.scm \ cal-month.import.scm cal-period.import.scm ansi.import.scm \ command-line.import.scm mbase-dir.import.scm \ - primes.import.scm brmember.import.scm table-old.import.scm \ - util-csv.import.scm util-set-list.import.scm \ - util-parser.import.scm util-string.import.scm \ - cal-day.import.scm util-dict-bst.import.scm \ - util-utf8.import.scm sgr-state.import.scm sgr-list.import.scm \ - sgr-block.import.scm template-list-expander.import.scm \ - table-style.import.scm box-drawing.import.scm + primes.import.scm brmember.import.scm util-csv.import.scm \ + util-set-list.import.scm util-parser.import.scm \ + util-string.import.scm cal-day.import.scm \ + util-dict-bst.import.scm util-utf8.import.scm \ + sgr-state.import.scm sgr-list.import.scm sgr-block.import.scm \ + template-list-expander.import.scm table-style.import.scm \ + box-drawing.import.scm tests.o: tests.import.scm tests.import.scm: $(TESTS-SOURCES) @@ -404,9 +397,8 @@ RACKET-KWARGS-SOURCES=racket-kwargs.scm racket-kwargs.import.scm: $(RACKET-KWARGS-SOURCES) TABLE-SOURCES=table.scm sgr-list.import.scm sgr-block.import.scm \ - racket-kwargs.import.scm table-processor.import.scm \ - table-border.import.scm table-style.import.scm \ - table-old.import.scm + racket-kwargs.import.scm table-processor.import.scm \ + table-border.import.scm table-style.import.scm table.o: table.import.scm table.import.scm: $(TABLE-SOURCES) diff --git a/src/hackerbase.scm b/src/hackerbase.scm index 9e8f2a3..9e004a0 100644 --- a/src/hackerbase.scm +++ b/src/hackerbase.scm @@ -46,7 +46,7 @@ util-git util-dict-list util-stdout - table-old) + table) ;; Command-line options and configurable parameters (define -needs-bank- (make-parameter #f)) diff --git a/src/table-old.scm b/src/table-old.scm deleted file mode 100644 index 536d194..0000000 --- a/src/table-old.scm +++ /dev/null @@ -1,401 +0,0 @@ -;; -;; table-old.scm -;; -;; Simple table formatter. -;; -;; ISC License -;; -;; Copyright 2023 Brmlab, z.s. -;; Dominik Pantůček -;; -;; 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-old)) - -(module - table-old - ( - *table-border-style* - table->list - table->string - table-tests! - ) - - (import scheme - (chicken base) - (chicken string) - (chicken format) - (chicken keyword) - (chicken irregex) - util-list - ansi - testing - util-string - racket-kwargs) - - ;; 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 list of strings suitable for printing. - (define* (table->list tbl - #:table-border (table-border #f) - #:row-border (row-border #f) - #:col-border (column-border #f) - #:row0-border (row0-border #f) - #:col0-border (col0-border #f) - #:border-style (border-style (*table-border-style*)) - #:ansi (ansi? #f)) - (let ((table (table-prepare tbl))) - (if (or (null? tbl) - (null? (car tbl))) - "" - (let* ((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))) - (flatten (reverse res0))) - (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))))))))) - - ;; Converts into single string - (define (table->string . args) - (string-intersperse - (apply table->list args) - "\n")) - - ;; 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) "/" "-" "+" "+" "\\") - "/-+--+---+-\\") - )) - - ) diff --git a/src/table.scm b/src/table.scm index 5e3fcf2..719fb1a 100644 --- a/src/table.scm +++ b/src/table.scm @@ -27,6 +27,7 @@ (module table ( + *table-border-style* print-table table->string table->string-list @@ -42,9 +43,11 @@ table-processor table-border table-style - (only table-old *table-border-style*) ) + ;; Default table border style to use if not explicitly specified. + (define *table-border-style* (make-parameter 'unicode)) + (define (print-table . args) (print (apply table->string args))) diff --git a/src/tests.scm b/src/tests.scm index 0906ee6..f5483ca 100644 --- a/src/tests.scm +++ b/src/tests.scm @@ -42,7 +42,6 @@ mbase-dir primes brmember - table-old util-csv util-set-list util-parser @@ -69,7 +68,6 @@ (mbase-dir-tests!) (ansi-tests!) (command-line-tests!) - (table-tests!) (csv-simple-tests!) (parser-tests!) (string-tests!)