Better GUI

2026-08-27 10:49:28 +02:00
parent 26833ad7eb
commit a2dea77eb0
4 changed files with 282 additions and 9 deletions
@@ -0,0 +1,97 @@
+#lang racket/base
+
+(require racket/port
+         racket/system)
+
+(provide windows-tray-available?
+         start-windows-tray!)
+
+(define (windows-tray-available?)
+  (and (eq? (system-type 'os) 'windows)
+       (find-executable-path "powershell.exe")
+       #t))
+
+(define tray-script
+  #<<POWERSHELL
+[Console]::OutputEncoding = [System.Text.Encoding]::UTF8
+Add-Type -AssemblyName System.Windows.Forms
+Add-Type -AssemblyName System.Drawing
+
+$tray = New-Object System.Windows.Forms.NotifyIcon
+$tray.Icon = [System.Drawing.SystemIcons]::Application
+$tray.Text = "RKT Web Player Agent"
+$tray.Visible = $true
+
+$menu = New-Object System.Windows.Forms.ContextMenuStrip
+$open = $menu.Items.Add("Open RKT Web Player Agent")
+$quit = $menu.Items.Add("Exit")
+$tray.ContextMenuStrip = $menu
+
+$send = {
+  param([string]$message)
+  [Console]::Out.WriteLine($message)
+  [Console]::Out.Flush()
+}
+
+$open.add_Click({ & $send "open" })
+$tray.add_DoubleClick({ & $send "open" })
+$quit.add_Click({
+  & $send "quit"
+  $tray.Visible = $false
+  [System.Windows.Forms.Application]::Exit()
+})
+
+[System.Windows.Forms.Application]::Run()
+$tray.Visible = $false
+$tray.Dispose()
+POWERSHELL
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Add a Windows notification-area icon with open and quit actions.
+; pre    : Called on Windows with PowerShell and a GUI eventspace available.
+; post   : Callbacks are delivered from a reader thread; the stop thunk removes
+;          the helper process and its icon.
+; result : A stop thunk, or #f when the platform has no supported tray helper.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (start-windows-tray! on-open on-quit)
+  (cond
+    ((not (windows-tray-available?)) #f)
+    (else
+     (let-values (((process output input error-output)
+                   (subprocess
+                    #f #f #f
+                    (find-executable-path "powershell.exe")
+                    "-NoLogo"
+                    "-NoProfile"
+                    "-NonInteractive"
+                    "-WindowStyle"
+                    "Hidden"
+                    "-STA"
+                    "-Command"
+                    tray-script)))
+       (close-output-port input)
+       (define stopped? #f)
+       (define reader
+         (thread
+          (λ ()
+            (let loop ()
+              (let ((line (read-line output 'any)))
+                (unless (eof-object? line)
+                  (cond
+                    ((string=? line "open") (on-open))
+                    ((string=? line "quit") (on-quit)))
+                  (loop)))))))
+       (thread
+        (λ ()
+          ;; Drain diagnostics so the helper cannot block on a full pipe.
+          (copy-port error-output (open-output-nowhere))))
+       (λ ()
+         (unless stopped?
+           (set! stopped? #t)
+           (when (and reader (not (thread-dead? reader)))
+             (kill-thread reader))
+           (close-input-port output)
+           (close-input-port error-output)
+           (when (eq? (subprocess-status process) 'running)
+             (subprocess-kill process #t))))))))