294 lines
13 KiB
Racket
294 lines
13 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/class
|
|
racket/gui/base
|
|
racket/runtime-path)
|
|
|
|
(provide mk-tray
|
|
tray-close
|
|
tray-set-icon!
|
|
tray-set-menu!)
|
|
|
|
;; 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)
|
|
|
|
(cond
|
|
[(eq? (system-type 'os) 'windows)
|
|
(set! platform-mk-tray
|
|
(dynamic-require windows-module 'mk-tray))
|
|
(set! platform-tray-close
|
|
(dynamic-require windows-module 'tray-close))
|
|
(set! platform-tray-set-icon!
|
|
(dynamic-require windows-module 'tray-set-icon!))
|
|
(set! platform-tray-set-menu!
|
|
(dynamic-require windows-module 'tray-set-menu!))]
|
|
[(eq? (system-type 'os) 'unix)
|
|
(set! platform-mk-tray
|
|
(dynamic-require linux-module 'mk-tray))
|
|
(set! platform-tray-close
|
|
(dynamic-require linux-module 'tray-close))
|
|
(set! platform-tray-set-icon!
|
|
(dynamic-require linux-module 'tray-set-icon!))
|
|
(set! platform-tray-set-menu!
|
|
(dynamic-require linux-module 'tray-set-menu!))]
|
|
[(eq? (system-type 'os) 'macosx)
|
|
(set! platform-mk-tray
|
|
(dynamic-require macos-module 'mk-tray))
|
|
(set! platform-tray-close
|
|
(dynamic-require macos-module 'tray-close))
|
|
(set! platform-tray-set-icon!
|
|
(dynamic-require macos-module 'tray-set-icon!))
|
|
(set! platform-tray-set-menu!
|
|
(dynamic-require macos-module 'tray-set-menu!))])
|
|
|
|
;; The public tray value keeps only platform-independent state. Native state is
|
|
;; owned entirely by the backend stored in platform-tray.
|
|
(struct tray (platform-tray
|
|
default-action
|
|
minimize-timer)
|
|
#:mutable)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Report that the current operating system has no tray backend.
|
|
; pre : who is the name of the public procedure being called.
|
|
; post : No state is changed.
|
|
; result : Does not return; raises an exception naming the unsupported OS.
|
|
; internals:
|
|
; The public module remains loadable on every platform; only an
|
|
; attempted tray operation fails when no backend was loaded.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (unsupported who)
|
|
(error who "not supported on this operating system: ~a" (system-type 'os)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; 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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a tray icon using the backend for the current platform.
|
|
; 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:
|
|
; 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
|
|
action-spec
|
|
#:hide-on-minimize? [hide-on-minimize? #f])
|
|
(unless (is-a? frame top-level-window<%>)
|
|
(raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame))
|
|
(unless (boolean? hide-on-minimize?)
|
|
(raise-argument-error 'mk-tray "boolean?" hide-on-minimize?))
|
|
(unless 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 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:
|
|
; Cleanup of native resources remains the responsibility of the
|
|
; backend; this procedure only coordinates the portable wrapper.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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 : 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:
|
|
; Image conversion and native resource ownership remain backend
|
|
; responsibilities because the accepted native image form differs by
|
|
; operating system.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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 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:
|
|
; Validation is performed once here so every backend receives the same
|
|
; small, platform-independent menu representation.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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))
|