hans/racket-tray
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

implemented

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-29 01:09:49 +02:00
parent b8a522c1de
commit c7137fc11f
7 changed files with 588 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+2
View File
@@ -15,3 +15,5 @@ compiled/
# Dependency tracking files # Dependency tracking files
*.dep *.dep
*.bak
README.md
+30 -15
View File
@@ -2,46 +2,61 @@
A small system tray API for Racket. A small system tray API for Racket.
Version 0.1 implements Windows directly through the Win32 API. It uses the Version 0.1.1 implements Windows directly through the Win32 API. It uses the
native `HWND` of an existing Racket `frame%`/`dialog%`, `Shell_NotifyIconW`, and native `HWND` of an existing Racket `frame%` or `dialog%`, `Shell_NotifyIconW`,
`SetWindowSubclass`. No additional native DLL is required. and `SetWindowSubclass`. No additional native DLL is required.
```racket ```racket
#lang racket/gui #lang racket/gui
(require racket-tray) (require racket-tray)
(define frame (define tray-frame%
(new frame% (class frame%
[label "Tray example"] (super-new [label "Tray example"]
[width 400] [width 400]
[height 250])) [height 250])
;; Close [X] to the tray instead of destroying the frame.
(define/override (on-close)
(send this show #f))))
(define frame (new tray-frame%))
(define (show-frame)
(send frame show #t)
(when (send frame is-iconized?)
(send frame iconize #f)))
(define tray (define tray
(mk-tray frame (mk-tray frame
"example.png" "example.png"
(λ () show-frame
(send frame show #t)))) #:hide-on-minimize? #t))
(tray-set-menu! (tray-set-menu!
tray tray
(list (list
(list "Open" (list "Open" show-frame)
(λ () (send frame show #t)))
'separator 'separator
(list "Exit" (list "Exit"
(λ () (λ ()
(tray-close tray) (tray-close tray)
(send frame show #f))))) (exit)))))
(send frame show #t) (send frame show #t)
``` ```
`mk-tray` and `tray-set-icon!` accept both Windows `.ico` files and `.png` `mk-tray` and `tray-set-icon!` accept both Windows `.ico` files and `.png`
files. PNG transparency is preserved when the image is converted to the native files. PNG transparency is preserved when the image is converted to a native
Windows tray icon. Windows tray icon.
`tray-set-menu!` also accepts a `popup-menu%` object directly, or `#f` to With `#:hide-on-minimize? #t`, minimizing the associated window hides it from
remove the context menu. the taskbar while keeping its native window handle alive. Closing a window to
the tray does not need a separate tray API: override `frame%`'s `on-close` and
call `(send this show #f)`.
`tray-set-menu!` accepts a `popup-menu%` object directly, a simple menu list,
or `#f` to remove the context menu.
At the moment non-Windows platforms report that the operation is unsupported. At the moment non-Windows platforms report that the operation is unsupported.
examples/simple.rkt
+40 -8
View File
@@ -3,39 +3,71 @@
;(require racket-tray) ;(require racket-tray)
(require "../main.rkt") (require "../main.rkt")
;; This example demonstrates the two common "close to tray" behaviours:
;;
;; * minimize: handled by racket-tray through #:hide-on-minimize?
;; * close [X]: handled by frame%'s normal on-close callback
;;
;; The frame remains alive in both cases because the tray icon uses its HWND.
(define simple% (define simple%
(class frame% (class frame%
(super-new [label "Racket Tray"] (super-new [label "Racket Tray"]
[width 400] [width 400]
[height 250]) [height 250])
(define lbl (new message% [label "Counting tray clicks"] [parent this] (define lbl
[auto-resize #t] [stretchable-width #t])) (new message%
[label "Counting tray clicks"]
[parent this]
[auto-resize #t]
[stretchable-width #t]))
(define count 0) (define count 0)
(define/public (count-next) (define/public (count-next)
(set! count (+ count 1)) (set! count (add1 count))
(send lbl set-label (format "Counting tray clicks: ~a" count))) (send lbl set-label
)) (format "Counting tray clicks: ~a" count)))
;; Clicking the window's close button hides the frame instead of
;; destroying it. The tray menu's Exit item terminates the application.
(define/override (on-close)
(send this show #f))))
(define frame (new simple%)) (define frame (new simple%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Show and restore the example frame from the tray.
; pre : frame has been created and has not been destroyed.
; post : frame is visible and no longer iconized.
; result : Unspecified.
; internals:
; A frame hidden in response to SIZE_MINIMIZED can still retain its
; iconized state, so show #t is followed by iconize #f when needed.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (show-frame)
;; A frame hidden after a minimize can still be iconized. Make sure it is
;; restored when it is opened from the tray.
(send frame show #t)
(when (send frame is-iconized?)
(send frame iconize #f)))
(define tray (define tray
(mk-tray frame (mk-tray frame
"simple.png" "simple.png"
(λ () (λ ()
(send frame count-next) (send frame count-next)
(send frame show #t)))) (show-frame))
#:hide-on-minimize? #t))
(tray-set-menu! (tray-set-menu!
tray tray
(list (list
(list "Open" (λ () (send frame show #t))) (list "Open" show-frame)
'separator 'separator
(list "Exit" (list "Exit"
(λ () (λ ()
(tray-close tray) (tray-close tray)
(send frame show #f))))) (exit)))))
(send frame show #t) (send frame show #t)
main.rkt
+95 -23
View File
@@ -7,33 +7,105 @@
tray-set-icon! tray-set-icon!
tray-set-menu!) tray-set-menu!)
(define (unsupported who . _args) ;; The platform implementation is loaded dynamically so that requiring
(error who "not supported on this operating system: ~a" (system-type 'os*))) ;; racket-tray remains possible on platforms that do not yet have a backend.
(define mk-tray
(λ args
(apply unsupported 'mk-tray args)))
(define tray-close
(λ args
(apply unsupported 'tray-close args)))
(define tray-set-icon!
(λ args
(apply unsupported 'tray-set-icon! args)))
(define tray-set-menu!
(λ args
(apply unsupported 'tray-set-menu! args)))
(define-runtime-module-path windows-module "private/windows.rkt") (define-runtime-module-path windows-module "private/windows.rkt")
(define platform-mk-tray #f)
(define platform-tray-close #f)
(define platform-tray-set-icon! #f)
(define platform-tray-set-menu! #f)
(when (eq? (system-type 'os*) 'windows) (when (eq? (system-type 'os*) 'windows)
(set! mk-tray (set! platform-mk-tray
(dynamic-require windows-module 'mk-tray)) (dynamic-require windows-module 'mk-tray))
(set! tray-close (set! platform-tray-close
(dynamic-require windows-module 'tray-close)) (dynamic-require windows-module 'tray-close))
(set! tray-set-icon! (set! platform-tray-set-icon!
(dynamic-require windows-module 'tray-set-icon!)) (dynamic-require windows-module 'tray-set-icon!))
(set! tray-set-menu! (set! platform-tray-set-menu!
(dynamic-require windows-module 'tray-set-menu!))) (dynamic-require windows-module 'tray-set-menu!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Report that the current operating system has no tray backend.
; pre : who is the name of the public procedure being called.
; post : No state is changed.
; result : Does not return; raises an exception naming the unsupported OS.
; internals:
; The public module remains loadable on every platform; only an
; attempted tray operation fails when no backend was loaded.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (unsupported who)
(error who "not supported on this operating system: ~a" (system-type 'os*)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Create a tray icon using the backend for the current platform.
; pre : frame, icon-file, on-click-cb and hide-on-minimize? satisfy the
; requirements documented for mk-tray.
; post : On a supported platform a tray icon is created; otherwise an
; unsupported-platform exception is raised.
; result : The platform tray value accepted by the other public procedures.
; internals:
; This module is a small platform-neutral dispatcher. Windows code is
; loaded dynamically only on Windows so requiring racket-tray remains
; possible on other operating systems.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (mk-tray frame
icon-file
on-click-cb
#:hide-on-minimize? [hide-on-minimize? #f])
(if platform-mk-tray
(platform-mk-tray frame
icon-file
on-click-cb
#:hide-on-minimize? hide-on-minimize?)
(unsupported 'mk-tray)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Close a tray icon through the active platform backend.
; pre : tray is a value previously returned by mk-tray.
; post : Platform tray resources are released on supported systems.
; result : void on success; raises when the platform is unsupported.
; internals:
; All resource ownership and idempotence rules are implemented by the
; platform backend.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-close tray)
(if platform-tray-close
(platform-tray-close tray)
(unsupported 'tray-close)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Replace the image of an existing tray icon.
; pre : tray is open and icon-file names a format supported by the backend.
; post : The active tray image is replaced when the backend succeeds.
; result : The backend result; the Windows implementation returns void.
; internals:
; The public facade performs no image conversion itself.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-icon! tray icon-file)
(if platform-tray-set-icon!
(platform-tray-set-icon! tray icon-file)
(unsupported 'tray-set-icon!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Set or remove the context menu of an existing tray icon.
; pre : tray is open and menu is accepted by the active backend.
; post : The tray uses the supplied menu specification on success.
; result : void on Windows; raises when the platform is unsupported.
; internals:
; Menu normalization belongs to the platform implementation because
; native event integration is platform-specific.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (tray-set-menu! tray menu)
(if platform-tray-set-menu!
(platform-tray-set-menu! tray menu)
(unsupported 'tray-set-menu!)))
private/windows.rkt
+341 -8
View File
@@ -14,6 +14,10 @@
tray-set-icon! tray-set-icon!
tray-set-menu!) tray-set-menu!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Windows constants and native types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Shell_NotifyIcon constants ;; Shell_NotifyIcon constants
(define NIM_ADD #x00000000) (define NIM_ADD #x00000000)
(define NIM_MODIFY #x00000001) (define NIM_MODIFY #x00000001)
@@ -27,7 +31,8 @@
(define NOTIFYICON_VERSION_4 4) (define NOTIFYICON_VERSION_4 4)
;; Window messages used by NOTIFYICON_VERSION_4. ;; Window messages used by the tray integration.
(define WM_SIZE #x0005)
(define WM_CONTEXTMENU #x007B) (define WM_CONTEXTMENU #x007B)
(define WM_NCDESTROY #x0082) (define WM_NCDESTROY #x0082)
(define WM_USER #x0400) (define WM_USER #x0400)
@@ -35,6 +40,8 @@
(define NIN_SELECT (+ WM_USER 0)) (define NIN_SELECT (+ WM_USER 0))
(define NIN_KEYSELECT (+ WM_USER 1)) (define NIN_KEYSELECT (+ WM_USER 1))
(define SIZE_MINIMIZED 1)
(define IMAGE_ICON 1) (define IMAGE_ICON 1)
(define LR_LOADFROMFILE #x00000010) (define LR_LOADFROMFILE #x00000010)
(define SM_CXSMICON 49) (define SM_CXSMICON 49)
@@ -92,6 +99,12 @@
[guidItem (_array _uint8 16)] [guidItem (_array _uint8 16)]
[hBalloonIcon _HICON])) [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 shell32 (ffi-lib "shell32.dll"))
(define user32 (ffi-lib "user32.dll")) (define user32 (ffi-lib "user32.dll"))
(define gdi32 (ffi-lib "gdi32.dll")) (define gdi32 (ffi-lib "gdi32.dll"))
@@ -102,63 +115,82 @@
(define-ffi-definer define-gdi32 gdi32) (define-ffi-definer define-gdi32 gdi32)
(define-ffi-definer define-comctl32 comctl32) (define-ffi-definer define-comctl32 comctl32)
;; Adds, modifies, configures, or removes a notification-area icon.
(define-shell32 Shell_NotifyIconW (define-shell32 Shell_NotifyIconW
(_fun #:abi winapi (_fun #:abi winapi
_uint32 _NOTIFYICONDATAW-pointer _uint32 _NOTIFYICONDATAW-pointer
-> _int32)) -> _int32))
;; Loads a native HICON from an ICO file. The returned icon is owned by us.
(define-user32 LoadImageW (define-user32 LoadImageW
(_fun #:abi winapi (_fun #:abi winapi
_pointer _string/utf-16 _uint32 _int32 _int32 _uint32 _pointer _string/utf-16 _uint32 _int32 _int32 _uint32
-> _pointer)) -> _pointer))
;; Releases an HICON that was loaded or created by this module.
(define-user32 DestroyIcon (define-user32 DestroyIcon
(_fun #:abi winapi _HICON -> _int32)) (_fun #:abi winapi _HICON -> _int32))
;; Creates an HICON by copying the HBITMAP values in ICONINFO.
(define-user32 CreateIconIndirect (define-user32 CreateIconIndirect
(_fun #:abi winapi _ICONINFO-pointer -> _HICON)) (_fun #:abi winapi _ICONINFO-pointer -> _HICON))
;; Returns the current Windows small-icon dimensions.
(define-user32 GetSystemMetrics (define-user32 GetSystemMetrics
(_fun #:abi winapi _int32 -> _int32)) (_fun #:abi winapi _int32 -> _int32))
;; Creates the 32-bit color bitmap used while converting PNG to HICON.
(define-gdi32 CreateDIBSection (define-gdi32 CreateDIBSection
(_fun #:abi winapi (_fun #:abi winapi
_pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32 _pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32
-> _HBITMAP)) -> _HBITMAP))
;; Creates the monochrome mask required by ICONINFO.
(define-gdi32 CreateBitmap (define-gdi32 CreateBitmap
(_fun #:abi winapi (_fun #:abi winapi
_int32 _int32 _uint32 _uint32 _pointer _int32 _int32 _uint32 _uint32 _pointer
-> _HBITMAP)) -> _HBITMAP))
;; Releases temporary GDI bitmap objects after CreateIconIndirect copies them.
(define-gdi32 DeleteObject (define-gdi32 DeleteObject
(_fun #:abi winapi _pointer -> _int32)) (_fun #:abi winapi _pointer -> _int32))
;; Native callback signature used by SetWindowSubclass.
(define _SUBCLASSPROC (define _SUBCLASSPROC
(_fun #:abi winapi (_fun #:abi winapi
_HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR _HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR
-> _LRESULT)) -> _LRESULT))
;; Adds our message hook without replacing Racket GUI's own window procedure.
(define-comctl32 SetWindowSubclass (define-comctl32 SetWindowSubclass
(_fun #:abi winapi (_fun #:abi winapi
_HWND _pointer _UINT_PTR _DWORD_PTR _HWND _pointer _UINT_PTR _DWORD_PTR
-> _int32)) -> _int32))
;; Detaches the hook installed for an open tray object.
(define-comctl32 RemoveWindowSubclass (define-comctl32 RemoveWindowSubclass
(_fun #:abi winapi (_fun #:abi winapi
_HWND _pointer _UINT_PTR _HWND _pointer _UINT_PTR
-> _int32)) -> _int32))
;; Forwards every message that racket-tray does not consume.
(define-comctl32 DefSubclassProc (define-comctl32 DefSubclassProc
(_fun #:abi winapi (_fun #:abi winapi
_HWND _uint32 _WPARAM _LPARAM _HWND _uint32 _WPARAM _LPARAM
-> _LRESULT)) -> _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 (struct tray (frame
hwnd hwnd
id id
callback-message callback-message
on-click on-click
hide-on-minimize?
eventspace eventspace
event-channel event-channel
event-thread event-thread
@@ -170,6 +202,20 @@
(define next-tray-id 1) (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 (allocate-tray-id)
(define id next-tray-id) (define id next-tray-id)
(when (> id #xffff) (when (> id #xffff)
@@ -177,9 +223,30 @@
(set! next-tray-id (add1 next-tray-id)) (set! next-tray-id (add1 next-tray-id))
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) (define (bool-result? v)
(not (zero? 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 (call-in-eventspace eventspace thunk)
(define handler-thread (eventspace-handler-thread eventspace)) (define handler-thread (eventspace-handler-thread eventspace))
(unless handler-thread (unless handler-thread
@@ -199,6 +266,17 @@
[(cons 'ok value) value] [(cons 'ok value) value]
[(cons 'error exn) (raise exn)])))) [(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 (make-notify-data hwnd id callback-message icon)
(define data (define data
(cast (malloc _NOTIFYICONDATAW 'atomic) (cast (malloc _NOTIFYICONDATAW 'atomic)
@@ -212,6 +290,17 @@
(set-NOTIFYICONDATAW-hIcon! data icon) (set-NOTIFYICONDATAW-hIcon! data icon)
data) 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 (set-wide-array! array text capacity)
(define source (cast text _string/utf-16 _pointer)) (define source (cast text _string/utf-16 _pointer))
(for ([i (in-range capacity)]) (for ([i (in-range capacity)])
@@ -223,6 +312,19 @@
(array-set! array i code-unit) (array-set! array i code-unit)
(loop (add1 i))))))) (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 (load-ico-icon icon-file)
(define width (GetSystemMetrics SM_CXSMICON)) (define width (GetSystemMetrics SM_CXSMICON))
(define height (GetSystemMetrics SM_CYSMICON)) (define height (GetSystemMetrics SM_CYSMICON))
@@ -237,6 +339,20 @@
(error 'mk-tray "could not load ICO file: ~a" icon-file)) (error 'mk-tray "could not load ICO file: ~a" icon-file))
icon) 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) (define (png->icon icon-file)
;; Racket's drawing library already decodes PNG and preserves its alpha ;; 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 ;; channel. Scale it to the same system-small-icon size that is used for
@@ -299,6 +415,16 @@
(error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file)) (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file))
(define mask-bitmap #f) (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!) (define (cleanup-bitmaps!)
(when mask-bitmap (when mask-bitmap
(DeleteObject mask-bitmap) (DeleteObject mask-bitmap)
@@ -351,6 +477,15 @@
(error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file)) (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file))
icon)) 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 (load-icon icon-file)
(define name (define name
(string-downcase (string-downcase
@@ -365,21 +500,70 @@
"expected an .ico or .png icon file; got: ~a" "expected an .ico or .png icon file; got: ~a"
icon-file)])) 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) (define (low-word value)
(bitwise-and value #xffff)) (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 (signed-word value)
(define n (low-word value)) (define n (low-word value))
(if (>= n #x8000) (if (>= n #x8000)
(- n #x10000) (- n #x10000)
n)) 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) (define (x-from-wparam wparam)
(signed-word 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) (define (y-from-wparam wparam)
(signed-word (arithmetic-shift wparam -16))) (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) (define (menu-spec->popup-menu menu-spec)
(cond (cond
[(not menu-spec) #f] [(not menu-spec) #f]
@@ -409,6 +593,16 @@
"expected a popup-menu%, menu specification list, or #f; got: ~e" "expected a popup-menu%, menu specification list, or #f; got: ~e"
menu-spec)])) 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 (queue-eventspace-callback t thunk)
(define eventspace (tray-eventspace t)) (define eventspace (tray-eventspace t))
(unless (eventspace-shutdown? eventspace) (unless (eventspace-shutdown? eventspace)
@@ -419,6 +613,17 @@
(unless (tray-closed? t) (unless (tray-closed? t)
(thunk)))))))) (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 (start-event-thread! t)
(define event-thread (define event-thread
(thread (thread
@@ -432,6 +637,14 @@
(when callback (when callback
(queue-eventspace-callback t callback))) (queue-eventspace-callback t callback)))
(loop)] (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) [(vector 'context-menu screen-x screen-y)
(queue-eventspace-callback (queue-eventspace-callback
t t
@@ -449,6 +662,18 @@
(loop)]))))) (loop)])))))
(set-tray-event-thread! t event-thread)) (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) (define (handle-native-tray-event t wparam lparam)
;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or ;; 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 ;; user code here. An OS async channel is explicitly safe to use from an OS
@@ -467,12 +692,35 @@
[else [else
(void)])) (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) (define (make-subclass-proc t)
(λ (hwnd msg wparam lparam subclass-id ref-data) (λ (hwnd msg wparam lparam _subclass-id _ref-data)
(cond (cond
[(= msg (tray-callback-message t)) [(= msg (tray-callback-message t))
(handle-native-tray-event t wparam lparam) (handle-native-tray-event t wparam lparam)
0] 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) [(= msg WM_NCDESTROY)
;; The HWND is going away. Remove the notification-area icon while the ;; The HWND is going away. Remove the notification-area icon while the
;; handle is still valid. Windows discards the subclass automatically ;; handle is still valid. Windows discards the subclass automatically
@@ -493,6 +741,20 @@
[else [else
(DefSubclassProc hwnd msg wparam lparam)]))) (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 (add-notify-icon! t icon tooltip)
(define data (define data
(make-notify-data (tray-hwnd t) (make-notify-data (tray-hwnd t)
@@ -512,9 +774,50 @@
(Shell_NotifyIconW NIM_DELETE data) (Shell_NotifyIconW NIM_DELETE data)
(error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4"))) (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4")))
(define (mk-tray frame icon-file on-click-cb) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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<%>) (unless (is-a? frame top-level-window<%>)
(raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame)) (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) (unless (or (not on-click-cb)
(and (procedure? on-click-cb) (and (procedure? on-click-cb)
(procedure-arity-includes? on-click-cb 0))) (procedure-arity-includes? on-click-cb 0)))
@@ -536,6 +839,7 @@
id id
callback-message callback-message
on-click-cb on-click-cb
hide-on-minimize?
eventspace eventspace
(make-os-async-channel) (make-os-async-channel)
#f #f
@@ -571,12 +875,19 @@
(if (string? frame-label) frame-label "Racket")) (if (string? frame-label) frame-label "Racket"))
t))))) t)))))
(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")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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) (define (tray-close t)
(unless (tray? t) (unless (tray? t)
(raise-argument-error 'tray-close "tray?" t)) (raise-argument-error 'tray-close "tray?" t))
@@ -601,6 +912,17 @@
(os-async-channel-put (tray-event-channel t) 'close)))))) (os-async-channel-put (tray-event-channel t) 'close))))))
(void)) (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) (define (tray-set-icon! t icon-file)
(check-open-tray 'tray-set-icon! t) (check-open-tray 'tray-set-icon! t)
(call-in-eventspace (call-in-eventspace
@@ -623,6 +945,17 @@
(DestroyIcon new-icon) (DestroyIcon new-icon)
(error 'tray-set-icon! "Shell_NotifyIconW failed to change the 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) (define (tray-set-menu! t menu-spec)
(check-open-tray 'tray-set-menu! t) (check-open-tray 'tray-set-menu! t)
(call-in-eventspace (call-in-eventspace
scrbl/racket-tray.scrbl
+69 -16
View File
@@ -6,39 +6,92 @@
racket-tray)) racket-tray))
@title{Racket Tray} @title{Racket Tray}
@author{hnmdijkema} @author{Hans Dijkema / hans@dijkewijk.nl}
@defmodule[racket-tray] @defmodule[racket-tray]
Racket Tray provides a small system-tray API. Version 0.1 supports Windows. Racket Tray provides a small API for adding a system tray icon to a Racket GUI
The Windows implementation uses the native handle of an existing Racket GUI application. Version 0.1.1 supports Windows. The Windows implementation uses
top-level window and does not require an additional native library. the native @tt{HWND} of an existing Racket top-level window and requires no
additional native library.
@section{Creating a Tray Icon}
@defproc[(mk-tray [frame (is-a?/c top-level-window<%>)] @defproc[(mk-tray [frame (is-a?/c top-level-window<%>)]
[icon-file path-string?] [icon-file path-string?]
[on-click-cb (or/c #f (-> any))]) [on-click-cb (or/c #f (-> any))]
[#:hide-on-minimize? hide-on-minimize? boolean? #f])
any/c]{ any/c]{
Creates a tray icon associated with @racket[frame]. @racket[icon-file] can be Creates a tray icon associated with @racket[frame]. The frame must already
a Windows @tt{.ico} file or a @tt{.png} file. PNG alpha transparency is have a native window handle. A @racket[frame%] or @racket[dialog%] is suitable.
preserved. When the tray icon is activated, @racket[on-click-cb] is queued in
the eventspace of @racket[frame]. The returned value is passed to the other @racket[icon-file] can be a Windows @tt{.ico} file or a @tt{.png} file. PNG
alpha transparency is preserved when the image is converted to a native
Windows icon.
When the tray icon is activated, @racket[on-click-cb] is queued in the
eventspace of @racket[frame]. Use @racket[#f] when no activation callback is
needed.
When @racket[hide-on-minimize?] is true, minimizing the associated window
hides it after Windows reports @tt{SIZE_MINIMIZED}. Hiding the window removes
it from the taskbar while leaving its native handle alive for the tray icon.
When showing such a window again, an application can restore it with
@racket[(send frame iconize #f)] when @racket[(send frame is-iconized?)] is
true.
The returned value represents the tray icon and is accepted by the other
procedures in this library. procedures in this library.
} }
@defproc[(tray-close [tray any/c]) void?]{ @section{Changing and Closing a Tray Icon}
Removes the tray icon and releases the Windows resources associated with it.
}
@defproc[(tray-set-icon! [tray any/c] @defproc[(tray-set-icon! [tray any/c]
[icon-file path-string?]) void?]{ [icon-file path-string?]) void?]{
Replaces the icon of @racket[tray] with the icon loaded from Replaces the image of @racket[tray]. Both @tt{.ico} and @tt{.png} files are
@racket[icon-file]. Both @tt{.ico} and @tt{.png} files are accepted. accepted.
} }
@defproc[(tray-set-menu! [tray any/c] @defproc[(tray-set-menu! [tray any/c]
[menu any/c]) void?]{ [menu any/c]) void?]{
Sets the context menu for @racket[tray]. @racket[menu] can be a Sets the context menu for @racket[tray]. @racket[menu] can be a
@racket[popup-menu%], @racket[#f], or a list. A list entry of the form @racket[popup-menu%], @racket[#f], or a list. A list entry of the form
@racket[(list label callback)] creates an item, while @racket['separator] or @racket[(list label callback)] creates a menu item. @racket['separator] and
@racket[#f] creates a separator. Each callback is a zero-argument procedure. @racket[#f] create a separator. Each callback must accept zero arguments.
} }
@defproc[(tray-close [tray any/c]) void?]{
Removes @racket[tray], detaches its native window hook, and releases the
Windows icon resources owned by the tray object. Calling this procedure does
not close the associated Racket window.
}
@section{Closing a Window to the Tray}
Racket already provides @method[frame% on-close] for handling the close button
of a frame. A tray application normally overrides it and hides the frame:
@racketblock[
(define tray-frame%
(class frame%
(super-new)
(define/override (on-close)
(send this show #f))))
]
This is intentionally separate from @racket[#:hide-on-minimize?]. Closing a
window is already represented by a public Racket GUI callback, while Windows
does not expose minimizing through a corresponding public Racket callback.
@section{Example}
The package contains @filepath{examples/simple.rkt}. It demonstrates hiding a
frame on both minimize and close, restoring it from the tray, and terminating
the application only through the tray menu.
@section{Platform Support}
Version 0.1.1 implements Windows. Requiring @racketmodname[racket-tray] is safe
on other operating systems, but calling its tray operations reports that the
platform is not yet supported.
tests/basic.rkt
+10 -1
View File
@@ -3,8 +3,17 @@
(require rackunit (require rackunit
racket-tray) racket-tray)
;; The public module must be loadable on non-Windows platforms as well. ;; The public module must be loadable on every platform, even when no tray
;; backend is available for the current operating system.
(check-true (procedure? mk-tray)) (check-true (procedure? mk-tray))
(check-true (procedure? tray-close)) (check-true (procedure? tray-close))
(check-true (procedure? tray-set-icon!)) (check-true (procedure? tray-set-icon!))
(check-true (procedure? tray-set-menu!)) (check-true (procedure? tray-set-menu!))
;; Keep the keyword part of the public API testable without constructing a GUI
;; window or depending on Windows being available on the package build host.
(define-values (required-keywords allowed-keywords)
(procedure-keywords mk-tray))
(check-equal? required-keywords '())
(check-not-false (member '#:hide-on-minimize? allowed-keywords))