From 4299b12d5b04c6d469b32f6c5ec11d843c45f662 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 18 Aug 2010 14:49:59 -0600 Subject: [PATCH] fix pretty-print problems, especially related to the custom-write property --- collects/racket/pretty.rkt | 106 +++++++++--------- .../scribblings/reference/pretty-print.scrbl | 3 +- collects/tests/racket/pretty.rktl | 90 ++++++++++++++- 3 files changed, 145 insertions(+), 54 deletions(-) diff --git a/collects/racket/pretty.rkt b/collects/racket/pretty.rkt index 08fd416bdb..db0246ec16 100644 --- a/collects/racket/pretty.rkt +++ b/collects/racket/pretty.rkt @@ -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)) diff --git a/collects/scribblings/reference/pretty-print.scrbl b/collects/scribblings/reference/pretty-print.scrbl index b7c8f0f868..bc6c1692e2 100644 --- a/collects/scribblings/reference/pretty-print.scrbl +++ b/collects/scribblings/reference/pretty-print.scrbl @@ -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. diff --git a/collects/tests/racket/pretty.rktl b/collects/tests/racket/pretty.rktl index 2d772cd6d8..5718eaf239 100644 --- a/collects/tests/racket/pretty.rktl +++ b/collects/tests/racket/pretty.rktl @@ -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)