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

More decoupling

Browse Source 
svn: r9218
This commit is contained in:
Kathy Gray 2008-04-09 11:00:12 +00:00
parent 70eb51202e
commit 03f299b652
3 changed files with 17 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/lang/htdp-langs.ss
View File

@ -39,6 +39,7 @@
stepper/private/shared
(lib "scheme-gui.scm" "test-engine")
(lib "test-display.scm" "test-engine")
)
@ -173,7 +174,7 @@
(read-accept-dot (get-read-accept-dot))
(namespace-attach-module drs-namespace scheme-test-module-name)
(namespace-require scheme-test-module-name)
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace))
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%))
)))
(super on-execute settings run-in-user-thread))

5
collects/test-engine/scheme-gui.scm
View File

@ -3,7 +3,8 @@
(require scheme/class
"test-engine.scm")
(define scheme-test-data (make-parameter (list #f #f)))
(define scheme-test-data (make-parameter (list #f #f #f)))
(define scheme-test-format (make-parameter (lambda (v) (format "~a" v))))
(define scheme-test%
(class* test-engine% ()
@ -28,4 +29,4 @@
(test)
(inner (void) run-test test))))
(provide scheme-test% scheme-test-data)
(provide scheme-test% scheme-test-data scheme-test-format)

25
collects/test-engine/scheme-tests.ss
View File

@ -1,10 +1,10 @@
#lang mzscheme
(require lang/private/teachprims
mred
framework
mzlib/pretty
mzlib/pconvert
#;mred
#;framework
#;mzlib/pretty
#;mzlib/pconvert
mzlib/class
"scheme-gui.scm")
@ -47,8 +47,7 @@
(current-namespace))])
(and test-info
(let ([display-data (scheme-test-data)])
(send test-info refine-display-class
(dynamic-require '(lib "test-display.scm" "test-engine") 'test-display%))
(send test-info refine-display-class (caddr display-data))
(send test-info setup-display
(car display-data) (cadr display-data))
(send test-info summarize-results (current-output-port)))))
@ -250,19 +249,19 @@
(cond
[(unexpected-error? fail)
(list "check encountered the following error instead of the expected value, "
(format-value (unexpected-error-expected fail))
((scheme-test-format) (unexpected-error-expected fail))
(format ". ~n :: ~a~n" (unexpected-error-message fail)))]
[(unequal? fail)
(list "Actual value "
(format-value (unequal-test fail))
((scheme-test-format) (unequal-test fail))
" differs from "
(format-value (unequal-actual fail))
((scheme-test-format) (unequal-actual fail))
", the expected value.\n")]
[(outofrange? fail)
(list "Actual value "
(format-value (outofrange-test fail))
((scheme-test-format) (outofrange-test fail))
(format " is not within ~v of expected value " (outofrange-range fail))
(format-value (outofrange-actual fail))
((scheme-test-format) (outofrange-actual fail))
".\n")]
[(incorrect-error? fail)
(list (format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n"
@ -270,10 +269,10 @@
(incorrect-error-message fail)))]
[(expected-error? fail)
(list "check-error expected the following error, but instead received the value "
(format-value (expected-error-value fail))
((scheme-test-format) (expected-error-value fail))
(format ".~n ~a~n" (expected-error-message fail)))]))
(define (format-value value)
#;(define (format-value value)
(cond
[(is-a? value snip%) value]
[(or (pair? value) (struct? value))