Remove old table implementation.

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			\
+	 mbase-dir.import.scm util-tag.import.scm			\
-	 util-tag.import.scm racket-kwargs.import.scm			\
+	 racket-kwargs.import.scm util-dict-bst.import.scm		\
-	 util-dict-bst.import.scm util-list.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	\
+	primes.import.scm brmember.import.scm util-csv.import.scm	\
-	util-csv.import.scm util-set-list.import.scm			\
+	util-set-list.import.scm util-parser.import.scm			\
-	util-parser.import.scm util-string.import.scm			\
+	util-string.import.scm cal-day.import.scm			\
-	cal-day.import.scm util-dict-bst.import.scm			\
+	util-dict-bst.import.scm util-utf8.import.scm			\
-	util-utf8.import.scm sgr-state.import.scm sgr-list.import.scm	\
+	sgr-state.import.scm sgr-list.import.scm sgr-block.import.scm	\
-	sgr-block.import.scm template-list-expander.import.scm		\
+	template-list-expander.import.scm table-style.import.scm	\
-	table-style.import.scm box-drawing.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		\
+		racket-kwargs.import.scm table-processor.import.scm	\
-	table-border.import.scm table-style.import.scm			\
+		table-border.import.scm table-style.import.scm
-	table-old.import.scm
 
 table.o: table.import.scm
 table.import.scm: $(TABLE-SOURCES)

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))

src/table-old.scm

@@ -1,401 +0,0 @@
-;;
-;; table-old.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-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) "/" "-" "+" "+" "\\")
-		 "/-+--+---+-\\")
-    ))
-
- )

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)))
 

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!)