diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index ed4ad0c5ff..963cdf7b2f 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -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)])) diff --git a/collects/test-engine/scheme-gui.ss b/collects/test-engine/scheme-gui.ss index 2ffc3cbedd..67abef5d3d 100644 --- a/collects/test-engine/scheme-gui.ss +++ b/collects/test-engine/scheme-gui.ss @@ -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")) ) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index e261d48fd5..69bfd7f764 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -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) \ No newline at end of file +(provide scheme-test-data test-format test-execute) \ No newline at end of file diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index f1cbd29fc3..598a47b90c 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -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) diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index dda1581ad5..ae219421e7 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -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) diff --git a/collects/test-engine/test-tool.scm b/collects/test-engine/test-tool.scm index 439f28fc32..c7381d48d8 100644 --- a/collects/test-engine/test-tool.scm +++ b/collects/test-engine/test-tool.scm @@ -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)