Initial import

2026-08-28 23:39:13 +02:00
parent 2349541c27
commit b8a522c1de
9 changed files with 859 additions and 1 deletions
@@ -0,0 +1,632 @@
+#lang racket/base
+
+(require ffi/unsafe
+         ffi/unsafe/define
+         ffi/unsafe/os-async-channel
+         ffi/winapi
+         racket/class
+         racket/draw
+         racket/gui/base
+         racket/match)
+
+(provide mk-tray
+         tray-close
+         tray-set-icon!
+         tray-set-menu!)
+
+;; Shell_NotifyIcon constants
+(define NIM_ADD        #x00000000)
+(define NIM_MODIFY     #x00000001)
+(define NIM_DELETE     #x00000002)
+(define NIM_SETVERSION #x00000004)
+
+(define NIF_MESSAGE #x00000001)
+(define NIF_ICON    #x00000002)
+(define NIF_TIP     #x00000004)
+(define NIF_SHOWTIP #x00000080)
+
+(define NOTIFYICON_VERSION_4 4)
+
+;; Window messages used by NOTIFYICON_VERSION_4.
+(define WM_CONTEXTMENU #x007B)
+(define WM_NCDESTROY   #x0082)
+(define WM_USER        #x0400)
+(define WM_APP         #x8000)
+(define NIN_SELECT     (+ WM_USER 0))
+(define NIN_KEYSELECT  (+ WM_USER 1))
+
+(define IMAGE_ICON       1)
+(define LR_LOADFROMFILE  #x00000010)
+(define SM_CXSMICON      49)
+(define SM_CYSMICON      50)
+
+(define BI_RGB         0)
+(define DIB_RGB_COLORS 0)
+
+;; Windows scalar aliases. Pointer-sized values matter on 64-bit Windows.
+(define _HWND      _pointer)
+(define _HICON     _pointer)
+(define _UINT_PTR  _uintptr)
+(define _DWORD_PTR _uintptr)
+(define _WPARAM    _uintptr)
+(define _LPARAM    _intptr)
+(define _LRESULT   _intptr)
+(define _HBITMAP   _pointer)
+
+(define-cstruct _BITMAPINFOHEADER
+  ([biSize          _uint32]
+   [biWidth         _int32]
+   [biHeight        _int32]
+   [biPlanes        _uint16]
+   [biBitCount      _uint16]
+   [biCompression   _uint32]
+   [biSizeImage     _uint32]
+   [biXPelsPerMeter _int32]
+   [biYPelsPerMeter _int32]
+   [biClrUsed       _uint32]
+   [biClrImportant  _uint32]))
+
+(define-cstruct _ICONINFO
+  ([fIcon    _int32]
+   [xHotspot _uint32]
+   [yHotspot _uint32]
+   [hbmMask  _HBITMAP]
+   [hbmColor _HBITMAP]))
+
+;; NOTIFYICONDATAW as defined by shellapi.h. The uTimeout/uVersion union is
+;; represented by one UINT because this package only uses uVersion.
+(define-cstruct _NOTIFYICONDATAW
+  ([cbSize           _uint32]
+   [hWnd             _HWND]
+   [uID              _uint32]
+   [uFlags           _uint32]
+   [uCallbackMessage _uint32]
+   [hIcon            _HICON]
+   [szTip            (_array _uint16 128)]
+   [dwState          _uint32]
+   [dwStateMask      _uint32]
+   [szInfo           (_array _uint16 256)]
+   [uVersion         _uint32]
+   [szInfoTitle      (_array _uint16 64)]
+   [dwInfoFlags      _uint32]
+   [guidItem         (_array _uint8 16)]
+   [hBalloonIcon     _HICON]))
+
+(define shell32  (ffi-lib "shell32.dll"))
+(define user32   (ffi-lib "user32.dll"))
+(define gdi32    (ffi-lib "gdi32.dll"))
+(define comctl32 (ffi-lib "comctl32.dll"))
+
+(define-ffi-definer define-shell32 shell32)
+(define-ffi-definer define-user32 user32)
+(define-ffi-definer define-gdi32 gdi32)
+(define-ffi-definer define-comctl32 comctl32)
+
+(define-shell32 Shell_NotifyIconW
+  (_fun #:abi winapi
+        _uint32 _NOTIFYICONDATAW-pointer
+        -> _int32))
+
+(define-user32 LoadImageW
+  (_fun #:abi winapi
+        _pointer _string/utf-16 _uint32 _int32 _int32 _uint32
+        -> _pointer))
+
+(define-user32 DestroyIcon
+  (_fun #:abi winapi _HICON -> _int32))
+
+(define-user32 CreateIconIndirect
+  (_fun #:abi winapi _ICONINFO-pointer -> _HICON))
+
+(define-user32 GetSystemMetrics
+  (_fun #:abi winapi _int32 -> _int32))
+
+(define-gdi32 CreateDIBSection
+  (_fun #:abi winapi
+        _pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32
+        -> _HBITMAP))
+
+(define-gdi32 CreateBitmap
+  (_fun #:abi winapi
+        _int32 _int32 _uint32 _uint32 _pointer
+        -> _HBITMAP))
+
+(define-gdi32 DeleteObject
+  (_fun #:abi winapi _pointer -> _int32))
+
+(define _SUBCLASSPROC
+  (_fun #:abi winapi
+        _HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR
+        -> _LRESULT))
+
+(define-comctl32 SetWindowSubclass
+  (_fun #:abi winapi
+        _HWND _pointer _UINT_PTR _DWORD_PTR
+        -> _int32))
+
+(define-comctl32 RemoveWindowSubclass
+  (_fun #:abi winapi
+        _HWND _pointer _UINT_PTR
+        -> _int32))
+
+(define-comctl32 DefSubclassProc
+  (_fun #:abi winapi
+        _HWND _uint32 _WPARAM _LPARAM
+        -> _LRESULT))
+
+(struct tray (frame
+              hwnd
+              id
+              callback-message
+              on-click
+              eventspace
+              event-channel
+              event-thread
+              subclass-proc
+              icon
+              menu
+              closed?)
+  #:mutable)
+
+(define next-tray-id 1)
+
+(define (allocate-tray-id)
+  (define id next-tray-id)
+  (when (> id #xffff)
+    (error 'mk-tray "too many tray icons have been created in this process"))
+  (set! next-tray-id (add1 next-tray-id))
+  id)
+
+(define (bool-result? v)
+  (not (zero? v)))
+
+(define (call-in-eventspace eventspace thunk)
+  (define handler-thread (eventspace-handler-thread eventspace))
+  (unless handler-thread
+    (error 'racket-tray "the frame's eventspace has been shut down"))
+  (if (eq? (current-thread) handler-thread)
+      (parameterize ([current-eventspace eventspace])
+        (thunk))
+      (let ([result-channel (make-channel)])
+        (parameterize ([current-eventspace eventspace])
+          (queue-callback
+           (λ ()
+             (with-handlers ([exn?
+                              (λ (exn)
+                                (channel-put result-channel (cons 'error exn)))])
+               (channel-put result-channel (cons 'ok (thunk)))))))
+        (match (channel-get result-channel)
+          [(cons 'ok value) value]
+          [(cons 'error exn) (raise exn)]))))
+
+(define (make-notify-data hwnd id callback-message icon)
+  (define data
+    (cast (malloc _NOTIFYICONDATAW 'atomic)
+          _pointer
+          _NOTIFYICONDATAW-pointer))
+  (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW))
+  (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW))
+  (set-NOTIFYICONDATAW-hWnd! data hwnd)
+  (set-NOTIFYICONDATAW-uID! data id)
+  (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message)
+  (set-NOTIFYICONDATAW-hIcon! data icon)
+  data)
+
+(define (set-wide-array! array text capacity)
+  (define source (cast text _string/utf-16 _pointer))
+  (for ([i (in-range capacity)])
+    (array-set! array i 0))
+  (let loop ([i 0])
+    (when (< i (sub1 capacity))
+      (let ([code-unit (ptr-ref source _uint16 i)])
+        (unless (zero? code-unit)
+          (array-set! array i code-unit)
+          (loop (add1 i)))))))
+
+(define (load-ico-icon icon-file)
+  (define width (GetSystemMetrics SM_CXSMICON))
+  (define height (GetSystemMetrics SM_CYSMICON))
+  (define icon
+    (LoadImageW #f
+                (path->string (path->complete-path icon-file))
+                IMAGE_ICON
+                width
+                height
+                LR_LOADFROMFILE))
+  (unless icon
+    (error 'mk-tray "could not load ICO file: ~a" icon-file))
+  icon)
+
+(define (png->icon icon-file)
+  ;; Racket's drawing library already decodes PNG and preserves its alpha
+  ;; channel. Scale it to the same system-small-icon size that is used for
+  ;; ICO files, then turn the premultiplied pixels into a native HICON.
+  (define source-bitmap
+    (read-bitmap icon-file 'png/alpha #f #t))
+  (unless (send source-bitmap ok?)
+    (error 'mk-tray "could not load PNG file: ~a" icon-file))
+
+  (define width (max 1 (GetSystemMetrics SM_CXSMICON)))
+  (define height (max 1 (GetSystemMetrics SM_CYSMICON)))
+  (define source-width (send source-bitmap get-width))
+  (define source-height (send source-bitmap get-height))
+
+  ;; Keep the aspect ratio and center non-square images in the tray-icon area.
+  (define scale
+    (min (/ width source-width)
+         (/ height source-height)))
+  (define draw-width (max 1 (inexact->exact (round (* source-width scale)))))
+  (define draw-height (max 1 (inexact->exact (round (* source-height scale)))))
+  (define draw-x (quotient (- width draw-width) 2))
+  (define draw-y (quotient (- height draw-height) 2))
+
+  (define bitmap (make-bitmap width height #t))
+  (define dc (new bitmap-dc% [bitmap bitmap]))
+  (send dc draw-bitmap-section-smooth
+        source-bitmap
+        draw-x
+        draw-y
+        draw-width
+        draw-height
+        0
+        0
+        source-width
+        source-height)
+  (send dc set-bitmap #f)
+
+  (define pixel-count (* width height))
+  (define argb (make-bytes (* pixel-count 4)))
+  (send bitmap get-argb-pixels 0 0 width height argb #f #t)
+
+  (define header
+    (make-BITMAPINFOHEADER
+     (ctype-sizeof _BITMAPINFOHEADER)
+     width
+     (- height) ; negative means top-down, matching Racket's row order
+     1
+     32
+     BI_RGB
+     (* pixel-count 4)
+     0
+     0
+     0
+     0))
+  (define bits-out (malloc _pointer 'atomic))
+  (ptr-set! bits-out _pointer #f)
+  (define color-bitmap
+    (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0))
+  (unless color-bitmap
+    (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file))
+
+  (define mask-bitmap #f)
+  (define (cleanup-bitmaps!)
+    (when mask-bitmap
+      (DeleteObject mask-bitmap)
+      (set! mask-bitmap #f))
+    (when color-bitmap
+      (DeleteObject color-bitmap)
+      (set! color-bitmap #f)))
+
+  (with-handlers ([exn?
+                   (λ (exn)
+                     (cleanup-bitmaps!)
+                     (raise exn))])
+    (define dib-bits (ptr-ref bits-out _pointer))
+    (unless dib-bits
+      (error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file))
+
+    ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order.
+    ;; get-argb-pixels was requested premultiplied because that is the form
+    ;; expected by alpha-blended Windows icons.
+    (for ([pixel (in-range pixel-count)])
+      (define source (* pixel 4))
+      (define alpha (bytes-ref argb source))
+      (define red (bytes-ref argb (+ source 1)))
+      (define green (bytes-ref argb (+ source 2)))
+      (define blue (bytes-ref argb (+ source 3)))
+      (ptr-set! dib-bits _uint8 source blue)
+      (ptr-set! dib-bits _uint8 (+ source 1) green)
+      (ptr-set! dib-bits _uint8 (+ source 2) red)
+      (ptr-set! dib-bits _uint8 (+ source 3) alpha))
+
+    ;; For modern 32-bit alpha icons the color bitmap carries transparency.
+    ;; ICONINFO still requires a same-sized monochrome mask for a color icon.
+    (define mask-stride (* 2 (quotient (+ width 15) 16)))
+    (define mask-size (* mask-stride height))
+    (define mask-bits (malloc mask-size 'atomic))
+    (memset mask-bits 0 0 mask-size)
+    (set! mask-bitmap
+          (CreateBitmap width height 1 1 mask-bits))
+    (unless mask-bitmap
+      (error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file))
+
+    (define icon-info
+      (make-ICONINFO 1 0 0 mask-bitmap color-bitmap))
+    (define icon (CreateIconIndirect icon-info))
+
+    ;; CreateIconIndirect copies both bitmaps, so the source GDI objects can
+    ;; be released immediately. The returned HICON remains owned by us.
+    (cleanup-bitmaps!)
+    (unless icon
+      (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file))
+    icon))
+
+(define (load-icon icon-file)
+  (define name
+    (string-downcase
+     (path->string (path->complete-path icon-file))))
+  (cond
+    [(regexp-match? #rx"[.]ico$" name)
+     (load-ico-icon icon-file)]
+    [(regexp-match? #rx"[.]png$" name)
+     (png->icon icon-file)]
+    [else
+     (error 'mk-tray
+            "expected an .ico or .png icon file; got: ~a"
+            icon-file)]))
+
+(define (low-word value)
+  (bitwise-and value #xffff))
+
+(define (signed-word value)
+  (define n (low-word value))
+  (if (>= n #x8000)
+      (- n #x10000)
+      n))
+
+(define (x-from-wparam wparam)
+  (signed-word wparam))
+
+(define (y-from-wparam wparam)
+  (signed-word (arithmetic-shift wparam -16)))
+
+(define (menu-spec->popup-menu menu-spec)
+  (cond
+    [(not menu-spec) #f]
+    [(is-a? menu-spec popup-menu%) menu-spec]
+    [(list? menu-spec)
+     (let ([popup (new popup-menu%)])
+       (for ([entry (in-list menu-spec)])
+         (match entry
+           [(or #f 'separator)
+            (new separator-menu-item% [parent popup])]
+           [(list (? string? label) (? procedure? callback))
+            (unless (procedure-arity-includes? callback 0)
+              (error 'tray-set-menu!
+                     "menu callback for ~e does not accept zero arguments"
+                     label))
+            (new menu-item%
+                 [parent popup]
+                 [label label]
+                 [callback (λ (_item _event) (callback))])]
+           [_
+            (error 'tray-set-menu!
+                   "expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e"
+                   entry)]))
+       popup)]
+    [else
+     (error 'tray-set-menu!
+            "expected a popup-menu%, menu specification list, or #f; got: ~e"
+            menu-spec)]))
+
+(define (queue-eventspace-callback t thunk)
+  (define eventspace (tray-eventspace t))
+  (unless (eventspace-shutdown? eventspace)
+    (with-handlers ([exn:fail? (λ (_exn) (void))])
+      (parameterize ([current-eventspace eventspace])
+        (queue-callback
+         (λ ()
+           (unless (tray-closed? t)
+             (thunk))))))))
+
+(define (start-event-thread! t)
+  (define event-thread
+    (thread
+     (λ ()
+       (let loop ()
+         (match (sync (tray-event-channel t))
+           ['close
+            (void)]
+           ['activate
+            (let ([callback (tray-on-click t)])
+              (when callback
+                (queue-eventspace-callback t callback)))
+            (loop)]
+           [(vector 'context-menu screen-x screen-y)
+            (queue-eventspace-callback
+             t
+             (λ ()
+               (define menu (tray-menu t))
+               (when menu
+                 (let-values ([(x y)
+                               (send (tray-frame t)
+                                     screen->client
+                                     screen-x
+                                     screen-y)])
+                   (send (tray-frame t) popup-menu menu x y)))))
+            (loop)]
+           [_
+            (loop)])))))
+  (set-tray-event-thread! t event-thread))
+
+(define (handle-native-tray-event t wparam lparam)
+  ;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or
+  ;; user code here. An OS async channel is explicitly safe to use from an OS
+  ;; callback/thread, so forward the event to an ordinary Racket thread.
+  (define notification (low-word lparam))
+  (cond
+    [(or (= notification NIN_SELECT)
+         (= notification NIN_KEYSELECT))
+     (os-async-channel-put (tray-event-channel t) 'activate)]
+    [(= notification WM_CONTEXTMENU)
+     (os-async-channel-put
+      (tray-event-channel t)
+      (vector 'context-menu
+              (x-from-wparam wparam)
+              (y-from-wparam wparam)))]
+    [else
+     (void)]))
+
+(define (make-subclass-proc t)
+  (λ (hwnd msg wparam lparam subclass-id ref-data)
+    (cond
+      [(= msg (tray-callback-message t))
+       (handle-native-tray-event t wparam lparam)
+       0]
+      [(= msg WM_NCDESTROY)
+       ;; The HWND is going away. Remove the notification-area icon while the
+       ;; handle is still valid. Windows discards the subclass automatically
+       ;; as part of window destruction.
+       (unless (tray-closed? t)
+         (let ([data
+                (make-notify-data hwnd
+                                  (tray-id t)
+                                  (tray-callback-message t)
+                                  (tray-icon t))])
+           (Shell_NotifyIconW NIM_DELETE data)
+           (when (tray-icon t)
+             (DestroyIcon (tray-icon t))
+             (set-tray-icon! t #f))
+           (set-tray-closed?! t #t)
+           (os-async-channel-put (tray-event-channel t) 'close)))
+       (DefSubclassProc hwnd msg wparam lparam)]
+      [else
+       (DefSubclassProc hwnd msg wparam lparam)])))
+
+(define (add-notify-icon! t icon tooltip)
+  (define data
+    (make-notify-data (tray-hwnd t)
+                      (tray-id t)
+                      (tray-callback-message t)
+                      icon))
+  (set-NOTIFYICONDATAW-uFlags!
+   data
+   (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP))
+  (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128)
+
+  (unless (bool-result? (Shell_NotifyIconW NIM_ADD data))
+    (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon"))
+
+  (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4)
+  (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data))
+    (Shell_NotifyIconW NIM_DELETE data)
+    (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4")))
+
+(define (mk-tray frame icon-file on-click-cb)
+  (unless (is-a? frame top-level-window<%>)
+    (raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame))
+  (unless (or (not on-click-cb)
+              (and (procedure? on-click-cb)
+                   (procedure-arity-includes? on-click-cb 0)))
+    (raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb))
+
+  (define eventspace (send frame get-eventspace))
+  (call-in-eventspace
+   eventspace
+   (λ ()
+     (define hwnd (send frame get-handle))
+     (unless hwnd
+       (error 'mk-tray "the frame does not have a native HWND"))
+
+     (let* ([id (allocate-tray-id)]
+            [callback-message (+ WM_APP id)]
+            [icon (load-icon icon-file)]
+            [t (tray frame
+                     hwnd
+                     id
+                     callback-message
+                     on-click-cb
+                     eventspace
+                     (make-os-async-channel)
+                     #f
+                     #f
+                     icon
+                     #f
+                     #f)]
+            [subclass-proc
+             (function-ptr (make-subclass-proc t) _SUBCLASSPROC)])
+       ;; WM_APP through 0xBFFF is reserved for application-private messages.
+       (when (> callback-message #xbfff)
+         (DestroyIcon icon)
+         (error 'mk-tray
+                "too many simultaneously addressable tray callback messages"))
+
+       (set-tray-subclass-proc! t subclass-proc)
+       (start-event-thread! t)
+
+       (unless (bool-result?
+                (SetWindowSubclass hwnd subclass-proc id 0))
+         (os-async-channel-put (tray-event-channel t) 'close)
+         (DestroyIcon icon)
+         (error 'mk-tray "SetWindowSubclass failed for the Racket frame"))
+
+       (with-handlers ([exn?
+                        (λ (exn)
+                          (RemoveWindowSubclass hwnd subclass-proc id)
+                          (os-async-channel-put (tray-event-channel t) 'close)
+                          (DestroyIcon icon)
+                          (raise exn))])
+         (define frame-label (send frame get-label))
+         (add-notify-icon! t icon
+                           (if (string? frame-label) frame-label "Racket"))
+         t)))))
+
+(define (check-open-tray who t)
+  (unless (tray? t)
+    (raise-argument-error who "tray?" t))
+  (when (tray-closed? t)
+    (error who "tray icon is already closed")))
+
+(define (tray-close t)
+  (unless (tray? t)
+    (raise-argument-error 'tray-close "tray?" t))
+  (unless (tray-closed? t)
+    (call-in-eventspace
+     (tray-eventspace t)
+     (λ ()
+       (unless (tray-closed? t)
+         (let ([data
+                (make-notify-data (tray-hwnd t)
+                                  (tray-id t)
+                                  (tray-callback-message t)
+                                  (tray-icon t))])
+           (Shell_NotifyIconW NIM_DELETE data)
+           (RemoveWindowSubclass (tray-hwnd t)
+                                 (tray-subclass-proc t)
+                                 (tray-id t))
+           (when (tray-icon t)
+             (DestroyIcon (tray-icon t))
+             (set-tray-icon! t #f))
+           (set-tray-closed?! t #t)
+           (os-async-channel-put (tray-event-channel t) 'close))))))
+  (void))
+
+(define (tray-set-icon! t icon-file)
+  (check-open-tray 'tray-set-icon! t)
+  (call-in-eventspace
+   (tray-eventspace t)
+   (λ ()
+     (define new-icon (load-icon icon-file))
+     (define data
+       (make-notify-data (tray-hwnd t)
+                         (tray-id t)
+                         (tray-callback-message t)
+                         new-icon))
+     (set-NOTIFYICONDATAW-uFlags! data NIF_ICON)
+     (cond
+       [(bool-result? (Shell_NotifyIconW NIM_MODIFY data))
+        (let ([old-icon (tray-icon t)])
+          (set-tray-icon! t new-icon)
+          (when old-icon
+            (DestroyIcon old-icon)))]
+       [else
+        (DestroyIcon new-icon)
+        (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")]))))
+
+(define (tray-set-menu! t menu-spec)
+  (check-open-tray 'tray-set-menu! t)
+  (call-in-eventspace
+   (tray-eventspace t)
+   (λ ()
+     (set-tray-menu! t (menu-spec->popup-menu menu-spec))))
+  (void))