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

svn: r11380

Browse Source
This commit is contained in:
Kathy Gray 2008-08-22 12:25:03 +00:00
parent 59041963ca
commit bd12705f83
5 changed files with 42 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

38
collects/test-engine/test-display.scm
View File

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

3
collects/test-engine/test-engine.scm
View File

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

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

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