mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-12 23:47:34 +02:00
Adding pretty-printing format combinators.
This commit is contained in:
Alex Shinn
parent
eebe3f0448
commit
83262a9dfa
5 changed files with 461 additions and 12 deletions
|
|
@ -3,7 +3,9 @@
|
|||
(export
|
||||
show fn fn-fork with update! each each-in-list call-with-output
|
||||
displayed written written-shared written-simply numeric nothing
|
||||
output-default)
|
||||
;; 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))
|
||||
(include "base.scm")
|
||||
|
|
|
|||
357
lib/chibi/show/pretty.scm
Normal file
357
lib/chibi/show/pretty.scm
Normal file
|
|
@ -0,0 +1,357 @@
|
|||
;; pretty.scm -- pretty printing format combinator
|
||||
;; Copyright (c) 2006-2013 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; utilities
|
||||
|
||||
(define (take* ls n) ; handles dotted lists and n > length
|
||||
(cond ((zero? n) '())
|
||||
((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
|
||||
(else '())))
|
||||
|
||||
(define (drop* ls n) ; may return the dot
|
||||
(cond ((zero? n) ls)
|
||||
((pair? ls) (drop* (cdr ls) (- n 1)))
|
||||
(else ls)))
|
||||
|
||||
(define (make-space n) (make-string n #\space))
|
||||
(define (make-nl-space n) (string-append "\n" (make-string n #\space)))
|
||||
|
||||
(define (joined/shares fmt ls shares . o)
|
||||
(let ((sep (displayed (if (pair? o) (car o) " "))))
|
||||
(fn ()
|
||||
(if (null? ls)
|
||||
nothing
|
||||
(let lp ((ls ls))
|
||||
(each
|
||||
(fmt (car ls))
|
||||
(let ((rest (cdr ls)))
|
||||
(cond
|
||||
((null? rest) nothing)
|
||||
((pair? rest)
|
||||
(call-with-shared-ref/cdr rest
|
||||
shares
|
||||
(fn () (lp rest))
|
||||
sep))
|
||||
(else (each sep ". " (fmt rest)))))))))))
|
||||
|
||||
(define (try-fitted2 proc fail)
|
||||
(fn (width string-width output)
|
||||
(let ((out (open-output-string)))
|
||||
(call-with-current-continuation
|
||||
(lambda (abort)
|
||||
;; Modify output to accumulate to an output string port,
|
||||
;; and escape immediately with failure if we exceed the
|
||||
;; column width.
|
||||
(define (output* str)
|
||||
(fn (col)
|
||||
(let lp ((i 0) (col col))
|
||||
(let ((nli (string-find str #\newline i))
|
||||
(len (string-width str)))
|
||||
(if (< nli len)
|
||||
(if (> (+ (- nli i) col) width)
|
||||
(abort fail)
|
||||
(lp (+ nli 1) 0))
|
||||
(let ((col (+ (- len i) col)))
|
||||
(cond
|
||||
((> col width)
|
||||
(abort fail))
|
||||
(else
|
||||
(output str)))))))))
|
||||
(fn-fork
|
||||
(with ((output output*)
|
||||
(port out))
|
||||
proc)
|
||||
;; fitted successfully
|
||||
(output (get-output-string out))))))))
|
||||
|
||||
(define (try-fitted proc . fail)
|
||||
(if (null? fail)
|
||||
proc
|
||||
(try-fitted2 proc (apply try-fitted fail))))
|
||||
|
||||
(define (fits-in-width width proc)
|
||||
(call-with-current-continuation
|
||||
(lambda (abort)
|
||||
(show
|
||||
#f
|
||||
(fn (output)
|
||||
(define (output* str)
|
||||
(each (output str)
|
||||
(fn (col)
|
||||
(if (>= col width)
|
||||
(abort #f)
|
||||
nothing))))
|
||||
(with ((output output*))
|
||||
proc))))))
|
||||
|
||||
(define (fits-in-columns width ls writer)
|
||||
(let ((max-w (quotient width 2)))
|
||||
(let lp ((ls ls) (res '()) (widest 0))
|
||||
(cond
|
||||
((pair? ls)
|
||||
(let ((str (fits-in-width max-w (writer (car ls)))))
|
||||
(and str
|
||||
(lp (cdr ls)
|
||||
(cons str res)
|
||||
(max (string-length str) widest)))))
|
||||
((null? ls) (cons widest (reverse res)))
|
||||
(else #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; style
|
||||
|
||||
(define syntax-abbrevs
|
||||
'((quote . "'") (quasiquote . "`")
|
||||
(unquote . ",") (unquote-splicing . ",@")
|
||||
))
|
||||
|
||||
(define (pp-let ls pp shares)
|
||||
(if (and (pair? (cdr ls)) (symbol? (cadr ls)))
|
||||
(pp-with-indent 2 ls pp shares)
|
||||
(pp-with-indent 1 ls pp shares)))
|
||||
|
||||
(define indent-rules
|
||||
`((lambda . 1) (define . 1)
|
||||
(let . ,pp-let) (loop . ,pp-let)
|
||||
(let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
|
||||
(let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
|
||||
(let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
|
||||
(match . 1) (match-let . 1) (match-let* . 1)
|
||||
(if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
|
||||
(do . 2) (dotimes . 1) (dolist . 1) (test . 1)
|
||||
(condition-case . 1) (guard . 1) (rec . 1)
|
||||
(call-with-current-continuation . 0)
|
||||
))
|
||||
|
||||
(define indent-prefix-rules
|
||||
`(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
|
||||
)
|
||||
|
||||
(define indent-suffix-rules
|
||||
`(("-case" . 1))
|
||||
)
|
||||
|
||||
(define (pp-indentation form)
|
||||
(let ((indent
|
||||
(cond
|
||||
((assq (car form) indent-rules) => cdr)
|
||||
((and (symbol? (car form))
|
||||
(let ((str (symbol->string (car form))))
|
||||
(or (find (lambda (rx) (string-prefix? (car rx) str))
|
||||
indent-prefix-rules)
|
||||
(find (lambda (rx) (string-suffix? (car rx) str))
|
||||
indent-suffix-rules))))
|
||||
=> cdr)
|
||||
(else #f))))
|
||||
(if (and (number? indent) (negative? indent))
|
||||
(max 0 (- (+ (length+ form) indent) 1))
|
||||
indent)))
|
||||
|
||||
(define (with-reset-shares shares proc)
|
||||
(let ((orig-count (cdr shares)))
|
||||
(fn ()
|
||||
(let ((new-count (cdr shares)))
|
||||
(cond
|
||||
((> new-count orig-count)
|
||||
(hash-table-walk
|
||||
(car shares)
|
||||
(lambda (k v)
|
||||
(if (and (cdr v) (>= (car v) orig-count))
|
||||
(set-cdr! v #f))))
|
||||
(set-cdr! shares orig-count)))
|
||||
proc))))
|
||||
|
||||
(define (pp-with-indent indent-rule ls pp shares)
|
||||
(fn ((col1 col))
|
||||
(each
|
||||
"("
|
||||
(pp (car ls))
|
||||
(fn ((col2 col) width string-width)
|
||||
(let ((fixed (take* (cdr ls) (or indent-rule 1)))
|
||||
(tail (drop* (cdr ls) (or indent-rule 1)))
|
||||
(default
|
||||
(let ((sep (make-nl-space (+ col1 1))))
|
||||
(each sep (joined/shares pp (cdr ls) shares sep) ")")))
|
||||
;; reset in case we don't fit on the first line
|
||||
(reset-shares (with-reset-shares shares nothing)))
|
||||
(call-with-output
|
||||
(each " "
|
||||
(joined/shares
|
||||
(lambda (x) (pp-flat x pp shares)) fixed shares " "))
|
||||
(lambda (first-line)
|
||||
(cond
|
||||
((< (+ col2 (string-width first-line)) width)
|
||||
;; fixed values on first line
|
||||
(let ((sep (make-nl-space
|
||||
(if indent-rule (+ col1 2) (+ col2 1)))))
|
||||
(each first-line
|
||||
(cond
|
||||
((not (or (null? tail) (pair? tail)))
|
||||
(each ". " (pp tail pp shares)))
|
||||
((> (length+ (cdr ls)) (or indent-rule 1))
|
||||
(each sep (joined/shares pp tail shares sep)))
|
||||
(else
|
||||
nothing)))))
|
||||
(indent-rule
|
||||
;; fixed values lined up, body indented two spaces
|
||||
(try-fitted
|
||||
(each
|
||||
reset-shares
|
||||
" "
|
||||
(joined/shares pp fixed shares (make-nl-space (+ col2 1)))
|
||||
(if (pair? tail)
|
||||
(let ((sep (make-nl-space (+ col1 2))))
|
||||
(each sep (joined/shares pp tail shares sep)))
|
||||
nothing))
|
||||
(each reset-shares default)))
|
||||
(else
|
||||
;; all on separate lines
|
||||
(each reset-shares default)))))))
|
||||
")")))
|
||||
|
||||
(define (pp-app ls pp shares)
|
||||
(let ((indent-rule (pp-indentation ls)))
|
||||
(if (procedure? indent-rule)
|
||||
(indent-rule ls pp shares)
|
||||
(pp-with-indent indent-rule ls pp shares))))
|
||||
|
||||
;; the elements may be shared, just checking the top level list
|
||||
;; structure
|
||||
(define (proper-non-shared-list? ls shares)
|
||||
(let ((tab (car shares)))
|
||||
(let lp ((ls ls))
|
||||
(or (null? ls)
|
||||
(and (pair? ls)
|
||||
(not (hash-table-ref/default tab ls #f))
|
||||
(lp (cdr ls)))))))
|
||||
|
||||
(define (non-app? x)
|
||||
(if (pair? x)
|
||||
(or (not (or (null? (cdr x)) (pair? (cdr x))))
|
||||
(non-app? (car x)))
|
||||
(not (symbol? x))))
|
||||
|
||||
(define (pp-data-list ls pp shares)
|
||||
(each
|
||||
"("
|
||||
(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))))))))))
|
||||
(else
|
||||
;; no room, print one per line
|
||||
(joined/shares pp ls shares (make-nl-space col))))))
|
||||
")"))
|
||||
|
||||
(define (pp-flat x pp shares)
|
||||
(cond
|
||||
((pair? x)
|
||||
(cond
|
||||
((and (pair? (cdr x)) (null? (cddr x))
|
||||
(assq (car x) syntax-abbrevs))
|
||||
=> (lambda (abbrev)
|
||||
(each (cdr abbrev)
|
||||
(call-with-shared-ref
|
||||
(cadr x)
|
||||
shares
|
||||
(pp-flat (cadr x) pp shares)))))
|
||||
(else
|
||||
(each "("
|
||||
(joined/shares (lambda (x) (pp-flat x pp shares)) x shares " ")
|
||||
")"))))
|
||||
((vector? x)
|
||||
(each "#("
|
||||
(joined/shares
|
||||
(lambda (x) (pp-flat x pp shares)) (vector->list x) shares " ")
|
||||
")"))
|
||||
(else
|
||||
(pp x))))
|
||||
|
||||
(define (pp-pair ls pp shares)
|
||||
(cond
|
||||
;; one element list, no lines to break
|
||||
((null? (cdr ls))
|
||||
(each "(" (pretty (car ls)) ")"))
|
||||
;; quote or other abbrev
|
||||
((and (pair? (cdr ls)) (null? (cddr ls))
|
||||
(assq (car ls) syntax-abbrevs))
|
||||
=> (lambda (abbrev)
|
||||
(each (cdr abbrev) (pp (cadr ls)))))
|
||||
(else
|
||||
(try-fitted
|
||||
(fn () (pp-flat ls pp shares))
|
||||
(with-reset-shares
|
||||
shares
|
||||
(fn ()
|
||||
(if (and (non-app? ls)
|
||||
(proper-non-shared-list? ls shares))
|
||||
(pp-data-list ls pp shares)
|
||||
(pp-app ls pp shares))))))))
|
||||
|
||||
(define (pp-vector vec pp shares)
|
||||
(each "#" (pp-data-list (vector->list vec) pp shares)))
|
||||
|
||||
;; adapted from `write-with-shares'
|
||||
(define (pp obj shares)
|
||||
(fn (radix precision)
|
||||
(let ((write-number
|
||||
(cond
|
||||
((and (not precision)
|
||||
(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))))))
|
||||
(else (lambda (n) (with ((radix 10)) (numeric n)))))))
|
||||
(let pp ((obj obj))
|
||||
(call-with-shared-ref
|
||||
obj shares
|
||||
(fn ()
|
||||
(cond
|
||||
((pair? obj)
|
||||
(pp-pair obj pp shares))
|
||||
((vector? obj)
|
||||
(pp-vector obj pp shares))
|
||||
((number? obj)
|
||||
(write-number obj))
|
||||
(else
|
||||
(write-with-shares obj shares)))))))))
|
||||
|
||||
(define (pretty obj)
|
||||
(fn ()
|
||||
(each (pp obj (extract-shared-objects obj #t))
|
||||
fl)))
|
||||
|
||||
(define (pretty-shared obj)
|
||||
(fn ()
|
||||
(each (pp obj (extract-shared-objects obj #f))
|
||||
fl)))
|
||||
|
||||
(define (pretty-simply obj)
|
||||
(fn ()
|
||||
(each (pp obj (extract-shared-objects #f #f))
|
||||
fl)))
|
||||
8
lib/chibi/show/pretty.sld
Normal file
8
lib/chibi/show/pretty.sld
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(define-library (chibi show pretty)
|
||||
(export pretty pretty-shared pretty-simply
|
||||
joined/shares
|
||||
)
|
||||
(import (scheme base) (scheme write) (chibi show) (chibi show base)
|
||||
(srfi 1) (srfi 69) (chibi string))
|
||||
(include "pretty.scm"))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
;; write.scm - written formatting, the default displayed for non-string/chars
|
||||
;; Copyright (c) 2013 Alex Shinn. All rights reserved.
|
||||
;; Copyright (c) 2006-2013 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -258,7 +258,7 @@
|
|||
((> v 1)
|
||||
(hash-table-set! res k (cons count #f))
|
||||
(set! count (+ count 1))))))
|
||||
res)))
|
||||
(cons res 0))))
|
||||
|
||||
(define (maybe-gen-shared-ref cell shares)
|
||||
(cond
|
||||
|
|
@ -275,15 +275,16 @@
|
|||
(each "#" (number->string (car cell)) "#")
|
||||
(each (maybe-gen-shared-ref cell shares) proc))))
|
||||
|
||||
(define (call-with-shared-ref/cdr obj shares proc)
|
||||
(let ((cell (hash-table-ref/default (car shares) obj #f)))
|
||||
(define (call-with-shared-ref/cdr obj shares proc . o)
|
||||
(let ((sep (displayed (if (pair? o) (car o) "")))
|
||||
(cell (hash-table-ref/default (car shares) obj #f)))
|
||||
(cond
|
||||
((and (pair? cell) (cdr cell))
|
||||
(each ". #" (number->string (car cell)) "#"))
|
||||
(each sep ". #" (number->string (car cell)) "#"))
|
||||
((pair? cell)
|
||||
(each ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
|
||||
(each sep ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
|
||||
(else
|
||||
proc))))
|
||||
(each sep proc)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; written
|
||||
|
|
@ -352,13 +353,13 @@
|
|||
|
||||
(define (written-default obj)
|
||||
(fn ()
|
||||
(write-with-shares obj (cons (extract-shared-objects obj #t) 0))))
|
||||
(write-with-shares obj (extract-shared-objects obj #t))))
|
||||
|
||||
;; Writes the object showing the full shared structure.
|
||||
|
||||
(define (written-shared obj)
|
||||
(fn ()
|
||||
(write-with-shares obj (cons (extract-shared-objects obj #f) 0))))
|
||||
(write-with-shares obj (extract-shared-objects obj #f))))
|
||||
|
||||
;; The only expensive part, in both time and memory, of handling
|
||||
;; shared structures when writing is building the initial table, so
|
||||
|
|
@ -367,7 +368,7 @@
|
|||
|
||||
(define (written-simply obj)
|
||||
(fn ()
|
||||
(write-with-shares obj (cons (make-hash-table eq?) 0))))
|
||||
(write-with-shares obj (extract-shared-objects #f #f))))
|
||||
|
||||
;; Local variables:
|
||||
;; eval: (put 'fn 'scheme-indent-function 1)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
(import (scheme base) (chibi show) (chibi test))
|
||||
(import (scheme base) (scheme read) (chibi test)
|
||||
(chibi show) (chibi show base) (chibi show pretty))
|
||||
|
||||
(test-begin "show")
|
||||
|
||||
|
|
@ -283,4 +284,84 @@
|
|||
(written-simply
|
||||
(let ((ones (list 1))) (set-cdr! ones ones) ones)))))
|
||||
|
||||
;; pretty printing
|
||||
|
||||
(define-syntax test-pretty
|
||||
(syntax-rules ()
|
||||
((test-pretty str)
|
||||
(let ((sexp (read (open-input-string str))))
|
||||
(test str (show #f (pretty sexp)))))))
|
||||
|
||||
(test-pretty "(foo bar)\n")
|
||||
|
||||
(test-pretty
|
||||
"((self . aquanet-paper-1991)
|
||||
(type . paper)
|
||||
(title . \"Aquanet: a hypertext tool to hold your\"))
|
||||
")
|
||||
|
||||
(test-pretty
|
||||
"(abracadabra xylophone
|
||||
bananarama
|
||||
yellowstonepark
|
||||
cryptoanalysis
|
||||
zebramania
|
||||
delightful
|
||||
wubbleflubbery)\n")
|
||||
|
||||
(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 20 21 22 23 24 25
|
||||
26 27 28 29 30 31 32 33 34 35 36 37)\n")
|
||||
|
||||
(test-pretty
|
||||
"(define (fold kons knil ls)
|
||||
(define (loop ls acc)
|
||||
(if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
|
||||
(loop ls knil))\n")
|
||||
|
||||
(test-pretty
|
||||
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")
|
||||
|
||||
(test-pretty
|
||||
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
|
||||
(vector-set! vec i 'supercalifrajalisticexpialidocious))\n")
|
||||
|
||||
(test-pretty
|
||||
"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
|
||||
((= index 5) my-vector)
|
||||
(vector-set! my-vector index index))\n")
|
||||
|
||||
(test-pretty
|
||||
"(define (fold kons knil ls)
|
||||
(let loop ((ls ls) (acc knil))
|
||||
(if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")
|
||||
|
||||
(test-pretty
|
||||
"(define (file->sexp-list pathname)
|
||||
(call-with-input-file pathname
|
||||
(lambda (port)
|
||||
(let loop ((res '()))
|
||||
(let ((line (read port)))
|
||||
(if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")
|
||||
|
||||
(test "(let ((ones '#0=(1 . #0#))) ones)\n"
|
||||
(show #f (pretty (let ((ones (list 1)))
|
||||
(set-cdr! ones ones)
|
||||
`(let ((ones ',ones)) ones)))))
|
||||
|
||||
'(test
|
||||
"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
|
||||
(ones '#0=(1 . #0#)))
|
||||
(append zeros ones))\n"
|
||||
(show #f (pretty
|
||||
(let ((ones (list 1)))
|
||||
(set-cdr! ones ones)
|
||||
`(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
|
||||
(ones ',ones))
|
||||
(append zeros ones))))))
|
||||
|
||||
(test-end)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue