#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_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 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
              callback
              default-action
              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)
  (let ((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)
  (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   : 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)
  (let ((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)
  (let ((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)
  (let* ((width (GetSystemMetrics SM_CXSMICON))
         (height (GetSystemMetrics SM_CYSMICON))
         (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.
  (let* ((source-bitmap (read-bitmap icon-file 'png/alpha #f #t))
         (width (max 1 (GetSystemMetrics SM_CXSMICON)))
         (height (max 1 (GetSystemMetrics SM_CYSMICON))))
    (unless (send source-bitmap ok?)
      (error 'mk-tray "could not load PNG file: ~a" icon-file))

    (let* ((source-width (send source-bitmap get-width))
           (source-height (send source-bitmap get-height))
           ;; Keep the aspect ratio and center non-square images in the
           ;; tray-icon area.
           (scale
            (min (/ width source-width)
                 (/ height source-height)))
           (draw-width
            (max 1 (inexact->exact (round (* source-width scale)))))
           (draw-height
            (max 1 (inexact->exact (round (* source-height scale)))))
           (draw-x (quotient (- width draw-width) 2))
           (draw-y (quotient (- height draw-height) 2))
           (bitmap (make-bitmap width height #t))
           (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)

      (let* ((pixel-count (* width height))
             (argb (make-bytes (* pixel-count 4)))
             (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))
             (bits-out (malloc _pointer 'atomic)))
        (send bitmap get-argb-pixels 0 0 width height argb #f #t)
        (ptr-set! bits-out _pointer #f)

        (let ((color-bitmap
               (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0))
              (mask-bitmap #f))
          (unless color-bitmap
            (error 'mk-tray
                   "CreateDIBSection failed while loading PNG icon: ~a"
                   icon-file))

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ; 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 procedure is used on both the normal and
          ;          exceptional CreateIconIndirect paths so temporary GDI
          ;          objects never leak.
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (letrec ((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))])
              (let ((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 icons.
                (for ((pixel (in-range pixel-count)))
                  (let* ((source (* pixel 4))
                         (alpha (bytes-ref argb source))
                         (red (bytes-ref argb (+ source 1)))
                         (green (bytes-ref argb (+ source 2)))
                         (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.
                (let* ((mask-stride (* 2 (quotient (+ width 15) 16)))
                       (mask-size (* mask-stride height))
                       (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))

                  (let* ((icon-info
                          (make-ICONINFO 1 0 0 mask-bitmap color-bitmap))
                         (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)
  (let ((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)
  (let ((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   : Convert a platform-independent menu specification to popup-menu%.
; pre    : t is an open tray and menu-spec contains (list action-id label)
;          entries and separator markers validated by the public module.
; post   : Menu items invoke the tray callback with their action symbol.
; result : A newly created popup-menu%.
; internals:
;          Windows can reuse Racket GUI's popup-menu% because the tray icon is
;          associated with the existing Racket frame HWND. Menu callbacks are
;          therefore ordinary GUI callbacks, not native Win32 callbacks.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (menu-spec->popup-menu t 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 (? symbol? action-id) (? string? label))
         (new menu-item%
              [parent popup]
              [label label]
              [callback
               (λ (_item _event)
                 ((tray-callback t) action-id))])]))
    popup))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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)
  (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 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 user work into the frame eventspace.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (start-event-thread! t)
  (let ((event-thread
         (thread
          (λ ()
            (let loop ()
              (match (sync (tray-event-channel t))
                ['close
                 (void)]
                ['activate
                 (queue-eventspace-callback
                  t
                  (λ ()
                    ((tray-callback t) (tray-default-action t))))
                 (loop)]
                [(vector 'context-menu screen-x screen-y)
                 (queue-eventspace-callback
                  t
                  (λ ()
                    (let ((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.
  (let ((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 and
;          WM_NCDESTROY cleanup. Minimize handling is intentionally absent:
;          the public module implements it portably with is-iconized? polling.
;          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]
      [(= 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)
  (let ((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, callback accepts one symbol, and
;          default-action is a symbol.
; 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. SetWindowSubclass observes only tray
;          messages and window destruction; minimize handling is portable and
;          belongs to the public module.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 ((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
                         callback
                         default-action
                         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))])
             (let ((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)
   (λ ()
     (let* ((new-icon (load-icon icon-file))
            (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 an action menu with an existing tray object.
; pre    : t is open and menu-spec contains validated (list action-id label)
;          entries and separator markers.
; post   : tray-menu contains a popup-menu% whose selections dispatch action
;          symbols through the callback supplied to mk-tray.
; 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 t menu-spec))))
  (void))