fix pretty-print problems, especially related to the custom-write property
This commit is contained in:
Matthew Flatt
parent
2faca724e3
commit
4299b12d5b
|
|
@ -251,57 +251,59 @@
|
|||
(define (make-tentative-output-port pport width esc)
|
||||
(let* ([content null]
|
||||
[special-ok? (port-writes-special? pport)]
|
||||
;; The null device counts for us:
|
||||
[/dev/null (let-values ([(line col pos) (port-next-location pport)])
|
||||
(relocate-output-port
|
||||
(let ([p (open-output-nowhere special-ok?)])
|
||||
(port-count-lines! p)
|
||||
p)
|
||||
(or line 1) (or col 0) (or pos 1)))]
|
||||
[check-esc (lambda ()
|
||||
(let-values ([(l c p) (port-next-location /dev/null)])
|
||||
(when (c . > . width)
|
||||
(esc))))]
|
||||
[p (make-output-port
|
||||
'tentative
|
||||
always-evt
|
||||
(lambda (s start end block? break?)
|
||||
(write-bytes s /dev/null start end)
|
||||
(check-esc)
|
||||
(set! content (cons (subbytes s start end) content))
|
||||
(- end start))
|
||||
void
|
||||
(and special-ok?
|
||||
(lambda (special block break?)
|
||||
(write-special special /dev/null)
|
||||
(check-esc)
|
||||
(set! content (cons (cons 'special special) content))
|
||||
#t))
|
||||
#f #f
|
||||
(lambda ()
|
||||
(port-next-location /dev/null)))]
|
||||
[first-line? #t])
|
||||
;; The null device counts for us:
|
||||
[/dev/null
|
||||
(let-values ([(line col pos) (port-next-location pport)])
|
||||
(relocate-output-port
|
||||
(let ([p (open-output-nowhere special-ok?)])
|
||||
(port-count-lines! p)
|
||||
p)
|
||||
(or line 1) (or col 0) (or pos 1)))]
|
||||
[first-line? #t]
|
||||
[check-esc (lambda ()
|
||||
(let-values ([(l c p) (port-next-location /dev/null)])
|
||||
(when (or (c . > . width)
|
||||
(not first-line?))
|
||||
(esc))))]
|
||||
[p (make-output-port
|
||||
'tentative
|
||||
always-evt
|
||||
(lambda (s start end block? break?)
|
||||
(write-bytes s /dev/null start end)
|
||||
(check-esc)
|
||||
(set! content (cons (subbytes s start end) content))
|
||||
(- end start))
|
||||
void
|
||||
(and special-ok?
|
||||
(lambda (special block break?)
|
||||
(write-special special /dev/null)
|
||||
(check-esc)
|
||||
(set! content (cons (cons 'special special) content))
|
||||
#t))
|
||||
#f #f
|
||||
(lambda ()
|
||||
(port-next-location /dev/null)))])
|
||||
(port-count-lines! /dev/null)
|
||||
(port-count-lines! p)
|
||||
(register-printing-port p
|
||||
(make-print-port-info
|
||||
(lambda () (reverse content))
|
||||
(box #t)
|
||||
(lambda (v)
|
||||
(set! content (cons (cons 'pre v) content)))
|
||||
(lambda (v)
|
||||
(set! content (cons (cons 'post v) content)))
|
||||
(lambda (v len display?)
|
||||
(display (make-string len #\.) /dev/null)
|
||||
(set! content (cons (list* 'hooked v len display?)
|
||||
content)))
|
||||
(lambda (use-line? offset width)
|
||||
(when (and (number? width)
|
||||
(not first-line?))
|
||||
(newline p))
|
||||
(set! first-line? #f)
|
||||
0)
|
||||
esc))
|
||||
(make-print-port-info
|
||||
(lambda () (reverse content))
|
||||
(box #t)
|
||||
(lambda (v)
|
||||
(set! content (cons (cons 'pre v) content)))
|
||||
(lambda (v)
|
||||
(set! content (cons (cons 'post v) content)))
|
||||
(lambda (v len display?)
|
||||
(display (make-string len #\.) /dev/null)
|
||||
(set! content (cons (list* 'hooked v len display?)
|
||||
content)))
|
||||
(lambda (use-line? offset width)
|
||||
(when (and (number? width)
|
||||
(not first-line?))
|
||||
(newline p))
|
||||
(set! first-line? #f)
|
||||
0)
|
||||
esc))
|
||||
p))
|
||||
|
||||
(define (make-tentative-pretty-print-output-port pport width esc)
|
||||
|
|
@ -670,12 +672,12 @@
|
|||
(let ([p (relocate-output-port pport l c p)])
|
||||
(port-count-lines! p)
|
||||
(let ([writer (lambda (v port)
|
||||
(recur port v (dsub1 depth) #f qd))]
|
||||
(recur port v (dsub1 depth) #f #f))]
|
||||
[displayer (lambda (v port)
|
||||
(recur port v (dsub1 depth) #t qd))]
|
||||
(recur port v (dsub1 depth) #t #f))]
|
||||
[printer (case-lambda
|
||||
[(v port) (recur port v (dsub1 depth) #t qd)]
|
||||
[(v port qd) (recur port v (dsub1 depth) #t qd)])])
|
||||
[(v port) (recur port v (dsub1 depth) #f qd)]
|
||||
[(v port qd) (recur port v (dsub1 depth) #f qd)])])
|
||||
(port-write-handler p writer)
|
||||
(port-display-handler p displayer)
|
||||
(port-print-handler p printer))
|
||||
|
|
|
|||
|
|
@ -354,7 +354,8 @@ port. The @scheme[width] argument should be a target column width,
|
|||
usually obtained from @scheme[pretty-print-columns], possibly
|
||||
decremented to leave room for a terminator. The
|
||||
@scheme[overflow-thunk] procedure is called if more than
|
||||
@scheme[width] items are printed to the port; it can escape from the
|
||||
@scheme[width] items are printed to the port or if a newline is
|
||||
printed to the port via @racket[pretty-print-newline]; it can escape from the
|
||||
recursive print through a continuation as a short cut, but
|
||||
@scheme[overflow-thunk] can also return, in which case it is called
|
||||
every time afterward that additional output is written to the port.
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
|
||||
(Section 'pretty)
|
||||
|
||||
(require mzlib/pretty)
|
||||
(require racket/pretty)
|
||||
|
||||
(print-as-expression #f)
|
||||
|
||||
|
|
@ -327,4 +327,92 @@
|
|||
|
||||
(print-as-expression #t)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Test custom-write hooks through a re-implementation
|
||||
;; of the transparent-struct printer:
|
||||
|
||||
(define (print-constructed port mode name . fields)
|
||||
(define (print-sub val port)
|
||||
(cond
|
||||
[(integer? mode) (print val port mode)]
|
||||
[mode (write val port)]
|
||||
[else (display val port)]))
|
||||
(display "(" port)
|
||||
(let-values ([(l c p) (port-next-location port)])
|
||||
(write name port)
|
||||
(if (not (pretty-printing))
|
||||
;; Not pretty-printing --- simple
|
||||
(for ([val (in-list fields)])
|
||||
(display " " port)
|
||||
(print-sub val port))
|
||||
;; Pretty-printing. First try simple:
|
||||
(unless ((let/ec esc
|
||||
(letrec ([sub-port (make-tentative-pretty-print-output-port
|
||||
port
|
||||
(pretty-print-columns)
|
||||
(lambda ()
|
||||
(esc (lambda ()
|
||||
(tentative-pretty-print-port-cancel sub-port)
|
||||
#f))))])
|
||||
(for ([val (in-list fields)])
|
||||
(display " " sub-port)
|
||||
(print-sub val sub-port))
|
||||
(lambda ()
|
||||
(tentative-pretty-print-port-transfer sub-port port)
|
||||
#t))))
|
||||
;; Simple attempt overflowed the line, so print with newlines.
|
||||
(for ([val (in-list fields)])
|
||||
(pretty-print-newline port (pretty-print-columns))
|
||||
(let-values ([(l2 c2 p2) (port-next-location port)])
|
||||
(display (make-string (max 0 (- c c2)) #\space) port))
|
||||
(print-sub val port)))))
|
||||
(display ")" port))
|
||||
|
||||
(let ()
|
||||
(struct duo (a b)
|
||||
#:property prop:custom-print-quotable 'never
|
||||
#:property prop:custom-write (lambda (v port mode)
|
||||
(print-constructed port
|
||||
mode
|
||||
'DUO
|
||||
(duo-a v)
|
||||
(duo-b v))))
|
||||
(let ([try-print
|
||||
(lambda (print v cols expect)
|
||||
(let ([s (open-output-string)])
|
||||
(parameterize ([pretty-print-columns cols])
|
||||
(print v s))
|
||||
(test expect get-output-string s)))])
|
||||
|
||||
(try-print pretty-print 'a 40 "'a\n")
|
||||
(try-print pretty-print "a" 40 "\"a\"\n")
|
||||
|
||||
(try-print pretty-print (duo 1 2) 40 "(DUO 1 2)\n")
|
||||
(try-print pretty-write (duo 1 2) 40 "(DUO 1 2)\n")
|
||||
(try-print pretty-display (duo 1 2) 40 "(DUO 1 2)\n")
|
||||
|
||||
(try-print print (duo "a" 'b) 40 "(DUO \"a\" 'b)")
|
||||
(try-print pretty-print (duo "a" 'b) 40 "(DUO \"a\" 'b)\n")
|
||||
(try-print write (duo "a" 'b) 40 "(DUO \"a\" b)")
|
||||
(try-print pretty-write (duo "a" 'b) 40 "(DUO \"a\" b)\n")
|
||||
(try-print display (duo "a" 'b) 40 "(DUO a b)")
|
||||
(try-print pretty-display (duo "a" 'b) 40 "(DUO a b)\n")
|
||||
|
||||
(try-print pretty-print (duo "abcdefghijklmno" 'b) 20 "(DUO\n \"abcdefghijklmno\"\n 'b)\n")
|
||||
(try-print pretty-write (duo "abcdefghijklmno" 'b) 20 "(DUO\n \"abcdefghijklmno\"\n b)\n")
|
||||
(try-print pretty-display (duo "abcdefghijklmno" 'b) 20 "(DUO\n abcdefghijklmno\n b)\n")
|
||||
|
||||
(try-print pretty-print (list (duo "abcdefghijklmno" 'b)) 20 "(list\n (DUO\n \"abcdefghijklmno\"\n 'b))\n")
|
||||
(try-print pretty-write (list (duo "abcdefghijklmno" 'b)) 20 "((DUO\n \"abcdefghijklmno\"\n b))\n")
|
||||
(try-print pretty-display (list (duo "abcdefghijklmno" 'b)) 20 "((DUO\n abcdefghijklmno\n b))\n")
|
||||
|
||||
(let ([val (list (duo '(a b c d e)
|
||||
'(1 2 3 4 5)))])
|
||||
(try-print pretty-print val 10 "(list\n (DUO\n '(a\n b\n c\n d\n e)\n '(1\n 2\n 3\n 4\n 5)))\n")
|
||||
(try-print pretty-write val 10 "((DUO\n (a\n b\n c\n d\n e)\n (1\n 2\n 3\n 4\n 5)))\n")
|
||||
(try-print pretty-display val 10 "((DUO\n (a\n b\n c\n d\n e)\n (1\n 2\n 3\n 4\n 5)))\n"))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user