940 lines
39 KiB
Racket
940 lines
39 KiB
Racket
#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))
|