418 lines
16 KiB
Scheme
418 lines
16 KiB
Scheme
|
;;;; fmt-block.scm -- columnar formatting
|
||
|
|
;;
|
||
|
|
;; Copyright (c) 2006-2011 Alex Shinn. All rights reserved.
|
||
|
|
;; BSD-style license: http://synthcode.com/license.txt
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Columnar formatting
|
||
|
|
;;
|
||
|
|
;; A line-oriented formatter. Takes a list of
|
||
|
|
;; (line-fmt1 gen-fmt1 line-fmt2 gen-fmt2 ...)
|
||
|
|
;; and formats each of the gen-fmt1 formats as columns, printed
|
||
|
|
;; side-by-side, each line allowing post-processing done by line-fmt1
|
||
|
|
;; (just use dsp if you want to display the lines verbatim).
|
||
|
|
|
||
|
|
;; Continuations come to the rescue to make this work properly,
|
||
|
|
;; letting us weave the output between different columns without
|
||
|
|
;; needing to build up intermediate strings.
|
||
|
|
|
||
|
|
(define (fmt-columns . ls)
|
||
|
|
(lambda (orig-st)
|
||
|
|
(call-with-current-continuation
|
||
|
|
(lambda (return)
|
||
|
|
(define (infinite? x)
|
||
|
|
(and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (caddr x)))
|
||
|
|
(let ((q1 '())
|
||
|
|
(q2 '())
|
||
|
|
(remaining (length (remove infinite? ls))))
|
||
|
|
(define (enq! proc) (set! q2 (cons proc q2)))
|
||
|
|
(define (deq!) (let ((proc (car q1))) (set! q1 (cdr q1)) proc))
|
||
|
|
(define (line-init!) (set! q1 (reverse q2)) (set! q2 '()))
|
||
|
|
(define (line-done?) (null? q1))
|
||
|
|
(define line-buf '())
|
||
|
|
(define line-non-empty? #f)
|
||
|
|
(define (write-column fmt str finite?)
|
||
|
|
(set! line-buf (cons (cons fmt str) line-buf))
|
||
|
|
(if finite? (set! line-non-empty? #t)))
|
||
|
|
(define (write-line)
|
||
|
|
(cond
|
||
|
|
(line-non-empty?
|
||
|
|
(for-each
|
||
|
|
(lambda (x) (set! orig-st (((car x) (cdr x)) orig-st)))
|
||
|
|
(reverse line-buf))
|
||
|
|
(set! orig-st (nl orig-st))))
|
||
|
|
(set! line-buf '())
|
||
|
|
(set! line-non-empty? #f)
|
||
|
|
(line-init!))
|
||
|
|
(define (next cont)
|
||
|
|
(enq! cont)
|
||
|
|
(cond
|
||
|
|
((line-done?)
|
||
|
|
(write-line)
|
||
|
|
(if (not (positive? remaining)) (finish) ((deq!) #f)))
|
||
|
|
(else ((deq!) #f))))
|
||
|
|
(define (finish)
|
||
|
|
(write-line)
|
||
|
|
(return orig-st))
|
||
|
|
(define (make-empty-col fmt)
|
||
|
|
(define (blank *ignored*)
|
||
|
|
(write-column fmt "" #f)
|
||
|
|
(next blank)) ; infinite loop, next terminates for us
|
||
|
|
blank)
|
||
|
|
(define (make-col st fmt gen finite?)
|
||
|
|
(let ((acc '())) ; buffer incomplete lines
|
||
|
|
(lambda (*ignored*)
|
||
|
|
(define (output* str st)
|
||
|
|
(let lp ((i 0))
|
||
|
|
(let ((nli (string-index str #\newline i)))
|
||
|
|
(cond
|
||
|
|
(nli
|
||
|
|
(let ((line
|
||
|
|
(string-concatenate-reverse
|
||
|
|
(cons (substring/shared str i nli) acc))))
|
||
|
|
(set! acc '())
|
||
|
|
(write-column fmt line finite?)
|
||
|
|
(call-with-current-continuation next)
|
||
|
|
(lp (+ nli 1))))
|
||
|
|
(else
|
||
|
|
(set! acc (cons (substring/shared str i) acc))))))
|
||
|
|
;; update - don't output or the string port will fill up
|
||
|
|
(fmt-update str st))
|
||
|
|
;; gen threads through it's own state, ignore result
|
||
|
|
(gen (fmt-set-writer! (copy-fmt-state st) output*))
|
||
|
|
;; reduce # of remaining finite columns
|
||
|
|
(set! remaining (- remaining 1))
|
||
|
|
;; write any remaining accumulated output
|
||
|
|
(if (pair? acc)
|
||
|
|
(let ((s (string-concatenate-reverse acc)))
|
||
|
|
(write-column fmt s (and finite? (not (equal? s ""))))))
|
||
|
|
;; (maybe) loop with an empty column in place
|
||
|
|
(if (not (positive? remaining))
|
||
|
|
(finish)
|
||
|
|
(next (make-empty-col fmt))))))
|
||
|
|
;; queue up the initial formatters
|
||
|
|
(for-each
|
||
|
|
(lambda (col)
|
||
|
|
(let ((st (fmt-set-port! (copy-fmt-state orig-st)
|
||
|
|
(open-output-string))))
|
||
|
|
(enq! (make-col st (car col) (dsp (cadr col))
|
||
|
|
(not (infinite? col))))))
|
||
|
|
ls)
|
||
|
|
(line-init!)
|
||
|
|
;; start
|
||
|
|
((deq!) #f))))))
|
||
|
|
|
||
|
|
(define (columnar . ls)
|
||
|
|
(define (proportional-width? w)
|
||
|
|
(and (number? w)
|
||
|
|
(or (< 0 w 1)
|
||
|
|
(and (inexact? w) (= w 1.0)))))
|
||
|
|
(define (whitespace-pad? st)
|
||
|
|
(char-whitespace? (or (fmt-pad-char st) #\space)))
|
||
|
|
(define (build-column ls)
|
||
|
|
(let-optionals* ls ((fixed-width #f)
|
||
|
|
(width #f)
|
||
|
|
(last? #t)
|
||
|
|
(tail '())
|
||
|
|
(gen #f)
|
||
|
|
(prefix '())
|
||
|
|
(align 'left)
|
||
|
|
(infinite? #f))
|
||
|
|
(define (scale-width st)
|
||
|
|
(max 1 (inexact->exact
|
||
|
|
(truncate (* width (- (fmt-width st) fixed-width))))))
|
||
|
|
(define (padder)
|
||
|
|
(if (proportional-width? width)
|
||
|
|
(case align
|
||
|
|
((right)
|
||
|
|
(lambda (str) (lambda (st) ((pad/left (scale-width st) str) st))))
|
||
|
|
((center)
|
||
|
|
(lambda (str) (lambda (st) ((pad/both (scale-width st) str) st))))
|
||
|
|
(else
|
||
|
|
(lambda (str) (lambda (st) ((pad/right (scale-width st) str) st)))))
|
||
|
|
(case align
|
||
|
|
((right) (lambda (str) (pad/left width str)))
|
||
|
|
((center) (lambda (str) (pad/both width str)))
|
||
|
|
(else (lambda (str) (pad/right width str))))))
|
||
|
|
(define (affix x)
|
||
|
|
(cond
|
||
|
|
((pair? tail)
|
||
|
|
(lambda (str)
|
||
|
|
(cat (string-concatenate prefix)
|
||
|
|
(x str)
|
||
|
|
(string-concatenate tail))))
|
||
|
|
((pair? prefix)
|
||
|
|
(lambda (str) (cat (string-concatenate prefix) (x str))))
|
||
|
|
(else x)))
|
||
|
|
(list
|
||
|
|
;; line formatter
|
||
|
|
(affix
|
||
|
|
(let ((pad (padder)))
|
||
|
|
(if (and last? (not (pair? tail)) (eq? align 'left))
|
||
|
|
(lambda (str)
|
||
|
|
(lambda (st)
|
||
|
|
(((if (whitespace-pad? st) dsp pad) str) st)))
|
||
|
|
pad)))
|
||
|
|
;; generator
|
||
|
|
(if (proportional-width? width)
|
||
|
|
(lambda (st) ((with-width (scale-width st) gen) st))
|
||
|
|
(with-width 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
|
||
|
|
(exact->inexact
|
||
|
|
(/ (- 1 (fold + 0 (map car scaled-ls))) denom)))))
|
||
|
|
(if (negative? rest)
|
||
|
|
(error 'columnar "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 fmt-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)
|
||
|
|
(caddar res))
|
||
|
|
(cdddar res))))
|
||
|
|
(cdr res))
|
||
|
|
border-width)
|
||
|
|
(finish (cons (cons (caar res) (cons #t (cddar res))) (cdr res))
|
||
|
|
border-width)))
|
||
|
|
((string? (car ls))
|
||
|
|
(if (string-index (car ls) #\newline)
|
||
|
|
(error 'columnar "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 'columnar "invalid column" (car ls))))))
|
||
|
|
|
||
|
|
(define (max-line-width string-width str)
|
||
|
|
(let lp ((i 0) (hi 0))
|
||
|
|
(let ((j (string-index str #\newline i)))
|
||
|
|
(if j
|
||
|
|
(lp (+ j 1) (max hi (string-width (substring str i j))))
|
||
|
|
(max hi (string-width (substring str i (string-length str))))))))
|
||
|
|
|
||
|
|
(define (pad-finite st proc width)
|
||
|
|
(let* ((str ((fmt-to-string proc) (copy-fmt-state st)))
|
||
|
|
(w (max-line-width (or (fmt-string-width st) string-length) str)))
|
||
|
|
(list (cat str)
|
||
|
|
(if (and (integer? width) (exact? width))
|
||
|
|
(max width w)
|
||
|
|
w))))
|
||
|
|
|
||
|
|
(define (tabular . ls)
|
||
|
|
(lambda (st)
|
||
|
|
(let lp ((ls ls) (infinite? #f) (width #t) (res '()))
|
||
|
|
(cond
|
||
|
|
((null? ls)
|
||
|
|
((apply columnar (reverse res)) st))
|
||
|
|
((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)))
|
||
|
|
(let ((gen+width (pad-finite st (car ls) width)))
|
||
|
|
(lp (cdr ls) #f #t (append gen+width res)))))
|
||
|
|
(else
|
||
|
|
(lp (cdr ls) infinite? width (cons (car ls) res)))))))
|
||
|
|
|
||
|
|
;; break lines only, don't fmt-join short lines or justify
|
||
|
|
(define (fold-lines . ls)
|
||
|
|
(lambda (st)
|
||
|
|
(define output (fmt-writer st))
|
||
|
|
(define (kons-in-line str st)
|
||
|
|
(let ((len ((or (fmt-string-width st) string-length) str))
|
||
|
|
(space (- (fmt-width st) (fmt-col st))))
|
||
|
|
(cond
|
||
|
|
((or (<= len space) (not (positive? space)))
|
||
|
|
(output str st))
|
||
|
|
(else
|
||
|
|
(kons-in-line
|
||
|
|
(substring/shared str space len)
|
||
|
|
(output nl-str
|
||
|
|
(output (substring/shared str 0 space) st)))))))
|
||
|
|
((fmt-let
|
||
|
|
'writer
|
||
|
|
(lambda (str st)
|
||
|
|
(let lp ((str str) (st st))
|
||
|
|
(let ((nli (string-index str #\newline)))
|
||
|
|
(cond
|
||
|
|
((not nli)
|
||
|
|
(kons-in-line str st))
|
||
|
|
(else
|
||
|
|
(lp (substring/shared str (+ nli 1))
|
||
|
|
(output nl-str
|
||
|
|
(kons-in-line
|
||
|
|
(substring/shared str 0 nli)
|
||
|
|
st))))))))
|
||
|
|
(apply-cat ls))
|
||
|
|
st)))
|
||
|
|
|
||
|
|
(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-tokenize str) o))
|
||
|
|
|
||
|
|
(define (wrap-lines . ls)
|
||
|
|
(define (print-line ls st)
|
||
|
|
(nl ((fmt-join dsp ls " ") st)))
|
||
|
|
(define buffer '())
|
||
|
|
(lambda (st)
|
||
|
|
((fmt-let
|
||
|
|
'writer
|
||
|
|
(lambda (str st) (set! buffer (cons str buffer)) st)
|
||
|
|
(apply-cat ls))
|
||
|
|
st)
|
||
|
|
(wrap-fold (string-concatenate-reverse buffer)
|
||
|
|
st (fmt-width st)
|
||
|
|
(or (fmt-string-width st) string-length)
|
||
|
|
print-line)))
|
||
|
|
|
||
|
|
(define (justify . ls)
|
||
|
|
(lambda (st)
|
||
|
|
(let ((width (fmt-width st))
|
||
|
|
(string-width (or (fmt-string-width st) string-length))
|
||
|
|
(output (fmt-writer st))
|
||
|
|
(buffer '()))
|
||
|
|
(define (justify-line ls st)
|
||
|
|
(if (null? ls)
|
||
|
|
(nl st)
|
||
|
|
(let* ((sum (fold (lambda (s n) (+ n (string-width 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)))))
|
||
|
|
(output
|
||
|
|
(call-with-output-string
|
||
|
|
(lambda (p)
|
||
|
|
(display (car ls) p)
|
||
|
|
(let lp ((ls (cdr ls)) (i 1))
|
||
|
|
(cond
|
||
|
|
((pair? ls)
|
||
|
|
(display sep p)
|
||
|
|
(if (<= i rem) (write-char #\space p))
|
||
|
|
(display (car ls) p)
|
||
|
|
(lp (cdr ls) (+ i 1)))))
|
||
|
|
(newline p)))
|
||
|
|
st))))
|
||
|
|
(define (justify-last ls st)
|
||
|
|
(nl ((fmt-join dsp ls " ") st)))
|
||
|
|
((fmt-let
|
||
|
|
'writer
|
||
|
|
(lambda (str st) (set! buffer (cons str buffer)) st)
|
||
|
|
(apply-cat ls))
|
||
|
|
st)
|
||
|
|
(wrap-fold (string-concatenate-reverse buffer)
|
||
|
|
st width string-width justify-line justify-last))))
|
||
|
|
|
||
|
|
(define (fmt-file path)
|
||
|
|
(lambda (st)
|
||
|
|
(call-with-input-file path
|
||
|
|
(lambda (p)
|
||
|
|
(let lp ((st st))
|
||
|
|
(let ((line (read-line p)))
|
||
|
|
(if (eof-object? line)
|
||
|
|
st
|
||
|
|
(lp (nl ((dsp line) st))))))))))
|
||
|
|
|
||
|
|
(define (line-numbers . o)
|
||
|
|
(let ((start (if (pair? o) (car o) 1)))
|
||
|
|
(fmt-join/range dsp start #f nl-str)))
|
||
|
|
|