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

improve rackunit gui performance

Browse Source 
original commit: 755b3d2df24401dee60f419fdd79393cef7e5c99
This commit is contained in:
Ryan Culpepper 2011-02-03 18:56:49 -07:00
parent 69c96bf63c
commit 03f033609b
3 changed files with 25 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/rackunit/gui.rkt
View File

@ -4,7 +4,9 @@
"private/gui/gui.rkt") "private/gui/gui.rkt")
(define (test/gui . tests) (define (test/gui . tests)
(apply (make-gui-runner) tests)) (let ([runner (make-gui-runner)])
(sleep 0.1) ;; give the gui a chance to initialize
(apply runner tests)))
(define test/c (or/c rackunit-test-case? rackunit-test-suite?)) (define test/c (or/c rackunit-test-case? rackunit-test-suite?))

4
collects/rackunit/private/gui/controller.rkt
View File

@ -52,8 +52,8 @@
;; on-model-status-change : model<%> -> void ;; on-model-status-change : model<%> -> void
(define/public (on-model-status-change model) (define/public (on-model-status-change model)
;; (check-ready) ;; allow completion of tests to change status (let ([view view]) ;; view field is async. mutable!
(send view queue-for-update model) (when view (send view queue-for-update model)))
(let [(parent (send model get-parent))] (let [(parent (send model get-parent))]
(when parent (send parent on-child-status-change model)))) (when parent (send parent on-child-status-change model))))

24
collects/rackunit/private/gui/view.rkt
View File

@ -83,6 +83,10 @@ still be there, just not visible?
;; update-lock : semaphore ;; update-lock : semaphore
(define update-lock (make-semaphore 1)) (define update-lock (make-semaphore 1))
;; update-timer : timer%
(define update-timer
(new timer% (notify-callback (lambda () (process-updates)))))
(send editor lock #t) (send editor lock #t)
(with-handlers ([exn:fail? void]) (with-handlers ([exn:fail? void])
(send -hpane set-percentages VIEW-PANE-PERCENTS)) (send -hpane set-percentages VIEW-PANE-PERCENTS))
@ -115,26 +119,30 @@ still be there, just not visible?
(let ([proc (lambda () (send tree-view create-view-link model parent))]) (let ([proc (lambda () (send tree-view create-view-link model parent))])
(semaphore-wait update-lock) (semaphore-wait update-lock)
(set! add-queue (cons proc add-queue)) (set! add-queue (cons proc add-queue))
(semaphore-post update-lock) (updates-pending!)
(process-updates))) (semaphore-post update-lock)))
;; queue-for-update : model -> void ;; queue-for-update : model -> void
(define/public (queue-for-update model) (define/public (queue-for-update model)
(semaphore-wait update-lock) (semaphore-wait update-lock)
(set! update-queue (hash-set update-queue model #t)) (set! update-queue (hash-set update-queue model #t))
(semaphore-post update-lock) (updates-pending!)
(process-updates)) (semaphore-post update-lock))
;; updates-pending! : -> void
(define/private (updates-pending!)
(send update-timer start 50 #t))
;; process-updates : -> void ;; process-updates : -> void
;; ** Must be called from eventspace thread.
(define/private (process-updates) (define/private (process-updates)
(parameterize ((current-eventspace eventspace))
(queue-callback
(lambda ()
(let-values ([(adds updates) (grab+clear-update-queue)]) (let-values ([(adds updates) (grab+clear-update-queue)])
(send (send tree-view get-editor) begin-edit-sequence #f)
(for ([add (in-list adds)]) (for ([add (in-list adds)])
(add)) (add))
(for ([model (in-hash-keys updates)]) (for ([model (in-hash-keys updates)])
(do-model-update model))))))) (do-model-update model))
(send (send tree-view get-editor) end-edit-sequence)))
;; grab+clear-update-queue : -> (values list hash) ;; grab+clear-update-queue : -> (values list hash)
;; ** Must be called from eventspace thread. ;; ** Must be called from eventspace thread.