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
.gitignore
+2
View File
@@ -15,3 +15,5 @@ compiled/
# Dependency tracking files
*.dep
*.bak
README.md
+31 -16
View File
@@ -2,46 +2,61 @@
A small system tray API for Racket.
Version 0.1 implements Windows directly through the Win32 API. It uses the
native `HWND` of an existing Racket `frame%`/`dialog%`, `Shell_NotifyIconW`, and
`SetWindowSubclass`. No additional native DLL is required.
Version 0.1.1 implements Windows directly through the Win32 API. It uses the
native `HWND` of an existing Racket `frame%` or `dialog%`, `Shell_NotifyIconW`,
and `SetWindowSubclass`. No additional native DLL is required.
```racket
#lang racket/gui
(require racket-tray)
(define frame
(new frame%
[label "Tray example"]
[width 400]
[height 250]))
(define tray-frame%
(class frame%
(super-new [label "Tray example"]
[width 400]
[height 250])
;; Close [X] to the tray instead of destroying the frame.
(define/override (on-close)
(send this show #f))))
(define frame (new tray-frame%))
(define (show-frame)
(send frame show #t)
(when (send frame is-iconized?)
(send frame iconize #f)))
(define tray
(mk-tray frame
"example.png"
(λ ()
(send frame show #t))))
show-frame
#:hide-on-minimize? #t))
(tray-set-menu!
tray
(list
(list "Open"
(λ () (send frame show #t)))
(list "Open" show-frame)
'separator
(list "Exit"
(λ ()
(tray-close tray)
(send frame show #f)))))
(exit)))))
(send frame show #t)
```
`mk-tray` and `tray-set-icon!` accept both Windows `.ico` files and `.png`
files. PNG transparency is preserved when the image is converted to the native
files. PNG transparency is preserved when the image is converted to a native
Windows tray icon.
`tray-set-menu!` also accepts a `popup-menu%` object directly, or `#f` to
remove the context menu.
With `#:hide-on-minimize? #t`, minimizing the associated window hides it from
the taskbar while keeping its native window handle alive. Closing a window to
the tray does not need a separate tray API: override `frame%`'s `on-close` and
call `(send this show #f)`.
`tray-set-menu!` accepts a `popup-menu%` object directly, a simple menu list,
or `#f` to remove the context menu.
At the moment non-Windows platforms report that the operation is unsupported.
examples/simple.rkt
+40 -8
View File
@@ -3,39 +3,71 @@
;(require racket-tray)
(require "../main.rkt")
;; This example demonstrates the two common "close to tray" behaviours:
;;
;; * minimize: handled by racket-tray through #:hide-on-minimize?
;; * close [X]: handled by frame%'s normal on-close callback
;;
;; The frame remains alive in both cases because the tray icon uses its HWND.
(define simple%
(class frame%
(super-new [label "Racket Tray"]
[width 400]
[height 250])
(define lbl (new message% [label "Counting tray clicks"] [parent this]
[auto-resize #t] [stretchable-width #t]))
(define lbl
(new message%
[label "Counting tray clicks"]
[parent this]
[auto-resize #t]
[stretchable-width #t]))
(define count 0)
(define/public (count-next)
(set! count (+ count 1))
(send lbl set-label (format "Counting tray clicks: ~a" count)))
))
(set! count (add1 count))
(send lbl set-label
(format "Counting tray clicks: ~a" count)))
;; Clicking the window's close button hides the frame instead of
;; destroying it. The tray menu's Exit item terminates the application.
(define/override (on-close)
(send this show #f))))
(define frame (new simple%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Show and restore the example frame from the tray.
; pre : frame has been created and has not been destroyed.
; post : frame is visible and no longer iconized.
; result : Unspecified.
; internals:
; A frame hidden in response to SIZE_MINIMIZED can still retain its
; iconized state, so show #t is followed by iconize #f when needed.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (show-frame)
;; A frame hidden after a minimize can still be iconized. Make sure it is
;; restored when it is opened from the tray.
(send frame show #t)
(when (send frame is-iconized?)
(send frame iconize #f)))
(define tray
(mk-tray frame
"simple.png"
(λ ()
(send frame count-next)
(send frame show #t))))
(show-frame))
#:hide-on-minimize? #t))
(tray-set-menu!
tray
(list
(list "Open" (λ () (send frame show #t)))
(list "Open" show-frame)
'separator
(list "Exit"
(λ ()
(tray-close tray)
(send frame show #f)))))
(exit)))))
(send frame show #t)
main.rkt
+95 -23
View File
@@ -7,33 +7,105 @@
tray-set-icon!
tray-set-menu!)
(define (unsupported who . _args)
(error who "not supported on this operating system: ~a" (system-type 'os*)))
(define mk-tray
(λ args
(apply unsupported 'mk-tray args)))
(define tray-close
(λ args
(apply unsupported 'tray-close args)))
(define tray-set-icon!
(λ args
(apply unsupported 'tray-set-icon! args)))
(define tray-set-menu!
(λ args
(apply unsupported 'tray-set-menu! args)))
;; The platform implementation is loaded dynamically so that requiring
;; racket-tray remains possible on platforms that do not yet have a backend.
(define-runtime-module-path windows-module "private/windows.rkt")
(define platform-mk-tray #f)
(define platform-tray-close #f)
(define platform-tray-set-icon! #f)
(define platform-tray-set-menu! #f)
(when (eq? (system-type 'os*) 'windows)
(set! mk-tray
(set! platform-mk-tray
(dynamic-require windows-module 'mk-tray))
(set! tray-close
(set! platform-tray-close
(dynamic-require windows-module 'tray-close))
(set! tray-set-icon!
(set! platform-tray-set-icon!
(dynamic-require windows-module 'tray-set-icon!))
(set! tray-set-menu!
(set! platform-tray-set-menu!
(dynamic-require windows-module 'tray-set-menu!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Report that the current operating system has no tray backend.
; pre : who is the name of the public procedure being called.
; post : No state is changed.
; result : Does not return; raises an exception naming the unsupported OS.
; internals:
; The public module remains loadable on every platform; only an
; attempted tray operation fails when no backend was loaded.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (unsupported who)
(error who "not supported on this operating system: ~a" (system-type 'os*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a tray icon using the backend for the current platform.
; pre : frame, icon-file, on-click-cb and hide-on-minimize? satisfy the
; requirements documented for mk-tray.
; post : On a supported platform a tray icon is created; otherwise an
; unsupported-platform exception is raised.
; result : The platform tray value accepted by the other public procedures.
; internals:
; This module is a small platform-neutral dispatcher. Windows code is
; loaded dynamically only on Windows so requiring racket-tray remains
; possible on other operating systems.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-tray frame
icon-file
on-click-cb
#:hide-on-minimize? [hide-on-minimize? #f])
(if platform-mk-tray
(platform-mk-tray frame
icon-file
on-click-cb
#:hide-on-minimize? hide-on-minimize?)
(unsupported 'mk-tray)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Close a tray icon through the active platform backend.
; pre : tray is a value previously returned by mk-tray.
; post : Platform tray resources are released on supported systems.
; result : void on success; raises when the platform is unsupported.
; internals:
; All resource ownership and idempotence rules are implemented by the
; platform backend.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-close tray)
(if platform-tray-close
(platform-tray-close tray)
(unsupported 'tray-close)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Replace the image of an existing tray icon.
; pre : tray is open and icon-file names a format supported by the backend.
; post : The active tray image is replaced when the backend succeeds.
; result : The backend result; the Windows implementation returns void.
; internals:
; The public facade performs no image conversion itself.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-icon! tray icon-file)
(if platform-tray-set-icon!
(platform-tray-set-icon! tray icon-file)
(unsupported 'tray-set-icon!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Set or remove the context menu of an existing tray icon.
; pre : tray is open and menu is accepted by the active backend.
; post : The tray uses the supplied menu specification on success.
; result : void on Windows; raises when the platform is unsupported.
; internals:
; Menu normalization belongs to the platform implementation because
; native event integration is platform-specific.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-menu! tray menu)
(if platform-tray-set-menu!
(platform-tray-set-menu! tray menu)
(unsupported 'tray-set-menu!)))
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
scrbl/racket-tray.scrbl
+69 -16
View File
@@ -6,39 +6,92 @@
racket-tray))
@title{Racket Tray}
@author{hnmdijkema}
@author{Hans Dijkema / hans@dijkewijk.nl}
@defmodule[racket-tray]
Racket Tray provides a small system-tray API. Version 0.1 supports Windows.
The Windows implementation uses the native handle of an existing Racket GUI
top-level window and does not require an additional native library.
Racket Tray provides a small API for adding a system tray icon to a Racket GUI
application. Version 0.1.1 supports Windows. The Windows implementation uses
the native @tt{HWND} of an existing Racket top-level window and requires no
additional native library.
@section{Creating a Tray Icon}
@defproc[(mk-tray [frame (is-a?/c top-level-window<%>)]
[icon-file path-string?]
[on-click-cb (or/c #f (-> any))])
[on-click-cb (or/c #f (-> any))]
[#:hide-on-minimize? hide-on-minimize? boolean? #f])
any/c]{
Creates a tray icon associated with @racket[frame]. @racket[icon-file] can be
a Windows @tt{.ico} file or a @tt{.png} file. PNG alpha transparency is
preserved. When the tray icon is activated, @racket[on-click-cb] is queued in
the eventspace of @racket[frame]. The returned value is passed to the other
Creates a tray icon associated with @racket[frame]. The frame must already
have a native window handle. A @racket[frame%] or @racket[dialog%] is suitable.
@racket[icon-file] can be a Windows @tt{.ico} file or a @tt{.png} file. PNG
alpha transparency is preserved when the image is converted to a native
Windows icon.
When the tray icon is activated, @racket[on-click-cb] is queued in the
eventspace of @racket[frame]. Use @racket[#f] when no activation callback is
needed.
When @racket[hide-on-minimize?] is true, minimizing the associated window
hides it after Windows reports @tt{SIZE_MINIMIZED}. Hiding the window removes
it from the taskbar while leaving its native handle alive for the tray icon.
When showing such a window again, an application can restore it with
@racket[(send frame iconize #f)] when @racket[(send frame is-iconized?)] is
true.
The returned value represents the tray icon and is accepted by the other
procedures in this library.
}
@defproc[(tray-close [tray any/c]) void?]{
Removes the tray icon and releases the Windows resources associated with it.
}
@section{Changing and Closing a Tray Icon}
@defproc[(tray-set-icon! [tray any/c]
[icon-file path-string?]) void?]{
Replaces the icon of @racket[tray] with the icon loaded from
@racket[icon-file]. Both @tt{.ico} and @tt{.png} files are accepted.
Replaces the image of @racket[tray]. Both @tt{.ico} and @tt{.png} files are
accepted.
}
@defproc[(tray-set-menu! [tray any/c]
[menu any/c]) void?]{
Sets the context menu for @racket[tray]. @racket[menu] can be a
@racket[popup-menu%], @racket[#f], or a list. A list entry of the form
@racket[(list label callback)] creates an item, while @racket['separator] or
@racket[#f] creates a separator. Each callback is a zero-argument procedure.
@racket[(list label callback)] creates a menu item. @racket['separator] and
@racket[#f] create a separator. Each callback must accept zero arguments.
}
@defproc[(tray-close [tray any/c]) void?]{
Removes @racket[tray], detaches its native window hook, and releases the
Windows icon resources owned by the tray object. Calling this procedure does
not close the associated Racket window.
}
@section{Closing a Window to the Tray}
Racket already provides @method[frame% on-close] for handling the close button
of a frame. A tray application normally overrides it and hides the frame:
@racketblock[
(define tray-frame%
(class frame%
(super-new)
(define/override (on-close)
(send this show #f))))
]
This is intentionally separate from @racket[#:hide-on-minimize?]. Closing a
window is already represented by a public Racket GUI callback, while Windows
does not expose minimizing through a corresponding public Racket callback.
@section{Example}
The package contains @filepath{examples/simple.rkt}. It demonstrates hiding a
frame on both minimize and close, restoring it from the tray, and terminating
the application only through the tray menu.
@section{Platform Support}
Version 0.1.1 implements Windows. Requiring @racketmodname[racket-tray] is safe
on other operating systems, but calling its tray operations reports that the
platform is not yet supported.
tests/basic.rkt
+10 -1
View File
@@ -3,8 +3,17 @@
(require rackunit
racket-tray)
;; The public module must be loadable on non-Windows platforms as well.
;; The public module must be loadable on every platform, even when no tray
;; backend is available for the current operating system.
(check-true (procedure? mk-tray))
(check-true (procedure? tray-close))
(check-true (procedure? tray-set-icon!))
(check-true (procedure? tray-set-menu!))
;; Keep the keyword part of the public API testable without constructing a GUI
;; window or depending on Windows being available on the package build host.
(define-values (required-keywords allowed-keywords)
(procedure-keywords mk-tray))
(check-equal? required-keywords '())
(check-not-false (member '#:hide-on-minimize? allowed-keywords))