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