diff --git a/.gitignore b/.gitignore index 39a4f9c..60a55a9 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,5 @@ compiled/ # Dependency tracking files *.dep +*.bak + diff --git a/README.md b/README.md index a66d009..66db052 100644 --- a/README.md +++ b/README.md @@ -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. diff --git a/examples/simple.rkt b/examples/simple.rkt index 1bd928b..c9eaf76 100644 --- a/examples/simple.rkt +++ b/examples/simple.rkt @@ -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) diff --git a/main.rkt b/main.rkt index 3e5a4f6..5d67c8c 100644 --- a/main.rkt +++ b/main.rkt @@ -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!))) diff --git a/private/windows.rkt b/private/windows.rkt index 6187103..e5e5e65 100644 --- a/private/windows.rkt +++ b/private/windows.rkt @@ -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 diff --git a/scrbl/racket-tray.scrbl b/scrbl/racket-tray.scrbl index 0ab65e5..670a43b 100644 --- a/scrbl/racket-tray.scrbl +++ b/scrbl/racket-tray.scrbl @@ -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. diff --git a/tests/basic.rkt b/tests/basic.rkt index 91015f7..76d6138 100644 --- a/tests/basic.rkt +++ b/tests/basic.rkt @@ -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))