From 97716e812556fa82d88eaae70b796adaa8deb3e7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 17 Jun 2017 21:53:35 +0900 Subject: [PATCH] initial (chibi show column) impl --- lib/chibi/monad/environment.scm | 8 +- lib/chibi/show-test.sld | 10 +- lib/chibi/show.sld | 5 +- lib/chibi/show/base.scm | 8 +- lib/chibi/show/column.scm | 450 ++++++++++++++++++++++++++++++++ lib/chibi/show/column.sld | 10 + lib/chibi/show/pretty.scm | 44 ++-- lib/chibi/show/show.scm | 14 + lib/chibi/show/write.scm | 10 +- 9 files changed, 521 insertions(+), 38 deletions(-) create mode 100644 lib/chibi/show/column.scm create mode 100644 lib/chibi/show/column.sld diff --git a/lib/chibi/monad/environment.scm b/lib/chibi/monad/environment.scm index d41e8b6b..a0c93e0e 100644 --- a/lib/chibi/monad/environment.scm +++ b/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 - (let ((st ((begin . b) st))) - (tell st 'p tmp) ooo - st)))) + (dynamic-wind + (lambda () (tell st 'p v) ooo) + (lambda () ((begin . b) 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) diff --git a/lib/chibi/show-test.sld b/lib/chibi/show-test.sld index bac1bd14..de4aaa2f 100644 --- a/lib/chibi/show-test.sld +++ b/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 diff --git a/lib/chibi/show.sld b/lib/chibi/show.sld index 04b2dcb9..207e15a5 100644 --- a/lib/chibi/show.sld +++ b/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")) diff --git a/lib/chibi/show/base.scm b/lib/chibi/show/base.scm index ce6c9365..bd586528 100644 --- a/lib/chibi/show/base.scm +++ b/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) (%with params (each . x))))) + ((with params x ... y) (%with params x ... (fn () (displayed y)))) + )) ;;> 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)))))) diff --git a/lib/chibi/show/column.scm b/lib/chibi/show/column.scm new file mode 100644 index 00000000..b4676a77 --- /dev/null +++ b/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-cursorline-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=? 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"))) diff --git a/lib/chibi/show/column.sld b/lib/chibi/show/column.sld new file mode 100644 index 00000000..8e131706 --- /dev/null +++ b/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")) diff --git a/lib/chibi/show/pretty.scm b/lib/chibi/show/pretty.scm index df859196..394d9f57 100644 --- a/lib/chibi/show/pretty.scm +++ b/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))) - ;; (fits-in-columns width ls (lambda (x) (pp-flat x pp shares)))) - ;; => (lambda (ls) - ;; ;; at least four elements which can be broken into columns - ;; (let* ((prefix (make-nl-space col)) - ;; (widest (+ 1 (car ls))) - ;; (columns (quotient width widest))) ; always >= 2 - ;; (let lp ((ls (cdr ls)) (i 1)) - ;; (cond - ;; ((null? ls) - ;; nothing) - ;; ((null? (cdr ls)) - ;; (displayed (car ls))) - ;; ((>= i columns) - ;; (each (car ls) - ;; prefix - ;; (fn () (lp (cdr ls) 1)))) - ;; (else - ;; (let ((pad (- widest (string-width (car ls))))) - ;; (each (car ls) - ;; (make-space pad) - ;; (lp (cdr ls) (+ i 1)))))))))) + ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdr (cddr ls))) + (fits-in-columns width ls (lambda (x) (pp-flat x pp shares)))) + => (lambda (ls) + ;; at least four elements which can be broken into columns + (let* ((prefix (make-nl-space col)) + (widest (+ 1 (car ls))) + (columns (quotient width widest))) ; always >= 2 + (let lp ((ls (cdr ls)) (i 1)) + (cond + ((null? ls) + nothing) + ((null? (cdr ls)) + (displayed (car ls))) + ((>= i columns) + (each (car ls) + prefix + (fn () (lp (cdr ls) 1)))) + (else + (let ((pad (- widest (string-width (car ls))))) + (each (car ls) + (make-space pad) + (lp (cdr ls) (+ i 1)))))))))) (else ;; no room, print one per line (joined/shares pp ls shares (make-nl-space col)))))) diff --git a/lib/chibi/show/show.scm b/lib/chibi/show/show.scm index 5cf9bb50..2a51e0f9 100644 --- a/lib/chibi/show/show.scm +++ b/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)))))))) diff --git a/lib/chibi/show/write.scm b/lib/chibi/show/write.scm index 42d224ed..0eb74da8 100644 --- a/lib/chibi/show/write.scm +++ b/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)) - (each (cdr cell) (number->string n (car cell))) - (with ((radix 10)) (numeric n)))))) + (cond + ((eqv? radix 10) + (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))