diff --git a/collects/rackunit/private/gui/controller.rkt b/collects/rackunit/private/gui/controller.rkt index 5e62687..16ba57f 100644 --- a/collects/rackunit/private/gui/controller.rkt +++ b/collects/rackunit/private/gui/controller.rkt @@ -10,20 +10,23 @@ (define controller% (class* object% (controller<%>) - (init display-window) (super-new) ;; model-shown : (notify-box (U model<%> #f)) ;; The model currently displayed in the Details view, of #f is none. (define-notify selected-model (new notify-box% (value #f))) - (define view - (new view% - (controller this) - (parent (send display-window get-area-container)))) + ;; view : #f or view<%> + (define view #f) + + ;; check-ready : -> void + (define/private (check-ready) + (unless view + (error 'racunit "The RacUnit GUI is no longer running."))) ;; create-model : test suite<%>/#f -> result<%> (define/public (create-model test parent) + (define _ (check-ready)) (define result (cond [(rackunit-test-case? test) (new case-result% @@ -44,7 +47,16 @@ ;; on-model-status-change : model<%> -> void (define/public (on-model-status-change model) + (check-ready) (send view queue-for-update model) (let [(parent (send model get-parent))] (when parent (send parent on-child-status-change model)))) + + ;; register-view : view<%> -> void + (define/public (register-view v) + (set! view v)) + + ;; on-view-shutdown : -> void + (define/public (on-view-shutdown) + (set! view #f)) )) diff --git a/collects/rackunit/private/gui/gui.rkt b/collects/rackunit/private/gui/gui.rkt index a987036..61050b2 100644 --- a/collects/rackunit/private/gui/gui.rkt +++ b/collects/rackunit/private/gui/gui.rkt @@ -11,12 +11,11 @@ (provide make-gui-runner) (define (make-gui-runner) + (define controller + (new controller%)) (define frame (parameterize ((current-eventspace (make-eventspace))) - (make-view-frame))) - (define controller - (new controller% - (display-window frame))) + (make-view-frame controller))) (lambda tests (for ([test (in-list tests)]) (run test controller)))) @@ -146,5 +145,3 @@ (values (make-output-collector 'output) (make-output-collector 'error) (lambda () output))) - - diff --git a/collects/rackunit/private/gui/interfaces.rkt b/collects/rackunit/private/gui/interfaces.rkt index 2d45ba0..004a086 100644 --- a/collects/rackunit/private/gui/interfaces.rkt +++ b/collects/rackunit/private/gui/interfaces.rkt @@ -12,7 +12,9 @@ listen-selected-model create-model - on-model-status-change)) + on-model-status-change + register-view + on-view-shutdown)) ;; result ;; Represents a test (case or suite) together with the state associated @@ -55,7 +57,8 @@ ;; Presents a graphical interface for inspecting and running tests. (define-interface view<%> () (create-view-link - queue-for-update)) + queue-for-update + shutdown)) ;; style-map ;; Maps symbolic style names ('bold, 'red) to GRacket styles. diff --git a/collects/rackunit/private/gui/view.rkt b/collects/rackunit/private/gui/view.rkt index 4cead96..c966a7c 100644 --- a/collects/rackunit/private/gui/view.rkt +++ b/collects/rackunit/private/gui/view.rkt @@ -10,8 +10,7 @@ "model2rml.rkt" "rml.rkt") -(provide make-view-frame - view%) +(provide make-view-frame) (define style-map rackunit-style-map) @@ -71,10 +70,16 @@ still be there, just not visible? (view this) (controller controller))) + ;; for update management + (define update-queue (make-hasheq)) + (define update-lock (make-semaphore 1)) + (send editor lock #t) (with-handlers ([exn:fail? void]) (send -hpane set-percentages VIEW-PANE-PERCENTS)) + (send/i controller controller<%> register-view this) + ;; View Links (define/public (create-view-link model parent) @@ -102,9 +107,6 @@ still be there, just not visible? ;; Update Management - (define update-queue (make-hasheq)) - (define update-lock (make-semaphore 1)) - ;; queue-for-update : model -> void (define/public (queue-for-update model) (semaphore-wait update-lock) @@ -166,6 +168,12 @@ still be there, just not visible? (end-edit-sequence) (scroll-to-position 0))) + ;; Shutdown + + ;; shutdown : -> void + ;; Notifies the controller that the view has hung up. + (define/public (shutdown) + (send/i controller controller<%> on-view-shutdown)) )) @@ -261,13 +269,14 @@ still be there, just not visible? (class (frame:standard-menus-mixin (frame:basic-mixin frame%)) + (init-field controller) (init [width (pref:width)] [height (pref:height)]) - (super-new (width width) (height height)) (inherit get-help-menu get-width - get-height) + get-height + get-area-container) (define-syntax override-false (syntax-rules () @@ -287,20 +296,26 @@ still be there, just not visible? edit-menu:create-paste? edit-menu:create-clear? edit-menu:create-find? - #;edit-menu:create-replace-and-find-again? edit-menu:create-preferences?) (define/augment (on-close) (pref:width (get-width)) (pref:height (get-height)) + (send view shutdown) (inner (void) on-close)) - (send (get-help-menu) delete))) + (super-new (width width) (height height)) + (send (get-help-menu) delete) + (define view + (new view% + (controller controller) + (parent (get-area-container)))))) -;; make-view-frame : -> frame% -(define (make-view-frame) +;; make-view-frame : controller -> frame% +(define (make-view-frame controller) (let ([frame (new view-frame% - (label FRAME-LABEL))]) + (label FRAME-LABEL) + (controller controller))]) (send frame show #t) frame))