diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index ec2ecc7054..822ce38e3f 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -1,11 +1,3 @@ -#| - -;; we don't use the built in debugging, use our own -;; version here that has no bug icon and only -;; annotates code that comes from editors. - -|# - #lang scheme (require string-constants framework @@ -39,7 +31,7 @@ stepper/private/shared (only-in test-engine/scheme-gui make-formatter) - (only-in test-engine/scheme-tests scheme-test-data scheme-error-handler test-format test-execute) + (only-in test-engine/scheme-tests scheme-test-data error-handler test-format test-execute) (lib "test-engine/test-display.scm") ) @@ -176,7 +168,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) + (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/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 4de3915ba6..fa11b9233c 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -190,7 +190,8 @@ (with-handlers ([exn? (lambda (e) #;((error-display-handler) (exn-message e) e) (list (make-unexpected-error src expect - (exn-message e) e) 'error e))]) + (exn-message e) + e) 'error (lambda () (test))))]) (let ([test-val (test)]) (cond [(check expect test-val range) (list #t test-val #f)] [else @@ -290,7 +291,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-error-handler (make-parameter (error-display-handler))) (define scheme-test% (class* test-engine% () @@ -315,4 +316,4 @@ (test) (inner (void) run-test test)))) -(provide scheme-test-data test-format test-execute test-silence scheme-error-handler) +(provide scheme-test-data test-format test-execute test-silence error-handler) diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index b1f82ee58f..55cba9cb50 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -5,7 +5,8 @@ mred framework string-constants - "test-info.scm") + "test-info.scm" + "test-engine.scm") (define test-display% (class* object% () @@ -112,10 +113,16 @@ (define/public (display-check-failures checks editor test-info src-editor) (for ([failed-check (reverse checks)]) (send editor insert "\t") - (make-link editor - (failed-check-msg failed-check) - (failed-check-src failed-check) - src-editor) + (if (failed-check-exn? failed-check) + (make-error-link editor + (failed-check-msg failed-check) + (failed-check-exn? failed-check) + (failed-check-src failed-check) + src-editor) + (make-link editor + (failed-check-msg failed-check) + (failed-check-src failed-check) + src-editor)) (send editor insert "\n"))) ;next-line: editor% -> void @@ -144,7 +151,28 @@ start end #f) (send c set-delta-foreground "royalblue") (send text change-style c start end #f))))) + + ;; make-error-link: text% (listof (U string snip%)) exn src editor -> void + (define (make-error-link text msg exn dest src-editor) + (make-link text msg dest src-editor) + (let ((start (send text get-end-position))) + (send text insert "Trace error ") + (when (and src-editor current-rep) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) (parameterize ([error-display-handler (error-handler)]) + (exn))) + #f #f) + (let ([end (send text get-end-position)] + [c (new style-delta%)]) + (send text insert " ") + (send text change-style + (make-object style-delta% 'change-underline #t) + start end #f) + (send c set-delta-foreground "red") + (send text change-style c start end #f))))) + ;format-src: src -> string (define (format-src src) (let ([src-file car] [src-line cadr] diff --git a/collects/test-engine/test-engine.scm b/collects/test-engine/test-engine.scm index 6aeb8042f7..953a118b82 100644 --- a/collects/test-engine/test-engine.scm +++ b/collects/test-engine/test-engine.scm @@ -166,6 +166,7 @@ (define test-format (make-parameter (lambda (v) (format "~a" v)))) (define test-execute (make-parameter #t)) +(define error-handler (make-parameter (error-display-handler))) (define test-silence (make-parameter #f)) -(provide test-engine% test-display-textual% test-format test-execute test-silence) +(provide test-engine% test-display-textual% test-format error-handler test-execute test-silence) diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index 1bf39865ae..b7db3e200a 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -5,7 +5,7 @@ (provide (all-defined-out)) ;; (make-failed-check src (listof (U string snip%)) (U #f exn)) -(define-struct failed-check (src msg exn)) +(define-struct failed-check (src msg exn?)) (define test-info-base% (class* object% ()