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

Committing a change to display lists in a pretty-printed box

Browse Source 
svn: r5225
This commit is contained in:
Kathy Gray 2007-01-05 02:25:38 +00:00
parent 6973ffde78
commit 5db137cf05
1 changed files with 22 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/htdp/testing.scm
View File

@ -3,6 +3,8 @@
(require (lib "teachprims.ss" "lang" "private") (require (lib "teachprims.ss" "lang" "private")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "pretty.ss")
(lib "pconvert.ss")
(lib "class.ss")) (lib "class.ss"))
(provide (provide
@ -152,8 +154,8 @@
(for-each (lambda (f) (report-check-failure f my-text)) (for-each (lambda (f) (report-check-failure f my-text))
(reverse failed-check)) (reverse failed-check))
(send my-frame resize (send my-frame resize
(min (+ 300 (* 3 (send my-text line-end-position num-failed-tests #f))) 900) (min (+ 300 (* 5 (send my-text line-end-position num-failed-tests #f))) 1000)
(min (+ 200 (* 5 num-failed-tests)) 900))) (min (+ 200 (* 5 num-failed-tests)) 1000)))
(send my-text move-position 'home) (send my-text move-position 'home)
(send my-text lock #t) (send my-text lock #t)
(send my-frame show #t) (send my-frame show #t)
@ -165,13 +167,13 @@
(send text insert "\n ") (send text insert "\n ")
(cond (cond
[(unexpected-error? fail) [(unexpected-error? fail)
(send text insert "check encountered the following error instead of the expected value ") (send text insert "check encountered the following error instead of the expected value, ")
(insert-value text (unexpected-error-expected fail)) (insert-value text (unexpected-error-expected fail))
(send text insert (format ". ~n :: ~a~n" (unexpected-error-message fail)))] (send text insert (format ". ~n :: ~a~n" (unexpected-error-message fail)))]
[(unequal? fail) [(unequal? fail)
(send text insert "Actual value ") (send text insert "Actual value ")
(insert-value text (unequal-test fail)) (insert-value text (unequal-test fail))
(send text insert " was not equal to expected value ") (send text insert " did not equal expected value ")
(insert-value text (unequal-actual fail)) (insert-value text (unequal-actual fail))
(send text insert ".\n")] (send text insert ".\n")]
[(outofrange? fail) [(outofrange? fail)
@ -191,12 +193,22 @@
(define (insert-value text value) (define (insert-value text value)
(send text insert (send text insert
(if (is-a? value snip%) (cond
(begin [(is-a? value snip%)
(send value set-style (send (send text get-style-list) (send value set-style (send (send text get-style-list)
find-named-style "Standard")) find-named-style "Standard"))
value) value]
(format "~v" value)))) [(pair? value)
(parameterize ([constructor-style-printing #t]
[pretty-print-columns 40])
(let* ([text* (new (editor:standard-style-list-mixin text%))]
[text-snip (new editor-snip% [editor text*])])
(pretty-print (print-convert value) (open-output-text-editor text*))
(send text* lock #t)
(send text-snip set-style (send (send text get-style-list)
find-named-style "Standard"))
text-snip))]
[else (format "~v" value)])))
;make-link: text% (listof (U string snip%)) src -> void ;make-link: text% (listof (U string snip%)) src -> void
(define (make-link text dest) (define (make-link text dest)