diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index b8068f3dc8..ec2ecc7054 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -39,7 +39,7 @@ stepper/private/shared (only-in test-engine/scheme-gui make-formatter) - (only-in test-engine/scheme-tests scheme-test-data test-format test-execute) + (only-in test-engine/scheme-tests scheme-test-data scheme-error-handler test-format test-execute) (lib "test-engine/test-display.scm") ) @@ -176,6 +176,7 @@ (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-error-handler teaching-languages-error-display-handler) (test-execute (get-preference 'tests:enable? (lambda () #t))) (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40)))) ))) diff --git a/collects/profj/libs/java/runtime.ss b/collects/profj/libs/java/runtime.ss index d9163cef8b..2573757326 100644 --- a/collects/profj/libs/java/runtime.ss +++ b/collects/profj/libs/java/runtime.ss @@ -341,7 +341,7 @@ (third current-check) (fourth current-check) mutate-msg-prefix) - (fifth current-check)))) + (fifth current-check) #f))) (report-results (cdr checks))))) result-value))) @@ -358,7 +358,7 @@ (send test-obj check-failed (compose-message test-obj check-kind info values #f) - src)))) + src #f)))) (define (compose-message test-obj check-kind info values mutate-message) (letrec ([test-format (construct-info-msg info)] diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 37eb0e1d93..224f4526ed 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -845,6 +845,7 @@ #f `(parse-java-interactions ,(parse-interactions port name level) ,name) #f))))))) + (define/public (front-end/finished-complete-program settings) (void)) (define (get-defn-editor port-name) (let* ([dr-frame (and (drscheme:rep:current-rep) diff --git a/collects/test-engine/java-tests.scm b/collects/test-engine/java-tests.scm index 5f6fcd943d..1f039d794f 100644 --- a/collects/test-engine/java-tests.scm +++ b/collects/test-engine/java-tests.scm @@ -170,13 +170,13 @@ (inner (void) complete-testcase pass?)) (define/public (get-current-testcase) current-testcase) - (define/augment (check-failed msg src) + (define/augment (check-failed msg src exn) (when current-testcase (set-tc-stat-checks! current-testcase (cons (make-failed-check src msg) (tc-stat-checks current-testcase)))) - (inner (void) check-failed msg src)) + (inner (void) check-failed msg src exn)) (define/public (format-value value) (make-java-snip value (make-format-style #t 'field #f))) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index e841786b29..4de3915ba6 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -38,14 +38,14 @@ (define-struct check-fail (src)) -;; (make-unexpected-error src string) -(define-struct (unexpected-error check-fail) (expected message)) +;; (make-unexpected-error src string exn) +(define-struct (unexpected-error check-fail) (expected message exn)) ;; (make-unequal src scheme-val scheme-val) (define-struct (unequal check-fail) (test actual)) ;; (make-outofrange src scheme-val scheme-val inexact) (define-struct (outofrange check-fail) (test actual range)) -;; (make-incorrect-error src string) -(define-struct (incorrect-error check-fail) (expected message)) +;; (make-incorrect-error src string exn) +(define-struct (incorrect-error check-fail) (expected message exn)) ;; (make-expected-error src string scheme-val) (define-struct (expected-error check-fail) (message value)) @@ -158,13 +158,14 @@ (lambda (e) (or (equal? (exn-message e) error) (make-incorrect-error src error - (exn-message e))))]) + (exn-message e) e)))]) (let ([test-val (test)]) (make-expected-error src error test-val)))]) (if (check-fail? result) (begin (send (send test-info get-info) check-failed - (check->message result) (check-fail-src result)) + (check->message result) (check-fail-src result) + (and (incorrect-error? result) (incorrect-error-exn result))) (list 'check-error-failed (if (expected-error? result) (expected-error-message result) @@ -185,16 +186,17 @@ ;; (scheme-val scheme-val scheme-val -> check-fail) ;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void (define (run-and-check check maker test expect range src test-info kind) - (match-let ([(list result result-val) + (match-let ([(list result result-val exn?) (with-handlers ([exn? (lambda (e) + #;((error-display-handler) (exn-message e) e) (list (make-unexpected-error src expect - (exn-message e)) 'error))]) + (exn-message e) e) 'error e))]) (let ([test-val (test)]) - (cond [(check expect test-val range) (list #t test-val)] + (cond [(check expect test-val range) (list #t test-val #f)] [else - (list (maker src test-val expect range) test-val)])))]) + (list (maker src test-val expect range) test-val #f)])))]) (cond [(check-fail? result) - (send (send test-info get-info) check-failed (check->message result) (check-fail-src result)) + (send (send test-info get-info) check-failed (check->message result) (check-fail-src result) exn?) (render-for-stepper/fail result expect range kind)] [else ;; I'd like to pass the actual, but I don't have it. @@ -288,6 +290,7 @@ (define (insert-test test-info test) (send test-info add-test test)) (define scheme-test-data (make-parameter (list #f #f #f))) +(define scheme-error-handler (make-parameter (error-display-handler))) (define scheme-test% (class* test-engine% () @@ -312,4 +315,4 @@ (test) (inner (void) run-test test)))) -(provide scheme-test-data test-format test-execute test-silence) +(provide scheme-test-data test-format test-execute test-silence scheme-error-handler) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index 98e475eca1..1bf39865ae 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -4,8 +4,8 @@ (provide (all-defined-out)) -;; (make-failed-check src (listof (U string snip%))) -(define-struct failed-check (src msg)) +;; (make-failed-check src (listof (U string snip%)) (U #f exn)) +(define-struct failed-check (src msg exn)) (define test-info-base% (class* object% () @@ -41,11 +41,11 @@ (set! total-tsts (add1 total-tsts)) (inner (void) add-test)) - ;; check-failed: (list (U string snip%)) src -> void - (define/pubment (check-failed msg src) + ;; check-failed: (list (U string snip%)) src (U exn false) -> void + (define/pubment (check-failed msg src exn?) (set! failed-cks (add1 failed-cks)) - (set! failures (cons (make-failed-check src msg) failures)) - (inner (void) check-failed msg src)) + (set! failures (cons (make-failed-check src msg exn?) failures)) + (inner (void) check-failed msg src exn?)) (define/pubment (test-failed failed-info) (set! failed-tsts (add1 failed-tsts))