player agent gui script for exe

private-player-agent/player-agent-gui.rkt

@@ -85,8 +85,8 @@
 ;          Playback and polling remain in player-agent-core.rkt. racket-tray
 ;          owns native tray resources and the portable minimize watcher.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define/contract (run-player-agent-gui)
-  (-> (is-a?/c frame%))
+(define/contract (run-player-agent-gui* exit-callback)
+  (-> procedure? void?)
   (sl-log-to-file log-file)
   (let ((config (load-player-agent-config))
         (frame #f)
@@ -98,9 +98,11 @@
         (name-field #f)
         (server-field #f)
         (connect-button #f)
+        (quit-button #f)
         (playback-timer #f)
         (tray #f)
-        (shutting-down? #f))
+        (shutting-down? #f)
+        )
 
     (define (cap200 msg)
       (substring msg 0 (min 199 (string-length msg))))
@@ -272,7 +274,8 @@
         ((player-agent-runtime-shutdown! runtime))
         (when tray
           (tray-close tray)
-          (set! tray #f))))
+          (set! tray #f)))
+      )
 
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ; goal   : Terminate the graphical agent from its tray menu.
@@ -285,7 +288,9 @@
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     (define (quit!)
       (shutdown!)
-      (send frame show #f))
+      (send frame show #f)
+      (exit-callback)
+      )
 
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ; goal   : Restore the agent frame from the tray.
@@ -380,6 +385,11 @@
                  (parent playback-panel)
                  (label "—")
                  [ellipsis 'right] [auto-resize #t] [stretchable-width #t]))
+      (set! quit-button
+            (new button%
+                 (parent controls)
+                 (label (tr 'quit))
+                 (callback (λ (_button _event) (quit!)))))
       (set! connect-button
             (new button%
                  (parent controls)
@@ -411,8 +421,22 @@
 
     (send frame show #t)
     ((player-agent-runtime-start! runtime))
+
     (send connect-button set-label (cap200 (tr 'reconnect)))
-    frame))
+
+    (void)))
+
+
+(define (run-player-agent-gui)
+  (let ((quit-semaphore (make-semaphore 0)))
+
+    (run-player-agent-gui*
+     (λ ()
+       (semaphore-post quit-semaphore)))
+
+    (yield quit-semaphore)
+
+    (void)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Tests for module library.rkt