378 lines
16 KiB
Racket
378 lines
16 KiB
Racket
#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))
|