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

Erase the contents of a test report after success.

Browse Source 
svn: r12035
This commit is contained in:
Kathy Gray 2008-10-14 16:29:24 +00:00
parent 453deb8a5d
commit c8dce8dccd
2 changed files with 33 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,6 +26,26 @@
(set! drscheme-frame df) (set! drscheme-frame df)
(set! src-editor ed)) (set! src-editor ed))
(define (docked?)
(and drscheme-frame
(get-preference 'test:test-window:docked?
(lambda () (put-preferences '(test:test-window:docked?) '(#f)) #f))))
(define/public (report-success)
(when current-rep
(unless current-tab
(set! current-tab (send (send current-rep get-definitions-text) get-tab)))
(unless drscheme-frame
(set! drscheme-frame (send current-rep get-top-level-window)))
(let ([curr-win (and current-tab (send current-tab get-test-window))]
[content (make-object (editor:standard-style-list-mixin text%))])
(send content lock #t)
(when curr-win (send curr-win update-editor content))
(when current-tab (send current-tab current-test-editor content))
(when (docked?)
(send drscheme-frame display-test-panel content)
(send curr-win show #f)))))
(define/public (display-results) (define/public (display-results)
(let* ([curr-win (and current-tab (send current-tab get-test-window))] (let* ([curr-win (and current-tab (send current-tab get-test-window))]
[window (or curr-win (make-object test-window%))] [window (or curr-win (make-object test-window%))]
@ -48,12 +68,7 @@
(send drscheme-frame deregister-test-window window) (send drscheme-frame deregister-test-window window)
(send current-tab current-test-window #f) (send current-tab current-test-window #f)
(send current-tab current-test-editor #f))))) (send current-tab current-test-editor #f)))))
(if (and drscheme-frame (if (docked?)
(get-preference 'test:test-window:docked?
(lambda ()
(put-preferences '(test:test-window:docked?)
'(#f))
#f)))
(send drscheme-frame display-test-panel content) (send drscheme-frame display-test-panel content)
(send window show #t)))) (send window show #t))))

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

@ -75,6 +75,8 @@
(failed-check-src failed-check)) (failed-check-src failed-check))
(printf "~a" "\n"))) (printf "~a" "\n")))
(define/public (report-success) (void))
(define/public (next-line) (printf "~a" "\n\t")) (define/public (next-line) (printf "~a" "\n\t"))
;; make-link: (listof (U string snip%)) src -> void ;; make-link: (listof (U string snip%)) src -> void
@ -130,24 +132,27 @@
(when (test-execute) (when (test-execute)
(unless test-display (setup-display #f #f)) (unless test-display (setup-display #f #f))
(let ([result (send test-info summarize-results)]) (let ([result (send test-info summarize-results)])
(send test-display install-info test-info)
(case result (case result
[(no-tests) (send this display-untested port)] [(no-tests) (send this display-untested port)]
[(all-passed) (send this display-success port)] [(all-passed) (send this display-success port display-event-space)]
[(mixed-results) [(mixed-results)
(send this display-results display-rep display-event-space)])))) (send this display-results display-rep display-event-space)]))))
(define/public (display-success port) (define/public (display-success port event)
(when event
(parameterize ([(dynamic-require 'scheme/gui 'current-eventspace) event])
((dynamic-require 'scheme/gui 'queue-callback)
(lambda () (send test-display report-success)))))
(unless (test-silence) (unless (test-silence)
(fprintf port "All tests passed!~n"))) (fprintf port "All tests passed!~n")))
(define/public (display-untested port) (define/public (display-untested port)
(unless (test-silence) (unless (test-silence)
(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)
(cond (cond
[(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))))]
[event-space [event-space