;;
;; 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) "/" "-" "+" "+" "\\")
		 "/-+--+---+-\\")
    ))

 )