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

Integrating support for enabling/disabling testing

Browse Source 
Including support for language-level appropriate printing

svn: r9331
This commit is contained in:
Kathy Gray 2008-04-16 15:59:14 +00:00
parent 69939fea1b
commit c15f41f948
6 changed files with 49 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -38,8 +38,8 @@
"run-teaching-program.ss"
stepper/private/shared
(only test-engine/scheme-gui format-value)
(only test-engine/scheme-tests scheme-test-data scheme-test-format)
(only test-engine/scheme-gui make-formatter)
(only test-engine/scheme-tests scheme-test-data test-format test-execute)
(lib "test-display.scm" "test-engine")
)
@ -176,7 +176,8 @@
(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 test-display%))
(scheme-test-format format-value)
(test-execute (get-preference 'tests:enable? (lambda () #t)))
(test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))
)))
(super on-execute settings run-in-user-thread))
@ -532,6 +533,7 @@
keywords]
[(drscheme:teachpack-menu-items) htdp-teachpack-callbacks]
[(drscheme:special:insert-lambda) #f]
[(tests:test-menu) #t]
[else (inner (drscheme:language:get-capability-default key)
capability-value
key)]))

18
collects/test-engine/scheme-gui.ss
View File

@ -5,7 +5,21 @@
(require (except-in "scheme-tests.ss" test) "test-display.scm")
(define (make-formatter printer)
(lambda (value)
(let* ([text* (new (editor:standard-style-list-mixin text%))]
[text-snip (new editor-snip% [editor text*])])
(printer value (open-output-text-editor text* 0))
(send text* delete (send text* get-end-position) 'back)
(send text* lock #t)
text-snip)))
(define (format-value value)
(parameterize ([constructor-style-printing #t]
[pretty-print-columns 40])
(make-formatter (lambda (v o) (pretty-print (print-convert v) o)))))
#;(define (format-value value)
(cond
[(is-a? value snip%) value]
[(or (pair? value) (struct? value))
@ -22,12 +36,12 @@
(define (pop-up)
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
(parameterize ([scheme-test-format format-value])
(parameterize ([test-format format-value])
(and test-info
(send test-info refine-display-class test-display%)
(send test-info setup-display #f #f)
(send test-info summarize-results (current-output-port))))))
(provide test format-value (all-from-out "scheme-tests.ss"))
(provide test format-value make-formatter (all-from-out "scheme-tests.ss"))
)

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

@ -196,19 +196,19 @@
(cond
[(unexpected-error? fail)
(list "check encountered the following error instead of the expected value, "
((scheme-test-format) (unexpected-error-expected fail))
((test-format) (unexpected-error-expected fail))
(format ". ~n :: ~a~n" (unexpected-error-message fail)))]
[(unequal? fail)
(list "Actual value "
((scheme-test-format) (unequal-test fail))
((test-format) (unequal-test fail))
" differs from "
((scheme-test-format) (unequal-actual fail))
((test-format) (unequal-actual fail))
", the expected value.\n")]
[(outofrange? fail)
(list "Actual value "
((scheme-test-format) (outofrange-test fail))
((test-format) (outofrange-test fail))
(format " is not within ~v of expected value " (outofrange-range fail))
((scheme-test-format) (outofrange-actual fail))
((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"
@ -216,7 +216,7 @@
(incorrect-error-message fail)))]
[(expected-error? fail)
(list "check-error expected the following error, but instead received the value "
((scheme-test-format) (expected-error-value fail))
((test-format) (expected-error-value fail))
(format ".~n ~a~n" (expected-error-message fail)))]))
@ -259,7 +259,6 @@
(define (insert-test test-info test) (send test-info add-test test))
(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% ()
@ -284,4 +283,4 @@
(test)
(inner (void) run-test test))))
(provide scheme-test-data scheme-test-format)
(provide scheme-test-data test-format test-execute)

4
collects/test-engine/test-display.scm
View File

@ -199,7 +199,7 @@
(when (eq? 'button (send c get-event-type))
(close-cleanup)
(send this show #f))))
(make-object button%
#;(make-object button%
(string-constant profj-test-results-close-and-disable)
button-panel
(lambda (b c)
@ -253,7 +253,7 @@
(lambda (b c)
(when (eq? 'button (send c get-event-type))
(hide))))
(make-object button%
#;(make-object button%
(string-constant profj-test-results-hide-and-disable)
button-panel
(lambda (b c)

25
collects/test-engine/test-engine.scm
View File

@ -121,16 +121,18 @@
(inner (void) setup-display cur-rep event-space))
(define/pubment (run)
(unless test-info (send this setup-info 'check-base))
(inner (void) run))
(when (test-execute)
(unless test-info (send this setup-info 'check-base))
(inner (void) run)))
(define/public (summarize-results port)
(unless test-display (setup-display #f #f))
(let ([result (send test-info summarize-results)])
(case result
[(no-tests) (send this display-untested port)]
[(all-passed) (send this display-success port)]
[(mixed-results)
(send this display-results display-rep display-event-space)])))
(when (test-execute)
(unless test-display (setup-display #f #f))
(let ([result (send test-info summarize-results)])
(case result
[(no-tests) (send this display-untested port)]
[(all-passed) (send this display-success port)]
[(mixed-results)
(send this display-results display-rep display-event-space)]))))
(define/public (display-success port)
(fprintf port "All tests passed!~n"))
@ -154,4 +156,7 @@
(define/pubment (run-testcase testcase)
(inner (void) run-testcase testcase))))
(provide test-engine% test-display-textual%)
(define test-format (make-parameter (lambda (v) (format "~a" v))))
(define test-execute (make-parameter #t))
(provide test-engine% test-display-textual% test-format test-execute)

8
collects/test-engine/test-tool.scm
View File

@ -141,7 +141,7 @@
(when (send _1 is-enabled?)
(send _1 enable #f)
(send disable-opt enable #t)
(put-preferences '(test:enable?) '(#t)))) #f)]
(put-preferences '(tests:enable?) '(#t)))) #f)]
[disable-opt
(make-object menu:can-restore-menu-item%
disable-label testing-menu
@ -149,7 +149,7 @@
(when (send _1 is-enabled?)
(send _1 enable #f)
(send enable-opt enable #t)
(put-preferences '(test:enable?) '(#f)))) #f)])
(put-preferences '(tests:enable?) '(#f)))) #f)])
(make-object separator-menu-item% testing-menu)
(set! dock-menu-item (make-object menu:can-restore-menu-item%
dock-label testing-menu
@ -163,12 +163,12 @@
(undock-tests)
(put-preferences '(test:test-window:docked?) '(#f)))) #f))
(if (get-preference 'test:enable? (lambda () #t))
(if (get-preference 'tests:enable? (lambda () #t))
(send enable-opt enable #f)
(send disable-opt enable #f))
(if (get-preference 'test:test-window:docked? (lambda () #t))
(send dock-menu-item enable #f)
(send undock-menu-item enable #t))
(send undock-menu-item enable #f))
(register-capability-menu-item 'tests:test-menu testing-menu))))
(define/override (language-changed)
(super language-changed)