Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial (chibi show column) impl

Browse source
This commit is contained in:
Alex Shinn 2017-06-17 21:53:35 +09:00
parent b52711cac8
commit 97716e8125
9 changed files with 521 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lib/chibi/monad/environment.scm
View file

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

10
lib/chibi/show-test.sld
View file

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

5
lib/chibi/show.sld
View file

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

8
lib/chibi/show/base.scm
View file

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

450
lib/chibi/show/column.scm Normal file
View file

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

10
lib/chibi/show/column.sld Normal file
View file

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

44
lib/chibi/show/pretty.scm
View file

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

14
lib/chibi/show/show.scm
View file

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

10
lib/chibi/show/write.scm
View file

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