#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))