updating (chibi show) with srfi changes

lib/chibi/show-test.sld

@@ -1,7 +1,9 @@
 (define-library (chibi show-test)
   (export run-tests)
-  (import (scheme base) (scheme read) (chibi test)
+  (import (scheme base) (scheme char) (scheme read)
-          (chibi show) (chibi show base) (chibi show pretty))
+          (chibi test)
+          (chibi show) (chibi show base)
+          (chibi show column) (chibi show pretty))
   (begin
     (define-syntax test-pretty
       (syntax-rules ()
@@ -144,6 +146,29 @@
         (test "3.14+2.00i"
             (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
 
+      (test "608" (show #f (numeric/si 608)))
+      (test "3.9Ki" (show #f (numeric/si 3986)))
+      (test "4kB" (show #f (numeric/si 3986 1000) "B"))
+      (test "1.2Mm" (show #f (numeric/si 1.23e6 1000) "m"))
+      (test "123km" (show #f (numeric/si 1.23e5 1000) "m"))
+      (test "12.3km" (show #f (numeric/si 1.23e4 1000) "m"))
+      (test "1.2km" (show #f (numeric/si 1.23e3 1000) "m"))
+      (test "123m" (show #f (numeric/si 1.23e2 1000) "m"))
+      (test "12.3m" (show #f (numeric/si 1.23e1 1000) "m"))
+      (test "1.2m" (show #f (numeric/si 1.23 1000) "m"))
+      (test "123mm" (show #f (numeric/si 0.123 1000) "m"))
+      (test "12.3mm" (show #f (numeric/si 1.23e-2 1000) "m")) ;?
+      (test "1.2mm" (show #f (numeric/si 1.23e-3 1000) "m"))
+      (test "123µm" (show #f (numeric/si 1.23e-4 1000) "m"))  ;?
+      (test "12.3µm" (show #f (numeric/si 1.23e-5 1000) "m")) ;?
+      (test "1.2µm" (show #f (numeric/si 1.23e-6 1000) "m"))
+
+      (test "1,234,567" (show #f (numeric/comma 1234567)))
+
+      (test "1.23" (show #f (numeric/fitted 4 1.2345 10 2)))
+      (test "1.00" (show #f (numeric/fitted 4 1 10 2)))
+      (test "#.##" (show #f (numeric/fitted 4 12.345 10 2)))
+
       ;; padding/trimming
 
       (test "abc  " (show #f (padded 5 "abc")))
@@ -253,6 +278,14 @@
                     '(lions tigers . bears)
                     ", ")))
 
+      ;; escaping
+
+      (test "hi, bob!" (show #f (escaped "hi, bob!")))
+      (test "hi, \\\"bob!\\\"" (show #f (escaped "hi, \"bob!\"")))
+      (test "bob" (show #f (maybe-escaped "bob" char-whitespace?)))
+      (test "\"hi, bob!\""
+          (show #f (maybe-escaped "hi, bob!" char-whitespace?)))
+
       ;; shared structures
 
       (test "#0=(1 . #0#)"
@@ -389,4 +422,163 @@
                               (ones ',ones))
                           (append zeros ones))))))
 
+      ;; columns
+
+      (test "abc\ndef\n"
+          (show #f (show-columns (list displayed "abc\ndef\n"))))
+      (test "abc123\ndef456\n"
+          (show #f (show-columns (list displayed "abc\ndef\n")
+                                 (list displayed "123\n456\n"))))
+      (test "abc123\ndef456\n"
+          (show #f (show-columns (list displayed "abc\ndef\n")
+                                 (list displayed "123\n456"))))
+      (test "abc123\ndef456\n"
+          (show #f (show-columns (list displayed "abc\ndef")
+                                 (list displayed "123\n456\n"))))
+      (test "abc123\ndef456\nghi789\n"
+          (show #f (show-columns (list displayed "abc\ndef\nghi\n")
+                                 (list displayed "123\n456\n789\n"))))
+      (test "abc123wuv\ndef456xyz\n"
+          (show #f (show-columns (list displayed "abc\ndef\n")
+                                 (list displayed "123\n456\n")
+                                 (list displayed "wuv\nxyz\n"))))
+      (test "abc  123\ndef  456\n"
+          (show #f (show-columns (list (lambda (x) (padded/right 5 x))
+                                       "abc\ndef\n")
+                                 (list displayed "123\n456\n"))))
+      (test "ABC  123\nDEF  456\n"
+          (show #f (show-columns (list (lambda (x) (upcased (padded/right 5 x)))
+                                       "abc\ndef\n")
+                                 (list displayed "123\n456\n"))))
+      (test "ABC  123\nDEF  456\n"
+          (show #f (show-columns (list (lambda (x) (padded/right 5 (upcased x)))
+                                       "abc\ndef\n")
+                                 (list displayed "123\n456\n"))))
+
+      (test "hello\nworld\n"
+          (show #f (with ((width 8)) (wrapped "hello world"))))
+      (test "\n" (show #f (wrapped "    ")))
+
+      (test
+          "The  quick
+brown  fox
+jumped
+over   the
+lazy dog
+"
+          (show #f
+                (with ((width 10))
+                  (justified "The quick brown fox jumped over the lazy dog"))))
+
+      (test
+          "The fundamental list iterator.
+Applies KONS to each element of
+LS and the result of the previous
+application, beginning with KNIL.
+With KONS as CONS and KNIL as '(),
+equivalent to REVERSE.
+"
+          (show #f
+                (with ((width 36))
+                  (wrapped "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))
+
+      (test
+          "(define (fold kons knil ls)
+  (let lp ((ls ls) (acc knil))
+    (if (null? ls)
+        acc
+        (lp (cdr ls)
+            (kons (car ls) acc)))))
+"
+          (show #f
+                (with ((width 36))
+                  (pretty '(define (fold kons knil ls)
+                             (let lp ((ls ls) (acc knil))
+                               (if (null? ls)
+                                   acc
+                                   (lp (cdr ls)
+                                       (kons (car ls) acc)))))))))
+
+      '(test
+           "(define (fold kons knil ls)          ; The fundamental list iterator.
+  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
+    (if (null? ls)                   ; LS and the result of the previous
+        acc                          ; application, beginning with KNIL.
+        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
+            (kons (car ls) acc)))))  ; equivalent to REVERSE.
+"
+           (show #f
+                 (show-columns
+                  (list
+                   (lambda (x) (padded/right 36 x))
+                   (with ((width 36))
+                     (pretty '(define (fold kons knil ls)
+                                (let lp ((ls ls) (acc knil))
+                                  (if (null? ls)
+                                      acc
+                                      (lp (cdr ls)
+                                          (kons (car ls) acc))))))))
+                  (list
+                   (lambda (x) (each " ; " x))
+                   (with ((width 36))
+                     (wrapped "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))))
+
+      '(test
+           "(define (fold kons knil ls)          ; The fundamental list iterator.
+  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
+    (if (null? ls)                   ; LS and the result of the previous
+        acc                          ; application, beginning with KNIL.
+        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
+            (kons (car ls) acc)))))  ; equivalent to REVERSE.
+"
+           (show #f (with ((width 76))
+                      (columnar
+                       (pretty '(define (fold kons knil ls)
+                                  (let lp ((ls ls) (acc knil))
+                                    (if (null? ls)
+                                        acc
+                                        (lp (cdr ls)
+                                            (kons (car ls) acc))))))
+                       " ; "
+                       (wrapped "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))
+
+      (test
+          "- Item 1: The text here is
+          indented according
+          to the space \"Item
+          1\" takes, and one
+          does not known what
+          goes here.
+"
+          (show #f (columnar 9 (each "- Item 1:") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
+
+      (test
+          "- Item 1: The text here is
+          indented according
+          to the space \"Item
+          1\" takes, and one
+          does not known what
+          goes here.
+"
+          (show #f (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
+
+      (test
+          "- Item 1: The-text-here-is----------------------------------------------------
+--------- indented-according--------------------------------------------------
+--------- to-the-space-\"Item--------------------------------------------------
+--------- 1\"-takes,-and-one---------------------------------------------------
+--------- does-not-known-what-------------------------------------------------
+--------- goes-here.----------------------------------------------------------
+"
+          (show #f (with ((pad-char #\-)) (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))))
+
+      (test
+          "a   | 123
+bc  | 45
+def | 6
+"
+          (show #f (with ((width 20))
+                    (tabular (each "a\nbc\ndef\n") " | "
+                             (each "123\n45\n6\n")))))
+
       (test-end))))

lib/chibi/show.sld

@@ -2,8 +2,9 @@
 (define-library (chibi show)
   (export
    show fn fn-fork with update! each each-in-list call-with-output
-   displayed written written-shared written-simply numeric nothing
+   displayed written written-shared written-simply
-   nl fl space-to tab-to
+   numeric numeric/comma numeric/si numeric/fitted
+   nothing nl fl space-to tab-to escaped maybe-escaped
    padded padded/left padded/right padded/both
    trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
    fitted fitted/left fitted/right fitted/both

lib/chibi/show/base.sld

@@ -3,10 +3,29 @@
   (export
    show fn fn-fork with update! each each-in-list call-with-output
    displayed written written-shared written-simply numeric nothing
+   escaped maybe-escaped numeric/si numeric/fitted numeric/comma
    ;; internal
    output-default extract-shared-objects write-to-string write-with-shares
    call-with-shared-ref call-with-shared-ref/cdr)
   (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
           (srfi 1) (srfi 69) (chibi string) (chibi monad environment))
+  (cond-expand
+   (chibi
+    (import (only (chibi) let-optionals*)))
+   (else
+    (begin
+      (define-syntax let-optionals*
+        (syntax-rules ()
+          ((let-optionals* opt-ls () . body)
+           (begin . body))
+          ((let-optionals* (op . args) vars . body)
+           (let ((tmp (op . args)))
+             (let-optionals* tmp vars . body)))
+          ((let-optionals* tmp ((var default) . rest) . body)
+           (let ((var (if (pair? tmp) (car tmp) default))
+                 (tmp2 (if (pair? tmp) (cdr tmp) '())))
+             (let-optionals* tmp2 rest . body)))
+          ((let-optionals* tmp tail . body)
+           (let ((tail tmp)) . body)))))))
   (include "base.scm")
   (include "write.scm"))

lib/chibi/show/column.scm

@@ -2,6 +2,20 @@
 ;; Copyright (c) 2006-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
+(define (string-split-words str separator?)
+  (let ((start (string-cursor-start str))
+        (end (string-cursor-end str)))
+    (let lp ((sc start) (res '()))
+      (cond
+       ((string-cursor>=? sc end)
+        (reverse res))
+       (else
+        (let ((sc2 (string-index str separator? sc)))
+          (lp (string-cursor-next str sc2)
+              (if (string-cursor=? sc sc2)
+                  res
+                  (cons (substring/cursors str sc sc2) res)))))))))
+
 (define (call-with-output-generator producer consumer)
   (fn ()
     (let ((out (open-output-string))
@@ -12,10 +26,18 @@
       (define (output* str)
         (fn (row col string-width)
           (list-queue-add-back! queue str)
+          (each
+           (let ((nl-index
+                  (string-index-right str (lambda (ch) (eqv? ch #\newline)))))
+             (if (string-cursor>? nl-index (string-cursor-start str))
+                 (update!
+                  (row (+ row (string-count str (lambda (ch) (eqv? ch #\newline)))))
+                  (col (string-width str (string-cursor->index str nl-index))))
+                 (update! (col (+ col (string-width str))))))
            (call-with-current-continuation
             (lambda (cc)
               (set! resume cc)
-             (return nothing)))
+              (return nothing))))
           nothing))
       (define (generate)
         (if (and resume (list-queue-empty? queue))
@@ -320,6 +342,10 @@
                        (fn () (lp (string-cursor-next str nli))))))))))))
       (each-in-list ls))))
 
+;; `seq' is a list or vector of pre-tokenized words.  `line' is called
+;; on each wrapped line and the accumulator, starting with `knil'.
+;; The optional `last-line' is used instead on the last line of the
+;; paragraph.
 (define (wrap-fold-words seq knil max-width get-width line . o)
   (let* ((last-line (if (pair? o) (car o) line))
          (vec (if (list? seq) (list->vector seq) seq))
@@ -380,21 +406,21 @@
               (last-line (sub-list i len-1) acc)
               (lp (+ break 1) (line (sub-list i break) acc)))))))))
 
-;; XXXX don't split, traverse the string manually and keep track of
+(define (wrapped/list ls)
-;; sentence endings so we can insert two spaces
+  (fn (width string-width pad-char)
-(define (wrap-fold str . o)
+    (joined/suffix
-  (apply wrap-fold-words (string-split str " ") o))
+     (lambda (ls) (joined displayed ls pad-char))
+     (reverse
+      (wrap-fold-words ls '() width (or string-width string-length) cons))
+     "\n")))
 
 (define (wrapped . ls)
   (call-with-output
    (each-in-list ls)
    (lambda (str)
-     (fn (width string-width pad-char)
+     (fn (word-separator?)
-       (joined/suffix
+       (wrapped/list
-        (lambda (ls) (joined displayed ls pad-char))
+        (string-split-words str (or word-separator? char-whitespace?)))))))
-        (reverse
-         (wrap-fold str '() width (or string-width string-length) cons))
-        "\n")))))
 
 (define (justified . ls)
   (fn (output width string-width)
@@ -427,11 +453,16 @@
     (call-with-output
      (each-in-list ls)
      (lambda (str)
+       (fn (word-separator?)
          (joined/last
           justify-line
           justify-last
-        (reverse (wrap-fold str '() width string-width cons))
+          (reverse
-        "\n")))))
+           (wrap-fold-words
+            (string-split-words str (or word-separator? char-whitespace?))
+            '() width (or string-width string-length)
+            cons))
+          "\n"))))))
 
 (define (from-file path)
   (fn ()

lib/chibi/show/column.sld

@@ -6,5 +6,6 @@
   (export
    call-with-output-generator call-with-output-generators
    string->line-generator
-   columnar tabular wrapped wrapped/char justified line-numbers from-file)
+   tabular columnar show-columns wrapped wrapped/list wrapped/char
+   justified line-numbers from-file)
   (include "column.scm"))

lib/chibi/show/pretty.scm

@@ -42,7 +42,7 @@
    (string-find str pred (string-index->cursor str i))))
 
 (define (try-fitted2 proc fail)
-  (fn (width string-width output)
+  (fn (width output)
     (let ((out (open-output-string)))
       (call-with-current-continuation
        (lambda (abort)
@@ -53,7 +53,7 @@
            (fn (col)
              (let lp ((i 0) (col col))
                (let ((nli (string-find/index str #\newline i))
-                     (len (string-width str)))
+                     (len (string-length str)))
                  (if (< nli len)
                      (if (> (+ (- nli i) col) width)
                          (abort fail)

lib/chibi/show/show.scm

@@ -1,5 +1,5 @@
 ;; show.scm -- additional combinator formatters
-;; Copyright (c) 2013 Alex Shinn.  All rights reserved.
+;; Copyright (c) 2013-2017 Alex Shinn.  All rights reserved.
 ;; BSD-style license: http://synthcode.com/license.txt
 
 ;;> A library of procedures for formatting Scheme objects to text in

lib/chibi/show/write.scm

@@ -30,6 +30,64 @@
               (if (pair? rule) (cdr rule) rule)
               (cons sep (cons (substring str i2 i) res)))))))
 
+;;> Outputs the string str, escaping any quote or escape characters.
+;;> If esc-ch, which defaults to #\\, is #f, escapes only the
+;;> quote-ch, which defaults to #\", by doubling it, as in SQL strings
+;;> and CSV values.  If renamer is provided, it should be a procedure
+;;> of one character which maps that character to its escape value,
+;;> e.g. #\newline => #\n, or #f if there is no escape value.
+
+(define (escaped fmt . o)
+  (let-optionals* o ((quot #\")
+                     (esc #\\)
+                     (rename (lambda (x) #f)))
+    (let ((quot-str (if (char? quot) (string quot) quot))
+          (esc-str (if (char? esc) (string esc) esc)))
+      (fn (output)
+        (define (output* str)
+          (let ((start (string-cursor-start str))
+                (end (string-cursor-end str)))
+            (let lp ((i start) (j start))
+              (define (collect)
+                (if (eq? i j) "" (substring-cursor str i j)))
+              (if (string-cursor>=? j end)
+                  (output (collect))
+                  (let ((c (string-cursor-ref str j))
+                        (j2 (string-cursor-next str j)))
+                    (cond
+                     ((or (eqv? c quot) (eqv? c esc))
+                      (each (output (collect))
+                            (output esc-str)
+                            (fn () (lp j j2))))
+                     ((rename c)
+                      => (lambda (c2)
+                           (each (output (collect))
+                                 (output esc-str)
+                                 (output (if (char? c2) (string c2) c2))
+                                 (fn () (lp j2 j2)))))
+                     (else
+                      (lp i j2))))))))
+        (with ((output output*))
+          fmt)))))
+
+;;> Only escape if there are special characters, in which case also
+;;> wrap in quotes.  For writing symbols in |...| escapes, or CSV
+;;> fields, etc.  The predicate indicates which characters cause
+;;> slashification - this is in addition to automatic slashifying when
+;;> either the quote or escape char is present.
+
+(define (maybe-escaped fmt pred . o)
+  (let-optionals* o ((quot #\")
+                     (esc #\\)
+                     (rename (lambda (x) #f)))
+    (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
+    (call-with-output
+     fmt
+     (lambda (str)
+       (if (string-cursor<? (string-find str esc?) (string-cursor-end str))
+           (each quot (escaped str quot esc rename) quot)
+           (displayed str))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; numeric formatting
 
@@ -47,9 +105,24 @@
 ;; special cases, so the below is a simplification which tries to rely
 ;; on number->string for common cases.
 
-(define (numeric n)
+(define unspec (list 'unspecified))
-  (fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule)
+
-    (let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))
+(define-syntax default
+  (syntax-rules ()
+    ((default var dflt) (if (eq? var unspec) dflt var))))
+
+(define (numeric n . o)
+  (let-optionals* o ((rad unspec) (prec unspec) (sgn unspec)
+                     (comma unspec) (commasep unspec) (decsep unspec))
+    (fn (radix precision sign-rule
+               comma-rule comma-sep decimal-sep decimal-align)
+      (let ((radix (default rad radix))
+            (precision (default prec precision))
+            (sign-rule (default sgn sign-rule))
+            (comma-rule (default comma comma-rule))
+            (comma-sep (default comma-sep commasep))
+            (dec-sep (default decsep
+                       (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))))
         ;; General formatting utilities.
         (define (get-scale q)
           (expt radix (- (integer-log q radix) 1)))
@@ -151,7 +224,7 @@
                                   (string-cursor>? last (string-cursor-start s))
                                   (odd? (digit-value
                                          (string-cursor-ref
-                                        s (string-cursor-prev last 1))))))))
+                                          s (string-cursor-prev s last))))))))
                       (list->string
                        (reverse
                         (map char-digit
@@ -229,7 +302,68 @@
             (each (format (real-part n) sign-rule)
                   (format (imag-part n) #t)
                   "i"))))
-      (write-complex n))))
+        (write-complex n)))))
+
+(define numeric/si
+  (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
+         (names-10 '#("" "m" "µ" "n" "p" "f" "a" "z" "y"))
+         (names2 (list->vector
+                  (cons ""
+                        (cons "Ki" (map (lambda (s) (string-append s "i"))
+                                        (cddr (vector->list names10)))))))
+         (names-2 (list->vector
+                   (cons ""
+                         (map (lambda (s) (string-append s "i"))
+                              (cdr (vector->list names-10)))))))
+    (define (round-to n k)
+      (/ (round (* n k)) k))
+    (lambda (n . o)
+      (let-optionals* o ((base 1024)
+                         (separator ""))
+        (let* ((log-n (log n))
+               (names  (if (negative? log-n)
+                           (if (= base 1024) names-2 names-10)
+                           (if (= base 1024) names2 names10)))
+               (k (min (exact ((if (negative? log-n) ceiling floor)
+                               (/ (abs log-n) (log base))))
+                       (vector-length names)))
+               (n2 (round-to (/ n (expt base (if (negative? log-n) (- k) k)))
+                             10)))
+          (each (if (integer? n2)
+                    (number->string (exact n2))
+                    (inexact n2))
+                (if (zero? k) "" separator)
+                (vector-ref names k)))))))
+
+;; Force a number into a fixed width, print as #'s if doesn't fit.
+;; Needs to be wrapped in PADDED if you want to expand to the width.
+
+(define (numeric/fitted width n . args)
+  (call-with-output
+   (apply numeric n args)
+   (lambda (str)
+     (if (> (string-length str) width)
+         (fn (precision decimal-sep comma-sep)
+           (let ((prec (if (and (pair? args) (pair? (cdr args)))
+                           (cadr args)
+                           precision)))
+             (if prec
+                 (let* ((dec-sep
+                         (or decimal-sep
+                             (if (eqv? #\. comma-sep) #\, #\.)))
+                        (diff (- width (+ prec
+                                          (if (char? dec-sep)
+                                              1
+                                              (string-length dec-sep))))))
+                   (each (if (positive? diff) (make-string diff #\#) "")
+                         dec-sep (make-string prec #\#)))
+                 (displayed (make-string width #\#)))))
+         (displayed str)))))
+
+(define (numeric/comma n . o)
+  (fn (comma-rule)
+    (with ((comma-rule (or comma-rule 3)))
+      (apply numeric n o))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; shared structure utilities