hans/racket-tray
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

implemented

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 01:09:49 +02:00
parent b8a522c1de
commit c7137fc11f
7 changed files with 588 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/windows.rkt
+341 -8
View File
@@ -14,6 +14,10 @@
tray-set-icon!
tray-set-menu!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Windows constants and native types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Shell_NotifyIcon constants
(define NIM_ADD #x00000000)
(define NIM_MODIFY #x00000001)
@@ -27,7 +31,8 @@
(define NOTIFYICON_VERSION_4 4)
;; Window messages used by NOTIFYICON_VERSION_4.
;; Window messages used by the tray integration.
(define WM_SIZE #x0005)
(define WM_CONTEXTMENU #x007B)
(define WM_NCDESTROY #x0082)
(define WM_USER #x0400)
@@ -35,6 +40,8 @@
(define NIN_SELECT (+ WM_USER 0))
(define NIN_KEYSELECT (+ WM_USER 1))
(define SIZE_MINIMIZED 1)
(define IMAGE_ICON 1)
(define LR_LOADFROMFILE #x00000010)
(define SM_CXSMICON 49)
@@ -92,6 +99,12 @@
[guidItem (_array _uint8 16)]
[hBalloonIcon _HICON]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Native Windows bindings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; shell32 owns the notification-area API; user32/gdi32 provide icon
;; creation and destruction; comctl32 provides safe window subclassing.
(define shell32 (ffi-lib "shell32.dll"))
(define user32 (ffi-lib "user32.dll"))
(define gdi32 (ffi-lib "gdi32.dll"))
@@ -102,63 +115,82 @@
(define-ffi-definer define-gdi32 gdi32)
(define-ffi-definer define-comctl32 comctl32)
;; Adds, modifies, configures, or removes a notification-area icon.
(define-shell32 Shell_NotifyIconW
(_fun #:abi winapi
_uint32 _NOTIFYICONDATAW-pointer
-> _int32))
;; Loads a native HICON from an ICO file. The returned icon is owned by us.
(define-user32 LoadImageW
(_fun #:abi winapi
_pointer _string/utf-16 _uint32 _int32 _int32 _uint32
-> _pointer))
;; Releases an HICON that was loaded or created by this module.
(define-user32 DestroyIcon
(_fun #:abi winapi _HICON -> _int32))
;; Creates an HICON by copying the HBITMAP values in ICONINFO.
(define-user32 CreateIconIndirect
(_fun #:abi winapi _ICONINFO-pointer -> _HICON))
;; Returns the current Windows small-icon dimensions.
(define-user32 GetSystemMetrics
(_fun #:abi winapi _int32 -> _int32))
;; Creates the 32-bit color bitmap used while converting PNG to HICON.
(define-gdi32 CreateDIBSection
(_fun #:abi winapi
_pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32
-> _HBITMAP))
;; Creates the monochrome mask required by ICONINFO.
(define-gdi32 CreateBitmap
(_fun #:abi winapi
_int32 _int32 _uint32 _uint32 _pointer
-> _HBITMAP))
;; Releases temporary GDI bitmap objects after CreateIconIndirect copies them.
(define-gdi32 DeleteObject
(_fun #:abi winapi _pointer -> _int32))
;; Native callback signature used by SetWindowSubclass.
(define _SUBCLASSPROC
(_fun #:abi winapi
_HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR
-> _LRESULT))
;; Adds our message hook without replacing Racket GUI's own window procedure.
(define-comctl32 SetWindowSubclass
(_fun #:abi winapi
_HWND _pointer _UINT_PTR _DWORD_PTR
-> _int32))
;; Detaches the hook installed for an open tray object.
(define-comctl32 RemoveWindowSubclass
(_fun #:abi winapi
_HWND _pointer _UINT_PTR
-> _int32))
;; Forwards every message that racket-tray does not consume.
(define-comctl32 DefSubclassProc
(_fun #:abi winapi
_HWND _uint32 _WPARAM _LPARAM
-> _LRESULT))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A tray object owns its HICON and native subclass registration. The HWND is
;; owned by the Racket top-level window and must never be destroyed here.
(struct tray (frame
hwnd
id
callback-message
on-click
hide-on-minimize?
eventspace
event-channel
event-thread
@@ -170,6 +202,20 @@
(define next-tray-id 1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Allocate a process-local identifier for a tray icon.
; pre : next-tray-id contains the next unused positive identifier.
; post : next-tray-id is advanced by one when allocation succeeds.
; result : A unique integer in the range 1 through #xffff.
; internals:
; The identifier is also used to derive the private WM_APP callback
; message. Limiting it to 16 bits keeps that message in the range
; reserved by Windows for application-private messages.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (allocate-tray-id)
(define id next-tray-id)
(when (> id #xffff)
@@ -177,9 +223,30 @@
(set! next-tray-id (add1 next-tray-id))
id)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Convert a Win32 BOOL-style result to a Racket boolean.
; pre : v is an exact integer returned by a Win32 procedure.
; post : No state is changed.
; result : #t for every non-zero value, #f for zero.
; internals:
; Win32 BOOL values are integers rather than Racket booleans.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (bool-result? v)
(not (zero? v)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run thunk synchronously in the handler thread of eventspace.
; pre : eventspace is a live Racket GUI eventspace and thunk accepts no
; arguments.
; post : thunk has completed, or its exception has been re-raised in the
; calling thread.
; result : The value returned by thunk.
; internals:
; When already in the handler thread, thunk is called directly.
; Otherwise queue-callback schedules it and a channel transfers its
; value or exception back to the caller. This keeps HWND operations
; on the GUI thread that owns the window.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (call-in-eventspace eventspace thunk)
(define handler-thread (eventspace-handler-thread eventspace))
(unless handler-thread
@@ -199,6 +266,17 @@
[(cons 'ok value) value]
[(cons 'error exn) (raise exn)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Allocate and initialize a NOTIFYICONDATAW structure.
; pre : hwnd is a valid HWND, id and callback-message are valid unsigned
; integer values, and icon is either an HICON or #f.
; post : A zero-initialized native structure has been filled with the common
; tray fields; the caller may add flags and text fields afterwards.
; result : A pointer to NOTIFYICONDATAW allocated in atomic memory.
; internals:
; Atomic memory is used because the structure is passed directly to
; Win32 without containing Racket-managed pointers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-notify-data hwnd id callback-message icon)
(define data
(cast (malloc _NOTIFYICONDATAW 'atomic)
@@ -212,6 +290,17 @@
(set-NOTIFYICONDATAW-hIcon! data icon)
data)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Copy a Racket string into a fixed-size UTF-16 Win32 array.
; pre : array has room for capacity UTF-16 code units and capacity is at
; least one.
; post : array contains a zero-terminated copy of text, truncated when
; necessary to leave room for the terminating zero.
; result : Unspecified; array is modified in place.
; internals:
; The destination is cleared first so truncation always leaves a
; valid zero-terminated Win32 string.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-wide-array! array text capacity)
(define source (cast text _string/utf-16 _pointer))
(for ([i (in-range capacity)])
@@ -223,6 +312,19 @@
(array-set! array i code-unit)
(loop (add1 i)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Icon loading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Load an ICO file as a native Windows small icon.
; pre : icon-file names an existing ICO file readable by Windows.
; post : On success a new HICON is owned by the caller.
; result : A non-#f HICON; raises an exception when LoadImageW fails.
; internals:
; Windows is asked for the current SM_CXSMICON/SM_CYSMICON size so
; the shell receives an icon already sized for the notification area.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (load-ico-icon icon-file)
(define width (GetSystemMetrics SM_CXSMICON))
(define height (GetSystemMetrics SM_CYSMICON))
@@ -237,6 +339,20 @@
(error 'mk-tray "could not load ICO file: ~a" icon-file))
icon)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Convert a PNG file with alpha transparency to a native HICON.
; pre : icon-file names a readable PNG image and the Windows GDI functions
; needed to create bitmaps and icons are available.
; post : Temporary HBITMAP objects are released before return; on success
; the returned HICON is owned by the caller.
; result : A non-#f HICON; raises an exception when decoding or native icon
; creation fails.
; internals:
; Racket decodes and scales the PNG. Premultiplied ARGB pixels are
; copied into a top-down 32-bit DIB in Windows BGRA byte order.
; CreateIconIndirect copies the color and mask bitmaps, allowing the
; temporary GDI objects to be deleted immediately afterwards.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
@@ -299,6 +415,16 @@
(error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file))
(define mask-bitmap #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Release temporary GDI bitmaps created during PNG conversion.
; pre : color-bitmap and mask-bitmap are HBITMAP values or #f.
; post : Every non-#f bitmap is deleted and its local variable is set to
; #f, making repeated cleanup safe.
; result : Unspecified.
; internals:
; This local helper is used on both the normal and exceptional
; CreateIconIndirect paths so temporary GDI objects never leak.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cleanup-bitmaps!)
(when mask-bitmap
(DeleteObject mask-bitmap)
@@ -351,6 +477,15 @@
(error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file))
icon))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Load a supported icon file into a native HICON.
; pre : icon-file is a path-string naming an .ico or .png file.
; post : On success the caller owns the returned HICON.
; result : An HICON loaded by load-ico-icon or created by png->icon.
; internals:
; Dispatch is deliberately based only on the filename extension so
; the public API stays predictable and small.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (load-icon icon-file)
(define name
(string-downcase
@@ -365,21 +500,70 @@
"expected an .ico or .png icon file; got: ~a"
icon-file)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Extract the low 16 bits from a pointer-sized Win32 value.
; pre : value is an exact integer.
; post : No state is changed.
; result : An integer in the range 0 through #xffff.
; internals:
; Tray notification codes are packed into the low word of LPARAM.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (low-word value)
(bitwise-and value #xffff))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Interpret the low 16 bits of value as a signed Windows coordinate.
; pre : value is an exact integer.
; post : No state is changed.
; result : An integer in the signed 16-bit range.
; internals:
; WM_CONTEXTMENU packs signed screen coordinates into WORD values;
; values >= #x8000 therefore represent negative coordinates.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (signed-word value)
(define n (low-word value))
(if (>= n #x8000)
(- n #x10000)
n))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Extract the signed X coordinate supplied by a tray notification.
; pre : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
; post : No state is changed.
; result : The signed screen X coordinate from the low word of wparam.
; internals:
; NOTIFYICON_VERSION_4 packs the anchor coordinates in WPARAM.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (x-from-wparam wparam)
(signed-word wparam))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Extract the signed Y coordinate supplied by a tray notification.
; pre : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
; post : No state is changed.
; result : The signed screen Y coordinate from the high word of wparam.
; internals:
; The high word is shifted down before signed-word interprets it.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (y-from-wparam wparam)
(signed-word (arithmetic-shift wparam -16)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Event and menu handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Normalize a public tray menu specification to popup-menu%.
; pre : menu-spec is #f, a popup-menu%, or a list containing two-element
; (label callback) lists and separator markers.
; post : Newly created menu items hold callbacks that invoke the supplied
; zero-argument procedures.
; result : #f, the original popup-menu%, or a newly created popup-menu%.
; internals:
; A simple list is converted directly to Racket GUI menu objects so
; menu callbacks remain ordinary Racket GUI callbacks rather than
; native Win32 callback code.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (menu-spec->popup-menu menu-spec)
(cond
[(not menu-spec) #f]
@@ -409,6 +593,16 @@
"expected a popup-menu%, menu specification list, or #f; got: ~e"
menu-spec)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Queue application work on the eventspace associated with tray t.
; pre : t is a tray object and thunk accepts no arguments.
; post : When the eventspace is live, thunk is queued; it is skipped when
; the tray has been closed before execution.
; result : Unspecified.
; internals:
; Shutdown races are intentionally ignored here because native tray
; messages can arrive while the GUI is being torn down.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (queue-eventspace-callback t thunk)
(define eventspace (tray-eventspace t))
(unless (eventspace-shutdown? eventspace)
@@ -419,6 +613,17 @@
(unless (tray-closed? t)
(thunk))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Start the ordinary Racket thread that dispatches native tray events.
; pre : t is a newly created tray with an event channel and no event thread.
; post : tray-event-thread contains the new dispatcher thread; the thread
; exits after receiving the symbol 'close.
; result : Unspecified; t is modified in place.
; internals:
; Native FFI callbacks only write small immutable event values to the
; OS async channel. This thread receives those values outside atomic
; FFI callback mode and queues GUI/user work into the frame eventspace.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (start-event-thread! t)
(define event-thread
(thread
@@ -432,6 +637,14 @@
(when callback
(queue-eventspace-callback t callback)))
(loop)]
['minimize
(queue-eventspace-callback
t
(λ ()
;; Hiding instead of iconizing removes the application from the
;; taskbar while keeping the HWND alive for the tray icon.
(send (tray-frame t) show #f)))
(loop)]
[(vector 'context-menu screen-x screen-y)
(queue-eventspace-callback
t
@@ -449,6 +662,18 @@
(loop)])))))
(set-tray-event-thread! t event-thread))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Translate a Shell_NotifyIcon callback message to an internal event.
; pre : t is an open tray and wparam/lparam are the values supplied by the
; native tray callback message.
; post : Recognized activation or context-menu events are written to the
; tray OS async channel; no GUI or user callback is run directly.
; result : void.
; internals:
; Racket CS executes foreign callbacks in atomic mode. Using
; os-async-channel-put here is safe and postpones ordinary Racket and
; GUI work until start-event-thread! receives the event.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
@@ -467,12 +692,35 @@
[else
(void)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Native window integration
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create the Win32 subclass procedure used by a tray object.
; pre : t contains the HWND, callback message, event channel and tray state
; required by the native callback.
; post : No subclass is installed by this procedure itself.
; result : A Racket procedure with the SUBCLASSPROC calling convention.
; internals:
; The procedure handles only the private tray callback, optional
; WM_SIZE/SIZE_MINIMIZED handling, and WM_NCDESTROY cleanup. Every
; other message is passed unchanged to DefSubclassProc so Racket's
; own window procedure remains in control.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-subclass-proc t)
(λ (hwnd msg wparam lparam subclass-id ref-data)
(λ (hwnd msg wparam lparam _subclass-id _ref-data)
(cond
[(= msg (tray-callback-message t))
(handle-native-tray-event t wparam lparam)
0]
[(and (= msg WM_SIZE)
(= wparam SIZE_MINIMIZED)
(tray-hide-on-minimize? t))
;; Forward only a small value from the native callback. GUI work is
;; performed later on the frame's eventspace.
(os-async-channel-put (tray-event-channel t) 'minimize)
(DefSubclassProc hwnd msg wparam lparam)]
[(= msg WM_NCDESTROY)
;; The HWND is going away. Remove the notification-area icon while the
;; handle is still valid. Windows discards the subclass automatically
@@ -493,6 +741,20 @@
[else
(DefSubclassProc hwnd msg wparam lparam)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Register tray t in the Windows notification area.
; pre : t has a live HWND and installed subclass; icon is a valid HICON and
; tooltip is a string.
; post : On success the shell owns a notification-area entry for t and it is
; configured for NOTIFYICON_VERSION_4 semantics.
; result : Unspecified; raises an exception when registration or version setup
; fails.
; internals:
; NIM_ADD installs the icon and callback message. NIM_SETVERSION is
; issued immediately afterwards so keyboard/context-menu events use
; the current notification protocol. A failed version setup removes
; the just-added icon again.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-notify-icon! t icon tooltip)
(define data
(make-notify-data (tray-hwnd t)
@@ -512,9 +774,50 @@
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Validate that t is a tray object that is still open.
; pre : who is a symbol naming the calling procedure.
; post : No state is changed.
; result : Unspecified when valid; otherwise raises a precise argument/state
; exception for the calling procedure.
; internals:
; Centralizing this check keeps the mutating public procedures small
; without introducing a wider abstraction layer.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a Windows notification-area icon bound to a Racket window.
; pre : frame implements top-level-window<%>, has a native HWND, icon-file
; names a supported icon, on-click-cb is #f or a zero-argument
; procedure, and hide-on-minimize? is boolean.
; post : A native icon is registered, the frame HWND is subclassed, and an
; event-dispatch thread is running. On failure, resources created up
; to that point are released.
; result : A mutable tray object used by tray-close, tray-set-icon! and
; tray-set-menu!.
; internals:
; Creation is performed in the frame's eventspace because the HWND
; belongs to that GUI thread. The existing Racket HWND is reused;
; SetWindowSubclass observes tray/minimize messages without replacing
; Racket's own WndProc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-tray frame
icon-file
on-click-cb
#:hide-on-minimize? [hide-on-minimize? #f])
(unless (is-a? frame top-level-window<%>)
(raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame))
(unless (boolean? hide-on-minimize?)
(raise-argument-error 'mk-tray "boolean?" hide-on-minimize?))
(unless (or (not on-click-cb)
(and (procedure? on-click-cb)
(procedure-arity-includes? on-click-cb 0)))
@@ -536,6 +839,7 @@
id
callback-message
on-click-cb
hide-on-minimize?
eventspace
(make-os-async-channel)
#f
@@ -571,12 +875,19 @@
(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")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Remove a tray icon and release all native resources owned by it.
; pre : t is a tray object; calling tray-close repeatedly is allowed.
; post : The shell icon is removed, the HWND subclass is detached, the HICON
; is destroyed, the tray is marked closed, and its event thread is
; told to stop.
; result : void.
; internals:
; Cleanup runs in the frame eventspace so subclass removal happens on
; the window-owning GUI thread. The closed? check makes cleanup
; idempotent and avoids double-destroying the HICON.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-close t)
(unless (tray? t)
(raise-argument-error 'tray-close "tray?" t))
@@ -601,6 +912,17 @@
(os-async-channel-put (tray-event-channel t) 'close))))))
(void))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Replace the image of an existing notification-area icon.
; pre : t is an open tray and icon-file names a readable .ico or .png file.
; post : On success the shell and tray object use the new HICON and the old
; HICON is destroyed. On failure the new HICON is destroyed and the
; existing tray icon remains unchanged.
; result : Unspecified.
; internals:
; NIM_MODIFY is issued with only NIF_ICON set. Ownership is swapped
; only after Windows accepts the new native icon.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-icon! t icon-file)
(check-open-tray 'tray-set-icon! t)
(call-in-eventspace
@@ -623,6 +945,17 @@
(DestroyIcon new-icon)
(error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Associate a context menu with an existing tray object.
; pre : t is an open tray and menu-spec is accepted by
; menu-spec->popup-menu.
; post : tray-menu contains #f or a popup-menu% ready to be shown on the
; frame eventspace when Windows reports WM_CONTEXTMENU.
; result : void.
; internals:
; Menu creation is performed in the frame eventspace because Racket
; GUI objects must belong to the appropriate GUI eventspace.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-menu! t menu-spec)
(check-open-tray 'tray-set-menu! t)
(call-in-eventspace