564 lines
22 KiB
Racket
564 lines
22 KiB
Racket
#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))
|