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

Puts the test display on drscheme's eventspace, even when we don't have a rep yet

Browse Source 
Doesn't make a link when there's no editor to link to

svn: r9636
This commit is contained in:
Kathy Gray 2008-05-03 23:17:59 +00:00
parent 7cd9e25970
commit a48f4923b6
2 changed files with 27 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -129,6 +129,7 @@
(send text insert m)) (send text insert m))
(let ((start (send text get-end-position))) (let ((start (send text get-end-position)))
(send text insert (format-src dest)) (send text insert (format-src dest))
(when (and src-editor current-rep)
(send text set-clickback (send text set-clickback
start (send text get-end-position) start (send text get-end-position)
(lambda (t s e) (highlight-check-error dest src-editor)) (lambda (t s e) (highlight-check-error dest src-editor))
@ -140,7 +141,7 @@
(make-object style-delta% 'change-underline #t) (make-object style-delta% 'change-underline #t)
start end #f) start end #f)
(send c set-delta-foreground "royalblue") (send c set-delta-foreground "royalblue")
(send text change-style c start end #f)))) (send text change-style c start end #f)))))
(define (format-src src) (define (format-src src)
(let ([src-file car] (let ([src-file car]
@ -151,8 +152,10 @@
[(symbol? (src-file src)) (string-append " At ")] [(symbol? (src-file src)) (string-append " At ")]
[(path? (src-file src)) (string-append " In " (path->string (src-file src)) " at ")] [(path? (src-file src)) (string-append " In " (path->string (src-file src)) " at ")]
[(is-a? (src-file src) editor<%>) " At "]) [(is-a? (src-file src) editor<%>) " At "])
"line " (number->string (src-line src)) "line " (cond [(src-line src) => number->string]
" column " (number->string (src-col src))))) [else "(unknown)"])
" column " (cond [(src-col src) => number->string]
[else "(unknown)"]))))
(define (highlight-check-error srcloc src-editor) (define (highlight-check-error srcloc src-editor)
(let* ([src-pos cadddr] (let* ([src-pos cadddr]

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

@ -142,13 +142,16 @@
(fprintf port "This program should be tested.~n")) (fprintf port "This program should be tested.~n"))
(define/public (display-results rep event-space) (define/public (display-results rep event-space)
(send test-display install-info test-info) (send test-display install-info test-info)
(cond
(if (and rep event-space) [(and rep event-space)
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) (parameterize ([(dynamic-require 'scheme/gui 'current-eventspace)
event-space]) event-space])
((dynamic-require 'scheme/gui 'queue-callback) ((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send rep display-test-results test-display)))) (lambda () (send rep display-test-results test-display))))]
(send test-display display-results))) [event-space
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event-space])
((dynamic-require 'scheme/gui 'queue-callback) (lambda () (send test-display display-results))))]
[else (send test-display display-results)]))
(define/pubment (initialize-test test) (define/pubment (initialize-test test)
(inner (void) initialize-test test)) (inner (void) initialize-test test))