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

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

@ -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]

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

@ -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)

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

@ -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%)])