#lang racket/base

(require ffi/unsafe
         ffi/unsafe/define
         ffi/unsafe/os-async-channel
         ffi/winapi
         racket/class
         racket/draw
         racket/gui/base
         racket/match)

(provide mk-tray
         tray-close
         tray-set-icon!
         tray-set-menu!)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Windows constants and native types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Shell_NotifyIcon constants
(define NIM_ADD        #x00000000)
(define NIM_MODIFY     #x00000001)
(define NIM_DELETE     #x00000002)
(define NIM_SETVERSION #x00000004)

(define NIF_MESSAGE #x00000001)
(define NIF_ICON    #x00000002)
(define NIF_TIP     #x00000004)
(define NIF_SHOWTIP #x00000080)

(define NOTIFYICON_VERSION_4 4)

;; Window messages used by the tray integration.
(define WM_SIZE        #x0005)
(define WM_CONTEXTMENU #x007B)
(define WM_NCDESTROY   #x0082)
(define WM_USER        #x0400)
(define WM_APP         #x8000)
(define NIN_SELECT     (+ WM_USER 0))
(define NIN_KEYSELECT  (+ WM_USER 1))

(define SIZE_MINIMIZED 1)

(define IMAGE_ICON       1)
(define LR_LOADFROMFILE  #x00000010)
(define SM_CXSMICON      49)
(define SM_CYSMICON      50)

(define BI_RGB         0)
(define DIB_RGB_COLORS 0)

;; Windows scalar aliases. Pointer-sized values matter on 64-bit Windows.
(define _HWND      _pointer)
(define _HICON     _pointer)
(define _UINT_PTR  _uintptr)
(define _DWORD_PTR _uintptr)
(define _WPARAM    _uintptr)
(define _LPARAM    _intptr)
(define _LRESULT   _intptr)
(define _HBITMAP   _pointer)

(define-cstruct _BITMAPINFOHEADER
  ([biSize          _uint32]
   [biWidth         _int32]
   [biHeight        _int32]
   [biPlanes        _uint16]
   [biBitCount      _uint16]
   [biCompression   _uint32]
   [biSizeImage     _uint32]
   [biXPelsPerMeter _int32]
   [biYPelsPerMeter _int32]
   [biClrUsed       _uint32]
   [biClrImportant  _uint32]))

(define-cstruct _ICONINFO
  ([fIcon    _int32]
   [xHotspot _uint32]
   [yHotspot _uint32]
   [hbmMask  _HBITMAP]
   [hbmColor _HBITMAP]))

;; NOTIFYICONDATAW as defined by shellapi.h. The uTimeout/uVersion union is
;; represented by one UINT because this package only uses uVersion.
(define-cstruct _NOTIFYICONDATAW
  ([cbSize           _uint32]
   [hWnd             _HWND]
   [uID              _uint32]
   [uFlags           _uint32]
   [uCallbackMessage _uint32]
   [hIcon            _HICON]
   [szTip            (_array _uint16 128)]
   [dwState          _uint32]
   [dwStateMask      _uint32]
   [szInfo           (_array _uint16 256)]
   [uVersion         _uint32]
   [szInfoTitle      (_array _uint16 64)]
   [dwInfoFlags      _uint32]
   [guidItem         (_array _uint8 16)]
   [hBalloonIcon     _HICON]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Native Windows bindings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; shell32 owns the notification-area API; user32/gdi32 provide icon
;; creation and destruction; comctl32 provides safe window subclassing.
(define shell32  (ffi-lib "shell32.dll"))
(define user32   (ffi-lib "user32.dll"))
(define gdi32    (ffi-lib "gdi32.dll"))
(define comctl32 (ffi-lib "comctl32.dll"))

(define-ffi-definer define-shell32 shell32)
(define-ffi-definer define-user32 user32)
(define-ffi-definer define-gdi32 gdi32)
(define-ffi-definer define-comctl32 comctl32)

;; Adds, modifies, configures, or removes a notification-area icon.
(define-shell32 Shell_NotifyIconW
  (_fun #:abi winapi
        _uint32 _NOTIFYICONDATAW-pointer
        -> _int32))

;; Loads a native HICON from an ICO file. The returned icon is owned by us.
(define-user32 LoadImageW
  (_fun #:abi winapi
        _pointer _string/utf-16 _uint32 _int32 _int32 _uint32
        -> _pointer))

;; Releases an HICON that was loaded or created by this module.
(define-user32 DestroyIcon
  (_fun #:abi winapi _HICON -> _int32))

;; Creates an HICON by copying the HBITMAP values in ICONINFO.
(define-user32 CreateIconIndirect
  (_fun #:abi winapi _ICONINFO-pointer -> _HICON))

;; Returns the current Windows small-icon dimensions.
(define-user32 GetSystemMetrics
  (_fun #:abi winapi _int32 -> _int32))

;; Creates the 32-bit color bitmap used while converting PNG to HICON.
(define-gdi32 CreateDIBSection
  (_fun #:abi winapi
        _pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32
        -> _HBITMAP))

;; Creates the monochrome mask required by ICONINFO.
(define-gdi32 CreateBitmap
  (_fun #:abi winapi
        _int32 _int32 _uint32 _uint32 _pointer
        -> _HBITMAP))

;; Releases temporary GDI bitmap objects after CreateIconIndirect copies them.
(define-gdi32 DeleteObject
  (_fun #:abi winapi _pointer -> _int32))

;; Native callback signature used by SetWindowSubclass.
(define _SUBCLASSPROC
  (_fun #:abi winapi
        _HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR
        -> _LRESULT))

;; Adds our message hook without replacing Racket GUI's own window procedure.
(define-comctl32 SetWindowSubclass
  (_fun #:abi winapi
        _HWND _pointer _UINT_PTR _DWORD_PTR
        -> _int32))

;; Detaches the hook installed for an open tray object.
(define-comctl32 RemoveWindowSubclass
  (_fun #:abi winapi
        _HWND _pointer _UINT_PTR
        -> _int32))

;; Forwards every message that racket-tray does not consume.
(define-comctl32 DefSubclassProc
  (_fun #:abi winapi
        _HWND _uint32 _WPARAM _LPARAM
        -> _LRESULT))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal state
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A tray object owns its HICON and native subclass registration. The HWND is
;; owned by the Racket top-level window and must never be destroyed here.
(struct tray (frame
              hwnd
              id
              callback-message
              on-click
              hide-on-minimize?
              eventspace
              event-channel
              event-thread
              subclass-proc
              icon
              menu
              closed?)
  #:mutable)

(define next-tray-id 1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Allocate a process-local identifier for a tray icon.
; pre    : next-tray-id contains the next unused positive identifier.
; post   : next-tray-id is advanced by one when allocation succeeds.
; result : A unique integer in the range 1 through #xffff.
; internals:
;          The identifier is also used to derive the private WM_APP callback
;          message. Limiting it to 16 bits keeps that message in the range
;          reserved by Windows for application-private messages.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (allocate-tray-id)
  (define id next-tray-id)
  (when (> id #xffff)
    (error 'mk-tray "too many tray icons have been created in this process"))
  (set! next-tray-id (add1 next-tray-id))
  id)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Convert a Win32 BOOL-style result to a Racket boolean.
; pre    : v is an exact integer returned by a Win32 procedure.
; post   : No state is changed.
; result : #t for every non-zero value, #f for zero.
; internals:
;          Win32 BOOL values are integers rather than Racket booleans.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (bool-result? v)
  (not (zero? v)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Run thunk synchronously in the handler thread of eventspace.
; pre    : eventspace is a live Racket GUI eventspace 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:
;          When already in the handler thread, thunk is called directly.
;          Otherwise queue-callback schedules it and a channel transfers its
;          value or exception back to the caller. This keeps HWND operations
;          on the GUI thread that owns the window.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (call-in-eventspace eventspace thunk)
  (define 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   : Allocate and initialize a NOTIFYICONDATAW structure.
; pre    : hwnd is a valid HWND, id and callback-message are valid unsigned
;          integer values, and icon is either an HICON or #f.
; post   : A zero-initialized native structure has been filled with the common
;          tray fields; the caller may add flags and text fields afterwards.
; result : A pointer to NOTIFYICONDATAW allocated in atomic memory.
; internals:
;          Atomic memory is used because the structure is passed directly to
;          Win32 without containing Racket-managed pointers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-notify-data hwnd id callback-message icon)
  (define data
    (cast (malloc _NOTIFYICONDATAW 'atomic)
          _pointer
          _NOTIFYICONDATAW-pointer))
  (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW))
  (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW))
  (set-NOTIFYICONDATAW-hWnd! data hwnd)
  (set-NOTIFYICONDATAW-uID! data id)
  (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message)
  (set-NOTIFYICONDATAW-hIcon! data icon)
  data)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Copy a Racket string into a fixed-size UTF-16 Win32 array.
; pre    : array has room for capacity UTF-16 code units and capacity is at
;          least one.
; post   : array contains a zero-terminated copy of text, truncated when
;          necessary to leave room for the terminating zero.
; result : Unspecified; array is modified in place.
; internals:
;          The destination is cleared first so truncation always leaves a
;          valid zero-terminated Win32 string.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-wide-array! array text capacity)
  (define source (cast text _string/utf-16 _pointer))
  (for ([i (in-range capacity)])
    (array-set! array i 0))
  (let loop ([i 0])
    (when (< i (sub1 capacity))
      (let ([code-unit (ptr-ref source _uint16 i)])
        (unless (zero? code-unit)
          (array-set! array i code-unit)
          (loop (add1 i)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Icon loading
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Load an ICO file as a native Windows small icon.
; pre    : icon-file names an existing ICO file readable by Windows.
; post   : On success a new HICON is owned by the caller.
; result : A non-#f HICON; raises an exception when LoadImageW fails.
; internals:
;          Windows is asked for the current SM_CXSMICON/SM_CYSMICON size so
;          the shell receives an icon already sized for the notification area.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (load-ico-icon icon-file)
  (define width (GetSystemMetrics SM_CXSMICON))
  (define height (GetSystemMetrics SM_CYSMICON))
  (define icon
    (LoadImageW #f
                (path->string (path->complete-path icon-file))
                IMAGE_ICON
                width
                height
                LR_LOADFROMFILE))
  (unless icon
    (error 'mk-tray "could not load ICO file: ~a" icon-file))
  icon)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Convert a PNG file with alpha transparency to a native HICON.
; pre    : icon-file names a readable PNG image and the Windows GDI functions
;          needed to create bitmaps and icons are available.
; post   : Temporary HBITMAP objects are released before return; on success
;          the returned HICON is owned by the caller.
; result : A non-#f HICON; raises an exception when decoding or native icon
;          creation fails.
; internals:
;          Racket decodes and scales the PNG. Premultiplied ARGB pixels are
;          copied into a top-down 32-bit DIB in Windows BGRA byte order.
;          CreateIconIndirect copies the color and mask bitmaps, allowing the
;          temporary GDI objects to be deleted immediately afterwards.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (png->icon icon-file)
  ;; Racket's drawing library already decodes PNG and preserves its alpha
  ;; channel. Scale it to the same system-small-icon size that is used for
  ;; ICO files, then turn the premultiplied pixels into a native HICON.
  (define source-bitmap
    (read-bitmap icon-file 'png/alpha #f #t))
  (unless (send source-bitmap ok?)
    (error 'mk-tray "could not load PNG file: ~a" icon-file))

  (define width (max 1 (GetSystemMetrics SM_CXSMICON)))
  (define height (max 1 (GetSystemMetrics SM_CYSMICON)))
  (define source-width (send source-bitmap get-width))
  (define source-height (send source-bitmap get-height))

  ;; Keep the aspect ratio and center non-square images in the tray-icon area.
  (define scale
    (min (/ width source-width)
         (/ height source-height)))
  (define draw-width (max 1 (inexact->exact (round (* source-width scale)))))
  (define draw-height (max 1 (inexact->exact (round (* source-height scale)))))
  (define draw-x (quotient (- width draw-width) 2))
  (define draw-y (quotient (- height draw-height) 2))

  (define bitmap (make-bitmap width height #t))
  (define dc (new bitmap-dc% [bitmap bitmap]))
  (send dc draw-bitmap-section-smooth
        source-bitmap
        draw-x
        draw-y
        draw-width
        draw-height
        0
        0
        source-width
        source-height)
  (send dc set-bitmap #f)

  (define pixel-count (* width height))
  (define argb (make-bytes (* pixel-count 4)))
  (send bitmap get-argb-pixels 0 0 width height argb #f #t)

  (define header
    (make-BITMAPINFOHEADER
     (ctype-sizeof _BITMAPINFOHEADER)
     width
     (- height) ; negative means top-down, matching Racket's row order
     1
     32
     BI_RGB
     (* pixel-count 4)
     0
     0
     0
     0))
  (define bits-out (malloc _pointer 'atomic))
  (ptr-set! bits-out _pointer #f)
  (define color-bitmap
    (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0))
  (unless color-bitmap
    (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file))

  (define mask-bitmap #f)
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ; goal   : Release temporary GDI bitmaps created during PNG conversion.
  ; pre    : color-bitmap and mask-bitmap are HBITMAP values or #f.
  ; post   : Every non-#f bitmap is deleted and its local variable is set to
  ;          #f, making repeated cleanup safe.
  ; result : Unspecified.
  ; internals:
  ;          This local helper is used on both the normal and exceptional
  ;          CreateIconIndirect paths so temporary GDI objects never leak.
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (define (cleanup-bitmaps!)
    (when mask-bitmap
      (DeleteObject mask-bitmap)
      (set! mask-bitmap #f))
    (when color-bitmap
      (DeleteObject color-bitmap)
      (set! color-bitmap #f)))

  (with-handlers ([exn?
                   (λ (exn)
                     (cleanup-bitmaps!)
                     (raise exn))])
    (define dib-bits (ptr-ref bits-out _pointer))
    (unless dib-bits
      (error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file))

    ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order.
    ;; get-argb-pixels was requested premultiplied because that is the form
    ;; expected by alpha-blended Windows icons.
    (for ([pixel (in-range pixel-count)])
      (define source (* pixel 4))
      (define alpha (bytes-ref argb source))
      (define red (bytes-ref argb (+ source 1)))
      (define green (bytes-ref argb (+ source 2)))
      (define blue (bytes-ref argb (+ source 3)))
      (ptr-set! dib-bits _uint8 source blue)
      (ptr-set! dib-bits _uint8 (+ source 1) green)
      (ptr-set! dib-bits _uint8 (+ source 2) red)
      (ptr-set! dib-bits _uint8 (+ source 3) alpha))

    ;; For modern 32-bit alpha icons the color bitmap carries transparency.
    ;; ICONINFO still requires a same-sized monochrome mask for a color icon.
    (define mask-stride (* 2 (quotient (+ width 15) 16)))
    (define mask-size (* mask-stride height))
    (define mask-bits (malloc mask-size 'atomic))
    (memset mask-bits 0 0 mask-size)
    (set! mask-bitmap
          (CreateBitmap width height 1 1 mask-bits))
    (unless mask-bitmap
      (error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file))

    (define icon-info
      (make-ICONINFO 1 0 0 mask-bitmap color-bitmap))
    (define icon (CreateIconIndirect icon-info))

    ;; CreateIconIndirect copies both bitmaps, so the source GDI objects can
    ;; be released immediately. The returned HICON remains owned by us.
    (cleanup-bitmaps!)
    (unless icon
      (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file))
    icon))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Load a supported icon file into a native HICON.
; pre    : icon-file is a path-string naming an .ico or .png file.
; post   : On success the caller owns the returned HICON.
; result : An HICON loaded by load-ico-icon or created by png->icon.
; internals:
;          Dispatch is deliberately based only on the filename extension so
;          the public API stays predictable and small.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (load-icon icon-file)
  (define name
    (string-downcase
     (path->string (path->complete-path icon-file))))
  (cond
    [(regexp-match? #rx"[.]ico$" name)
     (load-ico-icon icon-file)]
    [(regexp-match? #rx"[.]png$" name)
     (png->icon icon-file)]
    [else
     (error 'mk-tray
            "expected an .ico or .png icon file; got: ~a"
            icon-file)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Extract the low 16 bits from a pointer-sized Win32 value.
; pre    : value is an exact integer.
; post   : No state is changed.
; result : An integer in the range 0 through #xffff.
; internals:
;          Tray notification codes are packed into the low word of LPARAM.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (low-word value)
  (bitwise-and value #xffff))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Interpret the low 16 bits of value as a signed Windows coordinate.
; pre    : value is an exact integer.
; post   : No state is changed.
; result : An integer in the signed 16-bit range.
; internals:
;          WM_CONTEXTMENU packs signed screen coordinates into WORD values;
;          values >= #x8000 therefore represent negative coordinates.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (signed-word value)
  (define n (low-word value))
  (if (>= n #x8000)
      (- n #x10000)
      n))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Extract the signed X coordinate supplied by a tray notification.
; pre    : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
; post   : No state is changed.
; result : The signed screen X coordinate from the low word of wparam.
; internals:
;          NOTIFYICON_VERSION_4 packs the anchor coordinates in WPARAM.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (x-from-wparam wparam)
  (signed-word wparam))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Extract the signed Y coordinate supplied by a tray notification.
; pre    : wparam is the WPARAM received for a NOTIFYICON_VERSION_4 event.
; post   : No state is changed.
; result : The signed screen Y coordinate from the high word of wparam.
; internals:
;          The high word is shifted down before signed-word interprets it.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (y-from-wparam wparam)
  (signed-word (arithmetic-shift wparam -16)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Event and menu handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Normalize a public tray menu specification to popup-menu%.
; pre    : menu-spec is #f, a popup-menu%, or a list containing two-element
;          (label callback) lists and separator markers.
; post   : Newly created menu items hold callbacks that invoke the supplied
;          zero-argument procedures.
; result : #f, the original popup-menu%, or a newly created popup-menu%.
; internals:
;          A simple list is converted directly to Racket GUI menu objects so
;          menu callbacks remain ordinary Racket GUI callbacks rather than
;          native Win32 callback code.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (menu-spec->popup-menu menu-spec)
  (cond
    [(not menu-spec) #f]
    [(is-a? menu-spec popup-menu%) menu-spec]
    [(list? menu-spec)
     (let ([popup (new popup-menu%)])
       (for ([entry (in-list menu-spec)])
         (match entry
           [(or #f 'separator)
            (new separator-menu-item% [parent popup])]
           [(list (? string? label) (? procedure? callback))
            (unless (procedure-arity-includes? callback 0)
              (error 'tray-set-menu!
                     "menu callback for ~e does not accept zero arguments"
                     label))
            (new menu-item%
                 [parent popup]
                 [label label]
                 [callback (λ (_item _event) (callback))])]
           [_
            (error 'tray-set-menu!
                   "expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e"
                   entry)]))
       popup)]
    [else
     (error 'tray-set-menu!
            "expected a popup-menu%, menu specification list, or #f; got: ~e"
            menu-spec)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Queue application work on the eventspace associated with tray t.
; pre    : t is a tray object and thunk accepts no arguments.
; post   : When the eventspace is live, thunk is queued; it is skipped when
;          the tray has been closed before execution.
; result : Unspecified.
; internals:
;          Shutdown races are intentionally ignored here because native tray
;          messages can arrive while the GUI is being torn down.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (queue-eventspace-callback t thunk)
  (define 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 tray events.
; pre    : t is a newly created tray with an event channel and no event thread.
; post   : tray-event-thread contains the new dispatcher thread; the thread
;          exits after receiving the symbol 'close.
; result : Unspecified; t is modified in place.
; internals:
;          Native FFI callbacks only write small immutable event values to the
;          OS async channel. This thread receives those values outside atomic
;          FFI callback mode and queues GUI/user work into the frame eventspace.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (start-event-thread! t)
  (define event-thread
    (thread
     (λ ()
       (let loop ()
         (match (sync (tray-event-channel t))
           ['close
            (void)]
           ['activate
            (let ([callback (tray-on-click t)])
              (when callback
                (queue-eventspace-callback t callback)))
            (loop)]
           ['minimize
            (queue-eventspace-callback
             t
             (λ ()
               ;; Hiding instead of iconizing removes the application from the
               ;; taskbar while keeping the HWND alive for the tray icon.
               (send (tray-frame t) show #f)))
            (loop)]
           [(vector 'context-menu screen-x screen-y)
            (queue-eventspace-callback
             t
             (λ ()
               (define menu (tray-menu t))
               (when menu
                 (let-values ([(x y)
                               (send (tray-frame t)
                                     screen->client
                                     screen-x
                                     screen-y)])
                   (send (tray-frame t) popup-menu menu x y)))))
            (loop)]
           [_
            (loop)])))))
  (set-tray-event-thread! t event-thread))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Translate a Shell_NotifyIcon callback message to an internal event.
; pre    : t is an open tray and wparam/lparam are the values supplied by the
;          native tray callback message.
; post   : Recognized activation or context-menu events are written to the
;          tray OS async channel; no GUI or user callback is run directly.
; result : void.
; internals:
;          Racket CS executes foreign callbacks in atomic mode. Using
;          os-async-channel-put here is safe and postpones ordinary Racket and
;          GUI work until start-event-thread! receives the event.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (handle-native-tray-event t wparam lparam)
  ;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or
  ;; user code here. An OS async channel is explicitly safe to use from an OS
  ;; callback/thread, so forward the event to an ordinary Racket thread.
  (define notification (low-word lparam))
  (cond
    [(or (= notification NIN_SELECT)
         (= notification NIN_KEYSELECT))
     (os-async-channel-put (tray-event-channel t) 'activate)]
    [(= notification WM_CONTEXTMENU)
     (os-async-channel-put
      (tray-event-channel t)
      (vector 'context-menu
              (x-from-wparam wparam)
              (y-from-wparam wparam)))]
    [else
     (void)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Native window integration
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create the Win32 subclass procedure used by a tray object.
; pre    : t contains the HWND, callback message, event channel and tray state
;          required by the native callback.
; post   : No subclass is installed by this procedure itself.
; result : A Racket procedure with the SUBCLASSPROC calling convention.
; internals:
;          The procedure handles only the private tray callback, optional
;          WM_SIZE/SIZE_MINIMIZED handling, and WM_NCDESTROY cleanup. Every
;          other message is passed unchanged to DefSubclassProc so Racket's
;          own window procedure remains in control.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-subclass-proc t)
  (λ (hwnd msg wparam lparam _subclass-id _ref-data)
    (cond
      [(= msg (tray-callback-message t))
       (handle-native-tray-event t wparam lparam)
       0]
      [(and (= msg WM_SIZE)
            (= wparam SIZE_MINIMIZED)
            (tray-hide-on-minimize? t))
       ;; Forward only a small value from the native callback. GUI work is
       ;; performed later on the frame's eventspace.
       (os-async-channel-put (tray-event-channel t) 'minimize)
       (DefSubclassProc hwnd msg wparam lparam)]
      [(= msg WM_NCDESTROY)
       ;; The HWND is going away. Remove the notification-area icon while the
       ;; handle is still valid. Windows discards the subclass automatically
       ;; as part of window destruction.
       (unless (tray-closed? t)
         (let ([data
                (make-notify-data hwnd
                                  (tray-id t)
                                  (tray-callback-message t)
                                  (tray-icon t))])
           (Shell_NotifyIconW NIM_DELETE data)
           (when (tray-icon t)
             (DestroyIcon (tray-icon t))
             (set-tray-icon! t #f))
           (set-tray-closed?! t #t)
           (os-async-channel-put (tray-event-channel t) 'close)))
       (DefSubclassProc hwnd msg wparam lparam)]
      [else
       (DefSubclassProc hwnd msg wparam lparam)])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Register tray t in the Windows notification area.
; pre    : t has a live HWND and installed subclass; icon is a valid HICON and
;          tooltip is a string.
; post   : On success the shell owns a notification-area entry for t and it is
;          configured for NOTIFYICON_VERSION_4 semantics.
; result : Unspecified; raises an exception when registration or version setup
;          fails.
; internals:
;          NIM_ADD installs the icon and callback message. NIM_SETVERSION is
;          issued immediately afterwards so keyboard/context-menu events use
;          the current notification protocol. A failed version setup removes
;          the just-added icon again.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-notify-icon! t icon tooltip)
  (define data
    (make-notify-data (tray-hwnd t)
                      (tray-id t)
                      (tray-callback-message t)
                      icon))
  (set-NOTIFYICONDATAW-uFlags!
   data
   (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP))
  (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128)

  (unless (bool-result? (Shell_NotifyIconW NIM_ADD data))
    (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon"))

  (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4)
  (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data))
    (Shell_NotifyIconW NIM_DELETE data)
    (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Validate that t is a tray object that is still open.
; pre    : who is a symbol naming the calling procedure.
; post   : No state is changed.
; result : Unspecified when valid; otherwise raises a precise argument/state
;          exception for the calling procedure.
; internals:
;          Centralizing this check keeps the mutating public procedures small
;          without introducing a wider abstraction layer.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 Windows notification-area icon bound to a Racket window.
; pre    : frame implements top-level-window<%>, has a native HWND, icon-file
;          names a supported icon, on-click-cb is #f or a zero-argument
;          procedure, and hide-on-minimize? is boolean.
; post   : A native icon is registered, the frame HWND is subclassed, and an
;          event-dispatch thread is running. On failure, resources created up
;          to that point are released.
; result : A mutable tray object used by tray-close, tray-set-icon! and
;          tray-set-menu!.
; internals:
;          Creation is performed in the frame's eventspace because the HWND
;          belongs to that GUI thread. The existing Racket HWND is reused;
;          SetWindowSubclass observes tray/minimize messages without replacing
;          Racket's own WndProc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-tray frame
                 icon-file
                 on-click-cb
                 #: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 (or (not on-click-cb)
              (and (procedure? on-click-cb)
                   (procedure-arity-includes? on-click-cb 0)))
    (raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb))

  (define eventspace (send frame get-eventspace))
  (call-in-eventspace
   eventspace
   (λ ()
     (define hwnd (send frame get-handle))
     (unless hwnd
       (error 'mk-tray "the frame does not have a native HWND"))

     (let* ([id (allocate-tray-id)]
            [callback-message (+ WM_APP id)]
            [icon (load-icon icon-file)]
            [t (tray frame
                     hwnd
                     id
                     callback-message
                     on-click-cb
                     hide-on-minimize?
                     eventspace
                     (make-os-async-channel)
                     #f
                     #f
                     icon
                     #f
                     #f)]
            [subclass-proc
             (function-ptr (make-subclass-proc t) _SUBCLASSPROC)])
       ;; WM_APP through 0xBFFF is reserved for application-private messages.
       (when (> callback-message #xbfff)
         (DestroyIcon icon)
         (error 'mk-tray
                "too many simultaneously addressable tray callback messages"))

       (set-tray-subclass-proc! t subclass-proc)
       (start-event-thread! t)

       (unless (bool-result?
                (SetWindowSubclass hwnd subclass-proc id 0))
         (os-async-channel-put (tray-event-channel t) 'close)
         (DestroyIcon icon)
         (error 'mk-tray "SetWindowSubclass failed for the Racket frame"))

       (with-handlers ([exn?
                        (λ (exn)
                          (RemoveWindowSubclass hwnd subclass-proc id)
                          (os-async-channel-put (tray-event-channel t) 'close)
                          (DestroyIcon icon)
                          (raise exn))])
         (define frame-label (send frame get-label))
         (add-notify-icon! t icon
                           (if (string? frame-label) frame-label "Racket"))
         t)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Remove a tray icon and release all native resources owned by it.
; pre    : t is a tray object; calling tray-close repeatedly is allowed.
; post   : The shell icon is removed, the HWND subclass is detached, the HICON
;          is destroyed, the tray is marked closed, and its event thread is
;          told to stop.
; result : void.
; internals:
;          Cleanup runs in the frame eventspace so subclass removal happens on
;          the window-owning GUI thread. The closed? check makes cleanup
;          idempotent and avoids double-destroying the HICON.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)
         (let ([data
                (make-notify-data (tray-hwnd t)
                                  (tray-id t)
                                  (tray-callback-message t)
                                  (tray-icon t))])
           (Shell_NotifyIconW NIM_DELETE data)
           (RemoveWindowSubclass (tray-hwnd t)
                                 (tray-subclass-proc t)
                                 (tray-id t))
           (when (tray-icon t)
             (DestroyIcon (tray-icon t))
             (set-tray-icon! t #f))
           (set-tray-closed?! t #t)
           (os-async-channel-put (tray-event-channel t) 'close))))))
  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Replace the image of an existing notification-area icon.
; pre    : t is an open tray and icon-file names a readable .ico or .png file.
; post   : On success the shell and tray object use the new HICON and the old
;          HICON is destroyed. On failure the new HICON is destroyed and the
;          existing tray icon remains unchanged.
; result : Unspecified.
; internals:
;          NIM_MODIFY is issued with only NIF_ICON set. Ownership is swapped
;          only after Windows accepts the new native icon.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-icon! t icon-file)
  (check-open-tray 'tray-set-icon! t)
  (call-in-eventspace
   (tray-eventspace t)
   (λ ()
     (define new-icon (load-icon icon-file))
     (define data
       (make-notify-data (tray-hwnd t)
                         (tray-id t)
                         (tray-callback-message t)
                         new-icon))
     (set-NOTIFYICONDATAW-uFlags! data NIF_ICON)
     (cond
       [(bool-result? (Shell_NotifyIconW NIM_MODIFY data))
        (let ([old-icon (tray-icon t)])
          (set-tray-icon! t new-icon)
          (when old-icon
            (DestroyIcon old-icon)))]
       [else
        (DestroyIcon new-icon)
        (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")]))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Associate a context menu with an existing tray object.
; pre    : t is an open tray and menu-spec is accepted by
;          menu-spec->popup-menu.
; post   : tray-menu contains #f or a popup-menu% ready to be shown on the
;          frame eventspace when Windows reports WM_CONTEXTMENU.
; result : void.
; internals:
;          Menu creation is performed in the frame eventspace because Racket
;          GUI objects must belong to the appropriate GUI eventspace.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-menu! t menu-spec)
  (check-open-tray 'tray-set-menu! t)
  (call-in-eventspace
   (tray-eventspace t)
   (λ ()
     (set-tray-menu! t (menu-spec->popup-menu menu-spec))))
  (void))