From 9b1188c77a6d259e8fe9fd1ae271a7e7ca90f834 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Fri, 8 Oct 2010 14:52:40 +0200 Subject: [PATCH] Re-instate Robby's hack to display test results off REPL errors. ... and generalize it so there's an action before (clearing the old tests out) in addition to after (displaying the test results). Also, do for DMdA as for HtDP. --- collects/deinprogramm/deinprogramm-langs.rkt | 29 +++++++--- collects/lang/htdp-langs.rkt | 21 +++++++ collects/test-engine/racket-tests.rkt | 60 ++++++++++---------- 3 files changed, 74 insertions(+), 36 deletions(-) diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index 3657260907..5592789287 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -767,13 +767,28 @@ (drscheme:rep:current-rep) '#%deinprogramm)) - ;; DeinProgramm addition: needed for test boxes; see the code - ;; in collects/drscheme/private/language.ss - (define/override (front-end/interaction port settings) - (let ((reader (get-reader))) - (lambda () - (reader (object-name port) port)))) - + (define/override (front-end/interaction port settings) + (let ([reader (get-reader)] ;; DeinProgramm addition: + ;; needed for test boxes; see + ;; the code in + ;; collects/drscheme/private/language.ss + [start? #t] + [done? #f]) + (λ () + (cond + [start? + (set! start? #f) + #'(reset-tests)] + [done? eof] + [else + (let ([ans (reader (object-name port) port)]) + (cond + [(eof-object? ans) + (set! done? #t) + #`(test)] + [else + ans]))])))) + (define/augment (capability-value key) (case key [(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks] diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 4780adb251..7fd4335323 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -19,6 +19,7 @@ compiler/embed wxme/wxme setup/dirs + test-engine/racket-tests ;; this module is shared between the drscheme's namespace (so loaded here) ;; and the user's namespace in the teaching languages @@ -553,6 +554,26 @@ (get-module) (htdp-lang-settings-teachpacks settings) (drscheme:rep:current-rep))) + + (define/override (front-end/interaction port settings) + (let ([t (super front-end/interaction port settings)] + [start? #t] + [done? #f]) + (λ () + (cond + [start? + (set! start? #f) + #'(reset-tests)] + [done? eof] + [else + (let ([ans (t)]) + (cond + [(eof-object? ans) + (set! done? #t) + #`(test)] + [else + ans]))])))) + (define keywords #f) (define/augment (capability-value key) diff --git a/collects/test-engine/racket-tests.rkt b/collects/test-engine/racket-tests.rkt index 6ed3676f39..898175cb87 100644 --- a/collects/test-engine/racket-tests.rkt +++ b/collects/test-engine/racket-tests.rkt @@ -110,35 +110,31 @@ skipto/cdr skipto/third ;; application of insert-test '(syntax-e cdr cdr syntax-e car) ;; lambda ))) - #`(begin - (let ([test-engine (namespace-variable-value + #`(let ([test-engine (namespace-variable-value 'test~object #f builder (current-namespace))]) - (when test-engine - (begin - (send test-engine reset-info) - (insert-test test-engine - (lambda () - #,(with-stepper-syntax-properties - (['stepper-hint hint-tag] - ['stepper-hide-reduction #t] - ['stepper-use-val-as-final #t]) - (quasisyntax/loc stx - (#,checker-proc-stx - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(car - #,(with-stepper-syntax-properties - (['stepper-hide-reduction #t]) - #`(list - (lambda () #,test-expr) - #,(syntax/loc stx (void)))))) - #,@embedded-stxes - #,src-info - #,(with-stepper-syntax-properties - (['stepper-no-lifting-info #t] - ['stepper-hide-reduction #t]) - #'test-engine))))))))) - (test)))) + (when test-engine + (insert-test test-engine + (lambda () + #,(with-stepper-syntax-properties + (['stepper-hint hint-tag] + ['stepper-hide-reduction #t] + ['stepper-use-val-as-final #t]) + (quasisyntax/loc stx + (#,checker-proc-stx + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(car + #,(with-stepper-syntax-properties + (['stepper-hide-reduction #t]) + #`(list + (lambda () #,test-expr) + #,(syntax/loc stx (void)))))) + #,@embedded-stxes + #,src-info + #,(with-stepper-syntax-properties + (['stepper-no-lifting-info #t] + ['stepper-hide-reduction #t]) + #'test-engine)))))))))) (define-for-syntax (check-context?) (let ([c (syntax-local-context)]) @@ -302,6 +298,12 @@ [else #t]))) +(define (reset-tests) + (let ([test-engine (namespace-variable-value + 'test~object #f builder (current-namespace))]) + (when test-engine + (send test-engine reset-info)))) + (define (builder) (let ([te (build-test-engine)]) (namespace-set-variable-value! 'test~object te (current-namespace)) @@ -348,7 +350,7 @@ #'(display-results*) 'test-call #t)])) -(provide run-tests display-results test builder) +(provide run-tests display-results test builder reset-tests) (define (build-test-engine) (let ([engine (make-object scheme-test%)])