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

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

@ -26,6 +26,26 @@
(set! drscheme-frame df)
(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)
(let* ([curr-win (and current-tab (send current-tab get-test-window))]
[window (or curr-win (make-object test-window%))]
@ -48,14 +68,9 @@
(send drscheme-frame deregister-test-window window)
(send current-tab current-test-window #f)
(send current-tab current-test-editor #f)))))
(if (and drscheme-frame
(get-preference 'test:test-window:docked?
(lambda ()
(put-preferences '(test:test-window:docked?)
'(#f))
#f)))
(send drscheme-frame display-test-panel content)
(send window show #t))))
(if (docked?)
(send drscheme-frame display-test-panel content)
(send window show #t))))
(define/pubment (insert-test-results editor test-info src-editor)
(let* ([style (send test-info test-style)]

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

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