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

show timing for suites in rackunit gui

Browse Source 
original commit: 01fd205c9ab269a5d1cde81634eca93d0098bb43
This commit is contained in:
Ryan Culpepper 2013-09-14 04:29:27 -04:00
parent 305ea7dc4f
commit 8966ebd203
3 changed files with 33 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/rackunit-pkgs/rackunit-gui/rackunit/private/gui/interfaces.rkt
View File

@ -33,6 +33,7 @@
error?
has-output?
has-trash?
get-timing
get-total-cases
get-total-successes
@ -41,7 +42,6 @@
(define-interface case<%> (result<%>)
(update
get-result
get-timing
get-output
get-trash
get-property

49
pkgs/rackunit-pkgs/rackunit-gui/rackunit/private/gui/model.rkt
View File

@ -80,6 +80,9 @@
(define/public (get-output) (reverse output))
(define/public (has-output?) (pair? output))))
;; An aggr contains aggregate information about a suite's children.
(struct aggr (cases successes failures has-output? has-trash? tcpu treal tgc)
#:transparent)
;; suite-result%
(define suite-result%
@ -104,31 +107,37 @@
(send/i (get-controller) controller<%> on-model-status-change this))
(define children-cache
(cache (for/fold ([cs 0] [ss 0] [fs 0] [out? #f] [trash? #f])
([c (in-gvector children)])
(values (+ cs (send/i c result<%> get-total-cases))
(+ ss (send/i c result<%> get-total-successes))
(+ fs (send/i c result<%> get-total-failures))
(or out? (send/i c result<%> has-output?))
(or trash? (send/i c result<%> has-trash?))))))
(cache (call-with-values
(lambda ()
(for/fold ([cs 0] [ss 0] [fs 0] [out? #f] [trash? #f]
[tcpu 0] [treal 0] [tgc 0])
([c (in-gvector children)])
(let ([timing (or (send/i c result<%> get-timing) '(0 0 0))])
(values (+ cs (send/i c result<%> get-total-cases))
(+ ss (send/i c result<%> get-total-successes))
(+ fs (send/i c result<%> get-total-failures))
(or out? (send/i c result<%> has-output?))
(or trash? (send/i c result<%> has-trash?))
(+ tcpu (car timing))
(+ treal (cadr timing))
(+ tgc (caddr timing))))))
aggr)))
(define/public (finished?)
done?)
(define/public (get-total-cases)
(define-values (c _s _f _o _t) (cache-ref children-cache))
c)
(aggr-cases (cache-ref children-cache)))
(define/public (get-total-successes)
(define-values (_c s _f _o _t) (cache-ref children-cache))
s)
(aggr-successes (cache-ref children-cache)))
(define/public (get-total-failures)
(define-values (_c _s f _o _t) (cache-ref children-cache))
f)
(aggr-failures (cache-ref children-cache)))
(define/public (has-output?)
(define-values (_c _s _f o _t) (cache-ref children-cache))
o)
(aggr-has-output? (cache-ref children-cache)))
(define/public (has-trash?)
(define-values (_c _s _f _o t) (cache-ref children-cache))
t)
(aggr-has-trash? (cache-ref children-cache)))
(define/public (get-timing)
(let ([a (cache-ref children-cache)])
(list (aggr-tcpu a) (aggr-treal a) (aggr-tgc a))))
(define/public (success?)
(and (finished?) (zero? (get-total-failures))))
@ -138,10 +147,8 @@
;; on-child-status-change : model<%> -> void
(define/public (on-child-status-change child)
(let ([result
(call-with-values (lambda () (cache-ref children-cache)) list)])
(let ([result (cache-ref children-cache)])
(cache-invalidate! children-cache)
(let ([new-result
(call-with-values (lambda () (cache-ref children-cache)) list)])
(let ([new-result (cache-ref children-cache)])
(unless (equal? new-result result)
(send/i (get-controller) controller<%> on-model-status-change this)))))))

7
pkgs/rackunit-pkgs/rackunit-gui/rackunit/private/gui/model2rml.rkt
View File

@ -122,7 +122,8 @@
count-successes
num-tests))
(for-each (lambda (m) (render-model/short m)) successes)
(blank)))
(blank))
(render-timing model))
(if finished?
(put '()
"This test suite is empty.")
@ -158,7 +159,7 @@
(put `(,style)
(format " (~a)"
(n-things total-failures "failure" "failures"))))
(put '(test-unexecuted) " not yet executed"))
(put '(test-unexecuted) " not yet finished"))
(blank)))))
(define/private (render-case-short-form model)
@ -428,7 +429,7 @@
(blank))))
(define/private (render-timing model)
(let [(timing (send/i model case<%> get-timing))]
(let [(timing (send/i model result<%> get-timing))]
(when timing
(let ([cpu (car timing)]
[real (cadr timing)]