018dbd6add
Fix `get-unscaled-client-size` for Win32 and GTK scaling, and make the docs more generally sensible.
880 lines
31 KiB
Racket
880 lines
31 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
racket/draw/unsafe/bstr
|
|
"../../syntax.rkt"
|
|
"../common/freeze.rkt"
|
|
"../common/queue.rkt"
|
|
"../common/event.rkt"
|
|
"../common/local.rkt"
|
|
"../../lock.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"wndclass.rkt"
|
|
"queue.rkt"
|
|
"theme.rkt"
|
|
"cursor.rkt"
|
|
"key.rkt"
|
|
"dc.rkt"
|
|
"font.rkt")
|
|
|
|
(provide
|
|
(protect-out window%
|
|
queue-window-event
|
|
queue-window-refresh-event
|
|
location->window
|
|
flush-display
|
|
get-default-control-font
|
|
|
|
GetWindowRect
|
|
GetClientRect
|
|
|
|
_NMHDR))
|
|
|
|
(define (unhide-cursor) (void))
|
|
|
|
(define WM_PRINT #x0317)
|
|
(define WM_PRINTCLIENT #x0318)
|
|
|
|
(define MK_LBUTTON #x0001)
|
|
(define MK_RBUTTON #x0002)
|
|
(define MK_SHIFT #x0004)
|
|
(define MK_CONTROL #x0008)
|
|
(define MK_MBUTTON #x0010)
|
|
(define MK_XBUTTON1 #x0020)
|
|
(define MK_XBUTTON2 #x0040)
|
|
|
|
(define HTHSCROLL 6)
|
|
(define HTVSCROLL 7)
|
|
|
|
(define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
|
|
(if r rect (failed 'GetWindowRect))))
|
|
(define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
|
|
(if r rect (failed 'GetClientRect))))
|
|
|
|
(define-user32 ClientToScreen (_wfun _HWND _POINT-pointer -> (r : _BOOL)
|
|
-> (unless r (failed 'ClientToScreen))))
|
|
(define-user32 ScreenToClient (_wfun _HWND _POINT-pointer -> (r : _BOOL)
|
|
-> (unless r (failed 'ClientToScreen))))
|
|
|
|
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONTW-pointer -> _HFONT))
|
|
|
|
(define-shell32 DragAcceptFiles (_wfun _HWND _BOOL -> _void))
|
|
|
|
(define _HDROP _pointer)
|
|
(define-shell32 DragQueryFileW (_wfun _HDROP _UINT _pointer _UINT -> _UINT))
|
|
(define-shell32 DragFinish (_wfun _HDROP -> _void))
|
|
|
|
(define-user32 SetCapture (_wfun _HWND -> _HWND))
|
|
(define-user32 ReleaseCapture (_wfun -> _BOOL))
|
|
|
|
(define-user32 WindowFromPoint (_wfun _POINT -> _HWND))
|
|
(define-user32 GetParent (_wfun _HWND -> _HWND))
|
|
(define-user32 SetParent (_wfun _HWND _HWND -> (r : _HWND)
|
|
-> (unless r (failed 'SetParent))))
|
|
|
|
(define-user32 SetCursorPos (_wfun _int _int -> _BOOL))
|
|
|
|
(define-cstruct _NMHDR
|
|
([hwndFrom _HWND]
|
|
[idFrom _pointer]
|
|
[code _UINT]))
|
|
|
|
(define-user32 GetDialogBaseUnits (_fun -> _LONG))
|
|
(define measure-dc #f)
|
|
|
|
(define theme-hfont #f)
|
|
|
|
#;
|
|
(define-values (dlu-x dlu-y)
|
|
(let ([v (GetDialogBaseUnits)])
|
|
(values (* 1/4 (bitwise-and v #xFFFF))
|
|
(* 1/8 (arithmetic-shift v -16)))))
|
|
|
|
(define-cstruct _LOGBRUSH
|
|
([lbStyle _UINT]
|
|
[lbColor _COLORREF]
|
|
[lbHatch _pointer]))
|
|
|
|
(define BS_NULL 1)
|
|
(define transparent-logbrush (make-LOGBRUSH BS_NULL 0 #f))
|
|
|
|
(define-gdi32 CreateBrushIndirect (_wfun _LOGBRUSH-pointer -> _HBRUSH))
|
|
|
|
(define TRANSPARENT 1)
|
|
(define-gdi32 SetBkMode (_wfun _HDC _int -> (r : _int)
|
|
-> (when (zero? r) (failed 'SetBkMode))))
|
|
|
|
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
|
|
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
|
|
|
|
(define WM_IS_GRACKET (cast (scheme_register_process_global "PLT_WM_IS_GRACKET" #f)
|
|
_pointer
|
|
_UINT_PTR))
|
|
(define GRACKET_GUID (cast (scheme_register_process_global "PLT_GRACKET_GUID" #f)
|
|
_pointer
|
|
_bytes))
|
|
(define-cstruct _COPYDATASTRUCT
|
|
([dwData _pointer]
|
|
[cbData _DWORD]
|
|
[lpData _pointer]))
|
|
|
|
(define-cstruct _TRACKMOUSEEVENT
|
|
([cbSize _DWORD]
|
|
[dwFlags _DWORD]
|
|
[hwndTrack _HWND]
|
|
[dwHoverTime _DWORD]))
|
|
|
|
(define TME_LEAVE #x02)
|
|
(define TME_NONCLIENT #x10)
|
|
|
|
(define-user32 TrackMouseEvent (_wfun _TRACKMOUSEEVENT-pointer -> (r : _BOOL)
|
|
-> (unless r (failed 'TrackMouseEvent))))
|
|
(define-user32 GetCursorPos (_wfun _POINT-pointer -> _BOOL))
|
|
|
|
(defclass window% object%
|
|
(init-field parent hwnd)
|
|
(init style
|
|
[extra-hwnds null])
|
|
|
|
(define enabled? #t)
|
|
(define parent-enabled? #t)
|
|
|
|
(super-new)
|
|
|
|
(define eventspace (if parent
|
|
(send parent get-eventspace)
|
|
(current-eventspace)))
|
|
|
|
(set-hwnd-wx! hwnd this)
|
|
(for ([extra-hwnd (in-list extra-hwnds)])
|
|
(set-hwnd-wx! extra-hwnd this))
|
|
|
|
(define/public (get-hwnd) hwnd)
|
|
(define/public (get-client-hwnd) hwnd)
|
|
(define/public (get-content-hwnd) (get-client-hwnd))
|
|
(define/public (get-focus-hwnd) hwnd)
|
|
(define/public (get-eventspace) eventspace)
|
|
|
|
(define/public (is-hwnd? a-hwnd)
|
|
(ptr-equal? hwnd a-hwnd))
|
|
|
|
(define/public (wndproc w msg wParam lParam default)
|
|
(if (try-mouse w msg wParam lParam)
|
|
0
|
|
(cond
|
|
[(= msg WM_SETFOCUS)
|
|
(set-top-focus this null w)
|
|
(queue-window-event this (lambda () (on-set-focus)))
|
|
0]
|
|
[(= msg WM_KILLFOCUS)
|
|
(queue-window-event this (lambda () (on-kill-focus)))
|
|
0]
|
|
[(= msg WM_SYSKEYDOWN)
|
|
(let ([result (if (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close
|
|
(begin
|
|
(unhide-cursor)
|
|
(default w msg wParam lParam))
|
|
0)])
|
|
(do-key w msg wParam lParam #f #f void)
|
|
result)]
|
|
[(= msg WM_KEYDOWN)
|
|
(do-key w msg wParam lParam #f #f default)]
|
|
[(= msg WM_KEYUP)
|
|
(do-key w msg wParam lParam #f #t default)]
|
|
[(= msg WM_SYSCHAR)
|
|
(let ([result (if (= wParam VK_MENU)
|
|
(begin
|
|
(unhide-cursor)
|
|
(default w msg wParam lParam))
|
|
0)])
|
|
(do-key w msg wParam lParam #t #f void)
|
|
result)]
|
|
[(= msg WM_CHAR)
|
|
(do-key w msg wParam lParam #t #f default)]
|
|
[(= msg WM_MOUSEWHEEL)
|
|
(gen-wheels w msg lParam (HIWORD wParam) 'wheel-down 'wheel-up)
|
|
0]
|
|
[(= msg WM_MOUSEHWHEEL) ; Vista and later
|
|
(gen-wheels w msg lParam (HIWORD wParam) 'wheel-left 'wheel-right)
|
|
0]
|
|
[(= msg WM_COMMAND)
|
|
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
|
|
[wx (any-hwnd->wx control-hwnd)]
|
|
[cmd (HIWORD wParam)])
|
|
(if (and wx (send wx is-command? cmd))
|
|
(begin
|
|
(send wx do-command cmd control-hwnd)
|
|
0)
|
|
(default w msg wParam lParam)))]
|
|
[(= msg WM_NOTIFY)
|
|
(let* ([nmhdr (cast lParam _LPARAM _NMHDR-pointer)]
|
|
[control-hwnd (NMHDR-hwndFrom nmhdr)]
|
|
[wx (any-hwnd->wx control-hwnd)]
|
|
[cmd (LOWORD (NMHDR-code nmhdr))])
|
|
(if (and wx (send wx is-command? cmd))
|
|
(begin
|
|
(send wx do-command-ex cmd control-hwnd nmhdr)
|
|
0)
|
|
(default w msg wParam lParam)))]
|
|
[(or (= msg WM_HSCROLL)
|
|
(= msg WM_VSCROLL))
|
|
(let* ([control-hwnd (cast lParam _LPARAM _HWND)]
|
|
[wx (any-hwnd->wx control-hwnd)])
|
|
(if wx
|
|
(begin
|
|
(send wx control-scrolled)
|
|
0)
|
|
(default w msg wParam lParam)))]
|
|
[(= msg WM_DROPFILES)
|
|
(handle-drop-files wParam)
|
|
0]
|
|
;; for single-instance applications:
|
|
[(and (= msg WM_IS_GRACKET)
|
|
(positive? WM_IS_GRACKET))
|
|
;; return 79 to indicate that this is a GRacket window
|
|
79]
|
|
;; also for single-instance:
|
|
[(= msg WM_COPYDATA)
|
|
(handle-copydata lParam)
|
|
0]
|
|
[(= msg WM_INPUTLANGCHANGE)
|
|
(reset-key-mapping)
|
|
0]
|
|
[else
|
|
(default w msg wParam lParam)])))
|
|
|
|
(define/public (is-command? cmd) #f)
|
|
(define/public (control-scrolled) #f)
|
|
|
|
(define/public (do-command cmd control-hwnd)
|
|
(void))
|
|
(define/public (do-command-ex cmd control-hwnd nmhdr)
|
|
(do-command cmd control-hwnd))
|
|
|
|
(define/public (show on?)
|
|
(when on? (show-children))
|
|
(atomically (direct-show on?)))
|
|
|
|
(define shown? #f)
|
|
(define/public (direct-show on? [on-mode SW_SHOW])
|
|
;; atomic mode
|
|
(set! shown? (and on? #t))
|
|
(register-child-in-parent on?)
|
|
(unless on? (not-focus-child this))
|
|
(ShowWindow hwnd (if on? on-mode SW_HIDE)))
|
|
(unless (memq 'deleted style)
|
|
(show #t))
|
|
|
|
(define/public (queue-on-size) (void))
|
|
|
|
(define/public (on-set-focus) (void))
|
|
(define/public (on-kill-focus) (void))
|
|
(define/public (get-handle) hwnd)
|
|
(define/public (get-client-handle) (get-content-hwnd))
|
|
|
|
(define/public (enable on?)
|
|
(unless (eq? enabled? (and on? #t))
|
|
(atomically
|
|
(let ([prev? (and enabled? parent-enabled?)])
|
|
(set! enabled? (and on? #t))
|
|
(let ([now? (and parent-enabled? enabled?)])
|
|
(unless (eq? now? prev?)
|
|
(internal-enable now?)))))))
|
|
(define/public (parent-enable on?)
|
|
(unless (eq? on? parent-enabled?)
|
|
(let ([prev? (and enabled? parent-enabled?)])
|
|
(set! parent-enabled? (and on? #t))
|
|
(let ([now? (and parent-enabled? enabled?)])
|
|
(unless (eq? prev? now?)
|
|
(internal-enable now?))))))
|
|
(define/public (internal-enable on?)
|
|
(void (EnableWindow hwnd on?)))
|
|
|
|
(define/public (is-window-enabled?) enabled?)
|
|
(define/public (is-enabled-to-root?)
|
|
(and enabled? parent-enabled?))
|
|
|
|
(define/public (is-shown-to-root?)
|
|
(and shown?
|
|
(send parent is-shown-to-root?)))
|
|
|
|
(define/public (is-shown?)
|
|
shown?)
|
|
|
|
(define/public (get-x)
|
|
(let ([r (GetWindowRect hwnd)]
|
|
[pr (GetWindowRect (send parent get-content-hwnd))])
|
|
(->normal (- (RECT-left r) (RECT-left pr)))))
|
|
(define/public (get-y)
|
|
(let ([r (GetWindowRect hwnd)]
|
|
[pr (GetWindowRect (send parent get-content-hwnd))])
|
|
(->normal (- (RECT-top r) (RECT-top pr)))))
|
|
|
|
(define/public (get-width)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(->normal (- (RECT-right r) (RECT-left r)))))
|
|
(define/public (get-height)
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(->normal (- (RECT-bottom r) (RECT-top r)))))
|
|
|
|
(define/public (notify-child-extent x y)
|
|
(void))
|
|
|
|
;; Converting from normalized to screen coordinates
|
|
;; with just `->screen` can cause a child's right edge
|
|
;; to extend beyond the parent's right edge, due to
|
|
;; rounding via `ceiling`. Allow controls that would
|
|
;; look bad to round down, instead.
|
|
(define/public (size->screen v) (->screen v))
|
|
|
|
(define/public (set-size x y w h)
|
|
(let-values ([(x y w h)
|
|
(if (or (not x)
|
|
(not y)
|
|
(= w -1)
|
|
(= h -1))
|
|
(let ([r (GetWindowRect hwnd)])
|
|
(values (or x (->normal (RECT-left r)))
|
|
(or y (->normal (RECT-top r)))
|
|
(if (= w -1) (->normal (- (RECT-right r) (RECT-left r))) w)
|
|
(if (= h -1) (->normal (- (RECT-bottom r) (RECT-top r))) h)))
|
|
(values x y w h))])
|
|
(when parent (send parent notify-child-extent (+ x w) (+ y h)))
|
|
(MoveWindow hwnd (->screen x) (->screen y) (size->screen w) (size->screen h) #t))
|
|
(unless (and (= w -1) (= h -1))
|
|
(on-resized))
|
|
(queue-on-size)
|
|
(refresh-one))
|
|
(define/public (move x y)
|
|
(set-size x y -1 -1))
|
|
|
|
(define/public (set-control-font font [hwnd hwnd])
|
|
(unless theme-hfont
|
|
(set! theme-hfont (CreateFontIndirectW (get-theme-logfont))))
|
|
(let ([hfont (if font
|
|
(or (font->hfont font)
|
|
theme-hfont)
|
|
theme-hfont)])
|
|
(SendMessageW hwnd WM_SETFONT (cast hfont _HFONT _LPARAM) 0)))
|
|
|
|
(define/public (auto-size font label min-w min-h dw dh
|
|
[resize
|
|
(lambda (w h) (set-size #f #f w h))]
|
|
#:combine-width [combine-w max]
|
|
#:combine-height [combine-h max]
|
|
#:scale-w [scale-w 1]
|
|
#:scale-h [scale-h 1])
|
|
(atomically
|
|
(unless measure-dc
|
|
(let* ([bm (make-object win32-bitmap% 1 1 #f)]
|
|
[dc (make-object bitmap-dc% bm)])
|
|
(set! measure-dc dc)))
|
|
(send measure-dc set-font (or font
|
|
(get-default-control-font)))
|
|
(let-values ([(w h d a) (let loop ([label label])
|
|
(cond
|
|
[(null? label) (values 0 0 0 0)]
|
|
[(label . is-a? . bitmap%)
|
|
(values (send label get-width)
|
|
(send label get-height)
|
|
0
|
|
0)]
|
|
[(pair? label)
|
|
(let-values ([(w1 h1 d1 a1)
|
|
(loop (car label))]
|
|
[(w2 h2 d2 a2)
|
|
(loop (cdr label))])
|
|
(values (combine-w w1 w2) (combine-h h1 h2)
|
|
(combine-h d1 d1) (combine-h a1 a2)))]
|
|
[else
|
|
(define strs (regexp-split #rx"\n" label))
|
|
(for/fold ([w 0][h 0][d 0] [a 0]) ([str (in-list strs)])
|
|
(define-values (tw th d a) (send measure-dc get-text-extent label #f #t))
|
|
(values (max w tw) (+ h th) 0 0))]))]
|
|
[(->int) (lambda (v) (inexact->exact (ceiling v)))])
|
|
(resize (->int (* scale-h (max (+ w dw) min-w)))
|
|
(->int (* scale-w (max (+ h dh) min-h)))))))
|
|
|
|
(define/public (popup-menu m x y)
|
|
(let ([gx (box x)]
|
|
[gy (box y)])
|
|
(client-to-screen gx gy)
|
|
(send m popup (unbox gx) (unbox gy)
|
|
hwnd
|
|
(lambda (thunk) (queue-window-event this thunk)))))
|
|
|
|
(define/public (center a b) (void))
|
|
|
|
(define/public (get-parent) parent)
|
|
(define/public (set-parent p)
|
|
;; in atomic mode
|
|
(set! parent p)
|
|
(SetParent hwnd (send parent get-content-hwnd)))
|
|
|
|
(define/public (is-frame?) #f)
|
|
|
|
(define/public (refresh-one) (void))
|
|
(define/public (refresh)
|
|
(refresh-one)
|
|
(refresh-all-children))
|
|
(define/public (refresh-all-children) (void))
|
|
|
|
(define/public (on-resized) (void))
|
|
|
|
(define event-position-wrt-wx #f)
|
|
(define/public (set-event-positions-wrt wx)
|
|
(set! event-position-wrt-wx wx))
|
|
|
|
(define/private (adjust-event-position x y)
|
|
(if event-position-wrt-wx
|
|
(let ([xb (box x)]
|
|
[yb (box y)])
|
|
(internal-client-to-screen xb yb)
|
|
(send event-position-wrt-wx internal-screen-to-client xb yb)
|
|
(values (unbox xb) (unbox yb)))
|
|
(values x y)))
|
|
|
|
(define/public (screen-to-client x y)
|
|
(internal-screen-to-client x y))
|
|
(define/public (internal-screen-to-client x y)
|
|
(let ([p (make-POINT (->screen (unbox x)) (->screen (unbox y)))])
|
|
(ScreenToClient (get-client-hwnd) p)
|
|
(set-box! x (->normal (POINT-x p)))
|
|
(set-box! y (->normal (POINT-y p)))))
|
|
(define/public (client-to-screen x y)
|
|
(internal-client-to-screen x y))
|
|
(define/public (internal-client-to-screen x y)
|
|
(let ([p (make-POINT (->screen (unbox x)) (->screen (unbox y)))])
|
|
(ClientToScreen (get-client-hwnd) p)
|
|
(set-box! x (->normal (POINT-x p)))
|
|
(set-box! y (->normal (POINT-y p)))))
|
|
|
|
(define/public (warp-pointer x y)
|
|
(define xb (box x))
|
|
(define yb (box y))
|
|
(client-to-screen xb yb)
|
|
(void (SetCursorPos (->screen (unbox xb)) (->screen (unbox yb)))))
|
|
|
|
(define/public (in-content? p)
|
|
(ScreenToClient (get-client-hwnd) p)
|
|
(let ([r (GetClientRect (get-client-hwnd))])
|
|
(and (< 0 (POINT-x p) (- (RECT-right r)
|
|
(RECT-left r)))
|
|
(< 0 (POINT-y p) (- (RECT-bottom r)
|
|
(RECT-top r))))))
|
|
|
|
(define/public (drag-accept-files on?)
|
|
(DragAcceptFiles (get-hwnd) on?))
|
|
|
|
(define/private (handle-drop-files wParam)
|
|
(let* ([hdrop (cast wParam _WPARAM _HDROP)]
|
|
[count (DragQueryFileW hdrop #xFFFFFFFF #f 0)])
|
|
(for ([i (in-range count)])
|
|
(let* ([len (DragQueryFileW hdrop i #f 0)]
|
|
[b (malloc (add1 len) _int16)])
|
|
(DragQueryFileW hdrop i b (add1 len))
|
|
(let ([s (cast b _gcpointer _string/utf-16)])
|
|
(queue-window-event this (lambda () (on-drop-file (string->path s)))))))
|
|
(DragFinish hdrop)))
|
|
|
|
(define/public (on-drop-file p) (void))
|
|
|
|
(define/public (get-client-size w h)
|
|
(define-values (uw uh) (get-scaled-client-size))
|
|
(set-box! w (->normal uw))
|
|
(set-box! h (->normal uh)))
|
|
|
|
(define/public (get-scaled-client-size)
|
|
(let ([r (GetClientRect (get-client-hwnd))])
|
|
(values (- (RECT-right r) (RECT-left r))
|
|
(- (RECT-bottom r) (RECT-top r)))))
|
|
|
|
(define/public (get-size w h)
|
|
(let ([r (GetWindowRect (get-client-hwnd))])
|
|
(set-box! w (->normal (- (RECT-right r) (RECT-left r))))
|
|
(set-box! h (->normal (- (RECT-bottom r) (RECT-top r))))))
|
|
|
|
(define cursor-handle #f)
|
|
(define/public (set-cursor c)
|
|
(set! cursor-handle (and c (send (send c get-driver) get-handle)))
|
|
(when mouse-in?
|
|
(cursor-updated-here)))
|
|
|
|
(define/public (cursor-updated-here)
|
|
(when mouse-in?
|
|
(send (get-top-frame) reset-cursor (get-arrow-cursor))))
|
|
|
|
(define/public (reset-cursor-in-child child default)
|
|
(send child reset-cursor (or cursor-handle default)))
|
|
|
|
(define effective-cursor-handle #f)
|
|
(define/public (reset-cursor default)
|
|
(let ([c (or cursor-handle default)])
|
|
(set! effective-cursor-handle c)
|
|
(SetCursor c)))
|
|
|
|
(define/public (no-cursor-handle-here)
|
|
(send parent cursor-updated-here))
|
|
|
|
(define/public (set-focus [child-hwnd hwnd])
|
|
(when (can-accept-focus?)
|
|
(set-top-focus this null child-hwnd)))
|
|
|
|
(define/public (can-accept-focus?)
|
|
(child-can-accept-focus?))
|
|
|
|
(define/public (child-can-accept-focus?)
|
|
(and shown?
|
|
(send parent child-can-accept-focus?)))
|
|
|
|
(define/public (set-top-focus win win-path hwnd)
|
|
(send parent set-top-focus win (cons this win-path) hwnd))
|
|
(define/public (not-focus-child v)
|
|
(send parent not-focus-child v))
|
|
|
|
(define/public (gets-focus?) #f)
|
|
|
|
(define/public (register-child child on?)
|
|
(void))
|
|
(define/public (register-child-in-parent on?)
|
|
(when parent
|
|
(send parent register-child this on?)))
|
|
|
|
(define/public (show-children) (void))
|
|
(define/public (paint-children) (void))
|
|
|
|
(define/public (get-top-frame)
|
|
(send parent get-top-frame))
|
|
|
|
(define/private (gen-wheels w msg lParam val down up)
|
|
(let ([orig-delta (quotient val WHEEL_DELTA)])
|
|
(let loop ([delta (abs orig-delta)])
|
|
(unless (zero? delta)
|
|
(do-key w msg (if (negative? orig-delta)
|
|
down
|
|
up)
|
|
lParam #f #f void)
|
|
(loop (sub1 delta))))))
|
|
|
|
(define/private (do-key w msg wParam lParam is-char? is-up? default)
|
|
(let ([e (maybe-make-key-event #f wParam lParam is-char? is-up? hwnd)])
|
|
(if (or (and e
|
|
(if (definitely-wants-event? w msg wParam e)
|
|
(begin
|
|
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
|
|
#t)
|
|
(constrained-reply eventspace
|
|
(lambda () (dispatch-on-char e #t))
|
|
#t)))
|
|
(capture-all-key-events?))
|
|
0
|
|
(default w msg wParam lParam))))
|
|
|
|
(define/public (try-mouse w msg wParam lParam)
|
|
(cond
|
|
[(= msg WM_RBUTTONDOWN)
|
|
(do-mouse w msg #f 'right-down wParam lParam)]
|
|
[(= msg WM_RBUTTONUP)
|
|
(do-mouse w msg #f 'right-up wParam lParam)]
|
|
[(= msg WM_RBUTTONDBLCLK)
|
|
(do-mouse w msg #f 'right-down wParam lParam)]
|
|
[(= msg WM_MBUTTONDOWN)
|
|
(do-mouse w msg #f 'middle-down wParam lParam)]
|
|
[(= msg WM_MBUTTONUP)
|
|
(do-mouse w msg #f 'middle-up wParam lParam)]
|
|
[(= msg WM_MBUTTONDBLCLK)
|
|
(do-mouse w msg #f 'middle-down wParam lParam)]
|
|
[(= msg WM_LBUTTONDOWN)
|
|
(do-mouse w msg #f 'left-down wParam lParam)]
|
|
[(= msg WM_LBUTTONUP)
|
|
(do-mouse w msg #f 'left-up wParam lParam)]
|
|
[(= msg WM_LBUTTONDBLCLK)
|
|
(do-mouse w msg #f 'left-down wParam lParam)]
|
|
[(= msg WM_MOUSEMOVE)
|
|
(do-mouse w msg #f 'motion wParam lParam)]
|
|
[(= msg WM_MOUSELEAVE)
|
|
(let ([p (make-POINT 0 0)])
|
|
(let ([f (and (GetCursorPos p)
|
|
(location->window* (POINT-x p) (POINT-y p)))])
|
|
(unless (and (eq? f (get-top-frame))
|
|
(send f in-content? p))
|
|
(do-mouse w msg #f 'leave wParam lParam))))
|
|
;; send message on to default handling (e.g., for buttons):
|
|
#f]
|
|
[else (try-nc-mouse w msg wParam lParam)]))
|
|
|
|
;; Breaking out NC mouse operations lets us not handle
|
|
;; them for frames (where this method is overridden),
|
|
;; since handling them intereferes with the cursor and
|
|
;; resize handling for frames.
|
|
(define/public (try-nc-mouse w msg wParam lParam)
|
|
(cond
|
|
[(= msg WM_NCRBUTTONDOWN)
|
|
(do-mouse w msg #t 'right-down wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCRBUTTONUP)
|
|
(do-mouse w msg #t 'right-up wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCRBUTTONDBLCLK)
|
|
(do-mouse w msg #t 'right-down wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCMBUTTONDOWN)
|
|
(do-mouse w msg #t 'middle-down wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCMBUTTONUP)
|
|
(do-mouse w msg #t 'middle-up wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCMBUTTONDBLCLK)
|
|
(do-mouse w msg #t 'middle-down wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCLBUTTONDOWN)
|
|
(do-mouse w msg #t 'left-down wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCLBUTTONUP)
|
|
(do-mouse w msg #t 'left-up wParam (lp-screen->client w lParam))]
|
|
[(= msg WM_NCLBUTTONDBLCLK)
|
|
(do-mouse w msg #t 'left-down wParam (lp-screen->client w lParam))]
|
|
[(and (= msg WM_NCMOUSEMOVE)
|
|
(not (= wParam HTVSCROLL))
|
|
(not (= wParam HTHSCROLL)))
|
|
(do-mouse w msg #t 'motion wParam (lp-screen->client w lParam))]
|
|
[else #f]))
|
|
|
|
(define/private (lp-screen->client w lParam)
|
|
(let ([p (make-POINT (LOWORD lParam) (HIWORD lParam))])
|
|
(ScreenToClient w p)
|
|
(MAKELPARAM (POINT-x p) (POINT-y p))))
|
|
|
|
(define/private (do-mouse control-hwnd msg nc? type wParam lParam)
|
|
(let ([x (LOWORD lParam)]
|
|
[y (HIWORD lParam)]
|
|
[flags (if nc? 0 wParam)]
|
|
[bit? (lambda (v b) (not (zero? (bitwise-and v b))))])
|
|
(let ([make-e
|
|
(lambda (type)
|
|
(define-values (mx my) (adjust-event-position (->normal x) (->normal y)))
|
|
(new mouse-event%
|
|
[event-type type]
|
|
[left-down (case type
|
|
[(left-down) #t]
|
|
[(left-up) #f]
|
|
[else (bit? flags MK_LBUTTON)])]
|
|
[middle-down (case type
|
|
[(middle-down) #t]
|
|
[(middle-up) #f]
|
|
[else (bit? flags MK_MBUTTON)])]
|
|
[right-down (case type
|
|
[(right-down) #t]
|
|
[(right-up) #f]
|
|
[else (bit? flags MK_RBUTTON)])]
|
|
[x mx]
|
|
[y my]
|
|
[shift-down (bit? flags MK_SHIFT)]
|
|
[control-down (bit? flags MK_CONTROL)]
|
|
[meta-down #f]
|
|
[alt-down #f]
|
|
[time-stamp 0]
|
|
[caps-down #f]))])
|
|
(if (eq? type 'leave)
|
|
(let ([t (get-top-frame)])
|
|
(send t send-child-leaves make-e)
|
|
(send t send-leaves make-e))
|
|
(begin
|
|
(unless nc?
|
|
(when (wants-mouse-capture? control-hwnd)
|
|
(when (memq type '(left-down right-down middle-down))
|
|
(SetCapture control-hwnd))
|
|
(when (memq type '(left-up right-up middle-up))
|
|
(ReleaseCapture))))
|
|
(if mouse-in?
|
|
(if (send-child-leaves make-e)
|
|
(cursor-updated-here)
|
|
(if (send (get-top-frame) is-wait-cursor-on?)
|
|
(void (SetCursor (get-wait-cursor)))
|
|
(when effective-cursor-handle
|
|
(void (SetCursor effective-cursor-handle)))))
|
|
(let ([c (generate-mouse-ins this (lambda (type) (make-e type)))])
|
|
(TrackMouseEvent (make-TRACKMOUSEEVENT
|
|
(ctype-sizeof _TRACKMOUSEEVENT)
|
|
(bitwise-ior TME_LEAVE)
|
|
control-hwnd
|
|
0))
|
|
(when c
|
|
(set! effective-cursor-handle c)
|
|
(void (SetCursor (if (send (get-top-frame) is-wait-cursor-on?)
|
|
(get-wait-cursor)
|
|
c))))))
|
|
(when (memq type '(left-down right-down middle-down))
|
|
(set-focus))
|
|
(handle-mouse-event control-hwnd msg wParam (make-e type)))))))
|
|
|
|
(define/private (handle-mouse-event w msg wParam e)
|
|
(if (definitely-wants-event? w msg wParam e)
|
|
(begin
|
|
(queue-window-event this (lambda () (dispatch-on-event/sync e)))
|
|
#t)
|
|
(constrained-reply eventspace
|
|
(lambda () (dispatch-on-event e #t))
|
|
#t)))
|
|
|
|
(define skip-enter-leave? #f)
|
|
(define/public (skip-enter-leave-events skip?)
|
|
(set! skip-enter-leave? skip?))
|
|
|
|
(define mouse-in? #f)
|
|
(define/public (generate-mouse-ins in-window mk)
|
|
(if mouse-in?
|
|
effective-cursor-handle
|
|
(begin
|
|
(set! mouse-in? #t)
|
|
(let ([parent-cursor (generate-parent-mouse-ins mk)])
|
|
(unless skip-enter-leave?
|
|
(handle-mouse-event (get-client-hwnd) 0 0 (mk 'enter)))
|
|
(let ([c (or cursor-handle parent-cursor)])
|
|
(set! effective-cursor-handle c)
|
|
c)))))
|
|
|
|
(define/public (generate-parent-mouse-ins mk)
|
|
(send parent generate-mouse-ins this mk))
|
|
|
|
(define/public (send-leaves mk)
|
|
(when mouse-in?
|
|
(set! mouse-in? #f)
|
|
(unless skip-enter-leave?
|
|
(when mk
|
|
(let ([e (mk 'leave)])
|
|
(if (eq? (current-thread)
|
|
(eventspace-handler-thread eventspace))
|
|
(handle-mouse-event (get-client-hwnd) 0 0 e)
|
|
(queue-window-event this
|
|
(lambda () (dispatch-on-event/sync e)))))))))
|
|
|
|
(define/public (send-child-leaves mk)
|
|
#f)
|
|
|
|
(define/public (wants-mouse-capture? control-hwnd)
|
|
#f)
|
|
|
|
(define/public (definitely-wants-event? w msg wParam e)
|
|
#f)
|
|
(define/public (capture-all-key-events?)
|
|
#f)
|
|
|
|
(define/public (dispatch-on-char/sync e)
|
|
(pre-event-refresh #t)
|
|
(dispatch-on-char e #f))
|
|
(define/public (dispatch-on-char e just-pre?)
|
|
(cond
|
|
[(other-modal? this) #t]
|
|
[(call-pre-on-char this e) #t]
|
|
[just-pre? #f]
|
|
[else (when (is-enabled-to-root?) (on-char e)) #t]))
|
|
|
|
(define/public (dispatch-on-event/sync e)
|
|
(pre-event-refresh #f)
|
|
(dispatch-on-event e #f))
|
|
(define/public (dispatch-on-event e just-pre?)
|
|
(cond
|
|
[(other-modal? this e) #t]
|
|
[(call-pre-on-event this e) #t]
|
|
[just-pre? #f]
|
|
[else (when (is-enabled-to-root?) (on-event e)) #t]))
|
|
|
|
(define/public (call-pre-on-event w e)
|
|
(or (send parent call-pre-on-event w e)
|
|
(pre-on-event w e)))
|
|
(define/public (call-pre-on-char w e)
|
|
(or (send parent call-pre-on-char w e)
|
|
(pre-on-char w e)))
|
|
(define/public (pre-on-event w e) #f)
|
|
(define/public (pre-on-char w e) #f)
|
|
|
|
(define/public (on-char e) (void))
|
|
(define/public (on-event e) (void))
|
|
|
|
(define/private (pre-event-refresh key?)
|
|
;; Since we break the connection between the
|
|
;; Win32 queue and event handling, we
|
|
;; re-sync the display in case a stream of
|
|
;; events (e.g., key repeat) have a corresponding
|
|
;; stream of screen updates.
|
|
(flush-display))
|
|
|
|
(define/public (get-dialog-level) (send parent get-dialog-level)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (handle-copydata lParam)
|
|
(let* ([cd (cast lParam _LPARAM _COPYDATASTRUCT-pointer)]
|
|
[data (COPYDATASTRUCT-lpData cd)]
|
|
[guid-len (bytes-length GRACKET_GUID)]
|
|
[data-len (COPYDATASTRUCT-cbData cd)])
|
|
(when (and (data-len
|
|
. >= .
|
|
(+ guid-len 4 (ctype-sizeof _DWORD)))
|
|
(bytes=? GRACKET_GUID
|
|
(scheme_make_sized_byte_string data
|
|
guid-len
|
|
0))
|
|
(bytes=? #"OPEN"
|
|
(scheme_make_sized_byte_string (ptr-add data guid-len)
|
|
4
|
|
0)))
|
|
;; The command line's argv (sans argv[0]) is
|
|
;; expressed as a DWORD for the number of args,
|
|
;; followed by each arg. Each arg is a DWORD
|
|
;; for the number of chars and then the chars
|
|
(let ([args
|
|
(let ([count (ptr-ref data _DWORD 'abs (+ guid-len 4))])
|
|
(let loop ([i 0] [delta (+ guid-len 4 (ctype-sizeof _DWORD))])
|
|
(if (or (= i count)
|
|
((+ delta (ctype-sizeof _DWORD)) . > . data-len))
|
|
null
|
|
(let ([len (ptr-ref (ptr-add data delta) _DWORD)]
|
|
[delta (+ delta (ctype-sizeof _DWORD))])
|
|
(if ((+ delta len) . > . data-len)
|
|
null
|
|
(let ([s (scheme_make_sized_byte_string
|
|
(ptr-add data delta)
|
|
len
|
|
1)])
|
|
(if (or (bytes=? s #"")
|
|
(regexp-match? #rx"\0" s))
|
|
null
|
|
(cons (bytes->path s)
|
|
(loop (add1 i) (+ delta len))))))))))])
|
|
(map queue-file-event args)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define default-control-font #f)
|
|
(define (get-default-control-font)
|
|
(unless default-control-font
|
|
(set! default-control-font
|
|
(make-object font%
|
|
(->normal (get-theme-font-size))
|
|
(logfont->pango-family
|
|
(get-theme-logfont))
|
|
'system
|
|
'normal 'normal #f 'default
|
|
#t)))
|
|
default-control-font)
|
|
|
|
(define (queue-window-event win thunk)
|
|
(queue-event (send win get-eventspace) thunk))
|
|
|
|
(define (queue-window-refresh-event win thunk)
|
|
(queue-refresh-event (send win get-eventspace) thunk))
|
|
|
|
;; arguments in screen coordinates
|
|
(define (location->window* x y)
|
|
(let ([hwnd (WindowFromPoint (make-POINT x y))])
|
|
(let loop ([hwnd hwnd])
|
|
(and hwnd
|
|
(or (let ([wx (any-hwnd->wx hwnd)])
|
|
(and wx (send wx get-top-frame)))
|
|
(loop (GetParent hwnd)))))))
|
|
|
|
(define (location->window x y)
|
|
(location->window* (->screen x) (->screen y)))
|
|
|
|
(define (flush-display)
|
|
(atomically
|
|
(pre-event-sync #t)))
|