racunit: stop running tests when gui is closed

original commit: 3f9233a7182817b307d1ea18b0b2505e6b645a1b

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
+    ;; view : #f or view<%>
-      (new view%
+    (define view #f)
-           (controller this)
+
-           (parent (send display-window get-area-container))))
+    ;; 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))
     ))

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)))
+      (make-view-frame controller)))
-  (define controller
-    (new controller%
-         (display-window frame)))
   (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)))
-  
-

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.

collects/rackunit/private/gui/view.rkt

@@ -10,8 +10,7 @@
          "model2rml.rkt"
          "rml.rkt")
 
-(provide make-view-frame
+(provide make-view-frame)
-         view%)
 
 (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%
+;; make-view-frame : controller -> frame%
-(define (make-view-frame)
+(define (make-view-frame controller)
   (let ([frame 
          (new view-frame%
-              (label FRAME-LABEL))])
+              (label FRAME-LABEL)
+              (controller controller))])
     (send frame show #t)
     frame))