diff --git a/collects/rackunit/gui.rkt b/collects/rackunit/gui.rkt index 4238316..8baf65a 100644 --- a/collects/rackunit/gui.rkt +++ b/collects/rackunit/gui.rkt @@ -4,7 +4,9 @@ "private/gui/gui.rkt") (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?)) diff --git a/collects/rackunit/private/gui/controller.rkt b/collects/rackunit/private/gui/controller.rkt index 4742523..97e76bc 100644 --- a/collects/rackunit/private/gui/controller.rkt +++ b/collects/rackunit/private/gui/controller.rkt @@ -52,8 +52,8 @@ ;; on-model-status-change : model<%> -> void (define/public (on-model-status-change model) - ;; (check-ready) ;; allow completion of tests to change status - (send view queue-for-update model) + (let ([view view]) ;; view field is async. mutable! + (when view (send view queue-for-update model))) (let [(parent (send model get-parent))] (when parent (send parent on-child-status-change model)))) diff --git a/collects/rackunit/private/gui/view.rkt b/collects/rackunit/private/gui/view.rkt index 9a716b0..2089f1c 100644 --- a/collects/rackunit/private/gui/view.rkt +++ b/collects/rackunit/private/gui/view.rkt @@ -83,6 +83,10 @@ still be there, just not visible? ;; update-lock : semaphore (define update-lock (make-semaphore 1)) + ;; update-timer : timer% + (define update-timer + (new timer% (notify-callback (lambda () (process-updates))))) + (send editor lock #t) (with-handlers ([exn:fail? void]) (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))]) (semaphore-wait update-lock) (set! add-queue (cons proc add-queue)) - (semaphore-post update-lock) - (process-updates))) + (updates-pending!) + (semaphore-post update-lock))) ;; queue-for-update : model -> void (define/public (queue-for-update model) (semaphore-wait update-lock) (set! update-queue (hash-set update-queue model #t)) - (semaphore-post update-lock) - (process-updates)) + (updates-pending!) + (semaphore-post update-lock)) + + ;; updates-pending! : -> void + (define/private (updates-pending!) + (send update-timer start 50 #t)) ;; process-updates : -> void + ;; ** Must be called from eventspace thread. (define/private (process-updates) - (parameterize ((current-eventspace eventspace)) - (queue-callback - (lambda () - (let-values ([(adds updates) (grab+clear-update-queue)]) - (for ([add (in-list adds)]) - (add)) - (for ([model (in-hash-keys updates)]) - (do-model-update model))))))) + (let-values ([(adds updates) (grab+clear-update-queue)]) + (send (send tree-view get-editor) begin-edit-sequence #f) + (for ([add (in-list adds)]) + (add)) + (for ([model (in-hash-keys updates)]) + (do-model-update model)) + (send (send tree-view get-editor) end-edit-sequence))) ;; grab+clear-update-queue : -> (values list hash) ;; ** Must be called from eventspace thread.