diff --git a/README.md b/README.md index 66db052..8f11c04 100644 --- a/README.md +++ b/README.md @@ -1,10 +1,14 @@ # racket-tray -A small system tray API for Racket. +A small cross-platform system tray API for Racket GUI applications. -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. +Version 0.1.1 contains native backends for Windows, Linux and macOS: + +- Windows uses `Shell_NotifyIconW` and `SetWindowSubclass`. +- Linux uses Ayatana AppIndicator and GTK3. +- macOS uses AppKit `NSStatusItem` and `NSMenu` through Racket's Objective-C FFI. + +The public API and symbolic menu actions are the same on every platform. ```racket #lang racket/gui @@ -28,35 +32,106 @@ and `SetWindowSubclass`. No additional native DLL is required. (when (send frame is-iconized?) (send frame iconize #f))) +(define (tray-action action) + (case action + [(open) + (show-frame)] + [(exit) + (tray-close tray) + (exit)])) + (define tray (mk-tray frame "example.png" - show-frame + (list tray-action 'open) #:hide-on-minimize? #t)) (tray-set-menu! tray (list - (list "Open" show-frame) + (list 'open "Open") 'separator - (list "Exit" - (λ () - (tray-close tray) - (exit))))) + (list 'exit "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 a native -Windows tray icon. +## Action and menu model -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)`. +The third argument of `mk-tray` is mandatory and has the form: -`tray-set-menu!` accepts a `popup-menu%` object directly, a simple menu list, -or `#f` to remove the context menu. +```racket +(list callback default-action-id) +``` -At the moment non-Windows platforms report that the operation is unsupported. +`callback` accepts one symbol. `default-action-id` is a symbol that must also +occur in the menu installed by `tray-set-menu!`. + +A menu contains `(list action-id label)` entries and separators: + +```racket +(list + (list 'open "Open") + 'separator + (list 'exit "Exit")) +``` + +Choosing a menu item calls the callback with its action identifier. In the +example above, choosing `Open` calls `(tray-action 'open)` and choosing `Exit` +calls `(tray-action 'exit)`. + +Direct tray activation is platform dependent: + +- **Windows:** a normal activation invokes the configured default action. + The context-menu gesture opens the tray menu. +- **Linux with Ayatana AppIndicator 0.6 or newer:** a primary activation can + invoke the configured default action. The context-menu gesture opens the + menu. +- **Linux with Ayatana AppIndicator 0.5.x:** primary activation opens the menu; + the older library has no primary-activation callback. +- **macOS:** the native status item opens its menu. Menu selections invoke the + symbolic callback. The default id remains part of the common API but is not + invoked directly by an `NSStatusItem` with an attached menu. + +## Hide on minimize + +`#:hide-on-minimize?` is implemented in the platform-independent Racket layer. +It periodically checks `frame%`'s public `is-iconized?` method and hides the +frame when it becomes iconized. No Win32, GTK or AppKit minimize hook is used. + +Closing a frame to the tray is separate because Racket already has the public +`on-close` callback. Override it and call `(send this show #f)` as shown above. + +## Icons + +`example.png` is suitable on all three supported platforms. Windows also +accepts `.ico`; PNG alpha transparency is converted to a native `HICON` by the +Windows backend. Linux passes an absolute image path to AppIndicator. macOS +loads the image with `NSImage`. + +## Linux runtime dependency + +Linux requires the Ayatana AppIndicator GTK3 runtime library. `racket-tray` +loads the native shared library dynamically. If it is missing, `mk-tray` +reports the dependency and the appropriate package commands instead of +exposing a raw FFI loader error. + +Debian/Ubuntu: + +```text +sudo apt install libayatana-appindicator3-1 +``` + +Fedora: + +```text +sudo dnf install libayatana-appindicator-gtk3 +``` + +Arch Linux: + +```text +sudo pacman -S libayatana-appindicator +``` + +No additional native dependency is required by the Windows or macOS backend. diff --git a/examples/simple.rkt b/examples/simple.rkt index c9eaf76..c2dd585 100644 --- a/examples/simple.rkt +++ b/examples/simple.rkt @@ -5,10 +5,12 @@ ;; This example demonstrates the two common "close to tray" behaviours: ;; -;; * minimize: handled by racket-tray through #:hide-on-minimize? +;; * minimize: handled portably 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. +;; The frame remains alive in both cases. Only the tray menu's Exit action +;; terminates the application. (define simple% (class frame% (super-new [label "Racket Tray"] @@ -17,7 +19,7 @@ (define lbl (new message% - [label "Counting tray clicks"] + [label "Counting tray activations"] [parent this] [auto-resize #t] [stretchable-width #t])) @@ -27,11 +29,11 @@ (define/public (count-next) (set! count (add1 count)) (send lbl set-label - (format "Counting tray clicks: ~a" count))) + (format "Counting tray activations: ~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) + (define/augment (on-close) (send this show #f)))) (define frame (new simple%)) @@ -42,32 +44,44 @@ ; 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. +; The portable minimize watcher hides an iconized frame. Explicitly +; de-iconizing here makes restoring predictable on every platform. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Handle every symbolic action generated by the tray icon/menu. +; pre : action is one of the identifiers installed with tray-set-menu!. +; post : 'open restores the frame and increments the counter; 'exit removes +; the tray icon and terminates the example. +; result : Unspecified. +; internals: +; The same callback is used for menu selections and for native direct +; activation on platforms that support the configured default action. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-action action) + (case action + [(open) + (send frame count-next) + (show-frame)] + [(exit) + (tray-close tray) + (exit)])) + (define tray (mk-tray frame "simple.png" - (λ () - (send frame count-next) - (show-frame)) + (list tray-action 'open) #:hide-on-minimize? #t)) (tray-set-menu! tray (list - (list "Open" show-frame) + (list 'open "Open") 'separator - (list "Exit" - (λ () - (tray-close tray) - (exit))))) + (list 'exit "Exit"))) (send frame show #t) diff --git a/info.rkt b/info.rkt index 3ddb8cc..bb6c6f4 100644 --- a/info.rkt +++ b/info.rkt @@ -4,7 +4,7 @@ (define version "0.1.1") (define license 'MIT) (define collection "racket-tray") -(define pkg-desc "A tray icon for Racket") +(define pkg-desc "A cross-platform tray icon for Racket") (define scribblings '(("scrbl/racket-tray.scrbl" () (library 0)))) diff --git a/main.rkt b/main.rkt index 5d67c8c..ac58d47 100644 --- a/main.rkt +++ b/main.rkt @@ -1,30 +1,60 @@ #lang racket/base -(require racket/runtime-path) +(require racket/class + racket/gui/base + racket/runtime-path) (provide mk-tray tray-close tray-set-icon! tray-set-menu!) -;; The platform implementation is loaded dynamically so that requiring -;; racket-tray remains possible on platforms that do not yet have a backend. +;; Platform backends are loaded dynamically so requiring racket-tray stays +;; possible when a platform-specific native dependency is not installed. (define-runtime-module-path windows-module "private/windows.rkt") +(define-runtime-module-path linux-module "private/linux.rkt") +(define-runtime-module-path macos-module "private/macos.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! platform-mk-tray - (dynamic-require windows-module 'mk-tray)) - (set! platform-tray-close - (dynamic-require windows-module 'tray-close)) - (set! platform-tray-set-icon! - (dynamic-require windows-module 'tray-set-icon!)) - (set! platform-tray-set-menu! - (dynamic-require windows-module 'tray-set-menu!))) +(cond + [(eq? (system-type 'os) 'windows) + (set! platform-mk-tray + (dynamic-require windows-module 'mk-tray)) + (set! platform-tray-close + (dynamic-require windows-module 'tray-close)) + (set! platform-tray-set-icon! + (dynamic-require windows-module 'tray-set-icon!)) + (set! platform-tray-set-menu! + (dynamic-require windows-module 'tray-set-menu!))] + [(eq? (system-type 'os) 'unix) + (set! platform-mk-tray + (dynamic-require linux-module 'mk-tray)) + (set! platform-tray-close + (dynamic-require linux-module 'tray-close)) + (set! platform-tray-set-icon! + (dynamic-require linux-module 'tray-set-icon!)) + (set! platform-tray-set-menu! + (dynamic-require linux-module 'tray-set-menu!))] + [(eq? (system-type 'os) 'macosx) + (set! platform-mk-tray + (dynamic-require macos-module 'mk-tray)) + (set! platform-tray-close + (dynamic-require macos-module 'tray-close)) + (set! platform-tray-set-icon! + (dynamic-require macos-module 'tray-set-icon!)) + (set! platform-tray-set-menu! + (dynamic-require macos-module 'tray-set-menu!))]) + +;; The public tray value keeps only platform-independent state. Native state is +;; owned entirely by the backend stored in platform-tray. +(struct tray (platform-tray + default-action + minimize-timer) + #:mutable) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Supporting functions @@ -40,7 +70,128 @@ ; attempted tray operation fails when no backend was loaded. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (unsupported who) - (error who "not supported on this operating system: ~a" (system-type 'os*))) + (error who "not supported on this operating system: ~a" (system-type 'os))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Validate and split the action specification supplied to mk-tray. +; pre : action-spec is any Racket value. +; post : No state is changed. +; result : Two values: a one-argument callback and its default action symbol; +; raises an argument exception for any other shape. +; internals: +; A single application callback is shared by direct tray activation +; and menu items. The second list value identifies the menu action +; used for a platform-supported primary-click activation. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (action-spec->values action-spec) + (cond + [(and (list? action-spec) + (= (length action-spec) 2)) + (let ((callback (car action-spec)) + (default-action (cadr action-spec))) + (unless (and (procedure? callback) + (procedure-arity-includes? callback 1)) + (raise-argument-error + 'mk-tray + "(list/c (procedure-arity-includes/c 1) symbol?)" + action-spec)) + (unless (symbol? default-action) + (raise-argument-error + 'mk-tray + "(list/c (procedure-arity-includes/c 1) symbol?)" + action-spec)) + (values callback default-action))] + [else + (raise-argument-error + 'mk-tray + "(list/c (procedure-arity-includes/c 1) symbol?)" + action-spec)])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Validate a platform-independent tray menu specification. +; pre : menu-spec is any Racket value. +; post : No state is changed. +; result : A list of the action symbols present in menu-spec; raises a precise +; argument error for malformed entries or duplicate action symbols. +; internals: +; A menu contains (list action-id label) entries and separator +; markers. Keeping callbacks out of the menu specification gives all +; platforms the same action-dispatch API. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (menu-action-ids menu-spec) + (unless (list? menu-spec) + (raise-argument-error 'tray-set-menu! "list?" menu-spec)) + (let loop ((entries menu-spec) + (ids '())) + (cond + [(null? entries) + (reverse ids)] + [else + (let ((entry (car entries))) + (cond + [(or (eq? entry 'separator) + (eq? entry #f)) + (loop (cdr entries) ids)] + [(and (list? entry) + (= (length entry) 2) + (symbol? (car entry)) + (string? (cadr entry))) + (let ((action-id (car entry))) + (when (memq action-id ids) + (error 'tray-set-menu! + "duplicate tray menu action id: ~a" + action-id)) + (loop (cdr entries) (cons action-id ids)))] + [else + (error 'tray-set-menu! + "expected menu entries of the form (list symbol label), #f, or 'separator; got: ~e" + entry)]))]))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Create the portable timer that hides a frame after minimization. +; pre : frame implements top-level-window<%> and owns a live eventspace. +; post : A timer runs in the frame eventspace and hides the frame when +; is-iconized? changes from #f to #t. +; result : The timer% object; callers stop it when the tray is closed. +; internals: +; Racket GUI has no portable minimize callback. Polling is therefore +; intentionally implemented here instead of in a native backend, so +; Windows, Linux and macOS have identical hide-on-minimize behavior. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (make-minimize-timer frame) + (let ((was-iconized? #f) + (minimize-timer #f)) + (parameterize ([current-eventspace (send frame get-eventspace)]) + (set! minimize-timer + (new timer% + [interval 100] + [notify-callback + (λ () + (with-handlers ([exn:fail? + (λ (_exn) + (send minimize-timer stop))]) + (let ((iconized? (send frame is-iconized?))) + (when (and iconized? + (not was-iconized?)) + (send frame show #f)) + (set! was-iconized? iconized?))))]))) + minimize-timer)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Check that a value is an open public racket-tray value. +; pre : who names the calling public procedure and value is any value. +; post : No state is changed. +; result : void for a valid tray; raises an argument/state exception otherwise. +; internals: +; A closed tray has its platform-tray field set to #f after backend +; cleanup, which also prevents native procedures from being called +; twice on the same resources. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (check-open-tray who value) + (unless (tray? value) + (raise-argument-error who "tray?" value)) + (unless (tray-platform-tray value) + (error who "tray icon is already closed"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Provided functions @@ -48,64 +199,95 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; 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. +; pre : frame implements top-level-window<%>, icon-file is accepted by the +; platform backend, action-spec is (list callback default-action), +; callback accepts one symbol, and hide-on-minimize? is boolean. +; post : A native tray icon exists and, when requested, a portable minimize +; timer watches frame. Partial creation is cleaned up on failure. +; result : A public tray value accepted by the other provided 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. +; The backend receives the callback and default action separately. +; Hide-on-minimize is deliberately implemented in this module and is +; therefore independent of Win32, GTK/AppIndicator, or AppKit. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (mk-tray frame icon-file - on-click-cb + action-spec #: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))) + (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 platform-mk-tray + (unsupported 'mk-tray)) + (let-values (((callback default-action) + (action-spec->values action-spec))) + (let ((platform-tray + (platform-mk-tray frame icon-file callback default-action))) + (with-handlers ([exn? + (λ (exn) + (platform-tray-close platform-tray) + (raise exn))]) + (let ((minimize-timer + (if hide-on-minimize? + (make-minimize-timer frame) + #f))) + (tray platform-tray default-action minimize-timer)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; 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. +; goal : Close a tray icon and all platform-independent support around it. +; pre : value is a tray previously returned by mk-tray; repeated closing is +; allowed. +; post : The minimize timer is stopped, native resources are released once, +; and the public tray is marked closed. +; result : void. ; internals: -; All resource ownership and idempotence rules are implemented by the -; platform backend. +; Cleanup of native resources remains the responsibility of the +; backend; this procedure only coordinates the portable wrapper. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (tray-close tray) - (if platform-tray-close - (platform-tray-close tray) - (unsupported 'tray-close))) +(define (tray-close value) + (unless (tray? value) + (raise-argument-error 'tray-close "tray?" value)) + (when (tray-minimize-timer value) + (send (tray-minimize-timer value) stop) + (set-tray-minimize-timer! value #f)) + (when (tray-platform-tray value) + (platform-tray-close (tray-platform-tray value)) + (set-tray-platform-tray! value #f)) + (void)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; 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. +; pre : value is open and icon-file is accepted by the active backend. +; post : The active native tray image is replaced when the backend succeeds. +; result : void. ; internals: -; The public facade performs no image conversion itself. +; Image conversion and native resource ownership remain backend +; responsibilities because the accepted native image form differs by +; operating system. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (tray-set-icon! tray icon-file) - (if platform-tray-set-icon! - (platform-tray-set-icon! tray icon-file) - (unsupported 'tray-set-icon!))) +(define (tray-set-icon! value icon-file) + (check-open-tray 'tray-set-icon! value) + (platform-tray-set-icon! (tray-platform-tray value) icon-file) + (void)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; 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. +; goal : Set the action menu of an existing tray icon. +; pre : value is open and menu-spec is a list of (list symbol label) entries +; and separator markers; it contains the tray's default action id. +; post : The active backend displays a menu whose selections invoke the +; callback supplied to mk-tray with the selected action symbol. +; result : void. ; internals: -; Menu normalization belongs to the platform implementation because -; native event integration is platform-specific. +; Validation is performed once here so every backend receives the same +; small, platform-independent menu representation. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (tray-set-menu! tray menu) - (if platform-tray-set-menu! - (platform-tray-set-menu! tray menu) - (unsupported 'tray-set-menu!))) +(define (tray-set-menu! value menu-spec) + (check-open-tray 'tray-set-menu! value) + (let ((ids (menu-action-ids menu-spec))) + (unless (memq (tray-default-action value) ids) + (error 'tray-set-menu! + "menu does not contain the default action id: ~a" + (tray-default-action value))) + (platform-tray-set-menu! (tray-platform-tray value) menu-spec)) + (void)) diff --git a/private/linux.rkt b/private/linux.rkt new file mode 100644 index 0000000..ce89b97 --- /dev/null +++ b/private/linux.rkt @@ -0,0 +1,563 @@ +#lang racket/base + +(require ffi/unsafe + ffi/unsafe/os-async-channel + racket/class + racket/gui/base + racket/match) + +(provide mk-tray + tray-close + tray-set-icon! + tray-set-menu!) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Native libraries and constants +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define APP_INDICATOR_CATEGORY_APPLICATION_STATUS 0) +(define APP_INDICATOR_STATUS_PASSIVE 0) +(define APP_INDICATOR_STATUS_ACTIVE 1) + +;; Debian/Ubuntu install libayatana-appindicator3.so.1. The compatibility +;; libappindicator3.so.1 name is tried as a fallback because some distributions +;; and older installations expose that SONAME instead. +(define appindicator-lib + (or (ffi-lib "libayatana-appindicator3" '("1" #f) + #:fail (λ () #f)) + (ffi-lib "libappindicator3" '("1" #f) + #:fail (λ () #f)))) + +(define gtk-lib + (ffi-lib "libgtk-3" '("0" #f) + #:fail (λ () #f))) + +(define gobject-lib + (ffi-lib "libgobject-2.0" '("0" #f) + #:fail (λ () #f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Resolve a native function without making module loading fail. +; pre : lib is an ffi-lib value or #f, name is a foreign symbol name, and +; type is the FFI type of that function. +; post : No native state is changed. +; result : The foreign procedure when available, otherwise #f. +; internals: +; Linux native dependencies are intentionally checked lazily so the +; racket-tray package can still be installed, compiled and required +; on build hosts that do not have Ayatana AppIndicator installed. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (ffi-procedure lib name type) + (if lib + (get-ffi-obj name lib type (λ () #f)) + #f)) + +;; AppIndicator API. These functions are available in the 0.5.x GTK3 library +;; used by Debian/Fedora as well as the newer 0.6.x line. +(define app_indicator_get_type + (ffi-procedure appindicator-lib + "app_indicator_get_type" + (_fun -> _ulong))) + +(define app_indicator_new + (ffi-procedure appindicator-lib + "app_indicator_new" + (_fun _string/utf-8 _string/utf-8 _int -> _pointer))) + +(define app_indicator_set_status + (ffi-procedure appindicator-lib + "app_indicator_set_status" + (_fun _pointer _int -> _void))) + +(define app_indicator_set_menu + (ffi-procedure appindicator-lib + "app_indicator_set_menu" + (_fun _pointer _pointer -> _void))) + +(define app_indicator_set_icon_full + (ffi-procedure appindicator-lib + "app_indicator_set_icon_full" + (_fun _pointer _string/utf-8 _string/utf-8 -> _void))) + +(define app_indicator_set_title + (ffi-procedure appindicator-lib + "app_indicator_set_title" + (_fun _pointer _string/utf-8 -> _void))) + +;; GTK3 menu construction. +(define gtk_menu_new + (ffi-procedure gtk-lib "gtk_menu_new" (_fun -> _pointer))) + +(define gtk_menu_item_new_with_label + (ffi-procedure gtk-lib + "gtk_menu_item_new_with_label" + (_fun _string/utf-8 -> _pointer))) + +(define gtk_separator_menu_item_new + (ffi-procedure gtk-lib + "gtk_separator_menu_item_new" + (_fun -> _pointer))) + +(define gtk_menu_shell_append + (ffi-procedure gtk-lib + "gtk_menu_shell_append" + (_fun _pointer _pointer -> _void))) + +(define gtk_widget_show_all + (ffi-procedure gtk-lib + "gtk_widget_show_all" + (_fun _pointer -> _void))) + +;; GObject signal/ref-count functions. Two bindings to g_signal_connect_data +;; are used because menu activation and AppIndicator activation have different +;; callback signatures. +(define _MENU-ACTIVATE-CALLBACK + (_fun _pointer _pointer -> _void)) + +(define _INDICATOR-ACTIVATE-CALLBACK + (_fun _pointer _int _int _pointer -> _void)) + +(define g_signal_connect_menu + (ffi-procedure gobject-lib + "g_signal_connect_data" + (_fun _pointer + _string/utf-8 + _MENU-ACTIVATE-CALLBACK + _pointer + _pointer + _uint32 + -> _ulong))) + +(define g_signal_connect_indicator + (ffi-procedure gobject-lib + "g_signal_connect_data" + (_fun _pointer + _string/utf-8 + _INDICATOR-ACTIVATE-CALLBACK + _pointer + _pointer + _uint32 + -> _ulong))) + +(define g_signal_lookup + (ffi-procedure gobject-lib + "g_signal_lookup" + (_fun _string/utf-8 _ulong -> _uint32))) + +(define g_object_unref + (ffi-procedure gobject-lib + "g_object_unref" + (_fun _pointer -> _void))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal state +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Native GTK/AppIndicator objects are owned by this backend. callback and the +;; callback procedures kept in menu-callbacks/activate-callback must stay +;; reachable while C retains their generated function pointers. +(struct tray (frame + indicator + callback + default-action + eventspace + event-channel + event-thread + menu + menu-callbacks + activate-callback + closed?) + #:mutable) + +(define next-indicator-id 1) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Supporting functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Raise a clear installation error when Linux native libraries are +; unavailable. +; pre : Called before a tray operation that needs AppIndicator/GTK3. +; post : No native state is changed. +; result : void when all required functions are available; otherwise raises an +; exception with distribution-specific runtime package suggestions. +; internals: +; The runtime package, not a -dev package, is sufficient for Racket +; FFI because racket-tray loads the installed shared object directly. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (ensure-linux-libraries) + (unless (and appindicator-lib + gtk-lib + gobject-lib + app_indicator_get_type + app_indicator_new + app_indicator_set_status + app_indicator_set_menu + app_indicator_set_icon_full + gtk_menu_new + gtk_menu_item_new_with_label + gtk_separator_menu_item_new + gtk_menu_shell_append + gtk_widget_show_all + g_signal_connect_menu + g_signal_lookup + g_object_unref) + (error + 'racket-tray + (string-append + "Linux tray support requires the Ayatana AppIndicator GTK3 runtime library.\n" + "Install it and start the program again.\n\n" + "Debian/Ubuntu:\n" + " sudo apt install libayatana-appindicator3-1\n\n" + "Fedora:\n" + " sudo dnf install libayatana-appindicator-gtk3\n\n" + "Arch Linux:\n" + " sudo pacman -S libayatana-appindicator")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Allocate a stable process-local AppIndicator identifier. +; pre : next-indicator-id contains the next positive identifier. +; post : next-indicator-id is incremented by one. +; result : A string suitable as the AppIndicator id. +; internals: +; AppIndicator ids should be unique within an application. A simple +; monotonic process-local suffix is sufficient for racket-tray. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (allocate-indicator-id) + (let ((id next-indicator-id)) + (set! next-indicator-id (add1 next-indicator-id)) + (format "racket-tray-~a" id))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Run thunk synchronously in the handler thread of eventspace. +; pre : eventspace is live 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: +; GTK objects must be created and changed from the Racket GUI thread +; that owns the existing GTK application/event loop. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (call-in-eventspace eventspace thunk) + (let ((handler-thread (eventspace-handler-thread eventspace))) + (unless handler-thread + (error 'racket-tray "the frame's eventspace has been shut down")) + (if (eq? (current-thread) handler-thread) + (parameterize ([current-eventspace eventspace]) + (thunk)) + (let ((result-channel (make-channel))) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (with-handlers ([exn? + (λ (exn) + (channel-put result-channel + (cons 'error exn)))]) + (channel-put result-channel (cons 'ok (thunk))))))) + (match (channel-get result-channel) + [(cons 'ok value) value] + [(cons 'error exn) (raise exn)]))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Queue user work in the frame eventspace. +; pre : t is a tray and thunk accepts no arguments. +; post : thunk is queued when the eventspace is live and the tray stays open. +; result : Unspecified. +; internals: +; FFI signal callbacks do not execute application code directly. This +; also keeps Linux callback behavior aligned with the Windows backend. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (queue-eventspace-callback t thunk) + (let ((eventspace (tray-eventspace t))) + (unless (eventspace-shutdown? eventspace) + (with-handlers ([exn:fail? (λ (_exn) (void))]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (unless (tray-closed? t) + (thunk))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Start the ordinary Racket thread that dispatches native GTK events. +; pre : t has an event channel and no event thread. +; post : tray-event-thread is set and exits after receiving 'close. +; result : Unspecified; t is modified in place. +; internals: +; GTK/GObject callbacks only put immutable action values into the OS +; async channel. User callbacks run later as ordinary Racket GUI work. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (start-event-thread! t) + (let ((event-thread + (thread + (λ () + (let loop () + (match (sync (tray-event-channel t)) + ['close + (void)] + [(vector 'action action-id) + (queue-eventspace-callback + t + (λ () + ((tray-callback t) action-id))) + (loop)] + [_ + (loop)])))))) + (set-tray-event-thread! t event-thread))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Return an absolute icon filename accepted by AppIndicator. +; pre : icon-file is a path-string naming an existing file. +; post : No state is changed. +; result : An absolute native path string. +; internals: +; AppIndicator treats an icon name beginning with '/' as an absolute +; icon path and exports that path through StatusNotifierItem. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (icon-path icon-file) + (unless (path-string? icon-file) + (raise-argument-error 'racket-tray "path-string?" icon-file)) + (unless (file-exists? icon-file) + (error 'racket-tray "icon file does not exist: ~a" icon-file)) + (path->string (path->complete-path icon-file))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Build a native GtkMenu for the common menu specification. +; pre : t is open and menu-spec has already been validated by main.rkt. +; post : A GtkMenu and menu-item signal callbacks have been created. +; result : Two values: the GtkMenu pointer and a list of Racket callbacks that +; must remain reachable while that menu exists. +; internals: +; Each GtkMenuItem receives an "activate" handler that only forwards +; the corresponding symbol to the tray's OS async channel. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (make-menu t menu-spec) + (let ((menu (gtk_menu_new)) + (callbacks '())) + (for ((entry (in-list menu-spec))) + (cond + [(or (eq? entry 'separator) + (eq? entry #f)) + (gtk_menu_shell_append menu (gtk_separator_menu_item_new))] + [else + (let* ((action-id (car entry)) + (label (cadr entry)) + (item (gtk_menu_item_new_with_label label)) + (callback + (λ (_item _data) + (os-async-channel-put + (tray-event-channel t) + (vector 'action action-id))))) + (g_signal_connect_menu item "activate" callback #f #f 0) + (set! callbacks (cons callback callbacks)) + (gtk_menu_shell_append menu item))])) + (gtk_widget_show_all menu) + (values menu callbacks))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Connect primary activation when the installed AppIndicator supports +; its 0.6+ "activate" signal. +; pre : t has a live indicator and event channel. +; post : On AppIndicator 0.6+ a signal callback is installed and retained; +; on 0.5.x no callback is installed. +; result : #t when primary activation was connected, otherwise #f. +; internals: +; AppIndicator 0.6.0 added StatusNotifierItem Activate handling. Older +; 0.5.x libraries intentionally fall back to opening the menu, which +; is why the common default action remains a mandatory menu item. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (connect-primary-activation! t) + (if (and g_signal_connect_indicator + (> (g_signal_lookup "activate" (app_indicator_get_type)) 0)) + (let ((callback + (λ (_indicator _x _y _data) + (os-async-channel-put + (tray-event-channel t) + (vector 'action (tray-default-action t)))))) + (g_signal_connect_indicator + (tray-indicator t) + "activate" + callback + #f + #f + 0) + (set-tray-activate-callback! t callback) + #t) + #f)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Check that t is an open Linux tray value. +; pre : who names the calling backend procedure and t is any value. +; post : No state is changed. +; result : void when valid; otherwise raises an argument/state exception. +; internals: +; Native AppIndicator/GTK resources may only be mutated while the +; backend tray remains open. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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 Linux tray icon using Ayatana AppIndicator and GTK3. +; pre : frame implements top-level-window<%>, icon-file exists, callback +; accepts one symbol, default-action is a symbol, and the required +; Linux runtime libraries are installed. +; post : An active AppIndicator with an empty GtkMenu exists and an event +; dispatcher thread is running. +; result : A mutable Linux tray object. +; internals: +; Racket GUI already owns the GTK event loop, so this backend does not +; call gtk_init or gtk_main. AppIndicator 0.6+ primary activation is +; connected when available; 0.5.x retains its normal menu-on-click +; behavior. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (mk-tray frame icon-file callback default-action) + (ensure-linux-libraries) + (unless (is-a? frame top-level-window<%>) + (raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame)) + (unless (and (procedure? callback) + (procedure-arity-includes? callback 1)) + (raise-argument-error 'mk-tray "(procedure-arity-includes/c 1)" callback)) + (unless (symbol? default-action) + (raise-argument-error 'mk-tray "symbol?" default-action)) + (let ((eventspace (send frame get-eventspace)) + (filename (icon-path icon-file))) + (call-in-eventspace + eventspace + (λ () + (let ((indicator + (app_indicator_new + (allocate-indicator-id) + filename + APP_INDICATOR_CATEGORY_APPLICATION_STATUS))) + (unless indicator + (error 'mk-tray "app_indicator_new failed")) + (let ((menu (gtk_menu_new))) + (unless menu + (g_object_unref indicator) + (error 'mk-tray "gtk_menu_new failed")) + (let ((menu-installed? #f) + (t (tray frame + indicator + callback + default-action + eventspace + (make-os-async-channel) + #f + menu + '() + #f + #f))) + (with-handlers + ([exn? + (λ (exn) + (when (tray-event-thread t) + (os-async-channel-put (tray-event-channel t) 'close)) + (app_indicator_set_status + indicator + APP_INDICATOR_STATUS_PASSIVE) + (g_object_unref indicator) + (unless menu-installed? + (g_object_unref menu)) + (raise exn))]) + (app_indicator_set_menu indicator menu) + (set! menu-installed? #t) + (gtk_widget_show_all menu) + (app_indicator_set_icon_full + indicator + filename + "Racket tray icon") + (when app_indicator_set_title + (let ((frame-label (send frame get-label))) + (when (string? frame-label) + (app_indicator_set_title indicator frame-label)))) + (connect-primary-activation! t) + (start-event-thread! t) + (app_indicator_set_status indicator APP_INDICATOR_STATUS_ACTIVE) + t)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Hide and release a Linux AppIndicator and its GTK menu. +; pre : t is a Linux tray object; repeated closing is allowed. +; post : The indicator is passive and unreferenced, its GtkMenu reference is +; released by AppIndicator, callbacks are released, and the event +; thread is told to stop. +; result : void. +; internals: +; AppIndicator exposes no dedicated remove function. PASSIVE is the +; supported state for removing the indicator from the panel before +; the final GObject reference is released. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-close t) + (unless (tray? t) + (raise-argument-error 'tray-close "tray?" t)) + (unless (tray-closed? t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (unless (tray-closed? t) + (app_indicator_set_status + (tray-indicator t) + APP_INDICATOR_STATUS_PASSIVE) + ;; AppIndicator owns the GtkMenu reference installed through + ;; app_indicator_set_menu and releases it during object disposal. + (g_object_unref (tray-indicator t)) + (set-tray-menu! t #f) + (set-tray-menu-callbacks! t '()) + (set-tray-activate-callback! t #f) + (set-tray-closed?! t #t) + (os-async-channel-put (tray-event-channel t) 'close))))) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Replace the icon exported by an open Linux AppIndicator. +; pre : t is open and icon-file names an existing image file. +; post : AppIndicator exports the new absolute icon path. +; result : void. +; internals: +; Ayatana AppIndicator accepts absolute filenames as icon names, so no +; Racket-side image conversion is needed on Linux. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-set-icon! t icon-file) + (check-open-tray 'tray-set-icon! t) + (let ((filename (icon-path icon-file))) + (call-in-eventspace + (tray-eventspace t) + (λ () + (app_indicator_set_icon_full + (tray-indicator t) + filename + "Racket tray icon")))) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Replace the menu exported by an open Linux AppIndicator. +; pre : t is open and menu-spec has been validated by the public module. +; post : AppIndicator exports a newly built GtkMenu; its previous GtkMenu +; reference and the corresponding Racket callbacks are released. +; result : void. +; internals: +; GTK menu item activation is converted to the same symbolic action +; callback used by Windows and macOS. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-set-menu! t menu-spec) + (check-open-tray 'tray-set-menu! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (let-values (((menu callbacks) + (make-menu t menu-spec))) + ;; app_indicator_set_menu refs/sinks the new GtkMenu and unrefs the + ;; previous GtkMenu itself. The old Racket callbacks can be released + ;; immediately after the native call has returned. + (app_indicator_set_menu (tray-indicator t) menu) + (set-tray-menu! t menu) + (set-tray-menu-callbacks! t callbacks)))) + (void)) diff --git a/private/macos.rkt b/private/macos.rkt new file mode 100644 index 0000000..4c5626a --- /dev/null +++ b/private/macos.rkt @@ -0,0 +1,377 @@ +#lang racket/base + +(require ffi/unsafe + ffi/unsafe/objc + ffi/unsafe/nsstring + racket/class + racket/gui/base + racket/match) + +(provide mk-tray + tray-close + tray-set-icon! + tray-set-menu!) + +;; AppKit and Foundation are standard macOS frameworks. Load them explicitly +;; before importing Objective-C classes so this backend does not depend on +;; another Racket library having loaded them first. +(ffi-lib "/System/Library/Frameworks/Foundation.framework/Foundation") +(ffi-lib "/System/Library/Frameworks/AppKit.framework/AppKit") + +(import-class NSObject + NSImage + NSMenu + NSMenuItem + NSStatusBar) + +;; NSVariableStatusItemLength is the native sentinel for a status item whose +;; width follows the image or title supplied to its button. +(define NSVariableStatusItemLength -1.0) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal state / functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; NSMenuItem does not own its target. RacketTrayMenuTarget instances are +;; therefore kept in tray-menu-targets for as long as the corresponding menu +;; exists. Each target owns only Racket values in Objective-C ivars. +(struct tray (frame + status-bar + status-item + button + callback + default-action + eventspace + menu + menu-targets + closed?) + #:mutable) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Queue one application tray action in a Racket GUI eventspace. +; pre : eventspace is live, callback accepts one argument and action-id is +; the symbol associated with a menu item. +; post : callback is queued in eventspace unless that eventspace has shut +; down before the queue operation. +; result : Unspecified. +; internals: +; AppKit invokes Objective-C target/action methods from its native +; event processing. User code is kept outside that native callback by +; forwarding the action to Racket's normal GUI callback queue. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (queue-action eventspace callback action-id) + (unless (eventspace-shutdown? eventspace) + (with-handlers ([exn:fail? (λ (_exn) (void))]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (callback action-id))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Receive native NSMenuItem target/action messages for tray actions. +; pre : callback, action-id and eventspace ivars are set before the target +; is assigned to an NSMenuItem. +; post : trayAction: forwards the selected symbolic action to queue-action. +; result : Objective-C class RacketTrayMenuTarget. +; internals: +; define-objc-class stores the three fields as Racket-managed ivars. +; objc_lookUpClass reuses a class left by an earlier run in the same +; process, which avoids redefining an Objective-C runtime class in +; DrRacket. Instances are retained by the tray backend because +; NSMenuItem does not provide the ownership needed to keep a Racket +; callback target alive by itself. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define RacketTrayMenuTarget + (or (objc_lookUpClass "RacketTrayMenuTarget") + (let () + (define-objc-class RacketTrayMenuTarget NSObject + [callback action-id eventspace] + (- _void (trayAction: [_id _sender]) + (when (and callback action-id eventspace) + (queue-action eventspace callback action-id)))) + RacketTrayMenuTarget))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Run thunk synchronously in the handler thread of eventspace. +; pre : eventspace is live 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: +; AppKit objects that belong to a Racket GUI application are created +; and modified on the GUI eventspace thread. When the caller is +; already that thread, no callback round trip is needed. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (call-in-eventspace eventspace thunk) + (let ((handler-thread (eventspace-handler-thread eventspace))) + (unless handler-thread + (error 'racket-tray "the frame's eventspace has been shut down")) + (if (eq? (current-thread) handler-thread) + (parameterize ([current-eventspace eventspace]) + (thunk)) + (let ((result-channel (make-channel))) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (with-handlers ([exn? + (λ (exn) + (channel-put result-channel + (cons 'error exn)))]) + (channel-put result-channel (cons 'ok (thunk))))))) + (match (channel-get result-channel) + [(cons 'ok value) value] + [(cons 'error exn) (raise exn)]))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Validate an icon filename and return its absolute native path. +; pre : icon-file is any Racket value. +; post : No state is changed. +; result : An absolute path string when icon-file names an existing file; +; otherwise raises a precise argument or file error. +; internals: +; NSImage loads normal macOS image formats such as PNG directly from +; a filename, so the backend does not need an image converter. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (icon-path icon-file) + (unless (path-string? icon-file) + (raise-argument-error 'racket-tray "path-string?" icon-file)) + (unless (file-exists? icon-file) + (error 'racket-tray "icon file does not exist: ~a" icon-file)) + (path->string (path->complete-path icon-file))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Load icon-file as an NSImage owned by the caller. +; pre : icon-file names an existing image that AppKit can decode. +; post : One retained NSImage exists when loading succeeds. +; result : The retained NSImage; raises an exception if AppKit cannot load it. +; internals: +; alloc/initWithContentsOfFile: gives this procedure ownership. The +; caller releases that ownership after setImage:, because the status +; bar button retains the image it displays. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (load-image icon-file) + (let* ((path (icon-path icon-file)) + (image + (tell (tell NSImage alloc) + initWithContentsOfFile: #:type _NSString path))) + (unless image + (error 'racket-tray "could not load tray icon: ~a" icon-file)) + image)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Release Objective-C menu target objects owned by racket-tray. +; pre : targets is a list of retained RacketTrayMenuTarget instances. +; post : Each target has received release exactly once. +; result : void. +; internals: +; NSMenuItem's target reference is not used as an ownership boundary; +; racket-tray explicitly retains targets by creating them with new +; and explicitly releases them after detaching the menu. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (release-menu-targets targets) + (for ((target (in-list targets))) + (tellv target release)) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Build an NSMenu from the common racket-tray menu specification. +; pre : t is open and menu-spec has been validated by main.rkt. +; post : A retained NSMenu and retained target object for every actionable +; item have been created. +; result : Two values: the retained NSMenu and its retained target list. +; internals: +; Each item uses the same trayAction: selector. Its target stores the +; corresponding action symbol, so all choices reach the one callback +; supplied to mk-tray. Separators need no target object. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (make-menu t menu-spec) + (let ((menu (tell NSMenu new)) + (targets '())) + (tellv menu setAutoenablesItems: #:type _BOOL #f) + (for ((entry (in-list menu-spec))) + (cond + [(or (eq? entry 'separator) + (eq? entry #f)) + (tellv menu addItem: (tell NSMenuItem separatorItem))] + [else + (let* ((action-id (car entry)) + (label (cadr entry)) + (target (tell RacketTrayMenuTarget new)) + (item + (tell (tell NSMenuItem alloc) + initWithTitle: #:type _NSString label + action: #:type _SEL (selector trayAction:) + keyEquivalent: #:type _NSString ""))) + (set-ivar! target callback (tray-callback t)) + (set-ivar! target action-id action-id) + (set-ivar! target eventspace (tray-eventspace t)) + (tellv item setTarget: target) + (tellv menu addItem: item) + (tellv item release) + (set! targets (cons target targets)))])) + (values menu (reverse targets)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Validate that t is an open macOS tray object. +; pre : who names the calling procedure and t is any value. +; post : No state is changed. +; result : void when valid; otherwise raises an argument/state exception. +; internals: +; Native Objective-C objects must not receive messages after +; tray-close has released the status item and menu resources. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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 native macOS menu-bar status item for a Racket frame. +; pre : frame implements top-level-window<%>, icon-file is readable, +; callback accepts one symbol and default-action is a symbol. +; post : A retained NSStatusItem exists in the system status bar and shows +; icon-file. Its menu is initially empty. +; result : A mutable tray object for the remaining backend procedures. +; internals: +; macOS status items conventionally open their NSMenu when clicked. +; Menu selections invoke callback with their action symbol. The +; default-action is retained for the common cross-platform API, but +; AppKit does not use it for a status item that has an attached menu. +; statusItemWithLength: does not transfer ownership to the status bar, +; so racket-tray retains the returned status item until tray-close. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (mk-tray frame icon-file callback default-action) + (unless (is-a? frame top-level-window<%>) + (raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame)) + (unless (and (procedure? callback) + (procedure-arity-includes? callback 1)) + (raise-argument-error 'mk-tray "(procedure-arity-includes/c 1)" callback)) + (unless (symbol? default-action) + (raise-argument-error 'mk-tray "symbol?" default-action)) + (let ((eventspace (send frame get-eventspace))) + (call-in-eventspace + eventspace + (λ () + (let* ((status-bar (tell NSStatusBar systemStatusBar)) + (status-item + (tell status-bar + statusItemWithLength: #:type _double + NSVariableStatusItemLength)) + (button (tell status-item button))) + (unless (and status-item button) + (when status-item + (tellv status-bar removeStatusItem: status-item)) + (error 'mk-tray "could not create a macOS status item")) + (tellv status-item retain) + (let ((menu #f) + (image #f)) + (with-handlers + ([exn? + (λ (exn) + (when image + (tellv image release)) + (when menu + (tellv menu release)) + (tellv status-bar removeStatusItem: status-item) + (tellv status-item release) + (raise exn))]) + (set! menu (tell NSMenu new)) + (set! image (load-image icon-file)) + (tellv button setImage: image) + (tellv image release) + (set! image #f) + (let ((frame-label (send frame get-label))) + (when (string? frame-label) + (tellv button setToolTip: #:type _NSString frame-label))) + (tellv status-item setMenu: menu) + (tray frame + status-bar + status-item + button + callback + default-action + eventspace + menu + '() + #f)))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Remove a macOS status item and release resources owned by it. +; pre : t is a tray object; repeated calls are allowed. +; post : The status item is removed, its menu and item targets are released, +; and t is marked closed. +; result : void. +; internals: +; The menu is first detached from NSStatusItem so AppKit no longer +; references it. Targets are released after the menu is detached, and +; the explicit retain from mk-tray is balanced last. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-close t) + (unless (tray? t) + (raise-argument-error 'tray-close "tray?" t)) + (unless (tray-closed? t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (unless (tray-closed? t) + (tellv (tray-status-item t) setMenu: #f) + (tellv (tray-status-bar t) removeStatusItem: (tray-status-item t)) + (when (tray-menu t) + (tellv (tray-menu t) release) + (set-tray-menu! t #f)) + (release-menu-targets (tray-menu-targets t)) + (set-tray-menu-targets! t '()) + (tellv (tray-status-item t) release) + (set-tray-closed?! t #t))))) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Replace the image shown by an open macOS status item. +; pre : t is open and icon-file names an image AppKit can decode. +; post : The status bar button displays the new image. +; result : void. +; internals: +; The temporary retained NSImage is released immediately after +; setImage:, leaving normal AppKit ownership with the button. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-set-icon! t icon-file) + (check-open-tray 'tray-set-icon! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (let ((image (load-image icon-file))) + (tellv (tray-button t) setImage: image) + (tellv image release)))) + (void)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; goal : Replace the menu attached to an open macOS status item. +; pre : t is open and menu-spec is the validated common menu format. +; post : The status item opens the new NSMenu; resources belonging to the +; previous menu have been released. +; result : void. +; internals: +; The new menu is attached before the old menu and its retained target +; objects are released. This prevents AppKit from observing a target +; object whose Racket-owned retain has already been balanced. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (tray-set-menu! t menu-spec) + (check-open-tray 'tray-set-menu! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (let-values (((new-menu new-targets) + (make-menu t menu-spec))) + (let ((old-menu (tray-menu t)) + (old-targets (tray-menu-targets t))) + (tellv (tray-status-item t) setMenu: new-menu) + (set-tray-menu! t new-menu) + (set-tray-menu-targets! t new-targets) + (when old-menu + (tellv old-menu release)) + (release-menu-targets old-targets))))) + (void)) diff --git a/private/windows.rkt b/private/windows.rkt index e5e5e65..f2d0475 100644 --- a/private/windows.rkt +++ b/private/windows.rkt @@ -32,7 +32,6 @@ (define NOTIFYICON_VERSION_4 4) ;; Window messages used by the tray integration. -(define WM_SIZE #x0005) (define WM_CONTEXTMENU #x007B) (define WM_NCDESTROY #x0082) (define WM_USER #x0400) @@ -40,8 +39,6 @@ (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) @@ -189,8 +186,8 @@ hwnd id callback-message - on-click - hide-on-minimize? + callback + default-action eventspace event-channel event-thread @@ -217,11 +214,11 @@ ; reserved by Windows for application-private messages. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (allocate-tray-id) - (define id next-tray-id) - (when (> id #xffff) - (error 'mk-tray "too many tray icons have been created in this process")) - (set! next-tray-id (add1 next-tray-id)) - id) + (let ((id next-tray-id)) + (when (> id #xffff) + (error 'mk-tray "too many tray icons have been created in this process")) + (set! next-tray-id (add1 next-tray-id)) + id)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Convert a Win32 BOOL-style result to a Racket boolean. @@ -248,23 +245,23 @@ ; on the GUI thread that owns the window. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (call-in-eventspace eventspace thunk) - (define handler-thread (eventspace-handler-thread eventspace)) - (unless handler-thread - (error 'racket-tray "the frame's eventspace has been shut down")) - (if (eq? (current-thread) handler-thread) - (parameterize ([current-eventspace eventspace]) - (thunk)) - (let ([result-channel (make-channel)]) + (let ((handler-thread (eventspace-handler-thread eventspace))) + (unless handler-thread + (error 'racket-tray "the frame's eventspace has been shut down")) + (if (eq? (current-thread) handler-thread) (parameterize ([current-eventspace eventspace]) - (queue-callback - (λ () - (with-handlers ([exn? - (λ (exn) - (channel-put result-channel (cons 'error exn)))]) - (channel-put result-channel (cons 'ok (thunk))))))) - (match (channel-get result-channel) - [(cons 'ok value) value] - [(cons 'error exn) (raise exn)])))) + (thunk)) + (let ((result-channel (make-channel))) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (with-handlers ([exn? + (λ (exn) + (channel-put result-channel (cons 'error exn)))]) + (channel-put result-channel (cons 'ok (thunk))))))) + (match (channel-get result-channel) + [(cons 'ok value) value] + [(cons 'error exn) (raise exn)]))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Allocate and initialize a NOTIFYICONDATAW structure. @@ -278,17 +275,17 @@ ; Win32 without containing Racket-managed pointers. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (make-notify-data hwnd id callback-message icon) - (define data - (cast (malloc _NOTIFYICONDATAW 'atomic) - _pointer - _NOTIFYICONDATAW-pointer)) - (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW)) - (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW)) - (set-NOTIFYICONDATAW-hWnd! data hwnd) - (set-NOTIFYICONDATAW-uID! data id) - (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message) - (set-NOTIFYICONDATAW-hIcon! data icon) - data) + (let ((data + (cast (malloc _NOTIFYICONDATAW 'atomic) + _pointer + _NOTIFYICONDATAW-pointer))) + (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-hWnd! data hwnd) + (set-NOTIFYICONDATAW-uID! data id) + (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message) + (set-NOTIFYICONDATAW-hIcon! data icon) + data)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Copy a Racket string into a fixed-size UTF-16 Win32 array. @@ -302,15 +299,15 @@ ; 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)]) - (array-set! array i 0)) - (let loop ([i 0]) - (when (< i (sub1 capacity)) - (let ([code-unit (ptr-ref source _uint16 i)]) - (unless (zero? code-unit) - (array-set! array i code-unit) - (loop (add1 i))))))) + (let ((source (cast text _string/utf-16 _pointer))) + (for ([i (in-range capacity)]) + (array-set! array i 0)) + (let loop ((i 0)) + (when (< i (sub1 capacity)) + (let ((code-unit (ptr-ref source _uint16 i))) + (unless (zero? code-unit) + (array-set! array i code-unit) + (loop (add1 i)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Icon loading @@ -326,18 +323,18 @@ ; 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)) - (define icon - (LoadImageW #f - (path->string (path->complete-path icon-file)) - IMAGE_ICON - width - height - LR_LOADFROMFILE)) - (unless icon - (error 'mk-tray "could not load ICO file: ~a" icon-file)) - icon) + (let* ((width (GetSystemMetrics SM_CXSMICON)) + (height (GetSystemMetrics SM_CYSMICON)) + (icon + (LoadImageW #f + (path->string (path->complete-path icon-file)) + IMAGE_ICON + width + height + LR_LOADFROMFILE))) + (unless icon + (error 'mk-tray "could not load ICO file: ~a" icon-file)) + icon)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Convert a PNG file with alpha transparency to a native HICON. @@ -357,125 +354,135 @@ ;; Racket's drawing library already decodes PNG and preserves its alpha ;; channel. Scale it to the same system-small-icon size that is used for ;; ICO files, then turn the premultiplied pixels into a native HICON. - (define source-bitmap - (read-bitmap icon-file 'png/alpha #f #t)) - (unless (send source-bitmap ok?) - (error 'mk-tray "could not load PNG file: ~a" icon-file)) + (let* ((source-bitmap (read-bitmap icon-file 'png/alpha #f #t)) + (width (max 1 (GetSystemMetrics SM_CXSMICON))) + (height (max 1 (GetSystemMetrics SM_CYSMICON)))) + (unless (send source-bitmap ok?) + (error 'mk-tray "could not load PNG file: ~a" icon-file)) - (define width (max 1 (GetSystemMetrics SM_CXSMICON))) - (define height (max 1 (GetSystemMetrics SM_CYSMICON))) - (define source-width (send source-bitmap get-width)) - (define source-height (send source-bitmap get-height)) + (let* ((source-width (send source-bitmap get-width)) + (source-height (send source-bitmap get-height)) + ;; Keep the aspect ratio and center non-square images in the + ;; tray-icon area. + (scale + (min (/ width source-width) + (/ height source-height))) + (draw-width + (max 1 (inexact->exact (round (* source-width scale))))) + (draw-height + (max 1 (inexact->exact (round (* source-height scale))))) + (draw-x (quotient (- width draw-width) 2)) + (draw-y (quotient (- height draw-height) 2)) + (bitmap (make-bitmap width height #t)) + (dc (new bitmap-dc% [bitmap bitmap]))) + (send dc draw-bitmap-section-smooth + source-bitmap + draw-x + draw-y + draw-width + draw-height + 0 + 0 + source-width + source-height) + (send dc set-bitmap #f) - ;; Keep the aspect ratio and center non-square images in the tray-icon area. - (define scale - (min (/ width source-width) - (/ height source-height))) - (define draw-width (max 1 (inexact->exact (round (* source-width scale))))) - (define draw-height (max 1 (inexact->exact (round (* source-height scale))))) - (define draw-x (quotient (- width draw-width) 2)) - (define draw-y (quotient (- height draw-height) 2)) + (let* ((pixel-count (* width height)) + (argb (make-bytes (* pixel-count 4))) + (header + (make-BITMAPINFOHEADER + (ctype-sizeof _BITMAPINFOHEADER) + width + (- height) ; negative means top-down, matching Racket's row order + 1 + 32 + BI_RGB + (* pixel-count 4) + 0 + 0 + 0 + 0)) + (bits-out (malloc _pointer 'atomic))) + (send bitmap get-argb-pixels 0 0 width height argb #f #t) + (ptr-set! bits-out _pointer #f) - (define bitmap (make-bitmap width height #t)) - (define dc (new bitmap-dc% [bitmap bitmap])) - (send dc draw-bitmap-section-smooth - source-bitmap - draw-x - draw-y - draw-width - draw-height - 0 - 0 - source-width - source-height) - (send dc set-bitmap #f) + (let ((color-bitmap + (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0)) + (mask-bitmap #f)) + (unless color-bitmap + (error 'mk-tray + "CreateDIBSection failed while loading PNG icon: ~a" + icon-file)) - (define pixel-count (* width height)) - (define argb (make-bytes (* pixel-count 4))) - (send bitmap get-argb-pixels 0 0 width height argb #f #t) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ; 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 procedure is used on both the normal and + ; exceptional CreateIconIndirect paths so temporary GDI + ; objects never leak. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (letrec ((cleanup-bitmaps! + (λ () + (when mask-bitmap + (DeleteObject mask-bitmap) + (set! mask-bitmap #f)) + (when color-bitmap + (DeleteObject color-bitmap) + (set! color-bitmap #f))))) + (with-handlers ([exn? + (λ (exn) + (cleanup-bitmaps!) + (raise exn))]) + (let ((dib-bits (ptr-ref bits-out _pointer))) + (unless dib-bits + (error 'mk-tray + "CreateDIBSection did not return pixel storage for: ~a" + icon-file)) - (define header - (make-BITMAPINFOHEADER - (ctype-sizeof _BITMAPINFOHEADER) - width - (- height) ; negative means top-down, matching Racket's row order - 1 - 32 - BI_RGB - (* pixel-count 4) - 0 - 0 - 0 - 0)) - (define bits-out (malloc _pointer 'atomic)) - (ptr-set! bits-out _pointer #f) - (define color-bitmap - (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0)) - (unless color-bitmap - (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file)) + ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A + ;; byte order. get-argb-pixels was requested premultiplied + ;; because that is the form expected by alpha-blended icons. + (for ((pixel (in-range pixel-count))) + (let* ((source (* pixel 4)) + (alpha (bytes-ref argb source)) + (red (bytes-ref argb (+ source 1))) + (green (bytes-ref argb (+ source 2))) + (blue (bytes-ref argb (+ source 3)))) + (ptr-set! dib-bits _uint8 source blue) + (ptr-set! dib-bits _uint8 (+ source 1) green) + (ptr-set! dib-bits _uint8 (+ source 2) red) + (ptr-set! dib-bits _uint8 (+ source 3) alpha))) - (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) - (set! mask-bitmap #f)) - (when color-bitmap - (DeleteObject color-bitmap) - (set! color-bitmap #f))) + ;; For modern 32-bit alpha icons the color bitmap carries + ;; transparency. ICONINFO still requires a same-sized + ;; monochrome mask for a color icon. + (let* ((mask-stride (* 2 (quotient (+ width 15) 16))) + (mask-size (* mask-stride height)) + (mask-bits (malloc mask-size 'atomic))) + (memset mask-bits 0 0 mask-size) + (set! mask-bitmap + (CreateBitmap width height 1 1 mask-bits)) + (unless mask-bitmap + (error 'mk-tray + "CreateBitmap failed while loading PNG icon: ~a" + icon-file)) - (with-handlers ([exn? - (λ (exn) - (cleanup-bitmaps!) - (raise exn))]) - (define dib-bits (ptr-ref bits-out _pointer)) - (unless dib-bits - (error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file)) - - ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order. - ;; get-argb-pixels was requested premultiplied because that is the form - ;; expected by alpha-blended Windows icons. - (for ([pixel (in-range pixel-count)]) - (define source (* pixel 4)) - (define alpha (bytes-ref argb source)) - (define red (bytes-ref argb (+ source 1))) - (define green (bytes-ref argb (+ source 2))) - (define blue (bytes-ref argb (+ source 3))) - (ptr-set! dib-bits _uint8 source blue) - (ptr-set! dib-bits _uint8 (+ source 1) green) - (ptr-set! dib-bits _uint8 (+ source 2) red) - (ptr-set! dib-bits _uint8 (+ source 3) alpha)) - - ;; For modern 32-bit alpha icons the color bitmap carries transparency. - ;; ICONINFO still requires a same-sized monochrome mask for a color icon. - (define mask-stride (* 2 (quotient (+ width 15) 16))) - (define mask-size (* mask-stride height)) - (define mask-bits (malloc mask-size 'atomic)) - (memset mask-bits 0 0 mask-size) - (set! mask-bitmap - (CreateBitmap width height 1 1 mask-bits)) - (unless mask-bitmap - (error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file)) - - (define icon-info - (make-ICONINFO 1 0 0 mask-bitmap color-bitmap)) - (define icon (CreateIconIndirect icon-info)) - - ;; CreateIconIndirect copies both bitmaps, so the source GDI objects can - ;; be released immediately. The returned HICON remains owned by us. - (cleanup-bitmaps!) - (unless icon - (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file)) - icon)) + (let* ((icon-info + (make-ICONINFO 1 0 0 mask-bitmap color-bitmap)) + (icon (CreateIconIndirect icon-info))) + ;; CreateIconIndirect copies both bitmaps, so the source + ;; GDI objects can be released immediately. The returned + ;; HICON remains owned by us. + (cleanup-bitmaps!) + (unless icon + (error 'mk-tray + "CreateIconIndirect failed while loading PNG icon: ~a" + icon-file)) + icon)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Load a supported icon file into a native HICON. @@ -487,18 +494,18 @@ ; the public API stays predictable and small. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (load-icon icon-file) - (define name - (string-downcase - (path->string (path->complete-path icon-file)))) - (cond - [(regexp-match? #rx"[.]ico$" name) - (load-ico-icon icon-file)] - [(regexp-match? #rx"[.]png$" name) - (png->icon icon-file)] - [else - (error 'mk-tray - "expected an .ico or .png icon file; got: ~a" - icon-file)])) + (let ((name + (string-downcase + (path->string (path->complete-path icon-file))))) + (cond + [(regexp-match? #rx"[.]ico$" name) + (load-ico-icon icon-file)] + [(regexp-match? #rx"[.]png$" name) + (png->icon icon-file)] + [else + (error 'mk-tray + "expected an .ico or .png icon file; got: ~a" + icon-file)]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Extract the low 16 bits from a pointer-sized Win32 value. @@ -521,10 +528,10 @@ ; values >= #x8000 therefore represent negative coordinates. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (signed-word value) - (define n (low-word value)) - (if (>= n #x8000) - (- n #x10000) - n)) + (let ((n (low-word value))) + (if (>= n #x8000) + (- n #x10000) + n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Extract the signed X coordinate supplied by a tray notification. @@ -553,45 +560,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; 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%. +; goal : Convert a platform-independent menu specification to popup-menu%. +; pre : t is an open tray and menu-spec contains (list action-id label) +; entries and separator markers validated by the public module. +; post : Menu items invoke the tray callback with their action symbol. +; result : 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. +; Windows can reuse Racket GUI's popup-menu% because the tray icon is +; associated with the existing Racket frame HWND. Menu callbacks are +; therefore ordinary GUI callbacks, not native Win32 callbacks. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (menu-spec->popup-menu menu-spec) - (cond - [(not menu-spec) #f] - [(is-a? menu-spec popup-menu%) menu-spec] - [(list? menu-spec) - (let ([popup (new popup-menu%)]) - (for ([entry (in-list menu-spec)]) - (match entry - [(or #f 'separator) - (new separator-menu-item% [parent popup])] - [(list (? string? label) (? procedure? callback)) - (unless (procedure-arity-includes? callback 0) - (error 'tray-set-menu! - "menu callback for ~e does not accept zero arguments" - label)) - (new menu-item% - [parent popup] - [label label] - [callback (λ (_item _event) (callback))])] - [_ - (error 'tray-set-menu! - "expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e" - entry)])) - popup)] - [else - (error 'tray-set-menu! - "expected a popup-menu%, menu specification list, or #f; got: ~e" - menu-spec)])) +(define (menu-spec->popup-menu t menu-spec) + (let ((popup (new popup-menu%))) + (for ((entry (in-list menu-spec))) + (match entry + [(or #f 'separator) + (new separator-menu-item% [parent popup])] + [(list (? symbol? action-id) (? string? label)) + (new menu-item% + [parent popup] + [label label] + [callback + (λ (_item _event) + ((tray-callback t) action-id))])])) + popup)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Queue application work on the eventspace associated with tray t. @@ -604,14 +596,14 @@ ; 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) - (with-handlers ([exn:fail? (λ (_exn) (void))]) - (parameterize ([current-eventspace eventspace]) - (queue-callback - (λ () - (unless (tray-closed? t) - (thunk)))))))) + (let ((eventspace (tray-eventspace t))) + (unless (eventspace-shutdown? eventspace) + (with-handlers ([exn:fail? (λ (_exn) (void))]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (unless (tray-closed? t) + (thunk))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Start the ordinary Racket thread that dispatches native tray events. @@ -622,45 +614,38 @@ ; 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. +; FFI callback mode and queues user work into the frame eventspace. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (start-event-thread! t) - (define event-thread - (thread - (λ () - (let loop () - (match (sync (tray-event-channel t)) - ['close - (void)] - ['activate - (let ([callback (tray-on-click t)]) - (when callback - (queue-eventspace-callback t callback))) - (loop)] - ['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 - (λ () - (define menu (tray-menu t)) - (when menu - (let-values ([(x y) - (send (tray-frame t) - screen->client - screen-x - screen-y)]) - (send (tray-frame t) popup-menu menu x y))))) - (loop)] - [_ - (loop)]))))) - (set-tray-event-thread! t event-thread)) + (let ((event-thread + (thread + (λ () + (let loop () + (match (sync (tray-event-channel t)) + ['close + (void)] + ['activate + (queue-eventspace-callback + t + (λ () + ((tray-callback t) (tray-default-action t)))) + (loop)] + [(vector 'context-menu screen-x screen-y) + (queue-eventspace-callback + t + (λ () + (let ((menu (tray-menu t))) + (when menu + (let-values (((x y) + (send (tray-frame t) + screen->client + screen-x + screen-y))) + (send (tray-frame t) popup-menu menu x y)))))) + (loop)] + [_ + (loop)])))))) + (set-tray-event-thread! t event-thread))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Translate a Shell_NotifyIcon callback message to an internal event. @@ -678,19 +663,19 @@ ;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or ;; user code here. An OS async channel is explicitly safe to use from an OS ;; callback/thread, so forward the event to an ordinary Racket thread. - (define notification (low-word lparam)) - (cond - [(or (= notification NIN_SELECT) - (= notification NIN_KEYSELECT)) - (os-async-channel-put (tray-event-channel t) 'activate)] - [(= notification WM_CONTEXTMENU) - (os-async-channel-put - (tray-event-channel t) - (vector 'context-menu - (x-from-wparam wparam) - (y-from-wparam wparam)))] - [else - (void)])) + (let ((notification (low-word lparam))) + (cond + [(or (= notification NIN_SELECT) + (= notification NIN_KEYSELECT)) + (os-async-channel-put (tray-event-channel t) 'activate)] + [(= notification WM_CONTEXTMENU) + (os-async-channel-put + (tray-event-channel t) + (vector 'context-menu + (x-from-wparam wparam) + (y-from-wparam wparam)))] + [else + (void)]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Native window integration @@ -703,10 +688,11 @@ ; 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. +; The procedure handles only the private tray callback and +; WM_NCDESTROY cleanup. Minimize handling is intentionally absent: +; the public module implements it portably with is-iconized? polling. +; 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) @@ -714,23 +700,16 @@ [(= 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 ;; as part of window destruction. (unless (tray-closed? t) - (let ([data + (let ((data (make-notify-data hwnd (tray-id t) (tray-callback-message t) - (tray-icon t))]) + (tray-icon t)))) (Shell_NotifyIconW NIM_DELETE data) (when (tray-icon t) (DestroyIcon (tray-icon t)) @@ -756,23 +735,23 @@ ; the just-added icon again. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (add-notify-icon! t icon tooltip) - (define data - (make-notify-data (tray-hwnd t) - (tray-id t) - (tray-callback-message t) - icon)) - (set-NOTIFYICONDATAW-uFlags! - data - (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP)) - (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128) + (let ((data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + icon))) + (set-NOTIFYICONDATAW-uFlags! + data + (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP)) + (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128) - (unless (bool-result? (Shell_NotifyIconW NIM_ADD data)) - (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon")) + (unless (bool-result? (Shell_NotifyIconW NIM_ADD data)) + (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon")) - (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4) - (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data)) - (Shell_NotifyIconW NIM_DELETE data) - (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4"))) + (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4) + (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data)) + (Shell_NotifyIconW NIM_DELETE data) + (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Validate that t is a tray object that is still open. @@ -797,8 +776,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; 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. +; names a supported icon, callback accepts one symbol, and +; default-action is a symbol. ; 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. @@ -806,75 +785,70 @@ ; 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. +; belongs to that GUI thread. SetWindowSubclass observes only tray +; messages and window destruction; minimize handling is portable and +; belongs to the public module. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (mk-tray frame - icon-file - on-click-cb - #:hide-on-minimize? [hide-on-minimize? #f]) +(define (mk-tray frame icon-file callback default-action) (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))) - (raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb)) + (unless (and (procedure? callback) + (procedure-arity-includes? callback 1)) + (raise-argument-error 'mk-tray "(procedure-arity-includes/c 1)" callback)) + (unless (symbol? default-action) + (raise-argument-error 'mk-tray "symbol?" default-action)) - (define eventspace (send frame get-eventspace)) - (call-in-eventspace - eventspace - (λ () - (define hwnd (send frame get-handle)) - (unless hwnd - (error 'mk-tray "the frame does not have a native HWND")) + (let ((eventspace (send frame get-eventspace))) + (call-in-eventspace + eventspace + (λ () + (let ((hwnd (send frame get-handle))) + (unless hwnd + (error 'mk-tray "the frame does not have a native HWND")) - (let* ([id (allocate-tray-id)] - [callback-message (+ WM_APP id)] - [icon (load-icon icon-file)] - [t (tray frame - hwnd - id - callback-message - on-click-cb - hide-on-minimize? - eventspace - (make-os-async-channel) - #f - #f - icon - #f - #f)] - [subclass-proc - (function-ptr (make-subclass-proc t) _SUBCLASSPROC)]) - ;; WM_APP through 0xBFFF is reserved for application-private messages. - (when (> callback-message #xbfff) - (DestroyIcon icon) - (error 'mk-tray - "too many simultaneously addressable tray callback messages")) + (let* ((id (allocate-tray-id)) + (callback-message (+ WM_APP id)) + (icon (load-icon icon-file)) + (t (tray frame + hwnd + id + callback-message + callback + default-action + eventspace + (make-os-async-channel) + #f + #f + icon + #f + #f)) + (subclass-proc + (function-ptr (make-subclass-proc t) _SUBCLASSPROC))) + ;; WM_APP through 0xBFFF is reserved for application-private messages. + (when (> callback-message #xbfff) + (DestroyIcon icon) + (error 'mk-tray + "too many simultaneously addressable tray callback messages")) - (set-tray-subclass-proc! t subclass-proc) - (start-event-thread! t) + (set-tray-subclass-proc! t subclass-proc) + (start-event-thread! t) - (unless (bool-result? - (SetWindowSubclass hwnd subclass-proc id 0)) - (os-async-channel-put (tray-event-channel t) 'close) - (DestroyIcon icon) - (error 'mk-tray "SetWindowSubclass failed for the Racket frame")) - - (with-handlers ([exn? - (λ (exn) - (RemoveWindowSubclass hwnd subclass-proc id) - (os-async-channel-put (tray-event-channel t) 'close) - (DestroyIcon icon) - (raise exn))]) - (define frame-label (send frame get-label)) - (add-notify-icon! t icon - (if (string? frame-label) frame-label "Racket")) - t))))) + (unless (bool-result? + (SetWindowSubclass hwnd subclass-proc id 0)) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (error 'mk-tray "SetWindowSubclass failed for the Racket frame")) + (with-handlers ([exn? + (λ (exn) + (RemoveWindowSubclass hwnd subclass-proc id) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (raise exn))]) + (let ((frame-label (send frame get-label))) + (add-notify-icon! t icon + (if (string? frame-label) frame-label "Racket")) + t)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; goal : Remove a tray icon and release all native resources owned by it. @@ -928,29 +902,29 @@ (call-in-eventspace (tray-eventspace t) (λ () - (define new-icon (load-icon icon-file)) - (define data - (make-notify-data (tray-hwnd t) - (tray-id t) - (tray-callback-message t) - new-icon)) - (set-NOTIFYICONDATAW-uFlags! data NIF_ICON) - (cond - [(bool-result? (Shell_NotifyIconW NIM_MODIFY data)) - (let ([old-icon (tray-icon t)]) - (set-tray-icon! t new-icon) - (when old-icon - (DestroyIcon old-icon)))] - [else - (DestroyIcon new-icon) - (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")])))) + (let* ((new-icon (load-icon icon-file)) + (data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + new-icon))) + (set-NOTIFYICONDATAW-uFlags! data NIF_ICON) + (cond + [(bool-result? (Shell_NotifyIconW NIM_MODIFY data)) + (let ((old-icon (tray-icon t))) + (set-tray-icon! t new-icon) + (when old-icon + (DestroyIcon old-icon)))] + [else + (DestroyIcon new-icon) + (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")]))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; 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. +; goal : Associate an action menu with an existing tray object. +; pre : t is open and menu-spec contains validated (list action-id label) +; entries and separator markers. +; post : tray-menu contains a popup-menu% whose selections dispatch action +; symbols through the callback supplied to mk-tray. ; result : void. ; internals: ; Menu creation is performed in the frame eventspace because Racket @@ -961,5 +935,5 @@ (call-in-eventspace (tray-eventspace t) (λ () - (set-tray-menu! t (menu-spec->popup-menu menu-spec)))) + (set-tray-menu! t (menu-spec->popup-menu t menu-spec)))) (void)) diff --git a/scrbl/racket-tray.scrbl b/scrbl/racket-tray.scrbl index 670a43b..3068d55 100644 --- a/scrbl/racket-tray.scrbl +++ b/scrbl/racket-tray.scrbl @@ -10,60 +10,79 @@ @defmodule[racket-tray] -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. +Racket Tray provides a small cross-platform system tray API for Racket GUI +applications. Version 0.1.1 contains native backends for Windows, Linux and +macOS. The public API uses symbolic actions so application code does not depend +on a platform-specific tray menu implementation. @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))] + [action-spec list?] [#:hide-on-minimize? hide-on-minimize? boolean? #f]) any/c]{ -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. +Creates a tray icon associated with @racket[frame]. 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. +@racket[action-spec] is mandatory and must contain exactly two values: +@racket[(list callback default-action-id)]. @racket[callback] must accept one +argument and @racket[default-action-id] must be a symbol. Every action generated +by the tray is passed to @racket[callback] as a symbol. -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. +The default action must occur in the menu later installed with +@racket[tray-set-menu!]. Windows maps normal tray activation to this action. +Ayatana AppIndicator 0.6 or newer can do the same on Linux. Older AppIndicator +0.5.x implementations open the menu on primary activation instead. A native +macOS status item with an attached menu also opens its menu instead of invoking +the default action directly. -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. +When @racket[hide-on-minimize?] is true, Racket Tray periodically checks +@method[frame% is-iconized?]. When the frame changes to the iconized state it +is hidden with @racket[(send frame show #f)]. This implementation is entirely +platform independent and does not use a Win32, GTK or AppKit minimize hook. The returned value represents the tray icon and is accepted by the other procedures in this library. } +@section{Tray Actions and Menus} + +@defproc[(tray-set-menu! [tray any/c] + [menu-spec list?]) void?]{ +Sets the menu for @racket[tray]. An actionable entry has the form +@racket[(list action-id label)], where @racket[action-id] is a symbol and +@racket[label] is a string. @racket['separator] or @racket[#f] creates a +separator. Action identifiers must be unique and the menu must contain the +default action supplied to @racket[mk-tray]. + +For example: + +@racketblock[ +(tray-set-menu! + tray + (list + (list 'open "Open") + 'separator + (list 'exit "Exit"))) +] + +Choosing @racket["Open"] invokes the callback as @racket[(callback 'open)]. The +same callback receives every other menu action. +} + @section{Changing and Closing a Tray Icon} @defproc[(tray-set-icon! [tray any/c] [icon-file path-string?]) void?]{ -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 a menu item. @racket['separator] and -@racket[#f] create a separator. Each callback must accept zero arguments. +Replaces the image of @racket[tray]. PNG files can be used on all supported +platforms. The Windows backend also accepts ICO files. } @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. +Removes @racket[tray], stops its optional portable minimize watcher and releases +the native resources owned by the active platform backend. Calling this +procedure does not close the associated Racket window. } @section{Closing a Window to the Tray} @@ -81,17 +100,36 @@ of a frame. A tray application normally overrides it and hides the frame: ] 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. +window already has a portable public Racket callback; minimizing does not. + +@section{Platform Behaviour} + +On Windows, the backend uses the native HWND returned by Racket GUI, +@tt{Shell_NotifyIconW} and @tt{SetWindowSubclass}. A normal tray activation +invokes the configured default action. No additional native library is needed. + +On Linux, the backend uses Ayatana AppIndicator and GTK3. AppIndicator 0.6 or +newer provides primary activation, which Racket Tray maps to the default action. +With AppIndicator 0.5.x, primary activation opens the menu instead. Menu choices +have the same symbolic callback behaviour on both library versions. + +On macOS, the backend uses AppKit @tt{NSStatusItem}, @tt{NSStatusBarButton} and +@tt{NSMenu} through Racket's Objective-C FFI. A status item with an attached +menu opens that menu when activated. Menu choices invoke the common symbolic +callback. No additional native library is needed. + +@section{Linux Runtime Dependency} + +The Linux backend requires the Ayatana AppIndicator GTK3 runtime library. If it +cannot be loaded, @racket[mk-tray] reports the missing dependency and suggests +the native package to install. + +Debian and Ubuntu use @tt{libayatana-appindicator3-1}. Fedora uses +@tt{libayatana-appindicator-gtk3}. Arch Linux uses +@tt{libayatana-appindicator}. @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. +The package contains @filepath{examples/simple.rkt}. It demonstrates symbolic +tray actions, hiding a frame on minimize and close, restoring it from the tray, +and terminating the application only through the @racket['exit] action. diff --git a/tests/basic.rkt b/tests/basic.rkt index 76d6138..f0d1ce1 100644 --- a/tests/basic.rkt +++ b/tests/basic.rkt @@ -3,15 +3,17 @@ (require rackunit racket-tray) -;; The public module must be loadable on every platform, even when no tray -;; backend is available for the current operating system. +;; The public module must be loadable on every package build host, including a +;; Linux host that does not have the optional AppIndicator runtime installed. (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. +;; Keep the public signature testable without opening a GUI window or requiring +;; any native tray implementation to be available on the build host. +(check-true (procedure-arity-includes? mk-tray 3)) + (define-values (required-keywords allowed-keywords) (procedure-keywords mk-tray))