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