diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index e99d8ebc7a..42ad26275a 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -31,6 +31,8 @@ pretty-print-extend-style-table pretty-print-remap-stylable + pretty-format + pretty-printing pretty-print-newline make-tentative-pretty-print-output-port @@ -1122,5 +1124,20 @@ (substring padded-s (- len 10-power) len))) ;; d has factor(s) other than 2 and 5. ;; Print as a fraction. - (number->string x)))))))]))) + (number->string x)))))))])) + + (define pretty-format + (case-lambda + [(t) (pretty-format t (pretty-print-columns))] + [(t w) + (parameterize ([pretty-print-columns w]) + (let ([op (open-output-string)]) + (pretty-print t op) + (let ([s (get-output-string op)]) + (if (eq? w 'infinity) + s + (substring s 0 (- (string-length s) 1))))))])) + + + ) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 872f10a5ac..43f7c90566 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -118,6 +118,18 @@ #f void void) + + ;; make sure only a single syntax error occurs when in nested begin situation + (make-test "(begin (lambda ()) (lambda ()))" + "lambda: bad syntax in: (lambda ())" + "{file.gif} repl-test-tmp.ss:1:7: lambda: bad syntax in: (lambda ())" + "lambda: bad syntax in: (lambda ())" + "{bug09.gif} {file.gif} repl-test-tmp.ss:1:7: lambda: bad syntax in: (lambda ())" + (cons (make-loc 0 7 7) (make-loc 0 18 18)) + #f + void + void) + (make-test "xx" "reference to undefined identifier: xx" "reference to undefined identifier: xx" diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss index 1bda2654cd..9829a1b4cc 100644 --- a/collects/tests/mzscheme/pretty.ss +++ b/collects/tests/mzscheme/pretty.ss @@ -49,36 +49,35 @@ (make-struct-type 'pprec #f 2 0 #f (list (cons prop:custom-write pprec-print)))) -(define (pp-string v) - (let ([p (open-output-string)]) - (pretty-print v p) - (let ([s (get-output-string p)]) - (substring s 0 (sub1 (string-length s)))))) - -(test "10" pp-string 10) -(test "1/2" pp-string 1/2) -(test "-1/2" pp-string -1/2) -(test "1/2+3/4i" pp-string 1/2+3/4i) -(test "0.333" pp-string #i0.333) -(test "2.0+1.0i" pp-string #i2+1i) -(test "'a" pp-string ''a) -(test "`a" pp-string '`a) -(test ",a" pp-string ',a) -(test ",@a" pp-string ',@a) -(test "#'a" pp-string '#'a) -(test "W{1 2}" pp-string (make-pprec 1 2)) -(test "#&10" pp-string (box 10)) +(test "10" pretty-format 10) +(test "1/2" pretty-format 1/2) +(test "-1/2" pretty-format -1/2) +(test "1/2+3/4i" pretty-format 1/2+3/4i) +(test "0.333" pretty-format #i0.333) +(test "2.0+1.0i" pretty-format #i2+1i) +(test "'a" pretty-format ''a) +(test "`a" pretty-format '`a) +(test ",a" pretty-format ',a) +(test ",@a" pretty-format ',@a) +(test "#'a" pretty-format '#'a) +(test "W{1 2}" pretty-format (make-pprec 1 2)) +(test "#&10" pretty-format (box 10)) (parameterize ([print-box #f]) - (test "#" pp-string (box 10))) -(test "#1(10)" pp-string (vector 10)) -(test "#2(10)" pp-string (vector 10 10)) + (test "#" pretty-format (box 10))) +(test "#1(10)" pretty-format (vector 10)) +(test "#2(10)" pretty-format (vector 10 10)) (parameterize ([print-vector-length #f]) - (test "#(10 10)" pp-string (vector 10 10))) -(test "#" pp-string (let ([ht (make-hash-table)]) + (test "#(10 10)" pretty-format (vector 10 10))) +(test "#" pretty-format (let ([ht (make-hash-table)]) (hash-table-put! ht 1 2) ht)) + + +(test "(1\n 2)" pretty-format '(1 2) 2) +(test "(1 2)" pretty-format '(1 2) 'infinity) + (parameterize ([print-hash-table #t]) - (test "#hasheq((1 . 2))" pp-string (let ([ht (make-hash-table)]) + (test "#hasheq((1 . 2))" pretty-format (let ([ht (make-hash-table)]) (hash-table-put! ht 1 2) ht))) @@ -87,35 +86,35 @@ (test #t pretty-print-style-table? (pretty-print-extend-style-table (pretty-print-current-style-table) null null)) (parameterize ([pretty-print-columns 20]) - (test "(1234567890 1 2 3 4)" pp-string '(1234567890 1 2 3 4)) - (test "(1234567890xx\n 1\n 2\n 3\n 4)" pp-string '(1234567890xx 1 2 3 4)) - (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pp-string '(lambda 1234567890 1 2 3 4)) + (test "(1234567890 1 2 3 4)" pretty-format '(1234567890 1 2 3 4)) + (test "(1234567890xx\n 1\n 2\n 3\n 4)" pretty-format '(1234567890xx 1 2 3 4)) + (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) (let ([table (pretty-print-extend-style-table #f null null)]) (parameterize ([pretty-print-current-style-table (pretty-print-extend-style-table table '(lambda) '(list))]) - (test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pp-string '(lambda 1234567890 1 2 3 4))) - (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pp-string '(lambda 1234567890 1 2 3 4)) + (test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) + (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) (parameterize ([pretty-print-current-style-table table]) - (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pp-string '(lambda 1234567890 1 2 3 4))))) + (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))))) (parameterize ([pretty-print-exact-as-decimal #t]) - (test "10" pp-string 10) - (test "0.5" pp-string 1/2) - (test "-0.5" pp-string -1/2) - (test "3500.5" pp-string 7001/2) - (test "0.0001220703125" pp-string 1/8192) + (test "10" pretty-format 10) + (test "0.5" pretty-format 1/2) + (test "-0.5" pretty-format -1/2) + (test "3500.5" pretty-format 7001/2) + (test "0.0001220703125" pretty-format 1/8192) (test "0.0000000000000006869768746897623487" - pp-string 6869768746897623487/10000000000000000000000000000000000) - (test "0.00000000000001048576" pp-string (/ (expt 5 20))) + pretty-format 6869768746897623487/10000000000000000000000000000000000) + (test "0.00000000000001048576" pretty-format (/ (expt 5 20))) - (test "1/3" pp-string 1/3) - (test "1/300000000000000000000000" pp-string 1/300000000000000000000000) + (test "1/3" pretty-format 1/3) + (test "1/300000000000000000000000" pretty-format 1/300000000000000000000000) - (test "0.5+0.75i" pp-string 1/2+3/4i) - (test "0.5-0.75i" pp-string 1/2-3/4i) - (test "1/9+3/17i" pp-string 1/9+3/17i) - (test "0.333" pp-string #i0.333) - (test "2.0+1.0i" pp-string #i2+1i)) + (test "0.5+0.75i" pretty-format 1/2+3/4i) + (test "0.5-0.75i" pretty-format 1/2-3/4i) + (test "1/9+3/17i" pretty-format 1/9+3/17i) + (test "0.333" pretty-format #i0.333) + (test "2.0+1.0i" pretty-format #i2+1i)) (let () (define-struct wrap (content)) @@ -139,13 +138,13 @@ [pretty-print-print-hook (λ (val dsp? port) (write (wrap-content val) port))]) - (test "(lambda (x)\n abcdef)" pp-string (add-wrappers '(lambda (x) abcdef))) - (test "(call/cc\n call/cc)" pp-string (add-wrappers '(call/cc call/cc))))) + (test "(lambda (x)\n abcdef)" pretty-format (add-wrappers '(lambda (x) abcdef))) + (test "(call/cc\n call/cc)" pretty-format (add-wrappers '(call/cc call/cc))))) (parameterize ([print-struct #t]) (let () (define-struct s (x) (make-inspector)) - (test "#(struct:s 1)" pp-string (make-s 1)))) + (test "#(struct:s 1)" pretty-format (make-s 1)))) (err/rt-test (pretty-print-extend-style-table 'ack '(a) '(b))) (err/rt-test (pretty-print-extend-style-table (pretty-print-current-style-table) 'a '(b)))