920 lines
26 KiB
Scheme
920 lines
26 KiB
Scheme
; Originally:
|
|
;"genwrite.scm" generic write used by pp.scm
|
|
;;copyright (c) 1991, marc feeley
|
|
|
|
; Pretty-printer for MzScheme
|
|
; Handles structures, cycles, and graphs
|
|
|
|
; TO INSTALL this pretty-printer into a MzScheme's read-eval-print loop,
|
|
; load this file and evaluate:
|
|
; (current-print pretty-print-handler)
|
|
|
|
;; Matthew's changes:
|
|
;; Modified original for MrEd Spring/95
|
|
;; Added check for cyclic structures 11/9/95
|
|
;; Better (correct) graph printing, support boxes and structures 11/26/95
|
|
;; Support for print depth 2/28/96
|
|
;; functor 4/22/96
|
|
;; unit/s 6/13/96
|
|
;; size- and print-hook 8/22/96
|
|
;; real parameters 9/27/96
|
|
;; print-line parameter 8/18/97
|
|
;; Added pretty-print-style 12/1/01
|
|
|
|
(module pretty mzscheme
|
|
(require)
|
|
|
|
(provide pretty-print
|
|
pretty-display
|
|
pretty-print-columns
|
|
pretty-print-depth
|
|
pretty-print-handler
|
|
pretty-print-size-hook
|
|
pretty-print-print-hook
|
|
pretty-print-pre-print-hook
|
|
pretty-print-post-print-hook
|
|
pretty-print-display-string-handler
|
|
pretty-print-print-line
|
|
pretty-print-show-inexactness
|
|
pretty-print-exact-as-decimal
|
|
pretty-print-.-symbol-without-bars
|
|
|
|
pretty-print-style-table?
|
|
pretty-print-current-style-table
|
|
pretty-print-extend-style-table)
|
|
|
|
(define-struct pretty-print-style-table (hash))
|
|
|
|
(define pretty-print-extend-style-table
|
|
(lambda (table symbols like-symbols)
|
|
(let ([terr (lambda (kind which)
|
|
(raise-type-error
|
|
'pretty-print-extend-style-table
|
|
kind
|
|
which
|
|
table symbols like-symbols))])
|
|
(unless (or (not table) (pretty-print-style-table? table))
|
|
(terr "pretty-print style table or #f" 0))
|
|
(unless (and (list? symbols)
|
|
(andmap symbol? symbols))
|
|
(terr "list of symbols" 1))
|
|
(unless (and (list? like-symbols)
|
|
(andmap symbol? like-symbols))
|
|
(terr "list of symbols" 1))
|
|
(unless (= (length symbols) (length like-symbols))
|
|
(raise-mismatch-error
|
|
'pretty-print-extend-style-table
|
|
(format "length of first list (~a) doesn't match the length of the second list (~a): "
|
|
(length symbols) (length like-symbols))
|
|
like-symbols)))
|
|
(let ([ht (if table (pretty-print-style-table-hash table) (make-hash-table))]
|
|
[new-ht (make-hash-table)])
|
|
(hash-table-for-each
|
|
ht
|
|
(lambda (key val)
|
|
(hash-table-put! new-ht key val)))
|
|
(for-each
|
|
(lambda (symbol like-symbol)
|
|
(let ((s (hash-table-get ht
|
|
like-symbol
|
|
(lambda () #f))))
|
|
(hash-table-put! new-ht symbol (or s like-symbol))))
|
|
symbols like-symbols)
|
|
(make-pretty-print-style-table new-ht))))
|
|
|
|
(define pretty-print-current-style-table
|
|
(make-parameter
|
|
(pretty-print-extend-style-table #f null null)
|
|
(lambda (s)
|
|
(unless (pretty-print-style-table? s)
|
|
(raise-type-error
|
|
'pretty-print-current-style-table
|
|
"pretty-print style table"
|
|
s))
|
|
s)))
|
|
|
|
(define pretty-print-.-symbol-without-bars
|
|
(make-parameter #f (lambda (x) (and x #t))))
|
|
|
|
(define pretty-print-show-inexactness
|
|
(make-parameter #f
|
|
(lambda (x) (and x #t))))
|
|
|
|
(define pretty-print-exact-as-decimal
|
|
(make-parameter #f
|
|
(lambda (x) (and x #t))))
|
|
|
|
(define pretty-print-columns
|
|
(make-parameter 79
|
|
(lambda (x)
|
|
(unless (or (eq? x 'infinity)
|
|
(integer? x))
|
|
(raise-type-error
|
|
'pretty-print-columns
|
|
"integer or 'infinity"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-depth
|
|
(make-parameter #f
|
|
(lambda (x)
|
|
(unless (or (not x) (number? x))
|
|
(raise-type-error
|
|
'pretty-print-depth
|
|
"number or #f"
|
|
x))
|
|
x)))
|
|
|
|
(define can-accept-n?
|
|
(lambda (n x)
|
|
(procedure-arity-includes? x n)))
|
|
|
|
(define pretty-print-size-hook
|
|
(make-parameter (lambda (x display? port) #f)
|
|
(lambda (x)
|
|
(unless (can-accept-n? 3 x)
|
|
(raise-type-error
|
|
'pretty-print-size-hook
|
|
"procedure of 3 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-print-hook
|
|
(make-parameter void
|
|
(lambda (x)
|
|
(unless (can-accept-n? 3 x)
|
|
(raise-type-error
|
|
'pretty-print-print-hook
|
|
"procedure of 3 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-display-string-handler
|
|
(make-parameter (let ([dh (port-display-handler (open-output-string))])
|
|
; dh is primitive port display handler
|
|
dh)
|
|
(lambda (x)
|
|
(unless (can-accept-n? 2 x)
|
|
(raise-type-error
|
|
'pretty-print-display-string-handler
|
|
"procedure of 2 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-print-line
|
|
(make-parameter (lambda (line port offset width)
|
|
(when (and (number? width)
|
|
(not (eq? 0 line)))
|
|
(newline port))
|
|
0)
|
|
(lambda (x)
|
|
(unless (can-accept-n? 4 x)
|
|
(raise-type-error
|
|
'pretty-print-print-line
|
|
"procedure of 4 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-pre-print-hook
|
|
(make-parameter void
|
|
(lambda (x)
|
|
(unless (can-accept-n? 2 x)
|
|
(raise-type-error
|
|
'pretty-print-pre-print-hook
|
|
"procedure of 2 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define pretty-print-post-print-hook
|
|
(make-parameter void
|
|
(lambda (x)
|
|
(unless (can-accept-n? 2 x)
|
|
(raise-type-error
|
|
'pretty-print-post-print-hook
|
|
"procedure of 2 arguments"
|
|
x))
|
|
x)))
|
|
|
|
(define make-pretty-print
|
|
(lambda (display?)
|
|
(letrec ([pretty-print
|
|
(case-lambda
|
|
[(obj port)
|
|
(let ([width (pretty-print-columns)]
|
|
[size-hook (pretty-print-size-hook)]
|
|
[print-hook (pretty-print-print-hook)]
|
|
[pre-hook (pretty-print-pre-print-hook)]
|
|
[post-hook (pretty-print-post-print-hook)])
|
|
(generic-write obj display?
|
|
width
|
|
(let ([display (pretty-print-display-string-handler)])
|
|
(lambda (s)
|
|
(display s port)
|
|
#t))
|
|
(lambda (s l)
|
|
(print-hook s display? port)
|
|
#t)
|
|
(print-graph) (print-struct) (print-hash-table)
|
|
(and (not display?) (print-vector-length))
|
|
(pretty-print-depth)
|
|
(lambda (o display?)
|
|
(size-hook o display? port))
|
|
(let ([print-line (pretty-print-print-line)])
|
|
(lambda (line offset)
|
|
(print-line line port offset width)))
|
|
(lambda (obj)
|
|
(pre-hook obj port))
|
|
(lambda (obj)
|
|
(post-hook obj port)))
|
|
(void))]
|
|
[(obj) (pretty-print obj (current-output-port))])])
|
|
pretty-print)))
|
|
|
|
(define pretty-print (make-pretty-print #f))
|
|
(define pretty-display (make-pretty-print #t))
|
|
|
|
(define-struct mark (str def))
|
|
|
|
(define pre-sym (gensym 'pre))
|
|
(define post-sym (gensym 'post))
|
|
|
|
(define (generic-write obj display? width output output-hooked
|
|
print-graph? print-struct? print-hash-table? print-vec-length?
|
|
depth size-hook print-line
|
|
pre-print post-print)
|
|
|
|
(define line-number 0)
|
|
|
|
(define table (make-hash-table)) ; Hash table for looking for loops
|
|
|
|
(define show-inexactness? (pretty-print-show-inexactness))
|
|
(define exact-as-decimal? (pretty-print-exact-as-decimal))
|
|
|
|
(define vector->repeatless-list
|
|
(if print-vec-length?
|
|
(lambda (v)
|
|
(let ([len (vector-length v)])
|
|
(if (zero? len)
|
|
null
|
|
(let ([last (vector-ref v (sub1 len))])
|
|
(let loop ([i (- len 2)])
|
|
(if (i . < . 0)
|
|
(list last)
|
|
(let ([e (vector-ref v i)])
|
|
(if (eq? e last)
|
|
(loop (sub1 i))
|
|
(let loop ([i (sub1 i)][r (list e last)])
|
|
(if (i . < . 0)
|
|
r
|
|
(loop (sub1 i) (cons (vector-ref v i) r))))))))))))
|
|
vector->list))
|
|
|
|
(define found-cycle
|
|
(or print-graph?
|
|
(let loop ([obj obj])
|
|
(and (or (vector? obj)
|
|
(pair? obj)
|
|
(box? obj)
|
|
(and (struct? obj) print-struct?)
|
|
(and (hash-table? obj) print-hash-table?))
|
|
(or (hash-table-get table obj (lambda () #f))
|
|
(begin
|
|
(hash-table-put! table obj #t)
|
|
(let ([cycle
|
|
(cond
|
|
[(vector? obj)
|
|
(let ([len (vector-length obj)])
|
|
(let loop ([i 0])
|
|
(if (= i len)
|
|
#f
|
|
(or (vector-ref obj i)
|
|
(loop (add1 i))))))]
|
|
[(pair? obj)
|
|
(or (loop (car obj))
|
|
(loop (cdr obj)))]
|
|
[(box? obj) (loop (unbox obj))]
|
|
[(struct? obj)
|
|
(ormap loop
|
|
(vector->list (struct->vector obj)))]
|
|
[(hash-table? obj)
|
|
(let/ec esc
|
|
(hash-table-for-each
|
|
obj
|
|
(lambda (v k)
|
|
(when (or (loop v)
|
|
(loop k))
|
|
(esc #t))))
|
|
#f)])])
|
|
(hash-table-remove! table obj)
|
|
cycle)))))))
|
|
|
|
(define :::dummy:::
|
|
(if found-cycle
|
|
(let loop ([obj obj])
|
|
(if (or (vector? obj)
|
|
(pair? obj)
|
|
(box? obj)
|
|
(and (struct? obj) print-struct?)
|
|
(and (hash-table? obj) print-hash-table?))
|
|
; A little confusing: use #t for not-found
|
|
(let ([p (hash-table-get table obj (lambda () #t))])
|
|
(when (not (mark? p))
|
|
(if p
|
|
(begin
|
|
(hash-table-put! table obj #f)
|
|
(cond
|
|
[(vector? obj)
|
|
(let ([len (vector-length obj)])
|
|
(let vloop ([i 0])
|
|
(unless (= i len)
|
|
(loop (vector-ref obj i))
|
|
(vloop (add1 i)))))]
|
|
[(pair? obj)
|
|
(loop (car obj))
|
|
(loop (cdr obj))]
|
|
[(box? obj) (loop (unbox obj))]
|
|
[(struct? obj)
|
|
(for-each loop
|
|
(vector->list (struct->vector obj)))]
|
|
[(hash-table? obj)
|
|
(hash-table-for-each
|
|
obj
|
|
(lambda (k v)
|
|
(loop k)
|
|
(loop v)))]))
|
|
(begin
|
|
(hash-table-put! table obj
|
|
(make-mark #f (box #f)))))))))))
|
|
|
|
(define cycle-counter 0)
|
|
|
|
(define found (if found-cycle
|
|
table
|
|
#f))
|
|
|
|
(define dsub1 (lambda (d)
|
|
(if d
|
|
(sub1 d)
|
|
#f)))
|
|
|
|
(print-line
|
|
#f
|
|
(let generic-write ([obj obj] [display? display?]
|
|
[width width]
|
|
[output output] [output-hooked output-hooked]
|
|
[depth depth] [def-box (box #t)]
|
|
[startpos (print-line 0 0)]
|
|
[pre-print pre-print] [post-print post-print])
|
|
|
|
(define (read-macro? l)
|
|
(define (length1? l) (and (pair? l) (null? (cdr l))))
|
|
(let ((head (car l)) (tail (cdr l)))
|
|
(case head
|
|
((quote quasiquote unquote unquote-splicing syntax)
|
|
(length1? tail))
|
|
(else #f))))
|
|
|
|
(define (read-macro-body l)
|
|
(cadr l))
|
|
|
|
(define (read-macro-prefix l)
|
|
(let ((head (car l)))
|
|
(case head
|
|
((quote) "'")
|
|
((quasiquote) "`")
|
|
((unquote) ",")
|
|
((unquote-splicing) ",@")
|
|
((syntax) "#'"))))
|
|
|
|
(define (out str col)
|
|
(and col (output str) (+ col (string-length str))))
|
|
|
|
(define expr-found
|
|
(lambda (ref col)
|
|
(let ([n cycle-counter])
|
|
(set! cycle-counter (add1 cycle-counter))
|
|
(set-mark-str! ref
|
|
(string-append "#"
|
|
(number->string n)
|
|
"#"))
|
|
(set-mark-def! ref def-box)
|
|
(out (string-append "#"
|
|
(number->string n)
|
|
"=")
|
|
col))))
|
|
|
|
(define check-expr-found
|
|
(lambda (obj check? col c-k d-k n-k)
|
|
(let ([ref (and check?
|
|
found
|
|
(hash-table-get found obj (lambda () #f)))])
|
|
(if (and ref (unbox (mark-def ref)))
|
|
(if c-k
|
|
(c-k (mark-str ref) col)
|
|
(out (mark-str ref) col))
|
|
(if (and ref d-k)
|
|
(d-k col)
|
|
(let ([col (if ref
|
|
(expr-found ref col)
|
|
col)])
|
|
(n-k col)))))))
|
|
|
|
(define (wr obj col depth)
|
|
|
|
(define (wr-expr expr col depth)
|
|
(if (read-macro? expr)
|
|
(wr (read-macro-body expr) (out (read-macro-prefix expr) col) depth)
|
|
(wr-lst expr col #t depth)))
|
|
|
|
(define (wr-lst l col check? depth)
|
|
(if (pair? l)
|
|
(check-expr-found
|
|
l check? col
|
|
#f #f
|
|
(lambda (col)
|
|
(if (and depth (zero? depth))
|
|
(out "(...)" col)
|
|
(let loop ((l (cdr l)) (col (wr (car l) (out "(" col) (dsub1 depth))))
|
|
(check-expr-found
|
|
l (and check? (pair? l)) col
|
|
(lambda (s col) (out ")" (out s (out " . " col))))
|
|
(lambda (col)
|
|
(out ")" (wr-lst l (out " . " col) check? (dsub1 depth))))
|
|
(lambda (col)
|
|
(and col
|
|
(cond
|
|
((pair? l)
|
|
(if (and (eq? (car l) 'unquote)
|
|
(pair? (cdr l))
|
|
(null? (cddr l)))
|
|
(out ")" (wr (cadr l) (out " . ," col) (dsub1 depth)))
|
|
(loop (cdr l) (wr (car l) (out " " col) (dsub1 depth)))))
|
|
((null? l) (out ")" col))
|
|
(else
|
|
(out ")" (wr l (out " . " col) (dsub1 depth))))))))))))
|
|
(out "()" col)))
|
|
|
|
(pre-print obj)
|
|
(begin0
|
|
(if (and depth (negative? depth))
|
|
(out "..." col)
|
|
|
|
(cond ((size-hook obj display?)
|
|
=> (lambda (len)
|
|
(and col
|
|
(output-hooked obj len)
|
|
(+ len col))))
|
|
|
|
((pair? obj) (wr-expr obj col depth))
|
|
((null? obj) (wr-lst obj col #f depth))
|
|
((vector? obj) (check-expr-found
|
|
obj #t col
|
|
#f #f
|
|
(lambda (col)
|
|
(wr-lst (vector->repeatless-list obj)
|
|
(let ([col (out "#" col)])
|
|
(if print-vec-length?
|
|
(out (number->string (vector-length obj)) col)
|
|
col))
|
|
#f depth))))
|
|
((box? obj) (check-expr-found
|
|
obj #t col
|
|
#f #f
|
|
(lambda (col)
|
|
(wr (unbox obj) (out "#&" col)
|
|
(dsub1 depth)))))
|
|
((struct? obj) (if (and print-struct?
|
|
(not (and depth
|
|
(zero? depth))))
|
|
(check-expr-found
|
|
obj #t col
|
|
#f #f
|
|
(lambda (col)
|
|
(wr-lst (vector->list
|
|
(struct->vector obj))
|
|
(out "#" col) #f
|
|
depth)))
|
|
(out
|
|
(let ([p (open-output-string)]
|
|
[p-s (print-struct)])
|
|
(when p-s
|
|
(print-struct #f))
|
|
((if display? display write) obj p)
|
|
(when p-s
|
|
(print-struct p-s))
|
|
(get-output-string p))
|
|
col)))
|
|
((hash-table? obj) (if (and print-hash-table?
|
|
(not (and depth
|
|
(zero? depth))))
|
|
(check-expr-found
|
|
obj #t col
|
|
#f #f
|
|
(lambda (col)
|
|
(wr-lst (hash-table-map obj cons)
|
|
(out "#hash" col) #f
|
|
depth)))
|
|
(out
|
|
(let ([p (open-output-string)]
|
|
[p-s (print-hash-table)])
|
|
(when p-s
|
|
(print-hash-table #f))
|
|
((if display? display write) obj p)
|
|
(when p-s
|
|
(print-hash-table p-s))
|
|
(get-output-string p))
|
|
col)))
|
|
|
|
((boolean? obj) (out (if obj "#t" "#f") col))
|
|
((number? obj)
|
|
(when (and show-inexactness?
|
|
(inexact? obj))
|
|
(out "#i" col))
|
|
(out ((if exact-as-decimal?
|
|
number->decimal-string
|
|
number->string)
|
|
obj) col))
|
|
((string? obj) (if display?
|
|
(out obj col)
|
|
(let ([p (open-output-string)])
|
|
(write obj p)
|
|
(let ([s (get-output-string p)])
|
|
(out s col)))))
|
|
((char? obj) (if display?
|
|
(out (make-string 1 obj) col)
|
|
(out
|
|
;; Must go through string to determe "printable" chars in any case:
|
|
(let ([p (open-output-string)])
|
|
(write obj p)
|
|
(get-output-string p))
|
|
col)))
|
|
|
|
((and display? (path? obj)) (out (path->string obj) col))
|
|
|
|
;; Let symbol get printed by default case to get proper quoting
|
|
;; ((symbol? obj) (out (symbol->string obj) col))
|
|
|
|
[(and (pretty-print-.-symbol-without-bars)
|
|
(eq? obj '|.|))
|
|
(out "." col)]
|
|
|
|
(else (out (let ([p (open-output-string)])
|
|
((if display? display write) obj p)
|
|
(get-output-string p))
|
|
col))))
|
|
(post-print obj)))
|
|
|
|
(define (pp obj col depth)
|
|
|
|
(define (spaces n col)
|
|
(if (> n 0)
|
|
(if (> n 7)
|
|
(spaces (- n 8) (out " " col))
|
|
(out (substring " " 0 n) col))
|
|
col))
|
|
|
|
(define (indent to col)
|
|
(and col
|
|
(if (< to col)
|
|
(and col
|
|
(begin
|
|
(set! line-number (add1 line-number))
|
|
(let ([col (print-line line-number col)])
|
|
(spaces (- to col) col))))
|
|
(spaces (- to col) col))))
|
|
|
|
(define (pr obj col extra pp-pair depth)
|
|
; may have to split on multiple lines
|
|
(let* ([can-multi (or (pair? obj) (vector? obj)
|
|
(box? obj)
|
|
(and (struct? obj) print-struct?)
|
|
(and (hash-table? obj) print-hash-table?))]
|
|
[ref (if can-multi
|
|
(and found (hash-table-get found obj (lambda () #f)))
|
|
#f)])
|
|
(if (and can-multi
|
|
(or (not ref) (not (unbox (mark-def ref)))))
|
|
(let* ((result '())
|
|
(result-tail #f)
|
|
(new-def-box (box #t))
|
|
(left (+ (- (- width col) extra) 1))
|
|
(snoc (lambda (s len)
|
|
(let ([v (cons s null)])
|
|
(if result-tail
|
|
(set-cdr! result-tail v)
|
|
(set! result v))
|
|
(set! result-tail v))
|
|
(set! left (- left len))
|
|
(> left 0))))
|
|
(generic-write obj display? #f
|
|
(lambda (s)
|
|
(snoc s (string-length s)))
|
|
(lambda (s l)
|
|
(snoc (cons s l) l))
|
|
depth
|
|
new-def-box
|
|
0
|
|
(lambda (obj)
|
|
(snoc (cons pre-sym obj) 0))
|
|
(lambda (obj)
|
|
(snoc (cons post-sym obj) 0)))
|
|
(if (> left 0) ; all can be printed on one line
|
|
(let loop ([result result][col col])
|
|
(if (null? result)
|
|
col
|
|
(loop (cdr result)
|
|
(+ (let ([v (car result)])
|
|
(if (pair? v)
|
|
(cond
|
|
[(eq? (car v) pre-sym)
|
|
(pre-print (cdr v))
|
|
col]
|
|
[(eq? (car v) post-sym)
|
|
(post-print (cdr v))
|
|
col]
|
|
[else
|
|
(output-hooked (car v) (cdr v))
|
|
(+ col (cdr v))])
|
|
(out (car result) col)))))))
|
|
(begin
|
|
(set-box! new-def-box #f)
|
|
(let ([col
|
|
(if ref
|
|
(expr-found ref col)
|
|
col)])
|
|
(pre-print obj)
|
|
(begin0
|
|
(cond
|
|
[(pair? obj) (pp-pair obj col extra depth)]
|
|
[(vector? obj)
|
|
(pp-list (vector->repeatless-list obj)
|
|
(let ([col (out "#" col)])
|
|
(if print-vec-length?
|
|
(out (number->string (vector-length obj)) col)
|
|
col))
|
|
extra pp-expr #f depth)]
|
|
[(struct? obj)
|
|
(pp-list (vector->list (struct->vector obj))
|
|
(out "#" col) extra pp-expr #f depth)]
|
|
[(hash-table? obj)
|
|
(pp-list (hash-table-map obj cons)
|
|
(out "#hash" col) extra pp-expr #f depth)]
|
|
[(box? obj)
|
|
(pr (unbox obj) (out "#&" col) extra pp-pair depth)])
|
|
(post-print obj))))))
|
|
(wr obj col depth))))
|
|
|
|
(define (pp-expr expr col extra depth)
|
|
(if (read-macro? expr)
|
|
(pr (read-macro-body expr)
|
|
(out (read-macro-prefix expr) col)
|
|
extra
|
|
pp-expr
|
|
depth)
|
|
(let ((head (car expr)))
|
|
(if (and (symbol? head)
|
|
(not (size-hook head display?)))
|
|
(let ((proc (style head)))
|
|
(if proc
|
|
(proc expr col extra depth)
|
|
(if (> (string-length (symbol->string head))
|
|
max-call-head-width)
|
|
(pp-general expr col extra #f #f #f pp-expr depth)
|
|
(pp-list expr col extra pp-expr #t depth))))
|
|
(pp-list expr col extra pp-expr #t depth)))))
|
|
|
|
; (head item1
|
|
; item2
|
|
; item3)
|
|
(define (pp-call expr col extra pp-item depth)
|
|
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth))))
|
|
(and col
|
|
(pp-down (cdr expr) col* (+ col* 1) extra pp-item #t #t depth))))
|
|
|
|
; (head item1 item2
|
|
; item3
|
|
; item4)
|
|
(define (pp-two-up expr col extra pp-item depth)
|
|
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth)))
|
|
(col*2 (wr (cadr expr) (out " " col) (dsub1 depth))))
|
|
(and col
|
|
(pp-down (cddr expr) (+ col 1) (+ col 2) extra pp-item #t #t depth))))
|
|
|
|
; (head item1
|
|
; item2
|
|
; item3)
|
|
(define (pp-one-up expr col extra pp-item depth)
|
|
(let ((col* (wr (car expr) (out "(" col) (dsub1 depth))))
|
|
(and col
|
|
(pp-down (cdr expr) (+ col 1) (+ col 2) extra pp-item #t #t depth))))
|
|
|
|
; (item1
|
|
; item2
|
|
; item3)
|
|
(define (pp-list l col extra pp-item check? depth)
|
|
(let ((col (out "(" col)))
|
|
(pp-down l col col extra pp-item #f check? depth)))
|
|
|
|
(define (pp-down l col1 col2 extra pp-item check-first? check-rest? depth)
|
|
(let loop ((l l) (col col1) (check? check-first?))
|
|
(and col
|
|
(check-expr-found
|
|
l (and check? (pair? l)) col
|
|
(lambda (s col)
|
|
(out ")" (out s (indent col2 (out "." (indent col2 col))))))
|
|
(lambda (col)
|
|
(out ")" (pr l (indent col2 (out "." (indent col2 col)))
|
|
extra pp-item depth)))
|
|
(lambda (col)
|
|
(cond ((pair? l)
|
|
(let ((rest (cdr l)))
|
|
(let ((extra (if (null? rest) (+ extra 1) 0)))
|
|
(loop rest
|
|
(pr (car l) (indent col2 col)
|
|
extra pp-item
|
|
(dsub1 depth))
|
|
check-rest?))))
|
|
((null? l)
|
|
(out ")" col))
|
|
(else
|
|
(out ")"
|
|
(pr l
|
|
(indent col2 (out "." (indent col2 col)))
|
|
(+ extra 1)
|
|
pp-item
|
|
(dsub1 depth))))))))))
|
|
|
|
(define (pp-general expr col extra named? pp-1 pp-2 pp-3 depth)
|
|
|
|
(define (tail1 rest col1 col2 col3)
|
|
(if (and pp-1 (pair? rest))
|
|
(let* ((val1 (car rest))
|
|
(rest (cdr rest))
|
|
(extra (if (null? rest) (+ extra 1) 0)))
|
|
(tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1 depth) col3))
|
|
(tail2 rest col1 col2 col3)))
|
|
|
|
(define (tail2 rest col1 col2 col3)
|
|
(if (and pp-2 (pair? rest))
|
|
(let* ((val1 (car rest))
|
|
(rest (cdr rest))
|
|
(extra (if (null? rest) (+ extra 1) 0)))
|
|
(tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2 depth)))
|
|
(tail3 rest col1 col2)))
|
|
|
|
(define (tail3 rest col1 col2)
|
|
(pp-down rest col2 col1 extra pp-3 #f #t depth))
|
|
|
|
(let* ((head (car expr))
|
|
(rest (cdr expr))
|
|
(col* (wr head (out "(" col) (dsub1 depth))))
|
|
(if (and named? (pair? rest))
|
|
(let* ((name (car rest))
|
|
(rest (cdr rest))
|
|
(col** (wr name (out " " col*) (dsub1 depth))))
|
|
(tail1 rest (+ col indent-general) col** (+ col** 1)))
|
|
(tail1 rest (+ col indent-general) col* (+ col* 1)))))
|
|
|
|
(define (pp-expr-list l col extra depth)
|
|
(pp-list l col extra pp-expr #t depth))
|
|
|
|
(define (pp-lambda expr col extra depth)
|
|
(pp-general expr col extra #f pp-expr-list #f pp-expr depth))
|
|
|
|
(define (pp-if expr col extra depth)
|
|
(pp-general expr col extra #f pp-expr #f pp-expr depth))
|
|
|
|
(define (pp-cond expr col extra depth)
|
|
(pp-list expr col extra pp-expr-list #t depth))
|
|
|
|
(define (pp-class expr col extra depth)
|
|
(pp-two-up expr col extra pp-expr-list depth))
|
|
|
|
(define (pp-make-object expr col extra depth)
|
|
(pp-one-up expr col extra pp-expr-list depth))
|
|
|
|
(define (pp-case expr col extra depth)
|
|
(pp-general expr col extra #f pp-expr #f pp-expr-list depth))
|
|
|
|
(define (pp-and expr col extra depth)
|
|
(pp-call expr col extra pp-expr depth))
|
|
|
|
(define (pp-let expr col extra depth)
|
|
(let* ((rest (cdr expr))
|
|
(named? (and (pair? rest) (symbol? (car rest)))))
|
|
(pp-general expr col extra named? pp-expr-list #f pp-expr depth)))
|
|
|
|
(define (pp-begin expr col extra depth)
|
|
(pp-general expr col extra #f #f #f pp-expr depth))
|
|
|
|
(define (pp-do expr col extra depth)
|
|
(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr depth))
|
|
|
|
; define formatting style (change these to suit your style)
|
|
|
|
(define indent-general 2)
|
|
|
|
(define max-call-head-width 5)
|
|
|
|
(define (style head)
|
|
(case (or (hash-table-get (pretty-print-style-table-hash
|
|
(pretty-print-current-style-table))
|
|
head
|
|
(lambda () #f))
|
|
head)
|
|
((lambda define define-macro define-syntax
|
|
syntax-rules
|
|
shared
|
|
unless when)
|
|
pp-lambda)
|
|
((if set! set!-values)
|
|
pp-if)
|
|
((cond case-lambda)
|
|
pp-cond)
|
|
((case)
|
|
pp-case)
|
|
((and or import export
|
|
require require-for-syntax require-for-template
|
|
provide link
|
|
public private override rename inherit field init)
|
|
pp-and)
|
|
((let letrec let*
|
|
let-values letrec-values let*-values
|
|
let-syntax letrec-syntax
|
|
let-syntaxes letrec-syntaxes)
|
|
pp-let)
|
|
((begin begin0)
|
|
pp-begin)
|
|
((do letrec-syntaxes+values)
|
|
pp-do)
|
|
|
|
((send class syntax-case instantiate module)
|
|
pp-class)
|
|
((make-object)
|
|
pp-make-object)
|
|
|
|
(else #f)))
|
|
|
|
(pr obj col 0 pp-expr depth))
|
|
|
|
(if (and width (not (eq? width 'infinity)))
|
|
(pp obj startpos depth)
|
|
(wr obj startpos depth)))))
|
|
|
|
(define pretty-print-handler
|
|
(lambda (v)
|
|
(unless (void? v)
|
|
(pretty-print v))))
|
|
|
|
(define (number->decimal-string x)
|
|
(cond
|
|
[(or (inexact? x)
|
|
(integer? x))
|
|
(number->string x)]
|
|
[(not (real? x))
|
|
(let ([r (real-part x)]
|
|
[i (imag-part x)])
|
|
(format "~a~a~ai"
|
|
(number->decimal-string r)
|
|
(if (negative? i)
|
|
""
|
|
"+")
|
|
(number->decimal-string i)))]
|
|
[else
|
|
(let ([n (numerator x)]
|
|
[d (denominator x)])
|
|
;; Count powers of 2 in denomintor
|
|
(let loop ([v d][2-power 0])
|
|
(if (and (positive? v)
|
|
(even? v))
|
|
(loop (arithmetic-shift v -1) (add1 2-power))
|
|
;; Count powers of 5 in denominator
|
|
(let loop ([v v][5-power 0])
|
|
(if (zero? (remainder v 5))
|
|
(loop (quotient v 5) (add1 5-power))
|
|
;; No more 2s or 5s. Anything left?
|
|
(if (= v 1)
|
|
;; Denominator = (* (expt 2 2-power) (expt 5 5-power)).
|
|
;; Print number as decimal.
|
|
(let* ([10-power (max 2-power 5-power)]
|
|
[scale (* (expt 2 (- 10-power 2-power))
|
|
(expt 5 (- 10-power 5-power)))]
|
|
[s (number->string (* (abs n) scale))]
|
|
[orig-len (string-length s)]
|
|
[len (max (add1 10-power) orig-len)]
|
|
[padded-s (if (< orig-len len)
|
|
(string-append
|
|
(make-string (- len orig-len) #\0)
|
|
s)
|
|
s)])
|
|
(format "~a~a.~a"
|
|
(if (negative? n) "-" "")
|
|
(substring padded-s 0 (- len 10-power))
|
|
(substring padded-s (- len 10-power) len)))
|
|
;; d has factor(s) other than 2 and 5.
|
|
;; Print as a fraction.
|
|
(number->string x)))))))]))
|
|
|
|
)
|
|
|