initial (chibi show column) impl

lib/chibi/monad/environment.scm

@@ -175,10 +175,10 @@
            ((w ("step") ((p tmp v) ooo) () . b)
             (lambda (st)
               (let ((tmp (ask st 'p)) ooo)
-                (tell st 'p v) ooo
+                (dynamic-wind
-                (let ((st ((begin . b) st)))
+                  (lambda () (tell st 'p v) ooo)
-                  (tell st 'p tmp) ooo
+                  (lambda () ((begin . b) st))
-                  st))))
+                  (lambda () (tell st 'p tmp) ooo)))))
            ((w ("step") (props ooo) ((p v) . rest) . b)
             (w ("step") (props ooo (p tmp v)) rest . b))
            ((w ((prop value) ooo) . body)

lib/chibi/show-test.sld

@@ -310,14 +310,18 @@
              delightful
              wubbleflubbery)\n")
 
-      '(test-pretty
+      (test-pretty
         "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
   26 27 28 29 30 31 32 33 34 35 36 37)\n")
 
-      '(test-pretty
+      (test-pretty
         "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
  26 27 28 29 30 31 32 33 34 35 36 37)\n")
 
+      (test-pretty
+        "(#(0 1)   #(2 3)   #(4 5)   #(6 7)   #(8 9)   #(10 11) #(12 13) #(14 15)
+ #(16 17) #(18 19))\n")
+
       (test-pretty
        "(define (fold kons knil ls)
   (define (loop ls acc)
@@ -354,7 +358,7 @@
  (module (name \"\\\\testshiftregister\") (attributes (attribute (name \"\\\\src\"))))
  (wire (name \"\\\\shreg\") (attributes (attribute (name \"\\\\src\")))))\n")
 
-      '(test-pretty
+      (test-pretty
        "(design
  (module (name \"\\\\testshiftregister\")
          (attributes

lib/chibi/show.sld

@@ -7,7 +7,8 @@
    padded padded/left padded/right padded/both
    trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
    fitted fitted/left fitted/right fitted/both
-   joined joined/prefix joined/suffix joined/last joined/dot
+   joined joined/prefix joined/suffix joined/last joined/dot joined/range
    upcased downcased)
-  (import (scheme base) (scheme char) (chibi show base) (scheme write))
+  (import (scheme base) (scheme char) (scheme write)
+          (chibi show base))
   (include "show/show.scm"))

lib/chibi/show/base.scm

@@ -80,12 +80,12 @@
                           (string-width substring-length))
                  proc)))
 
-;;> Shortcut syntax for \scheme{(bind (...) (each ...))}.
+;;> Temporarily bind the parameters in the body \var{x}.
 
 (define-syntax with
   (syntax-rules ()
-    ((with params x) (%with params (displayed x)))
+    ((with params x ... y) (%with params x ... (fn () (displayed y))))
-    ((with params . x) (%with params (each . x)))))
+    ))
 
 ;;> The noop formatter.  Generates no output and leaves the state
 ;;> unmodified.
@@ -134,5 +134,5 @@
 ;;> \var{consumer}.
 (define (call-with-output producer consumer)
   (let ((out (open-output-string)))
-    (fn-fork (with ((port out)) producer)
+    (fn-fork (with ((port out) (output output-default)) producer)
              (fn () (consumer (get-output-string out))))))

lib/chibi/show/column.scm

@@ -0,0 +1,450 @@
+;; column.scm -- formatting columns and tables
+;; Copyright (c) 2006-2017 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (call-with-output-generator producer consumer)
+  (fn ()
+    (let ((out (open-output-string))
+          (queue (list-queue))
+          (return #f)
+          (resume #f))
+      (define eof (read-char (open-input-string "")))
+      (define (output* str)
+        (fn (row col string-width)
+          (list-queue-add-back! queue str)
+          ;;(set! lines (append lines (list str)))
+          (call-with-current-continuation
+           (lambda (cc)
+             (set! resume cc)
+             (return nothing)))
+          nothing))
+      (define (generate)
+        (if (and resume (list-queue-empty? queue))
+            (call-with-current-continuation
+             (lambda (cc)
+               (set! return cc)
+               (resume nothing))))
+        (if (list-queue-empty? queue)
+            eof
+            (list-queue-remove-front! queue)))
+      (fn-fork (fn () (with ((port out) (output output*))
+                  (call-with-current-continuation
+                   (lambda (cc)
+                     (set! return cc)
+                     (each producer
+                           (fn (output)
+                             (set! resume #f)
+                             (fn () (return nothing) nothing)))))))
+               (consumer generate)))))
+
+(define (call-with-output-generators producers consumer)
+  (let lp ((ls producers) (generators '()))
+    (if (null? ls)
+        (consumer (reverse generators))
+        (call-with-output-generator
+         (car ls)
+         (lambda (generator)
+           (lp (cdr ls) (cons generator generators)))))))
+
+(define (string->line-generator source)
+  (let ((str '())
+        (scanned? #f))
+    (define (gen)
+      (if (pair? str)
+          (if scanned?
+              (let ((res (source)))
+                (cond
+                 ((eof-object? res)
+                  (let ((res (string-concatenate (reverse str))))
+                    (set! str '())
+                    res))
+                 ((equal? res "")
+                  (gen))
+                 (else
+                  (set! str (cons res str))
+                  (set! scanned? #f)
+                  (gen))))
+              (let ((nl (string-index (car str) #\newline))
+                    (end (string-cursor-end (car str))))
+                (cond
+                 ((string-cursor<? nl end)
+                  (let* ((left (substring/cursors
+                                (car str)
+                                (string-cursor-start (car str))
+                                nl))
+                         (right (substring/cursors
+                                 (car str)
+                                 (string-cursor-next (car str) nl)
+                                 end))
+                         (res (string-concatenate
+                               (reverse (cons left (cdr str))))))
+                    (set! str (if (equal? right "") '() (list right)))
+                    res))
+                 (else
+                  (set! scanned? #t)
+                  (gen)))))
+          (let ((res (source)))
+            (cond
+             ((eof-object? res)
+              res)
+             ((equal? res "")
+              (gen))
+             (else
+              (set! str (cons res str))
+              (set! scanned? #f)
+              (gen))))))
+    gen))
+
+(define-record-type Column
+  (make-column format generate infinite?)
+  column?
+  (format column-format)
+  (generate column-generate)
+  (infinite? column-infinite?))
+
+;; (show-columns (fmt gen [infinite?]) ...)
+(define (show-columns . ls)
+  (fn ()
+    (let* ((cols (map (lambda (x)
+                        (make-column (or (car x) displayed)
+                                     (displayed (cadr x))
+                                     (and (pair? (cddr x)) (car (cddr x)))))
+                      ls))
+           (num-infinite (count column-infinite? cols)))
+      (call-with-output-generators
+       (map column-generate cols)
+       (lambda (gens)
+         (let ((gens (map string->line-generator gens)))
+           (let lp ()
+             (let* ((lines (map (lambda (gen) (gen)) gens))
+                    (num-present (count string? lines)))
+               (if (<= num-present num-infinite)
+                   nothing
+                   (each
+                    (each-in-list
+                     (map (lambda (col line)
+                            ((column-format col)
+                             (if (eof-object? line) "" line)))
+                          cols
+                          lines))
+                    "\n"
+                    (fn () (lp))))))))))))
+
+;; (columnar ['infinite|'right|'left|'center|width] string-or-formatter ...)
+(define (columnar . ls)
+  (define (proportional-width? w)
+    (and (number? w)
+         (or (< 0 w 1)
+             (and (inexact? w) (= w 1.0)))))
+  (define (build-column ls)
+    (let-optionals* ls ((fixed-width #f)
+                        (col-width #f)
+                        (last? #t)
+                        (tail '())
+                        (gen #f)
+                        (prefix '())
+                        (align 'left)
+                        (infinite? #f))
+      (define (scale-width width)
+        (max 1 (exact (truncate (* col-width (- width fixed-width))))))
+      (define (padder)
+        (if (proportional-width? col-width)
+            (case align
+              ((right)
+               (lambda (str) (fn (width) (padded/left (scale-width width) str))))
+              ((center)
+               (lambda (str) (fn (width) (padded/both (scale-width width) str))))
+              (else
+               (lambda (str) (fn (width) (padded/right (scale-width width) str)))))
+            (case align
+              ((right) (lambda (str) (padded/left col-width str)))
+              ((center) (lambda (str) (padded/both col-width str)))
+              (else (lambda (str) (padded/right col-width str))))))
+      (define (affix x)
+        (cond
+         ((pair? tail)
+          (lambda (str)
+            (each (each-in-list prefix)
+                  (x str)
+                  (each-in-list tail))))
+         ((pair? prefix)
+          (lambda (str) (each (each-in-list prefix) (x str))))
+         (else (displayed x))))
+      (list
+       ;; line formatter
+       (affix
+        (let ((pad (padder)))
+          (if (and last? (not (pair? tail)) (eq? align 'left))
+              (lambda (str)
+                (fn (pad-char)
+                  ((if (or (not pad-char) (char-whitespace? pad-char))
+                       displayed
+                       pad)
+                   str)))
+              pad)))
+       ;; generator
+       (if (proportional-width? col-width)
+           (fn (width)
+             (with ((width (scale-width width)))
+               gen))
+           (with ((width col-width)) gen))
+       infinite?)))
+  (define (adjust-widths ls border-width)
+    (let* ((fixed-ls
+            (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls))
+           (fixed-total (fold + border-width (map car fixed-ls)))
+           (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls))
+           (denom (- (length ls) (+ (length fixed-ls) (length scaled-ls))))
+           (rest (if (zero? denom)
+                     0
+                     (inexact
+                      (/ (- 1 (fold + 0 (map car scaled-ls))) denom)))))
+      (if (negative? rest)
+          (error "fractional widths must sum to less than 1"
+                 (map car scaled-ls)))
+      (map
+       (lambda (col)
+         (cons fixed-total
+               (if (not (number? (car col)))
+                   (cons rest (cdr col))
+                   col)))
+       ls)))
+  (define (finish ls border-width)
+    (apply show-columns
+           (map build-column (adjust-widths (reverse ls) border-width))))
+  (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f)
+           (width #t) (border-width 0) (res '()))
+    (cond
+     ((null? ls)
+      (if (pair? strs)
+          (finish (cons (cons (caar res)
+                              (cons #t (cons (append (reverse strs)
+                                                     (cadr (cdar res)))
+                                             (cddr (cdar res)))))
+                        (cdr res))
+                  border-width)
+          (finish (cons (cons (caar res) (cons #t (cddr (car res)))) (cdr res))
+                  border-width)))
+     ((char? (car ls))
+      (lp (cons (string (car ls)) (cdr ls)) strs align infinite?
+          width border-width res))
+     ((string? (car ls))
+      (if (string-contains "\n" (car ls))
+          (error "column string literals can't contain newlines")
+          (lp (cdr ls) (cons (car ls) strs) align infinite?
+              width (+ border-width (string-length (car ls))) res)))
+     ((number? (car ls))
+      (lp (cdr ls) strs align infinite? (car ls) border-width res))
+     ((eq? (car ls) 'infinite)
+      (lp (cdr ls) strs align #t width border-width res))
+     ((symbol? (car ls))
+      (lp (cdr ls) strs (car ls) infinite? width border-width res))
+     ((procedure? (car ls))
+      (lp (cdr ls) '() 'left #f #t border-width
+          (cons (list width #f '() (car ls) (reverse strs) align infinite?)
+                res)))
+     (else
+      (error "invalid column" (car ls))))))
+
+(define (max-line-width string-width str)
+  (let ((end (string-cursor-end str)))
+    (let lp ((i (string-cursor-start str)) (hi 0))
+      (let ((j (string-index str #\newline i)))
+        (if (string-cursor<? j end)
+            (lp (string-cursor-next str j)
+                (max hi (string-width (substring/cursors str i j))))
+            (max hi (string-width (substring/cursors str i end))))))))
+
+(define (pad-finite proc width string-width k)
+  (call-with-output
+   proc
+   (lambda (str)
+     (let ((w (max-line-width (or string-width string-length) str)))
+       (k (displayed str)
+          (if (and (integer? width) (exact? width))
+              (max width w)
+              w))))))
+
+(define (tabular . ls)
+  (fn (string-width)
+    (let lp ((ls ls) (infinite? #f) (width #t) (res '()))
+      (cond
+       ((null? ls)
+        (apply columnar (reverse res)))
+       ((number? (car ls))
+        (lp (cdr ls) infinite? (car ls) res))
+       ((eq? 'infinite (car ls))
+        (lp (cdr ls) #t width (cons (car ls) res)))
+       ((procedure? (car ls))
+        (if infinite?
+            (if width
+                (lp (cdr ls) #f #t (cons (car ls) (cons width res)))
+                (lp (cdr ls) #f #t (cons (car ls) res)))
+            (pad-finite (car ls) width string-width
+                        (lambda (gen width)
+                          (lp (cdr ls) #f #t (cons gen (cons width res)))))))
+       (else
+        (lp (cdr ls) infinite? width (cons (car ls) res)))))))
+
+;; break lines only, don't fmt-join short lines or justify
+(define (wrapped/char . ls)
+  (fn (output width string-width)
+    (define (kons-in-line str)
+      (fn (col)
+        (let ((len ((or string-width string-length) str))
+              (space (- width col)))
+          (cond
+           ((equal? "" str)
+            nothing)
+           ((or (<= len space) (not (positive? space)))
+            (each (output str) (output "\n")))
+           (else
+            (each
+             ;; TODO: when splitting by string-width, substring needs
+             ;; to be provided
+             (output (substring str 0 space))
+             (output "\n")
+             (fn () (kons-in-line (substring str space len)))))))))
+    (with ((output
+            (lambda (str)
+              (let ((end (string-cursor-end str)))
+                (let lp ((i (string-cursor-start str)))
+                  (let ((nli (string-index str #\newline i)))
+                    (cond
+                     ((string-cursor>=? i end)
+                      nothing)
+                     ((string-cursor>=? nli end)
+                      (kons-in-line (substring/cursors str i end)))
+                     (else
+                      (each
+                       (fn () (kons-in-line (substring/cursors str i nli)))
+                       (fn () (lp (string-cursor-next str nli))))))))))))
+      (each-in-list ls))))
+
+(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))
+         (len (vector-length vec))
+         (len-1 (- len 1))
+         (breaks (make-vector len #f))
+         (penalties (make-vector len #f))
+         (widths
+          (list->vector
+           (map get-width (if (list? seq) seq (vector->list vec))))))
+    (define (largest-fit i)
+      (let lp ((j (+ i 1)) (width (vector-ref widths i)))
+        (let ((width (+ width 1 (vector-ref widths j))))
+          (cond
+            ((>= width max-width) (- j 1))
+            ((>= j len-1) len-1)
+            (else (lp (+ j 1) width))))))
+    (define (min-penalty! i)
+      (cond
+        ((>= i len-1) 0)
+        ((vector-ref penalties i))
+        (else
+         (vector-set! penalties i (expt (+ max-width 1) 3))
+         (vector-set! breaks i i)
+         (let ((k (largest-fit i)))
+           (let lp ((j i) (width 0))
+             (if (<= j k)
+                 (let* ((width (+ width (vector-ref widths j)))
+                        (break-penalty
+                         (+ (max 0 (expt (- max-width (+ width (- j i))) 3))
+                            (min-penalty! (+ j 1)))))
+                   (cond
+                     ((< break-penalty (vector-ref penalties i))
+                      (vector-set! breaks i j)
+                      (vector-set! penalties i break-penalty)))
+                   (lp (+ j 1) width)))))
+         (if (>= (vector-ref breaks i) len-1)
+             (vector-set! penalties i 0))
+         (vector-ref penalties i))))
+    (define (sub-list i j)
+      (let lp ((i i) (res '()))
+        (if (> i j)
+            (reverse res)
+            (lp (+ i 1) (cons (vector-ref vec i) res)))))
+    (cond
+     ((zero? len)
+      ;; degenerate case
+      (last-line '() knil))
+     (else
+      ;; compute optimum breaks
+      (vector-set! breaks len-1 len-1)
+      (vector-set! penalties len-1 0)
+      (min-penalty! 0)
+      ;; fold
+      (let lp ((i 0) (acc knil))
+        (let ((break (vector-ref breaks i)))
+          (if (>= break len-1)
+              (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
+;; sentence endings so we can insert two spaces
+(define (wrap-fold str . o)
+  (apply wrap-fold-words (string-split str " ") o))
+
+(define (wrapped . ls)
+  (call-with-output
+   (each-in-list ls)
+   (lambda (str)
+     (fn (width string-width pad-char)
+       (joined/suffix
+        (lambda (ls) (joined displayed ls pad-char))
+        (reverse
+         (wrap-fold str '() width (or string-width string-length) cons))
+        "\n")))))
+
+(define (justified . ls)
+  (fn (output width string-width)
+    (define (justify-line ls)
+      (if (null? ls)
+          nl
+          (let* ((sum (fold (lambda (s n)
+                              (+ n ((or string-width string-length) s)))
+                            0 ls))
+                 (len (length ls))
+                 (diff (max 0 (- width sum)))
+                 (sep (make-string (if (= len 1)
+                                       0
+                                       (quotient diff (- len 1)))
+                                   #\space))
+                 (rem (if (= len 1)
+                          diff
+                          (remainder diff (- len 1))))
+                 (p (open-output-string)))
+            (display (car ls) p)
+            (let lp ((ls (cdr ls)) (i 1))
+              (when (pair? ls)
+                (display sep p)
+                (if (<= i rem) (write-char #\space p))
+                (display (car ls) p)
+                (lp (cdr ls) (+ i 1))))
+            (displayed (get-output-string p)))))
+    (define (justify-last ls)
+      (each (joined displayed ls " ") "\n"))
+    (call-with-output
+     (each-in-list ls)
+     (lambda (str)
+       (joined/last
+        justify-line
+        justify-last
+        (reverse (wrap-fold str '() width string-width cons))
+        "\n")))))
+
+(define (from-file path)
+  (fn ()
+    (call-with-input-file path
+      (lambda (in)
+        (let lp ()
+          (let ((line (read-line in)))
+            (if (eof-object? line)
+                nothing
+                (each line
+                      (fn () (lp))))))))))
+
+(define (counted . o)
+  (let ((start (if (pair? o) (car o) 1)))
+    (joined/range displayed start #f "\n")))

lib/chibi/show/column.sld

@@ -0,0 +1,10 @@
+
+(define-library (chibi show column)
+  (import (scheme base) (scheme char) (scheme file) (scheme write)
+          (srfi 1) (srfi 117) (srfi 130)
+          (chibi optional) (chibi show))
+  (export
+   call-with-output-generator call-with-output-generators
+   string->line-generator
+   columnar tabular wrapped wrapped/char justified counted from-file)
+  (include "column.scm"))

lib/chibi/show/pretty.scm

@@ -244,28 +244,28 @@
    (fn (col width string-width)
      (let ((avail (- width col)))
        (cond
-        ;; ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))
+        ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls)))
-        ;;       (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))))
+              (fits-in-columns width ls (lambda (x) (pp-flat x pp shares))))
-        ;;  => (lambda (ls)
+         => (lambda (ls)
-        ;;       ;; at least four elements which can be broken into columns
+              ;; at least four elements which can be broken into columns
-        ;;       (let* ((prefix (make-nl-space col))
+              (let* ((prefix (make-nl-space col))
-        ;;              (widest (+ 1 (car ls)))
+                     (widest (+ 1 (car ls)))
-        ;;              (columns (quotient width widest))) ; always >= 2
+                     (columns (quotient width widest))) ; always >= 2
-        ;;         (let lp ((ls (cdr ls)) (i 1))
+                (let lp ((ls (cdr ls)) (i 1))
-        ;;           (cond
+                  (cond
-        ;;            ((null? ls)
+                   ((null? ls)
-        ;;             nothing)
+                    nothing)
-        ;;            ((null? (cdr ls))
+                   ((null? (cdr ls))
-        ;;             (displayed (car ls)))
+                    (displayed (car ls)))
-        ;;            ((>= i columns)
+                   ((>= i columns)
-        ;;             (each (car ls)
+                    (each (car ls)
-        ;;                   prefix
+                          prefix
-        ;;                   (fn () (lp (cdr ls) 1))))
+                          (fn () (lp (cdr ls) 1))))
-        ;;            (else
+                   (else
-        ;;             (let ((pad (- widest (string-width (car ls)))))
+                    (let ((pad (- widest (string-width (car ls)))))
-        ;;               (each (car ls)
+                      (each (car ls)
-        ;;                     (make-space pad)
+                            (make-space pad)
-        ;;                     (lp (cdr ls) (+ i 1))))))))))
+                            (lp (cdr ls) (+ i 1))))))))))
         (else
          ;; no room, print one per line
          (joined/shares pp ls shares (make-nl-space col))))))

lib/chibi/show/show.scm

@@ -297,3 +297,17 @@
 ;;> \var{dot-f} to the dotted tail as a final element.
 (define (joined/dot elt-f dot-f ls . o)
   (joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))
+
+;;> As \scheme{joined} but counts from \var{start} to \var{end}
+;;> (exclusive), formatting each integer in the range.  If \var{end}
+;;> is \scheme{#f} or unspecified, produces an infinite stream of
+;;> output.
+(define (joined/range elt-f start . o)
+  (let ((end (and (pair? o) (car o)))
+        (sep (if (and (pair? o) (pair? (cdr o))) (cadr o) "")))
+    (let lp ((i start))
+      (if (and end (>= i end))
+          nothing
+          (each (if (> i start) sep nothing)
+                (elt-f i)
+                (fn () (lp (+ i 1))))))))

lib/chibi/show/write.scm

@@ -308,9 +308,13 @@
                   (assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
              => (lambda (cell)
                   (lambda (n)
-                    (if (or (exact? n) (eqv? radix 10))
+                    (cond
-                        (each (cdr cell) (number->string n (car cell)))
+                     ((eqv? radix 10)
-                        (with ((radix 10)) (numeric n))))))
+                      (displayed (number->string n (car cell))))
+                     ((exact? n)
+                      (each (cdr cell) (number->string n (car cell))))
+                     (else
+                      (with ((radix 10)) (numeric n)))))))
             (else (lambda (n) (with ((radix 10)) (numeric n)))))))
       ;; `wr' is the recursive writer closing over the shares.
       (let wr ((obj obj))