linux & mac support, refactoring on minimize
This commit is contained in:
+368
-394
@@ -32,7 +32,6 @@
|
||||
(define NOTIFYICON_VERSION_4 4)
|
||||
|
||||
;; Window messages used by the tray integration.
|
||||
(define WM_SIZE #x0005)
|
||||
(define WM_CONTEXTMENU #x007B)
|
||||
(define WM_NCDESTROY #x0082)
|
||||
(define WM_USER #x0400)
|
||||
@@ -40,8 +39,6 @@
|
||||
(define NIN_SELECT (+ WM_USER 0))
|
||||
(define NIN_KEYSELECT (+ WM_USER 1))
|
||||
|
||||
(define SIZE_MINIMIZED 1)
|
||||
|
||||
(define IMAGE_ICON 1)
|
||||
(define LR_LOADFROMFILE #x00000010)
|
||||
(define SM_CXSMICON 49)
|
||||
@@ -189,8 +186,8 @@
|
||||
hwnd
|
||||
id
|
||||
callback-message
|
||||
on-click
|
||||
hide-on-minimize?
|
||||
callback
|
||||
default-action
|
||||
eventspace
|
||||
event-channel
|
||||
event-thread
|
||||
@@ -217,11 +214,11 @@
|
||||
; reserved by Windows for application-private messages.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (allocate-tray-id)
|
||||
(define id next-tray-id)
|
||||
(when (> id #xffff)
|
||||
(error 'mk-tray "too many tray icons have been created in this process"))
|
||||
(set! next-tray-id (add1 next-tray-id))
|
||||
id)
|
||||
(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.
|
||||
@@ -248,23 +245,23 @@
|
||||
; on the GUI thread that owns the window.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (call-in-eventspace eventspace thunk)
|
||||
(define handler-thread (eventspace-handler-thread eventspace))
|
||||
(unless handler-thread
|
||||
(error 'racket-tray "the frame's eventspace has been shut down"))
|
||||
(if (eq? (current-thread) handler-thread)
|
||||
(parameterize ([current-eventspace eventspace])
|
||||
(thunk))
|
||||
(let ([result-channel (make-channel)])
|
||||
(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])
|
||||
(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)]))))
|
||||
(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.
|
||||
@@ -278,17 +275,17 @@
|
||||
; Win32 without containing Racket-managed pointers.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (make-notify-data hwnd id callback-message icon)
|
||||
(define data
|
||||
(cast (malloc _NOTIFYICONDATAW 'atomic)
|
||||
_pointer
|
||||
_NOTIFYICONDATAW-pointer))
|
||||
(memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW))
|
||||
(set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW))
|
||||
(set-NOTIFYICONDATAW-hWnd! data hwnd)
|
||||
(set-NOTIFYICONDATAW-uID! data id)
|
||||
(set-NOTIFYICONDATAW-uCallbackMessage! data callback-message)
|
||||
(set-NOTIFYICONDATAW-hIcon! data icon)
|
||||
data)
|
||||
(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.
|
||||
@@ -302,15 +299,15 @@
|
||||
; valid zero-terminated Win32 string.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-wide-array! array text capacity)
|
||||
(define source (cast text _string/utf-16 _pointer))
|
||||
(for ([i (in-range capacity)])
|
||||
(array-set! array i 0))
|
||||
(let loop ([i 0])
|
||||
(when (< i (sub1 capacity))
|
||||
(let ([code-unit (ptr-ref source _uint16 i)])
|
||||
(unless (zero? code-unit)
|
||||
(array-set! array i code-unit)
|
||||
(loop (add1 i)))))))
|
||||
(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
|
||||
@@ -326,18 +323,18 @@
|
||||
; the shell receives an icon already sized for the notification area.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (load-ico-icon icon-file)
|
||||
(define width (GetSystemMetrics SM_CXSMICON))
|
||||
(define height (GetSystemMetrics SM_CYSMICON))
|
||||
(define icon
|
||||
(LoadImageW #f
|
||||
(path->string (path->complete-path icon-file))
|
||||
IMAGE_ICON
|
||||
width
|
||||
height
|
||||
LR_LOADFROMFILE))
|
||||
(unless icon
|
||||
(error 'mk-tray "could not load ICO file: ~a" icon-file))
|
||||
icon)
|
||||
(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.
|
||||
@@ -357,125 +354,135 @@
|
||||
;; 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))
|
||||
(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))
|
||||
|
||||
(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))
|
||||
(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)
|
||||
|
||||
;; 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))
|
||||
(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)
|
||||
|
||||
(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)
|
||||
(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))
|
||||
|
||||
(define pixel-count (* width height))
|
||||
(define argb (make-bytes (* pixel-count 4)))
|
||||
(send bitmap get-argb-pixels 0 0 width height argb #f #t)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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))
|
||||
|
||||
(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))
|
||||
;; 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)))
|
||||
|
||||
(define mask-bitmap #f)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Release temporary GDI bitmaps created during PNG conversion.
|
||||
; pre : color-bitmap and mask-bitmap are HBITMAP values or #f.
|
||||
; post : Every non-#f bitmap is deleted and its local variable is set to
|
||||
; #f, making repeated cleanup safe.
|
||||
; result : Unspecified.
|
||||
; internals:
|
||||
; This local helper is used on both the normal and exceptional
|
||||
; CreateIconIndirect paths so temporary GDI objects never leak.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (cleanup-bitmaps!)
|
||||
(when mask-bitmap
|
||||
(DeleteObject mask-bitmap)
|
||||
(set! mask-bitmap #f))
|
||||
(when color-bitmap
|
||||
(DeleteObject color-bitmap)
|
||||
(set! color-bitmap #f)))
|
||||
;; 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))
|
||||
|
||||
(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))
|
||||
(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.
|
||||
@@ -487,18 +494,18 @@
|
||||
; the public API stays predictable and small.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (load-icon icon-file)
|
||||
(define name
|
||||
(string-downcase
|
||||
(path->string (path->complete-path icon-file))))
|
||||
(cond
|
||||
[(regexp-match? #rx"[.]ico$" name)
|
||||
(load-ico-icon icon-file)]
|
||||
[(regexp-match? #rx"[.]png$" name)
|
||||
(png->icon icon-file)]
|
||||
[else
|
||||
(error 'mk-tray
|
||||
"expected an .ico or .png icon file; got: ~a"
|
||||
icon-file)]))
|
||||
(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.
|
||||
@@ -521,10 +528,10 @@
|
||||
; values >= #x8000 therefore represent negative coordinates.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (signed-word value)
|
||||
(define n (low-word value))
|
||||
(if (>= n #x8000)
|
||||
(- n #x10000)
|
||||
n))
|
||||
(let ((n (low-word value)))
|
||||
(if (>= n #x8000)
|
||||
(- n #x10000)
|
||||
n)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Extract the signed X coordinate supplied by a tray notification.
|
||||
@@ -553,45 +560,30 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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%.
|
||||
; 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:
|
||||
; 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.
|
||||
; 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 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 (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.
|
||||
@@ -604,14 +596,14 @@
|
||||
; messages can arrive while the GUI is being torn down.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (queue-eventspace-callback t thunk)
|
||||
(define eventspace (tray-eventspace t))
|
||||
(unless (eventspace-shutdown? eventspace)
|
||||
(with-handlers ([exn:fail? (λ (_exn) (void))])
|
||||
(parameterize ([current-eventspace eventspace])
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(unless (tray-closed? t)
|
||||
(thunk))))))))
|
||||
(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.
|
||||
@@ -622,45 +614,38 @@
|
||||
; 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.
|
||||
; FFI callback mode and queues user work into the frame eventspace.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (start-event-thread! t)
|
||||
(define event-thread
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(match (sync (tray-event-channel t))
|
||||
['close
|
||||
(void)]
|
||||
['activate
|
||||
(let ([callback (tray-on-click t)])
|
||||
(when callback
|
||||
(queue-eventspace-callback t callback)))
|
||||
(loop)]
|
||||
['minimize
|
||||
(queue-eventspace-callback
|
||||
t
|
||||
(λ ()
|
||||
;; Hiding instead of iconizing removes the application from the
|
||||
;; taskbar while keeping the HWND alive for the tray icon.
|
||||
(send (tray-frame t) show #f)))
|
||||
(loop)]
|
||||
[(vector 'context-menu screen-x screen-y)
|
||||
(queue-eventspace-callback
|
||||
t
|
||||
(λ ()
|
||||
(define menu (tray-menu t))
|
||||
(when menu
|
||||
(let-values ([(x y)
|
||||
(send (tray-frame t)
|
||||
screen->client
|
||||
screen-x
|
||||
screen-y)])
|
||||
(send (tray-frame t) popup-menu menu x y)))))
|
||||
(loop)]
|
||||
[_
|
||||
(loop)])))))
|
||||
(set-tray-event-thread! t event-thread))
|
||||
(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.
|
||||
@@ -678,19 +663,19 @@
|
||||
;; 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)]))
|
||||
(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
|
||||
@@ -703,10 +688,11 @@
|
||||
; 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.
|
||||
; 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)
|
||||
@@ -714,23 +700,16 @@
|
||||
[(= msg (tray-callback-message t))
|
||||
(handle-native-tray-event t wparam lparam)
|
||||
0]
|
||||
[(and (= msg WM_SIZE)
|
||||
(= wparam SIZE_MINIMIZED)
|
||||
(tray-hide-on-minimize? t))
|
||||
;; Forward only a small value from the native callback. GUI work is
|
||||
;; performed later on the frame's eventspace.
|
||||
(os-async-channel-put (tray-event-channel t) 'minimize)
|
||||
(DefSubclassProc hwnd msg wparam lparam)]
|
||||
[(= msg WM_NCDESTROY)
|
||||
;; The HWND is going away. Remove the notification-area icon while the
|
||||
;; handle is still valid. Windows discards the subclass automatically
|
||||
;; as part of window destruction.
|
||||
(unless (tray-closed? t)
|
||||
(let ([data
|
||||
(let ((data
|
||||
(make-notify-data hwnd
|
||||
(tray-id t)
|
||||
(tray-callback-message t)
|
||||
(tray-icon t))])
|
||||
(tray-icon t))))
|
||||
(Shell_NotifyIconW NIM_DELETE data)
|
||||
(when (tray-icon t)
|
||||
(DestroyIcon (tray-icon t))
|
||||
@@ -756,23 +735,23 @@
|
||||
; the just-added icon again.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (add-notify-icon! t icon tooltip)
|
||||
(define data
|
||||
(make-notify-data (tray-hwnd t)
|
||||
(tray-id t)
|
||||
(tray-callback-message t)
|
||||
icon))
|
||||
(set-NOTIFYICONDATAW-uFlags!
|
||||
data
|
||||
(bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP))
|
||||
(set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128)
|
||||
(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"))
|
||||
(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")))
|
||||
(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.
|
||||
@@ -797,8 +776,8 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; 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.
|
||||
; 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.
|
||||
@@ -806,75 +785,70 @@
|
||||
; 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.
|
||||
; 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
|
||||
on-click-cb
|
||||
#:hide-on-minimize? [hide-on-minimize? #f])
|
||||
(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 (boolean? hide-on-minimize?)
|
||||
(raise-argument-error 'mk-tray "boolean?" hide-on-minimize?))
|
||||
(unless (or (not on-click-cb)
|
||||
(and (procedure? on-click-cb)
|
||||
(procedure-arity-includes? on-click-cb 0)))
|
||||
(raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb))
|
||||
(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))
|
||||
|
||||
(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 ((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
|
||||
on-click-cb
|
||||
hide-on-minimize?
|
||||
eventspace
|
||||
(make-os-async-channel)
|
||||
#f
|
||||
#f
|
||||
icon
|
||||
#f
|
||||
#f)]
|
||||
[subclass-proc
|
||||
(function-ptr (make-subclass-proc t) _SUBCLASSPROC)])
|
||||
;; WM_APP through 0xBFFF is reserved for application-private messages.
|
||||
(when (> callback-message #xbfff)
|
||||
(DestroyIcon icon)
|
||||
(error 'mk-tray
|
||||
"too many simultaneously addressable tray callback messages"))
|
||||
(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)
|
||||
(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)))))
|
||||
(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.
|
||||
@@ -928,29 +902,29 @@
|
||||
(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")]))))
|
||||
(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 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.
|
||||
; 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
|
||||
@@ -961,5 +935,5 @@
|
||||
(call-in-eventspace
|
||||
(tray-eventspace t)
|
||||
(λ ()
|
||||
(set-tray-menu! t (menu-spec->popup-menu menu-spec))))
|
||||
(set-tray-menu! t (menu-spec->popup-menu t menu-spec))))
|
||||
(void))
|
||||
|
||||
Reference in New Issue
Block a user