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

Getting source of error into test reports

Browse Source 
svn: r11333
This commit is contained in:
Kathy Gray 2008-08-19 17:03:40 +00:00
parent b8147e1e2e
commit b0aeb1d259
6 changed files with 28 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/lang/htdp-langs.ss
View File

@ -39,7 +39,7 @@
stepper/private/shared stepper/private/shared
(only-in test-engine/scheme-gui make-formatter) (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") (lib "test-engine/test-display.scm")
) )
@ -176,6 +176,7 @@
(namespace-attach-module drs-namespace scheme-test-module-name) (namespace-attach-module drs-namespace scheme-test-module-name)
(namespace-require scheme-test-module-name) (namespace-require scheme-test-module-name)
(scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) (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-execute (get-preference 'tests:enable? (lambda () #t)))
(test-format (make-formatter (lambda (v o) (render-value/format v settings o 40)))) (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))
))) )))

4
collects/profj/libs/java/runtime.ss
View File

@ -341,7 +341,7 @@
(third current-check) (third current-check)
(fourth current-check) (fourth current-check)
mutate-msg-prefix) mutate-msg-prefix)
(fifth current-check)))) (fifth current-check) #f)))
(report-results (cdr checks))))) (report-results (cdr checks)))))
result-value))) result-value)))
@ -358,7 +358,7 @@
(send test-obj (send test-obj
check-failed check-failed
(compose-message test-obj check-kind info values #f) (compose-message test-obj check-kind info values #f)
src)))) src #f))))
(define (compose-message test-obj check-kind info values mutate-message) (define (compose-message test-obj check-kind info values mutate-message)
(letrec ([test-format (construct-info-msg info)] (letrec ([test-format (construct-info-msg info)]

1
collects/profj/tool.ss
View File

@ -845,6 +845,7 @@
#f #f
`(parse-java-interactions ,(parse-interactions port name level) ,name) `(parse-java-interactions ,(parse-interactions port name level) ,name)
#f))))))) #f)))))))
(define/public (front-end/finished-complete-program settings) (void))
(define (get-defn-editor port-name) (define (get-defn-editor port-name)
(let* ([dr-frame (and (drscheme:rep:current-rep) (let* ([dr-frame (and (drscheme:rep:current-rep)

4
collects/test-engine/java-tests.scm
View File

@ -170,13 +170,13 @@
(inner (void) complete-testcase pass?)) (inner (void) complete-testcase pass?))
(define/public (get-current-testcase) current-testcase) (define/public (get-current-testcase) current-testcase)
(define/augment (check-failed msg src) (define/augment (check-failed msg src exn)
(when current-testcase (when current-testcase
(set-tc-stat-checks! (set-tc-stat-checks!
current-testcase current-testcase
(cons (make-failed-check src msg) (cons (make-failed-check src msg)
(tc-stat-checks current-testcase)))) (tc-stat-checks current-testcase))))
(inner (void) check-failed msg src)) (inner (void) check-failed msg src exn))
(define/public (format-value value) (define/public (format-value value)
(make-java-snip value (make-format-style #t 'field #f))) (make-java-snip value (make-format-style #t 'field #f)))

27
collects/test-engine/scheme-tests.ss
View File

@ -38,14 +38,14 @@
(define-struct check-fail (src)) (define-struct check-fail (src))
;; (make-unexpected-error src string) ;; (make-unexpected-error src string exn)
(define-struct (unexpected-error check-fail) (expected message)) (define-struct (unexpected-error check-fail) (expected message exn))
;; (make-unequal src scheme-val scheme-val) ;; (make-unequal src scheme-val scheme-val)
(define-struct (unequal check-fail) (test actual)) (define-struct (unequal check-fail) (test actual))
;; (make-outofrange src scheme-val scheme-val inexact) ;; (make-outofrange src scheme-val scheme-val inexact)
(define-struct (outofrange check-fail) (test actual range)) (define-struct (outofrange check-fail) (test actual range))
;; (make-incorrect-error src string) ;; (make-incorrect-error src string exn)
(define-struct (incorrect-error check-fail) (expected message)) (define-struct (incorrect-error check-fail) (expected message exn))
;; (make-expected-error src string scheme-val) ;; (make-expected-error src string scheme-val)
(define-struct (expected-error check-fail) (message value)) (define-struct (expected-error check-fail) (message value))
@ -158,13 +158,14 @@
(lambda (e) (lambda (e)
(or (equal? (exn-message e) error) (or (equal? (exn-message e) error)
(make-incorrect-error src error (make-incorrect-error src error
(exn-message e))))]) (exn-message e) e)))])
(let ([test-val (test)]) (let ([test-val (test)])
(make-expected-error src error test-val)))]) (make-expected-error src error test-val)))])
(if (check-fail? result) (if (check-fail? result)
(begin (begin
(send (send test-info get-info) check-failed (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 (list 'check-error-failed
(if (expected-error? result) (if (expected-error? result)
(expected-error-message result) (expected-error-message result)
@ -185,16 +186,17 @@
;; (scheme-val scheme-val scheme-val -> check-fail) ;; (scheme-val scheme-val scheme-val -> check-fail)
;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void ;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void
(define (run-and-check check maker test expect range src test-info kind) (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) (with-handlers ([exn? (lambda (e)
#;((error-display-handler) (exn-message e) e)
(list (make-unexpected-error src expect (list (make-unexpected-error src expect
(exn-message e)) 'error))]) (exn-message e) e) 'error e))])
(let ([test-val (test)]) (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 [else
(list (maker src test-val expect range) test-val)])))]) (list (maker src test-val expect range) test-val #f)])))])
(cond [(check-fail? result) (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)] (render-for-stepper/fail result expect range kind)]
[else [else
;; I'd like to pass the actual, but I don't have it. ;; 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 (insert-test test-info test) (send test-info add-test test))
(define scheme-test-data (make-parameter (list #f #f #f))) (define scheme-test-data (make-parameter (list #f #f #f)))
(define scheme-error-handler (make-parameter (error-display-handler)))
(define scheme-test% (define scheme-test%
(class* test-engine% () (class* test-engine% ()
@ -312,4 +315,4 @@
(test) (test)
(inner (void) run-test 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)

12
collects/test-engine/test-info.scm
View File

@ -4,8 +4,8 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; (make-failed-check src (listof (U string snip%))) ;; (make-failed-check src (listof (U string snip%)) (U #f exn))
(define-struct failed-check (src msg)) (define-struct failed-check (src msg exn))
(define test-info-base% (define test-info-base%
(class* object% () (class* object% ()
@ -41,11 +41,11 @@
(set! total-tsts (add1 total-tsts)) (set! total-tsts (add1 total-tsts))
(inner (void) add-test)) (inner (void) add-test))
;; check-failed: (list (U string snip%)) src -> void ;; check-failed: (list (U string snip%)) src (U exn false) -> void
(define/pubment (check-failed msg src) (define/pubment (check-failed msg src exn?)
(set! failed-cks (add1 failed-cks)) (set! failed-cks (add1 failed-cks))
(set! failures (cons (make-failed-check src msg) failures)) (set! failures (cons (make-failed-check src msg exn?) failures))
(inner (void) check-failed msg src)) (inner (void) check-failed msg src exn?))
(define/pubment (test-failed failed-info) (define/pubment (test-failed failed-info)
(set! failed-tsts (add1 failed-tsts)) (set! failed-tsts (add1 failed-tsts))