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

linux & mac support, refactoring on minimize

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 21:13:29 +02:00
parent c7137fc11f
commit 9f87eae8aa
9 changed files with 1760 additions and 535 deletions
Download Patch File Download Diff File Expand all files Collapse all files
private/linux.rkt
+563
View File
@@ -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))
private/macos.rkt
+377
View File
@@ -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))
private/windows.rkt
+368 -394
View File
@@ -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))