suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

change `pretty-print' to accept a qq-depth argument

Browse Source 
makes it more consistent with `print'
 fixes the htdp/bsl, etc. languages, which install a global print
  handler
 Merge to v5.0
This commit is contained in:
Matthew Flatt 2010-05-27 17:25:20 -06:00
parent fbab6af045
commit c8de3b5d1e
3 changed files with 31 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/htdp/bsl/runtime.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require mzlib/pconvert
scheme/pretty
racket/pretty
lang/private/set-result)
(provide configure)
@ -34,8 +34,10 @@
(lambda (v)
(unless (void? v)
(pretty-print (print-convert v)))))
(global-port-print-handler
(lambda (val port [depth 0])
(let ([val (print-convert val)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print val port depth))))))
(let ([orig (global-port-print-handler)])
(global-port-print-handler
(lambda (val port [depth 0])
(parameterize ([global-port-print-handler orig])
(let ([val (print-convert val)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print val port depth))))))))

28
collects/racket/pretty.rkt
View File

@ -203,10 +203,15 @@
res)))))
(define make-pretty-print
(lambda (display? as-qq?)
(lambda (name display? as-qq?)
(letrec ([pretty-print
(case-lambda
[(obj port)
[(obj port qq-depth)
(unless (output-port? port)
(raise-type-error name "output port" port))
(unless (or (equal? qq-depth 0)
(equal? qq-depth 1))
(raise-type-error name "0 or 1" qq-depth))
(let ([width (pretty-print-columns)]
[size-hook (pretty-print-size-hook)]
[print-hook (pretty-print-print-hook)]
@ -221,17 +226,24 @@
(pretty-print-print-line))
(print-graph) (print-struct) (print-hash-table)
(and (not display?) (print-vector-length)) (print-box)
(and (not display?) as-qq? (print-as-expression))
(and (not display?) as-qq? (print-as-expression)) qq-depth
(pretty-print-depth)
(lambda (o display?)
(size-hook o display? port)))
(void))]
[(obj port) (pretty-print obj port 0)]
[(obj) (pretty-print obj (current-output-port))])])
pretty-print)))
(define pretty-print (make-pretty-print #f #t))
(define pretty-display (make-pretty-print #t #f))
(define pretty-write (make-pretty-print #f #f))
(define pretty-print (make-pretty-print 'pretty-print #f #t))
(define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)])
(case-lambda
[(v) (pp v)]
[(v o) (pp v o)])))
(define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)])
(case-lambda
[(v) (pp v)]
[(v o) (pp v o)])))
(define-struct mark (str def) #:mutable)
(define-struct hide (val))
@ -407,7 +419,7 @@
(define (generic-write obj display? width pport
print-graph? print-struct? print-hash-table? print-vec-length?
print-box? print-as-qq?
print-box? print-as-qq? qq-depth
depth size-hook)
(define pair-open (if (print-pair-curly-braces) "{" "("))
@ -1418,7 +1430,7 @@
;; This is where generic-write's body expressions start
((printing-port-print-line pport) #t 0 width)
(let ([qd (if print-as-qq? 0 #f)])
(let ([qd (if print-as-qq? qq-depth #f)])
(let-values ([(l col p) (port-next-location pport)])
(if (and width (not (eq? width 'infinity)))
(pp* pport obj depth display? qd)

3
collects/scribblings/reference/pretty-print.scrbl
View File

@ -6,7 +6,8 @@
@note-lib[racket/pretty]
@defproc[(pretty-print [v any/c] [port output-port? (current-output-port)])
@defproc[(pretty-print [v any/c] [port output-port? (current-output-port)]
[quote-depth (or/c 0 1) 0])
void?]{
Pretty-prints the value @scheme[v] using the same printed form as the