diff --git a/README.md b/README.md index 1d804fd..a66d009 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,47 @@ # racket-tray -A tray icon for racket. \ No newline at end of file +A small system tray API for Racket. + +Version 0.1 implements Windows directly through the Win32 API. It uses the +native `HWND` of an existing Racket `frame%`/`dialog%`, `Shell_NotifyIconW`, and +`SetWindowSubclass`. No additional native DLL is required. + +```racket +#lang racket/gui + +(require racket-tray) + +(define frame + (new frame% + [label "Tray example"] + [width 400] + [height 250])) + +(define tray + (mk-tray frame + "example.png" + (λ () + (send frame show #t)))) + +(tray-set-menu! + tray + (list + (list "Open" + (λ () (send frame show #t))) + 'separator + (list "Exit" + (λ () + (tray-close tray) + (send frame show #f))))) + +(send frame show #t) +``` + +`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 +Windows tray icon. + +`tray-set-menu!` also accepts a `popup-menu%` object directly, or `#f` to +remove the context menu. + +At the moment non-Windows platforms report that the operation is unsupported. diff --git a/examples/simple.png b/examples/simple.png new file mode 100644 index 0000000..57e3d37 Binary files /dev/null and b/examples/simple.png differ diff --git a/examples/simple.rkt b/examples/simple.rkt new file mode 100644 index 0000000..1bd928b --- /dev/null +++ b/examples/simple.rkt @@ -0,0 +1,41 @@ +#lang racket/gui + +;(require racket-tray) +(require "../main.rkt") + +(define simple% + (class frame% + (super-new [label "Racket Tray"] + [width 400] + [height 250]) + + (define lbl (new message% [label "Counting tray clicks"] [parent this] + [auto-resize #t] [stretchable-width #t])) + + (define count 0) + + (define/public (count-next) + (set! count (+ count 1)) + (send lbl set-label (format "Counting tray clicks: ~a" count))) + )) + +(define frame (new simple%)) + +(define tray + (mk-tray frame + "simple.png" + (λ () + (send frame count-next) + (send frame show #t)))) + +(tray-set-menu! + tray + (list + (list "Open" (λ () (send frame show #t))) + 'separator + (list "Exit" + (λ () + (tray-close tray) + (send frame show #f))))) + +(send frame show #t) diff --git a/info.bak b/info.bak new file mode 100644 index 0000000..f67f599 --- /dev/null +++ b/info.bak @@ -0,0 +1,27 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.8") +(define license 'MIT) ; +(define collection "rackedit") +(define pkg-desc "rackedit exports the rkdt procedure, that can be used to open an editor window with a given file") + +(define scribblings + '( + ("scrbl/rkdt.scrbl" (multi-page) (library 0)) + )) + +(define deps + '("racket/gui" + "racket/base" + "simple-ini" + "rackunit-lib" + ) + ) + +(define build-deps + '("racket-doc" + "draw-doc" + "rackunit-lib" + "scribble-lib" + )) \ No newline at end of file diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..3ddb8cc --- /dev/null +++ b/info.rkt @@ -0,0 +1,21 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.1") +(define license 'MIT) +(define collection "racket-tray") +(define pkg-desc "A tray icon for Racket") + +(define scribblings + '(("scrbl/racket-tray.scrbl" () (library 0)))) + +(define deps + '("base" + "draw-lib" + "gui-lib")) + +(define build-deps + '("racket-doc" + "gui-doc" + "rackunit-lib" + "scribble-lib")) \ No newline at end of file diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..3e5a4f6 --- /dev/null +++ b/main.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +(require racket/runtime-path) + +(provide mk-tray + tray-close + tray-set-icon! + tray-set-menu!) + +(define (unsupported who . _args) + (error who "not supported on this operating system: ~a" (system-type 'os*))) + +(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") + +(when (eq? (system-type 'os*) 'windows) + (set! mk-tray + (dynamic-require windows-module 'mk-tray)) + (set! tray-close + (dynamic-require windows-module 'tray-close)) + (set! tray-set-icon! + (dynamic-require windows-module 'tray-set-icon!)) + (set! tray-set-menu! + (dynamic-require windows-module 'tray-set-menu!))) diff --git a/private/windows.rkt b/private/windows.rkt new file mode 100644 index 0000000..6187103 --- /dev/null +++ b/private/windows.rkt @@ -0,0 +1,632 @@ +#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!) + +;; 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 NOTIFYICON_VERSION_4. +(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])) + +(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) + +(define-shell32 Shell_NotifyIconW + (_fun #:abi winapi + _uint32 _NOTIFYICONDATAW-pointer + -> _int32)) + +(define-user32 LoadImageW + (_fun #:abi winapi + _pointer _string/utf-16 _uint32 _int32 _int32 _uint32 + -> _pointer)) + +(define-user32 DestroyIcon + (_fun #:abi winapi _HICON -> _int32)) + +(define-user32 CreateIconIndirect + (_fun #:abi winapi _ICONINFO-pointer -> _HICON)) + +(define-user32 GetSystemMetrics + (_fun #:abi winapi _int32 -> _int32)) + +(define-gdi32 CreateDIBSection + (_fun #:abi winapi + _pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32 + -> _HBITMAP)) + +(define-gdi32 CreateBitmap + (_fun #:abi winapi + _int32 _int32 _uint32 _uint32 _pointer + -> _HBITMAP)) + +(define-gdi32 DeleteObject + (_fun #:abi winapi _pointer -> _int32)) + +(define _SUBCLASSPROC + (_fun #:abi winapi + _HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR + -> _LRESULT)) + +(define-comctl32 SetWindowSubclass + (_fun #:abi winapi + _HWND _pointer _UINT_PTR _DWORD_PTR + -> _int32)) + +(define-comctl32 RemoveWindowSubclass + (_fun #:abi winapi + _HWND _pointer _UINT_PTR + -> _int32)) + +(define-comctl32 DefSubclassProc + (_fun #:abi winapi + _HWND _uint32 _WPARAM _LPARAM + -> _LRESULT)) + +(struct tray (frame + hwnd + id + callback-message + on-click + eventspace + event-channel + event-thread + subclass-proc + icon + menu + closed?) + #:mutable) + +(define next-tray-id 1) + +(define (allocate-tray-id) + (define id next-tray-id) + (when (> id #xffff) + (error 'mk-tray "too many tray icons have been created in this process")) + (set! next-tray-id (add1 next-tray-id)) + id) + +(define (bool-result? v) + (not (zero? v))) + +(define (call-in-eventspace eventspace thunk) + (define handler-thread (eventspace-handler-thread eventspace)) + (unless handler-thread + (error 'racket-tray "the frame's eventspace has been shut down")) + (if (eq? (current-thread) handler-thread) + (parameterize ([current-eventspace eventspace]) + (thunk)) + (let ([result-channel (make-channel)]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (with-handlers ([exn? + (λ (exn) + (channel-put result-channel (cons 'error exn)))]) + (channel-put result-channel (cons 'ok (thunk))))))) + (match (channel-get result-channel) + [(cons 'ok value) value] + [(cons 'error exn) (raise exn)])))) + +(define (make-notify-data hwnd id callback-message icon) + (define data + (cast (malloc _NOTIFYICONDATAW 'atomic) + _pointer + _NOTIFYICONDATAW-pointer)) + (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-hWnd! data hwnd) + (set-NOTIFYICONDATAW-uID! data id) + (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message) + (set-NOTIFYICONDATAW-hIcon! data icon) + data) + +(define (set-wide-array! array text capacity) + (define source (cast text _string/utf-16 _pointer)) + (for ([i (in-range capacity)]) + (array-set! array i 0)) + (let loop ([i 0]) + (when (< i (sub1 capacity)) + (let ([code-unit (ptr-ref source _uint16 i)]) + (unless (zero? code-unit) + (array-set! array i code-unit) + (loop (add1 i))))))) + +(define (load-ico-icon icon-file) + (define width (GetSystemMetrics SM_CXSMICON)) + (define height (GetSystemMetrics SM_CYSMICON)) + (define icon + (LoadImageW #f + (path->string (path->complete-path icon-file)) + IMAGE_ICON + width + height + LR_LOADFROMFILE)) + (unless icon + (error 'mk-tray "could not load ICO file: ~a" icon-file)) + icon) + +(define (png->icon icon-file) + ;; Racket's drawing library already decodes PNG and preserves its alpha + ;; channel. Scale it to the same system-small-icon size that is used for + ;; ICO files, then turn the premultiplied pixels into a native HICON. + (define source-bitmap + (read-bitmap icon-file 'png/alpha #f #t)) + (unless (send source-bitmap ok?) + (error 'mk-tray "could not load PNG file: ~a" icon-file)) + + (define width (max 1 (GetSystemMetrics SM_CXSMICON))) + (define height (max 1 (GetSystemMetrics SM_CYSMICON))) + (define source-width (send source-bitmap get-width)) + (define source-height (send source-bitmap get-height)) + + ;; Keep the aspect ratio and center non-square images in the tray-icon area. + (define scale + (min (/ width source-width) + (/ height source-height))) + (define draw-width (max 1 (inexact->exact (round (* source-width scale))))) + (define draw-height (max 1 (inexact->exact (round (* source-height scale))))) + (define draw-x (quotient (- width draw-width) 2)) + (define draw-y (quotient (- height draw-height) 2)) + + (define bitmap (make-bitmap width height #t)) + (define dc (new bitmap-dc% [bitmap bitmap])) + (send dc draw-bitmap-section-smooth + source-bitmap + draw-x + draw-y + draw-width + draw-height + 0 + 0 + source-width + source-height) + (send dc set-bitmap #f) + + (define pixel-count (* width height)) + (define argb (make-bytes (* pixel-count 4))) + (send bitmap get-argb-pixels 0 0 width height argb #f #t) + + (define header + (make-BITMAPINFOHEADER + (ctype-sizeof _BITMAPINFOHEADER) + width + (- height) ; negative means top-down, matching Racket's row order + 1 + 32 + BI_RGB + (* pixel-count 4) + 0 + 0 + 0 + 0)) + (define bits-out (malloc _pointer 'atomic)) + (ptr-set! bits-out _pointer #f) + (define color-bitmap + (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0)) + (unless color-bitmap + (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file)) + + (define mask-bitmap #f) + (define (cleanup-bitmaps!) + (when mask-bitmap + (DeleteObject mask-bitmap) + (set! mask-bitmap #f)) + (when color-bitmap + (DeleteObject color-bitmap) + (set! color-bitmap #f))) + + (with-handlers ([exn? + (λ (exn) + (cleanup-bitmaps!) + (raise exn))]) + (define dib-bits (ptr-ref bits-out _pointer)) + (unless dib-bits + (error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file)) + + ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order. + ;; get-argb-pixels was requested premultiplied because that is the form + ;; expected by alpha-blended Windows icons. + (for ([pixel (in-range pixel-count)]) + (define source (* pixel 4)) + (define alpha (bytes-ref argb source)) + (define red (bytes-ref argb (+ source 1))) + (define green (bytes-ref argb (+ source 2))) + (define blue (bytes-ref argb (+ source 3))) + (ptr-set! dib-bits _uint8 source blue) + (ptr-set! dib-bits _uint8 (+ source 1) green) + (ptr-set! dib-bits _uint8 (+ source 2) red) + (ptr-set! dib-bits _uint8 (+ source 3) alpha)) + + ;; For modern 32-bit alpha icons the color bitmap carries transparency. + ;; ICONINFO still requires a same-sized monochrome mask for a color icon. + (define mask-stride (* 2 (quotient (+ width 15) 16))) + (define mask-size (* mask-stride height)) + (define mask-bits (malloc mask-size 'atomic)) + (memset mask-bits 0 0 mask-size) + (set! mask-bitmap + (CreateBitmap width height 1 1 mask-bits)) + (unless mask-bitmap + (error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file)) + + (define icon-info + (make-ICONINFO 1 0 0 mask-bitmap color-bitmap)) + (define icon (CreateIconIndirect icon-info)) + + ;; CreateIconIndirect copies both bitmaps, so the source GDI objects can + ;; be released immediately. The returned HICON remains owned by us. + (cleanup-bitmaps!) + (unless icon + (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file)) + icon)) + +(define (load-icon icon-file) + (define name + (string-downcase + (path->string (path->complete-path icon-file)))) + (cond + [(regexp-match? #rx"[.]ico$" name) + (load-ico-icon icon-file)] + [(regexp-match? #rx"[.]png$" name) + (png->icon icon-file)] + [else + (error 'mk-tray + "expected an .ico or .png icon file; got: ~a" + icon-file)])) + +(define (low-word value) + (bitwise-and value #xffff)) + +(define (signed-word value) + (define n (low-word value)) + (if (>= n #x8000) + (- n #x10000) + n)) + +(define (x-from-wparam wparam) + (signed-word wparam)) + +(define (y-from-wparam wparam) + (signed-word (arithmetic-shift wparam -16))) + +(define (menu-spec->popup-menu menu-spec) + (cond + [(not menu-spec) #f] + [(is-a? menu-spec popup-menu%) menu-spec] + [(list? menu-spec) + (let ([popup (new popup-menu%)]) + (for ([entry (in-list menu-spec)]) + (match entry + [(or #f 'separator) + (new separator-menu-item% [parent popup])] + [(list (? string? label) (? procedure? callback)) + (unless (procedure-arity-includes? callback 0) + (error 'tray-set-menu! + "menu callback for ~e does not accept zero arguments" + label)) + (new menu-item% + [parent popup] + [label label] + [callback (λ (_item _event) (callback))])] + [_ + (error 'tray-set-menu! + "expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e" + entry)])) + popup)] + [else + (error 'tray-set-menu! + "expected a popup-menu%, menu specification list, or #f; got: ~e" + menu-spec)])) + +(define (queue-eventspace-callback t thunk) + (define eventspace (tray-eventspace t)) + (unless (eventspace-shutdown? eventspace) + (with-handlers ([exn:fail? (λ (_exn) (void))]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (unless (tray-closed? t) + (thunk)))))))) + +(define (start-event-thread! t) + (define event-thread + (thread + (λ () + (let loop () + (match (sync (tray-event-channel t)) + ['close + (void)] + ['activate + (let ([callback (tray-on-click t)]) + (when callback + (queue-eventspace-callback t callback))) + (loop)] + [(vector 'context-menu screen-x screen-y) + (queue-eventspace-callback + t + (λ () + (define menu (tray-menu t)) + (when menu + (let-values ([(x y) + (send (tray-frame t) + screen->client + screen-x + screen-y)]) + (send (tray-frame t) popup-menu menu x y))))) + (loop)] + [_ + (loop)]))))) + (set-tray-event-thread! t event-thread)) + +(define (handle-native-tray-event t wparam lparam) + ;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or + ;; user code here. An OS async channel is explicitly safe to use from an OS + ;; callback/thread, so forward the event to an ordinary Racket thread. + (define notification (low-word lparam)) + (cond + [(or (= notification NIN_SELECT) + (= notification NIN_KEYSELECT)) + (os-async-channel-put (tray-event-channel t) 'activate)] + [(= notification WM_CONTEXTMENU) + (os-async-channel-put + (tray-event-channel t) + (vector 'context-menu + (x-from-wparam wparam) + (y-from-wparam wparam)))] + [else + (void)])) + +(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)]))) + +(define (add-notify-icon! t icon tooltip) + (define data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + icon)) + (set-NOTIFYICONDATAW-uFlags! + data + (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP)) + (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128) + + (unless (bool-result? (Shell_NotifyIconW NIM_ADD data)) + (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon")) + + (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4) + (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data)) + (Shell_NotifyIconW NIM_DELETE data) + (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4"))) + +(define (mk-tray frame icon-file on-click-cb) + (unless (is-a? frame top-level-window<%>) + (raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame)) + (unless (or (not on-click-cb) + (and (procedure? on-click-cb) + (procedure-arity-includes? on-click-cb 0))) + (raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb)) + + (define eventspace (send frame get-eventspace)) + (call-in-eventspace + eventspace + (λ () + (define hwnd (send frame get-handle)) + (unless hwnd + (error 'mk-tray "the frame does not have a native HWND")) + + (let* ([id (allocate-tray-id)] + [callback-message (+ WM_APP id)] + [icon (load-icon icon-file)] + [t (tray frame + hwnd + id + callback-message + on-click-cb + eventspace + (make-os-async-channel) + #f + #f + icon + #f + #f)] + [subclass-proc + (function-ptr (make-subclass-proc t) _SUBCLASSPROC)]) + ;; WM_APP through 0xBFFF is reserved for application-private messages. + (when (> callback-message #xbfff) + (DestroyIcon icon) + (error 'mk-tray + "too many simultaneously addressable tray callback messages")) + + (set-tray-subclass-proc! t subclass-proc) + (start-event-thread! t) + + (unless (bool-result? + (SetWindowSubclass hwnd subclass-proc id 0)) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (error 'mk-tray "SetWindowSubclass failed for the Racket frame")) + + (with-handlers ([exn? + (λ (exn) + (RemoveWindowSubclass hwnd subclass-proc id) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (raise exn))]) + (define frame-label (send frame get-label)) + (add-notify-icon! t icon + (if (string? frame-label) frame-label "Racket")) + t))))) + +(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"))) + +(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)) + +(define (tray-set-icon! t icon-file) + (check-open-tray 'tray-set-icon! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (define new-icon (load-icon icon-file)) + (define data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + new-icon)) + (set-NOTIFYICONDATAW-uFlags! data NIF_ICON) + (cond + [(bool-result? (Shell_NotifyIconW NIM_MODIFY data)) + (let ([old-icon (tray-icon t)]) + (set-tray-icon! t new-icon) + (when old-icon + (DestroyIcon old-icon)))] + [else + (DestroyIcon new-icon) + (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")])))) + +(define (tray-set-menu! t menu-spec) + (check-open-tray 'tray-set-menu! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (set-tray-menu! t (menu-spec->popup-menu menu-spec)))) + (void)) diff --git a/scrbl/racket-tray.scrbl b/scrbl/racket-tray.scrbl new file mode 100644 index 0000000..0ab65e5 --- /dev/null +++ b/scrbl/racket-tray.scrbl @@ -0,0 +1,44 @@ +#lang scribble/manual + +@(require (for-label racket/base + racket/class + racket/gui/base + racket-tray)) + +@title{Racket Tray} +@author{hnmdijkema} + +@defmodule[racket-tray] + +Racket Tray provides a small system-tray API. Version 0.1 supports Windows. +The Windows implementation uses the native handle of an existing Racket GUI +top-level window and does not require an additional native library. + +@defproc[(mk-tray [frame (is-a?/c top-level-window<%>)] + [icon-file path-string?] + [on-click-cb (or/c #f (-> any))]) + any/c]{ +Creates a tray icon associated with @racket[frame]. @racket[icon-file] can be +a Windows @tt{.ico} file or a @tt{.png} file. PNG alpha transparency is +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 +procedures in this library. +} + +@defproc[(tray-close [tray any/c]) void?]{ +Removes the tray icon and releases the Windows resources associated with it. +} + +@defproc[(tray-set-icon! [tray any/c] + [icon-file path-string?]) void?]{ +Replaces the icon of @racket[tray] with the icon loaded from +@racket[icon-file]. Both @tt{.ico} and @tt{.png} files are accepted. +} + +@defproc[(tray-set-menu! [tray any/c] + [menu any/c]) void?]{ +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[(list label callback)] creates an item, while @racket['separator] or +@racket[#f] creates a separator. Each callback is a zero-argument procedure. +} diff --git a/tests/basic.rkt b/tests/basic.rkt new file mode 100644 index 0000000..91015f7 --- /dev/null +++ b/tests/basic.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +(require rackunit + racket-tray) + +;; The public module must be loadable on non-Windows platforms as well. +(check-true (procedure? mk-tray)) +(check-true (procedure? tray-close)) +(check-true (procedure? tray-set-icon!)) +(check-true (procedure? tray-set-menu!))