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

Re-instate Robby's hack to display test results off REPL errors.

Browse Source 
... 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.
This commit is contained in:
Mike Sperber 2010-10-08 14:52:40 +02:00
parent 02cde446cc
commit 9b1188c77a
3 changed files with 74 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/deinprogramm/deinprogramm-langs.rkt
View File

@ -767,12 +767,27 @@
(drscheme:rep:current-rep) (drscheme:rep:current-rep)
'#%deinprogramm)) '#%deinprogramm))
;; DeinProgramm addition: needed for test boxes; see the code (define/override (front-end/interaction port settings)
;; in collects/drscheme/private/language.ss (let ([reader (get-reader)] ;; DeinProgramm addition:
(define/override (front-end/interaction port settings) ;; needed for test boxes; see
(let ((reader (get-reader))) ;; the code in
(lambda () ;; collects/drscheme/private/language.ss
(reader (object-name port) port)))) [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) (define/augment (capability-value key)
(case key (case key

21
collects/lang/htdp-langs.rkt
View File

@ -19,6 +19,7 @@
compiler/embed compiler/embed
wxme/wxme wxme/wxme
setup/dirs setup/dirs
test-engine/racket-tests
;; this module is shared between the drscheme's namespace (so loaded here) ;; this module is shared between the drscheme's namespace (so loaded here)
;; and the user's namespace in the teaching languages ;; and the user's namespace in the teaching languages
@ -554,6 +555,26 @@
(htdp-lang-settings-teachpacks settings) (htdp-lang-settings-teachpacks settings)
(drscheme:rep:current-rep))) (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 keywords #f)
(define/augment (capability-value key) (define/augment (capability-value key)
(case key (case key

60
collects/test-engine/racket-tests.rkt
View File

@ -110,35 +110,31 @@
skipto/cdr skipto/third ;; application of insert-test skipto/cdr skipto/third ;; application of insert-test
'(syntax-e cdr cdr syntax-e car) ;; lambda '(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))]) 'test~object #f builder (current-namespace))])
(when test-engine (when test-engine
(begin (insert-test test-engine
(send test-engine reset-info) (lambda ()
(insert-test test-engine #,(with-stepper-syntax-properties
(lambda () (['stepper-hint hint-tag]
#,(with-stepper-syntax-properties ['stepper-hide-reduction #t]
(['stepper-hint hint-tag] ['stepper-use-val-as-final #t])
['stepper-hide-reduction #t] (quasisyntax/loc stx
['stepper-use-val-as-final #t]) (#,checker-proc-stx
(quasisyntax/loc stx #,(with-stepper-syntax-properties
(#,checker-proc-stx (['stepper-hide-reduction #t])
#,(with-stepper-syntax-properties #`(car
(['stepper-hide-reduction #t]) #,(with-stepper-syntax-properties
#`(car (['stepper-hide-reduction #t])
#,(with-stepper-syntax-properties #`(list
(['stepper-hide-reduction #t]) (lambda () #,test-expr)
#`(list #,(syntax/loc stx (void))))))
(lambda () #,test-expr) #,@embedded-stxes
#,(syntax/loc stx (void)))))) #,src-info
#,@embedded-stxes #,(with-stepper-syntax-properties
#,src-info (['stepper-no-lifting-info #t]
#,(with-stepper-syntax-properties ['stepper-hide-reduction #t])
(['stepper-no-lifting-info #t] #'test-engine))))))))))
['stepper-hide-reduction #t])
#'test-engine)))))))))
(test))))
(define-for-syntax (check-context?) (define-for-syntax (check-context?)
(let ([c (syntax-local-context)]) (let ([c (syntax-local-context)])
@ -302,6 +298,12 @@
[else [else
#t]))) #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) (define (builder)
(let ([te (build-test-engine)]) (let ([te (build-test-engine)])
(namespace-set-variable-value! 'test~object te (current-namespace)) (namespace-set-variable-value! 'test~object te (current-namespace))
@ -348,7 +350,7 @@
#'(display-results*) #'(display-results*)
'test-call #t)])) 'test-call #t)]))
(provide run-tests display-results test builder) (provide run-tests display-results test builder reset-tests)
(define (build-test-engine) (define (build-test-engine)
(let ([engine (make-object scheme-test%)]) (let ([engine (make-object scheme-test%)])