linux & mac support, refactoring on minimize
This commit is contained in:
@@ -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.
|
||||
|
||||
+31
-17
@@ -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)
|
||||
|
||||
@@ -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))))
|
||||
|
||||
@@ -1,22 +1,27 @@
|
||||
#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)
|
||||
(cond
|
||||
[(eq? (system-type 'os) 'windows)
|
||||
(set! platform-mk-tray
|
||||
(dynamic-require windows-module 'mk-tray))
|
||||
(set! platform-tray-close
|
||||
@@ -24,7 +29,32 @@
|
||||
(set! platform-tray-set-icon!
|
||||
(dynamic-require windows-module 'tray-set-icon!))
|
||||
(set! platform-tray-set-menu!
|
||||
(dynamic-require windows-module '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))
|
||||
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
+167
-193
@@ -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)
|
||||
(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)
|
||||
id))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Convert a Win32 BOOL-style result to a Racket boolean.
|
||||
@@ -248,13 +245,13 @@
|
||||
; on the GUI thread that owns the window.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (call-in-eventspace eventspace thunk)
|
||||
(define handler-thread (eventspace-handler-thread eventspace))
|
||||
(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)])
|
||||
(let ((result-channel (make-channel)))
|
||||
(parameterize ([current-eventspace eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
@@ -264,7 +261,7 @@
|
||||
(channel-put result-channel (cons 'ok (thunk)))))))
|
||||
(match (channel-get result-channel)
|
||||
[(cons 'ok value) value]
|
||||
[(cons 'error exn) (raise exn)]))))
|
||||
[(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
|
||||
(let ((data
|
||||
(cast (malloc _NOTIFYICONDATAW 'atomic)
|
||||
_pointer
|
||||
_NOTIFYICONDATAW-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)
|
||||
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))
|
||||
(let ((source (cast text _string/utf-16 _pointer)))
|
||||
(for ([i (in-range capacity)])
|
||||
(array-set! array i 0))
|
||||
(let loop ([i 0])
|
||||
(let loop ((i 0))
|
||||
(when (< i (sub1 capacity))
|
||||
(let ([code-unit (ptr-ref source _uint16 i)])
|
||||
(let ((code-unit (ptr-ref source _uint16 i)))
|
||||
(unless (zero? code-unit)
|
||||
(array-set! array i code-unit)
|
||||
(loop (add1 i)))))))
|
||||
(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
|
||||
(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))
|
||||
LR_LOADFROMFILE)))
|
||||
(unless icon
|
||||
(error 'mk-tray "could not load ICO file: ~a" icon-file))
|
||||
icon)
|
||||
icon))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Convert a PNG file with alpha transparency to a native HICON.
|
||||
@@ -357,27 +354,27 @@
|
||||
;; 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))
|
||||
(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))
|
||||
|
||||
;; Keep the aspect ratio and center non-square images in the tray-icon area.
|
||||
(define scale
|
||||
(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)))
|
||||
(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))
|
||||
|
||||
(define bitmap (make-bitmap width height #t))
|
||||
(define dc (new bitmap-dc% [bitmap bitmap]))
|
||||
(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
|
||||
@@ -390,11 +387,9 @@
|
||||
source-height)
|
||||
(send dc set-bitmap #f)
|
||||
|
||||
(define pixel-count (* width height))
|
||||
(define argb (make-bytes (* pixel-count 4)))
|
||||
(send bitmap get-argb-pixels 0 0 width height argb #f #t)
|
||||
|
||||
(define header
|
||||
(let* ((pixel-count (* width height))
|
||||
(argb (make-bytes (* pixel-count 4)))
|
||||
(header
|
||||
(make-BITMAPINFOHEADER
|
||||
(ctype-sizeof _BITMAPINFOHEADER)
|
||||
width
|
||||
@@ -407,75 +402,87 @@
|
||||
0
|
||||
0
|
||||
0))
|
||||
(define bits-out (malloc _pointer 'atomic))
|
||||
(bits-out (malloc _pointer 'atomic)))
|
||||
(send bitmap get-argb-pixels 0 0 width height argb #f #t)
|
||||
(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))
|
||||
|
||||
(define mask-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))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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.
|
||||
; 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.
|
||||
; This local procedure is used on both the normal and
|
||||
; exceptional CreateIconIndirect paths so temporary GDI
|
||||
; objects never leak.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (cleanup-bitmaps!)
|
||||
(letrec ((cleanup-bitmaps!
|
||||
(λ ()
|
||||
(when mask-bitmap
|
||||
(DeleteObject mask-bitmap)
|
||||
(set! mask-bitmap #f))
|
||||
(when color-bitmap
|
||||
(DeleteObject color-bitmap)
|
||||
(set! color-bitmap #f)))
|
||||
|
||||
(set! color-bitmap #f)))))
|
||||
(with-handlers ([exn?
|
||||
(λ (exn)
|
||||
(cleanup-bitmaps!)
|
||||
(raise exn))])
|
||||
(define dib-bits (ptr-ref bits-out _pointer))
|
||||
(let ((dib-bits (ptr-ref bits-out _pointer)))
|
||||
(unless dib-bits
|
||||
(error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file))
|
||||
(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)))
|
||||
;; 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))
|
||||
(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))
|
||||
;; 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))
|
||||
(error 'mk-tray
|
||||
"CreateBitmap failed while loading PNG icon: ~a"
|
||||
icon-file))
|
||||
|
||||
(define icon-info
|
||||
(let* ((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.
|
||||
(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))
|
||||
(error 'mk-tray
|
||||
"CreateIconIndirect failed while loading PNG icon: ~a"
|
||||
icon-file))
|
||||
icon))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Load a supported icon file into a native HICON.
|
||||
@@ -487,9 +494,9 @@
|
||||
; the public API stays predictable and small.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (load-icon icon-file)
|
||||
(define name
|
||||
(let ((name
|
||||
(string-downcase
|
||||
(path->string (path->complete-path icon-file))))
|
||||
(path->string (path->complete-path icon-file)))))
|
||||
(cond
|
||||
[(regexp-match? #rx"[.]ico$" name)
|
||||
(load-ico-icon icon-file)]
|
||||
@@ -498,7 +505,7 @@
|
||||
[else
|
||||
(error 'mk-tray
|
||||
"expected an .ico or .png icon file; got: ~a"
|
||||
icon-file)]))
|
||||
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))
|
||||
(let ((n (low-word value)))
|
||||
(if (>= n #x8000)
|
||||
(- n #x10000)
|
||||
n))
|
||||
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)])
|
||||
(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 (? string? label) (? procedure? callback))
|
||||
(unless (procedure-arity-includes? callback 0)
|
||||
(error 'tray-set-menu!
|
||||
"menu callback for ~e does not accept zero arguments"
|
||||
label))
|
||||
[(list (? symbol? action-id) (? string? 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)]))
|
||||
[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))
|
||||
(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))))))))
|
||||
(thunk)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Start the ordinary Racket thread that dispatches native tray events.
|
||||
@@ -622,10 +614,10 @@
|
||||
; 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
|
||||
(let ((event-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
@@ -633,34 +625,27 @@
|
||||
['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)))
|
||||
((tray-callback t) (tray-default-action t))))
|
||||
(loop)]
|
||||
[(vector 'context-menu screen-x screen-y)
|
||||
(queue-eventspace-callback
|
||||
t
|
||||
(λ ()
|
||||
(define menu (tray-menu t))
|
||||
(let ((menu (tray-menu t)))
|
||||
(when menu
|
||||
(let-values ([(x y)
|
||||
(let-values (((x y)
|
||||
(send (tray-frame t)
|
||||
screen->client
|
||||
screen-x
|
||||
screen-y)])
|
||||
(send (tray-frame t) popup-menu menu x y)))))
|
||||
screen-y)))
|
||||
(send (tray-frame t) popup-menu menu x y))))))
|
||||
(loop)]
|
||||
[_
|
||||
(loop)])))))
|
||||
(set-tray-event-thread! t event-thread))
|
||||
(loop)]))))))
|
||||
(set-tray-event-thread! t event-thread)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Translate a Shell_NotifyIcon callback message to an internal event.
|
||||
@@ -678,7 +663,7 @@
|
||||
;; 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))
|
||||
(let ((notification (low-word lparam)))
|
||||
(cond
|
||||
[(or (= notification NIN_SELECT)
|
||||
(= notification NIN_KEYSELECT))
|
||||
@@ -690,7 +675,7 @@
|
||||
(x-from-wparam wparam)
|
||||
(y-from-wparam wparam)))]
|
||||
[else
|
||||
(void)]))
|
||||
(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,11 +735,11 @@
|
||||
; the just-added icon again.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (add-notify-icon! t icon tooltip)
|
||||
(define data
|
||||
(let ((data
|
||||
(make-notify-data (tray-hwnd t)
|
||||
(tray-id t)
|
||||
(tray-callback-message t)
|
||||
icon))
|
||||
icon)))
|
||||
(set-NOTIFYICONDATAW-uFlags!
|
||||
data
|
||||
(bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP))
|
||||
@@ -772,7 +751,7 @@
|
||||
(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")))
|
||||
(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,49 +785,45 @@
|
||||
; 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))
|
||||
(let ((eventspace (send frame get-eventspace)))
|
||||
(call-in-eventspace
|
||||
eventspace
|
||||
(λ ()
|
||||
(define hwnd (send frame get-handle))
|
||||
(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
|
||||
(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?
|
||||
callback
|
||||
default-action
|
||||
eventspace
|
||||
(make-os-async-channel)
|
||||
#f
|
||||
#f
|
||||
icon
|
||||
#f
|
||||
#f)]
|
||||
[subclass-proc
|
||||
(function-ptr (make-subclass-proc t) _SUBCLASSPROC)])
|
||||
#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)
|
||||
@@ -870,11 +845,10 @@
|
||||
(os-async-channel-put (tray-event-channel t) 'close)
|
||||
(DestroyIcon icon)
|
||||
(raise exn))])
|
||||
(define frame-label (send frame get-label))
|
||||
(let ((frame-label (send frame get-label)))
|
||||
(add-notify-icon! t icon
|
||||
(if (string? frame-label) frame-label "Racket"))
|
||||
t)))))
|
||||
|
||||
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
|
||||
(let* ((new-icon (load-icon icon-file))
|
||||
(data
|
||||
(make-notify-data (tray-hwnd t)
|
||||
(tray-id t)
|
||||
(tray-callback-message t)
|
||||
new-icon))
|
||||
new-icon)))
|
||||
(set-NOTIFYICONDATAW-uFlags! data NIF_ICON)
|
||||
(cond
|
||||
[(bool-result? (Shell_NotifyIconW NIM_MODIFY data))
|
||||
(let ([old-icon (tray-icon t)])
|
||||
(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")]))))
|
||||
(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))
|
||||
|
||||
+81
-43
@@ -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.
|
||||
|
||||
+6
-4
@@ -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))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user