diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index e7bc3052..5a26a8d5 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -30,6 +30,7 @@ main-eventspace? eventspace-handler-thread eventspace-wait-cursor-count + eventspace-extra-table queue-callback middle-queue-key @@ -151,7 +152,8 @@ done-evt [shutdown? #:mutable] done-sema - [wait-cursor-count #:mutable]) + [wait-cursor-count #:mutable] + extra-table) #:property prop:evt (lambda (v) (wrap-evt (eventspace-done-evt v) (lambda (_) v)))) @@ -315,7 +317,8 @@ (semaphore-peek-evt done-sema) #f done-sema - 0)] + 0 + (make-hash))] [cb-box (box #f)]) (parameterize ([current-cb-box cb-box]) (scheme_add_managed (current-custodian) diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index 972bc468..df623434 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -15,13 +15,13 @@ (init parent cb label x y w h style font) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "BUTTON" label (bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS) 0 0 0 0 - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index dd34e487..4fbd9bbc 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -18,7 +18,29 @@ (define-user32 GetDC (_wfun _HWND -> _HDC)) (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) -(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL)) +(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL) + -> (unless r (failed 'InvalidateRect)))) +(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'ShowScrollbar)))) + +(define-cstruct _SCROLLINFO + ([cbSize _UINT] + [fMask _UINT] + [nMin _int] + [nMax _int] + [nPage _UINT] + [nPos _int] + [nTrackPos _int])) + +(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int)) +(define-user32 GetScrollPos (_wfun _HWND _int -> _int)) +(define-user32 SetScrollPos (_wfun _HWND _int _BOOL -> _int)) +(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer + = (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior SIF_RANGE SIF_POS SIF_PAGE) + 0 0 0 0 0)) + -> (r : _BOOL) + -> (if r i (error 'GetScrollInfo "failed")))) (define canvas% (canvas-mixin @@ -29,14 +51,14 @@ [ignored-name #f] [gl-config #f]) - (inherit get-win32 + (inherit get-hwnd get-client-size) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "PLTCanvas" #f @@ -44,13 +66,13 @@ (if hscroll? WS_HSCROLL 0) (if vscroll? WS_VSCROLL 0)) 0 0 w h - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] [style style]) - (define win32 (get-win32)) + (define hwnd (get-hwnd)) (define/override (wndproc w msg wparam lparam) (cond @@ -66,9 +88,13 @@ [else (super wndproc w msg wparam lparam)])) (define dc (new dc% [canvas this])) + (send dc start-backing-retained) (define/public (get-dc) dc) + (define/override (on-resized) + (send dc reset-backing-retained)) + ;; The `queue-paint' and `paint-children' methods ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) @@ -79,7 +105,7 @@ (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) - (define/public (get-flush-window) win32) + (define/public (get-flush-window) hwnd) (define/public (begin-refresh-sequence) (send dc suspend-flush)) @@ -90,7 +116,7 @@ (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) - (void (InvalidateRect win32 #f #t))) + (InvalidateRect hwnd #f #t)) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) @@ -114,19 +140,78 @@ bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) + (define h-scroll-visible? hscroll?) + (define v-scroll-visible? vscroll?) + (define/public (show-scrollbars h? v?) + (when hscroll? + (atomically + (set! h-scroll-visible? (and h? #t)) + (ShowScrollBar hwnd SB_HORZ h?))) + (when vscroll? + (atomically + (set! v-scroll-visible? (and v? #t)) + (ShowScrollBar hwnd SB_VERT v?)))) + + (define/public (set-scrollbars h-step v-step + h-len v-len + h-page v-page + h-pos v-pos + auto?) + (define (make-info len page pos vis?) + (make-SCROLLINFO (ctype-sizeof _SCROLLINFO) + (bitwise-ior (if vis? SIF_DISABLENOSCROLL 0) + SIF_RANGE + SIF_POS + SIF_PAGE) + 0 (+ len page -1) page pos 0)) + (when hscroll? + (SetScrollInfo hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t)) + (when vscroll? + (SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))) + (def/public-unimplemented set-background-to-gray) (def/public-unimplemented on-scroll) - (def/public-unimplemented set-scroll-page) - (def/public-unimplemented set-scroll-range) - (def/public-unimplemented set-scroll-pos) - (def/public-unimplemented get-scroll-page) - (def/public-unimplemented get-scroll-range) - (def/public-unimplemented get-scroll-pos) + + (define/public (get-scroll-pos which) + (GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) + (define/public (get-scroll-range which) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (+ (SCROLLINFO-nMax i) + (SCROLLINFO-nPage i) + 1))) + (define/public (get-scroll-page which) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (SCROLLINFO-nPage i))) + + (define/public (set-scroll-pos which v) + (void (SetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) + (define/public (set-scroll-range which v) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (- v (SCROLLINFO-nPage i) -1)) + (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + (define/public (set-scroll-page which v) + (let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE + (if (if (eq? which 'vertical) + v-scroll-visible? + h-scroll-visible?) + SIF_DISABLENOSCROLL + 0))) + (set-SCROLLINFO-nMax! i (- (+ (SCROLLINFO-nMax i) (SCROLLINFO-nPage i)) + v)) + (set-SCROLLINFO-nPage! i v) + (SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t))) + + (define/override (definitely-wants-event? e) + #t) + (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) (def/public-unimplemented view-start) - (def/public-unimplemented set-resize-corner) - (def/public-unimplemented show-scrollbars) - (def/public-unimplemented set-scrollbars) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event)))) + (def/public-unimplemented set-resize-corner)))) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index b3cbc40f..8eddac09 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -411,3 +411,142 @@ (define MB_YESNOCANCEL #x00000003) (define MB_YESNO #x00000004) (define MB_RETRYCANCEL #x00000005) + +(define SIZE_RESTORED 0) +(define SIZE_MINIMIZED 1) +(define SIZE_MAXIMIZED 2) +(define SIZE_MAXSHOW 3) +(define SIZE_MAXHIDE 4) + +(define SB_HORZ 0) +(define SB_VERT 1) +(define SB_CTL 2) +(define SB_BOTH 3) + +(define SIF_RANGE #x0001) +(define SIF_PAGE #x0002) +(define SIF_POS #x0004) +(define SIF_DISABLENOSCROLL #x0008) +(define SIF_TRACKPOS #x0010) +(define SIF_ALL (bitwise-ior SIF_RANGE SIF_PAGE SIF_POS SIF_TRACKPOS)) + +(define VK_LBUTTON #x01) +(define VK_RBUTTON #x02) +(define VK_CANCEL #x03) +(define VK_MBUTTON #x04) +(define VK_XBUTTON1 #x05) +(define VK_XBUTTON2 #x06) +(define VK_BACK #x08) +(define VK_TAB #x09) +(define VK_CLEAR #x0C) +(define VK_RETURN #x0D) +(define VK_SHIFT #x10) +(define VK_CONTROL #x11) +(define VK_MENU #x12) +(define VK_PAUSE #x13) +(define VK_CAPITAL #x14) +(define VK_KANA #x15) +(define VK_HANGUL #x15) +(define VK_JUNJA #x17) +(define VK_FINAL #x18) +(define VK_HANJA #x19) +(define VK_KANJI #x19) +(define VK_ESCAPE #x1B) +(define VK_CONVERT #x1C) +(define VK_NONCONVERT #x1D) +(define VK_ACCEPT #x1E) +(define VK_MODECHANGE #x1F) +(define VK_SPACE #x20) +(define VK_PRIOR #x21) +(define VK_NEXT #x22) +(define VK_END #x23) +(define VK_HOME #x24) +(define VK_LEFT #x25) +(define VK_UP #x26) +(define VK_RIGHT #x27) +(define VK_DOWN #x28) +(define VK_SELECT #x29) +(define VK_PRINT #x2A) +(define VK_EXECUTE #x2B) +(define VK_SNAPSHOT #x2C) +(define VK_INSERT #x2D) +(define VK_DELETE #x2E) +(define VK_HELP #x2F) +(define VK_LWIN #x5B) +(define VK_RWIN #x5C) +(define VK_APPS #x5D) +(define VK_SLEEP #x5F) +(define VK_NUMPAD0 #x60) +(define VK_NUMPAD1 #x61) +(define VK_NUMPAD2 #x62) +(define VK_NUMPAD3 #x63) +(define VK_NUMPAD4 #x64) +(define VK_NUMPAD5 #x65) +(define VK_NUMPAD6 #x66) +(define VK_NUMPAD7 #x67) +(define VK_NUMPAD8 #x68) +(define VK_NUMPAD9 #x69) +(define VK_MULTIPLY #x6A) +(define VK_ADD #x6B) +(define VK_SEPARATOR #x6C) +(define VK_SUBTRACT #x6D) +(define VK_DECIMAL #x6E) +(define VK_DIVIDE #x6F) +(define VK_F1 #x70) +(define VK_F2 #x71) +(define VK_F3 #x72) +(define VK_F4 #x73) +(define VK_F5 #x74) +(define VK_F6 #x75) +(define VK_F7 #x76) +(define VK_F8 #x77) +(define VK_F9 #x78) +(define VK_F10 #x79) +(define VK_F11 #x7A) +(define VK_F12 #x7B) +(define VK_F13 #x7C) +(define VK_F14 #x7D) +(define VK_F15 #x7E) +(define VK_F16 #x7F) +(define VK_F17 #x80) +(define VK_F18 #x81) +(define VK_F19 #x82) +(define VK_F20 #x83) +(define VK_F21 #x84) +(define VK_F22 #x85) +(define VK_F23 #x86) +(define VK_F24 #x87) +(define VK_NUMLOCK #x90) +(define VK_SCROLL #x91) +(define VK_LSHIFT #xA0) +(define VK_RSHIFT #xA1) +(define VK_LCONTROL #xA2) +(define VK_RCONTROL #xA3) +(define VK_LMENU #xA4) +(define VK_RMENU #xA5) +(define VK_OEM_1 #xBA) +(define VK_OEM_PLUS #xBB) +(define VK_OEM_COMMA #xBC) +(define VK_OEM_MINUS #xBD) +(define VK_OEM_PERIOD #xBE) +(define VK_OEM_2 #xBF) +(define VK_OEM_3 #xC0) +(define VK_OEM_4 #xDB) +(define VK_OEM_5 #xDC) +(define VK_OEM_6 #xDD) +(define VK_OEM_7 #xDE) +(define VK_OEM_8 #xDF) + +(define KF_EXTENDED #x0100) +(define KF_DLGMODE #x0800) +(define KF_MENUMODE #x1000) +(define KF_ALTDOWN #x2000) +(define KF_REPEAT #x4000) +(define KF_UP #x8000) + +(define GW_HWNDFIRST 0) +(define GW_HWNDLAST 1) +(define GW_HWNDNEXT 2) +(define GW_HWNDPREV 3) +(define GW_OWNER 4) +(define GW_CHILD 5) diff --git a/collects/mred/private/wx/win32/dc.rkt b/collects/mred/private/wx/win32/dc.rkt index ab997110..37375244 100644 --- a/collects/mred/private/wx/win32/dc.rkt +++ b/collects/mred/private/wx/win32/dc.rkt @@ -18,18 +18,18 @@ cancel-flush-delay) (define-user32 GetDC (_wfun _HWND -> _HDC)) -(define-user32 ReleaseDC (_wfun _HDC -> _void)) +(define-user32 ReleaseDC (_wfun _HDC -> _int)) (define win32-bitmap% (class bitmap% - (init w h win32) + (init w h hwnd) (super-make-object (make-alternate-bitmap-kind w h)) (define s - (if (not win32) + (if (not hwnd) (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h) (atomically - (let ([hdc (GetDC win32)]) + (let ([hdc (GetDC hwnd)]) (begin0 (cairo_win32_surface_create_with_ddb hdc CAIRO_FORMAT_RGB24 w h) @@ -56,7 +56,7 @@ (define/override (make-backing-bitmap w h) (if (send canvas get-canvas-background) - (make-object win32-bitmap% w h (send canvas get-win32)) + (make-object win32-bitmap% w h (send canvas get-hwnd)) (super make-backing-bitmap w h))) (define/override (get-backing-size xb yb) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 045517cb..b2c47468 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -1,5 +1,7 @@ #lang racket/base (require racket/class + (only-in racket/list last) + ffi/unsafe "../../syntax.rkt" "../common/queue.rkt" "utils.ss" @@ -11,6 +13,8 @@ (provide frame%) (define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL)) +(define-user32 GetActiveWindow (_wfun -> _HWND)) +(define-user32 SetFocus (_wfun _HWND -> _HWND)) (defclass frame% window% (init parent @@ -18,13 +22,15 @@ x y w h style) - (inherit get-win32 + (inherit get-hwnd is-shown? - get-eventspace) + get-eventspace + on-size + pre-on-char pre-on-event) (super-new [parent #f] - [win32 - (CreateWindowExW (bitwise-ior WS_EX_LAYERED) + [hwnd + (CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED) "PLTFrame" (if label label "") WS_OVERLAPPEDWINDOW @@ -35,8 +41,8 @@ #f)] [style (cons 'invisible style)]) - (define win32 (get-win32)) - (SetLayeredWindowAttributes win32 0 255 LWA_ALPHA) + (define hwnd (get-hwnd)) + (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA) (define/public (is-dialog?) #f) @@ -56,14 +62,33 @@ (register-frame-shown this on?) (super direct-show on?)) - (define/override (wndproc w msg wparam lparam) + (define/private (stdret f d) + (if (is-dialog?) d f)) + + (define/override (wndproc w msg wParam lParam) (cond [(= msg WM_CLOSE) (queue-window-event this (lambda () (when (on-close) (direct-show #f)))) 0] - [else (super wndproc w msg wparam lparam)])) + [(= msg WM_SIZE) + (unless (= wParam SIZE_MINIMIZED) + (queue-window-event this (lambda () (on-size 0 0)))) + (stdret 0 1)] + [(= msg WM_MOVE) + (queue-window-event this (lambda () (on-size 0 0))) + 0] + [(= msg WM_ACTIVATE) + (let ([state (LOWORD wParam)] + [minimized (HIWORD wParam)]) + (unless (not (zero? minimized)) + (let ([on? (or (= state WA_ACTIVE) + (= state WA_CLICKACTIVE))]) + (when on? (set-frame-focus)) + (queue-window-event this (lambda () (on-activate on?)))))) + 0] + [else (super wndproc w msg wParam lParam)])) (define/public (on-close) (void)) @@ -73,9 +98,9 @@ #t) (define/override (get-x) - (RECT-left (GetWindowRect win32))) + (RECT-left (GetWindowRect hwnd))) (define/override (get-y) - (RECT-top (GetWindowRect win32))) + (RECT-top (GetWindowRect hwnd))) (def/public-unimplemented on-toolbar-click) (def/public-unimplemented on-menu-click) @@ -85,7 +110,41 @@ (define/public (enforce-size min-x min-y max-x max-y step-x step-y) (void)) - (def/public-unimplemented on-activate) + (define focus-window-path #f) + (define/override (not-focus-child v) + (when (and focus-window-path + (memq v focus-window-path)) + (set! focus-window-path #f))) + (define/override (set-top-focus win win-path child-hwnd) + (set! focus-window-path win-path) + (when (ptr-equal? hwnd (GetActiveWindow)) + (SetFocus child-hwnd))) + + (define/private (set-frame-focus) + (when focus-window-path + (SetFocus (send (last focus-window-path) get-hwnd)))) + + (define/override (child-can-accept-focus?) + #t) + + (define/public (on-activate on?) (void)) + + (define/override (call-pre-on-event w e) + (pre-on-event w e)) + (define/override (call-pre-on-char w e) + (pre-on-char w e)) + + (define dialog-level 0) + (define/public (frame-relative-dialog-status win) + (cond + [(is-dialog?) (let ([dl (send win get-dialog-level)]) + (cond + [(= dl dialog-level) 'same] + [(dl . > . dialog-level) #f] + [else 'other]))] + [else #f])) + + (def/public-unimplemented designate-root-frame) (def/public-unimplemented system-menu) (def/public-unimplemented set-modified) @@ -93,7 +152,9 @@ (def/public-unimplemented maximize) (def/public-unimplemented iconized?) (def/public-unimplemented get-menu-bar) - (def/public-unimplemented set-menu-bar) + + (define/public (set-menu-bar mb) (void)) + (def/public-unimplemented set-icon) (def/public-unimplemented iconize) (def/public-unimplemented set-title)) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt new file mode 100644 index 00000000..b56ecdf0 --- /dev/null +++ b/collects/mred/private/wx/win32/key.rkt @@ -0,0 +1,230 @@ +#lang racket/base +(require racket/class + ffi/unsafe + "utils.rkt" + "types.rkt" + "const.rkt" + "../common/event.rkt") + +(provide make-key-event + generates-key-event?) + +(define-user32 GetKeyState (_wfun _int -> _SHORT)) +(define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) +(define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT)) + +(define (generates-key-event? msg) + (let ([message (MSG-message msg)]) + (and (memq message (list WM_KEYDOWN WM_SYSKEYDOWN + WM_KEYUP WM_SYSKEYUP)) + (make-key-event #t + (MSG-wParam msg) + (MSG-lParam msg) + #f + (or (= message WM_KEYUP) + (= message WM_SYSKEYUP)) + (MSG-hwnd msg))))) + +(define (THE_SCAN_CODE lParam) + (bitwise-and (arithmetic-shift lParam -16) #x1FF)) + +(define generic_ascii_code (make-hasheq)) + +;; The characters in find_shift_alts are things that we'll try +;; to include in keyboard events as char-if-Shift-weren't-pressed, +;; char-if-AltGr-weren't-pressed, etc. +(define other-key-codes + (let ([find_shift_alts (string-append + "!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789")]) + (list->vector + (for/list ([i (in-string find_shift_alts)]) + (VkKeyScanW (char->integer i)))))) + +;; If a virtual key code has no mapping here, then the key should be +;; ignored by WM_KEYDOWN and processed by WM_CHAR instead +(define win32->symbol + (hasheq VK_CANCEL 'cancel + VK_BACK 'back + VK_TAB 'tab + VK_CLEAR 'clear + VK_RETURN 'return + VK_SHIFT 'shift + VK_CONTROL 'control + VK_MENU 'menu + VK_PAUSE 'pause + VK_SPACE 'space + VK_ESCAPE 'escape + VK_PRIOR 'prior + VK_NEXT 'next + VK_END 'end + VK_HOME 'home + VK_LEFT 'left + VK_UP 'up + VK_RIGHT 'right + VK_DOWN 'down + VK_SELECT 'select + VK_PRINT 'print + VK_EXECUTE 'execute + VK_INSERT 'insert + VK_DELETE 'delete + VK_HELP 'help + VK_NUMPAD0 'numpad0 + VK_NUMPAD1 'numpad1 + VK_NUMPAD2 'numpad2 + VK_NUMPAD3 'numpad3 + VK_NUMPAD4 'numpad4 + VK_NUMPAD5 'numpad5 + VK_NUMPAD6 'numpad6 + VK_NUMPAD7 'numpad7 + VK_NUMPAD8 'numpad8 + VK_NUMPAD9 'numpad9 + VK_MULTIPLY 'multiply + VK_ADD 'add + VK_SUBTRACT 'subtract + VK_DECIMAL 'decimal + VK_DIVIDE 'divide + VK_F1 'f1 + VK_F2 'f2 + VK_F3 'f3 + VK_F4 'f4 + VK_F5 'f5 + VK_F6 'f6 + VK_F7 'f7 + VK_F8 'f8 + VK_F9 'f9 + VK_F10 'f10 + VK_F11 'f11 + VK_F12 'f12 + VK_F13 'f13 + VK_F14 'f14 + VK_F15 'f15 + VK_F16 'f16 + VK_F17 'f17 + VK_F18 'f18 + VK_F19 'f19 + VK_F20 'f20 + VK_F21 'f21 + VK_F22 'f22 + VK_F23 'f23 + VK_F24 'f24 + VK_NUMLOCK 'numlock + VK_SCROLL 'scroll)) + + +(define (make-key-event just-check? wParam lParam is-char? is-up? hwnd) + (let ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))] + [shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))] + [caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))] + [alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)]) + (let-values ([(id other-shift other-altgr other-shift-altgr) + (if is-char? + ;; wParam is a character + (let ([id wParam] + [sc (THE_SCAN_CODE lParam)]) + ;; Remember scan codes to help with some key-release events: + (when (byte? id) + (hash-set! generic_ascii_code id sc)) + ;; Look for elements of find_shift_alts that have a different + ;; shift/AltGr state: + (let ([k (MapVirtualKeyW sc 1)]) + (if (zero? k) + (values (integer->char id) #f #f #f) + (for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) k) + ;; Figure out whether it's different in the shift + ;; for AltGr dimension, or both: + (if (eq? (zero? (bitwise-and o #x100)) shift-down?) + ;; different Shift + (if (eq? (= (bitwise-and o #x600) #x6000) + (and control-down? alt-down?)) + ;; same AltGr + (values id o a sa) + ;; different AltGr + (values id s a o)) + ;; same Shift + (if (eq? (= (bitwise-and o #x600) #x6000) + (and control-down? alt-down?)) + ;; same AltGr + (values id s a sa) + ;; different AltGr + (values id s o sa))) + (values id s a sa)))))) + ;; wParam is a virtual key code + (let ([id (hash-ref win32->symbol wParam #f)] + [override-mapping? (and control-down? (not alt-down?))] + [try-generate-release + (lambda () + (let ([sc (THE_SCAN_CODE lParam)]) + (for/fold ([id #f]) ([i (in-range 256)] #:when (not id)) + (and (equal? sc (hash-ref generic_ascii_code i #f)) + (let ([id i]) + (if (id . < . 127) + (char->integer (char-downcase (integer->char id))) + id))))))]) + (if (not id) + (if (or override-mapping? is-up?) + ;; Non-AltGr Ctl- combination, or a release event: + ;; map manually, because the default mapping is + ;; unsatisfactory + ;; Set id to the unshifted key: + (let* ([id (bitwise-and (MapVirtualKeyW wParam 2) #xFFFF)] + [id (cond + [(zero? id) #f] + [(id . < . 128) + (char->integer (char-downcase (integer->char id)))] + [else id])]) + (let-values ([(s a sa) + ;; Look for shifted alternate: + (for/fold ([s #f][a #f][sa #f]) ([o (in-vector other-key-codes)] + [j (in-naturals)]) + (if (= (bitwise-and o #xFF) wParam) + (if (not (zero? (bitwise-and o #x100))) + (if (= (bitwise-and o #x600) #x6000) + (values s a o) + (values o a sa)) + (if (= (bitwise-and o #x600) #x6000) + (values s o sa) + (values s a sa))) + (values s a sa)))]) + (if (and id shift-down?) + ;; shift was pressed, so swap role of shifted and unshifted + (values s id sa a) + (values id s a sa)))) + (values (try-generate-release) #f #f #f)) + (cond + [(and (not is-up?) (= wParam VK_CONTROL)) + ;; Don't generate control-key down events: + (values #f #f #f #f)] + [(and (not override-mapping?) (not is-up?) + ;; Let these get translated to WM_CHAR or skipped + ;; entirely: + (memq wParam + (list VK_ESCAPE VK_SHIFT VK_CONTROL + VK_SPACE VK_RETURN VK_TAB VK_BACK))) + (values #f #f #f #f)] + [(and (not id) is-up?) + (values (try-generate-release) #f #f #f)] + [else + (values id #f #f #f)]))))]) + (and id + (if just-check? + #t + (let* ([id (if (number? id) (integer->char id) id)] + [e (new key-event% + [key-code (if is-up? + 'release + id)] + [shift-down shift-down?] + [control-down control-down?] + [meta-down #f] + [alt-down alt-down?] + [x 0] + [y 0] + [time-stamp 0] + [caps-down caps-down?])]) + e)))))) + diff --git a/collects/mred/private/wx/win32/menu-bar.rkt b/collects/mred/private/wx/win32/menu-bar.rkt index f8feb528..6a2bf8f7 100644 --- a/collects/mred/private/wx/win32/menu-bar.rkt +++ b/collects/mred/private/wx/win32/menu-bar.rkt @@ -9,5 +9,5 @@ (def/public-unimplemented number) (def/public-unimplemented enable-top) (def/public-unimplemented delete) - (def/public-unimplemented append) + (define/public (append m l) (void)) (super-new)) diff --git a/collects/mred/private/wx/win32/menu-item.rkt b/collects/mred/private/wx/win32/menu-item.rkt index 3b0f521c..afe240e0 100644 --- a/collects/mred/private/wx/win32/menu-item.rkt +++ b/collects/mred/private/wx/win32/menu-item.rkt @@ -5,5 +5,5 @@ (provide menu-item%) (defclass menu-item% object% - (def/public-unimplemented id) + (define/public (id) this) (super-new)) diff --git a/collects/mred/private/wx/win32/menu.rkt b/collects/mred/private/wx/win32/menu.rkt index 06e79d85..7de02166 100644 --- a/collects/mred/private/wx/win32/menu.rkt +++ b/collects/mred/private/wx/win32/menu.rkt @@ -5,6 +5,10 @@ (provide menu%) (defclass menu% object% + (init label + callback + font) + (def/public-unimplemented select) (def/public-unimplemented get-font) (def/public-unimplemented set-width) @@ -15,8 +19,14 @@ (def/public-unimplemented enable) (def/public-unimplemented check) (def/public-unimplemented checked?) - (def/public-unimplemented append-separator) (def/public-unimplemented delete-by-position) (def/public-unimplemented delete) - (def/public-unimplemented append) + + (public [append-item append]) + (define (append-item i label help-str-or-submenu chckable?) + (void)) + + (define/public (append-separator) + (void)) + (super-new)) diff --git a/collects/mred/private/wx/win32/panel.rkt b/collects/mred/private/wx/win32/panel.rkt index c069a22e..650dbb7d 100644 --- a/collects/mred/private/wx/win32/panel.rkt +++ b/collects/mred/private/wx/win32/panel.rkt @@ -14,13 +14,13 @@ label) (super-new [parent parent] - [win32 + [hwnd (CreateWindowExW 0 "PLTPanel" #f (bitwise-ior WS_CHILD) 0 0 w h - (send parent get-win32) + (send parent get-hwnd) #f hInstance #f)] @@ -28,8 +28,6 @@ (def/public-unimplemented get-label-position) (def/public-unimplemented set-label-position) - (def/public-unimplemented on-char) - (def/public-unimplemented on-event) (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 5e785901..c8dd68f7 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -52,7 +52,7 @@ (define-unimplemented find-graphical-system-path) (define-unimplemented register-collecting-blit) (define-unimplemented unregister-collecting-blit) -(define (shortcut-visible-in-label? ?) #t) +(define (shortcut-visible-in-label? [? #f]) #t) (define-unimplemented location->window) (define-unimplemented send-event) (define-unimplemented file-creator-and-type) @@ -71,7 +71,9 @@ (set-box! xb 1024) (set-box! yb 768)) (define-unimplemented bell) -(define-unimplemented hide-cursor) + +(define (hide-cursor) (void)) + (define-unimplemented end-busy-cursor) (define-unimplemented is-busy?) (define-unimplemented begin-busy-cursor) diff --git a/collects/mred/private/wx/win32/queue.rkt b/collects/mred/private/wx/win32/queue.rkt index 229c6aff..f1f1adda 100644 --- a/collects/mred/private/wx/win32/queue.rkt +++ b/collects/mred/private/wx/win32/queue.rkt @@ -1,8 +1,13 @@ #lang racket/base (require ffi/unsafe + racket/class + ffi/unsafe/alloc + ffi/unsafe/try-atomic "utils.rkt" "types.rkt" "const.rkt" + "key.rkt" + "wndclass.rkt" "../../lock.rkt" "../common/queue.rkt") @@ -19,26 +24,33 @@ (define _LPMSG _pointer) -(define-cstruct _MSG ([hwnd _HWND] - [message _UINT] - [wParam _WPARAM] - [lParam _LPARAM] - [time _DWORD] - [pt _POINT])) - (define-user32 GetQueueStatus (_wfun _UINT -> _DWORD)) (define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL)) (define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL)) (define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL)) (define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT)) (define-user32 PostQuitMessage (_wfun _int -> _void)) +(define-user32 EnumThreadWindows (_wfun _DWORD _fpointer _LPARAM -> _BOOL)) +(define-user32 GetWindow (_wfun _HWND _UINT -> _HWND)) +(define-kernel32 GetCurrentThreadId (_wfun -> _DWORD)) + +(define _enum_proc (_wfun _HWND _LPARAM -> _BOOL)) (define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void)) -(define msg (malloc _MSG 'raw)) +(define free-msg + ((deallocator) + (lambda (msg) + (free msg)))) + +(define malloc-msg + ((allocator free-msg) + (lambda () + (malloc _MSG 'raw)))) (define (events-ready?) - (not (zero? (GetQueueStatus QS_ALLINPUT)))) + ;; Check for events only since the last PeekMessage: + (not (zero? (LOWORD (GetQueueStatus QS_ALLINPUT))))) (define (install-wakeup fds) (pre-event-sync #t) @@ -47,17 +59,89 @@ (set-check-queue! events-ready?) (set-queue-wakeup! install-wakeup) +(define other-peek-evt (make-semaphore)) +(define peek-other-peek-evt (semaphore-peek-evt other-peek-evt)) + +(define (message-dequeue es hwnd) + ;; Called in the eventspace for hwnd: + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _long)]) + (atomically (hash-remove! t id)) + (let ([msg (malloc-msg)]) + (let loop () + (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) + ;; Since we called PeekMeessage in a thread other than the + ;; event-pump thread, see `other-peek-evt' so the pump + ;; knows to check again. + (unless (sync/timeout 0 peek-other-peek-evt) + (semaphore-post other-peek-evt)) + ;; Now handle the event: + (when v + (unless (generates-key-event? (cast msg _pointer _MSG-pointer)) + (TranslateMessage msg)) + (call-as-nonatomic-retry-point + (lambda () + ;; in atomic mode: + (DispatchMessageW msg))) + ;; Maybe there's another event for this window: + (loop)))) + (free-msg msg)))) + +(define (queue-message-dequeue es hwnd) + (let ([t (eventspace-extra-table es)] + [id (cast hwnd _HWND _long)]) + (unless (hash-ref t id #f) + (hash-set! t id #t) + (queue-event es (lambda () (message-dequeue es hwnd)))))) + +;; For use only in the event-pump thread: +(define msg (malloc-msg)) + +(define (check-window-event hwnd data) + (let* ([root (let loop ([hwnd hwnd]) + (let ([p (GetWindow hwnd GW_OWNER)]) + (if p + (loop p) + hwnd)))] + [wx (any-hwnd->wx root)]) + (if wx + ;; One of our windows, so make sure its eventspace + ;; asks for the message: + (let ([v (PeekMessageW msg hwnd 0 0 PM_NOREMOVE)]) + (when v + (queue-message-dequeue (send wx get-eventspace) + hwnd))) + ;; Not our window, so dispatch any available events + (let loop () + (let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop))))) + #f)) + +(define check_window_event (function-ptr check-window-event _enum_proc)) + (define (dispatch-all-ready) (pre-event-sync #f) - (let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)]) - (when v - (TranslateMessage msg) - (DispatchMessageW msg) - (dispatch-all-ready)))) + + ;; Windows uses messages above #x4000 to hilite items in the task bar, + ;; etc. In any case, these messages won't be handled by us, so they + ;; can't trigger callbacks. + (let loop () + (let ([v (PeekMessageW msg #f #x4000 #xFFFF PM_REMOVE)]) + (when v + (TranslateMessage msg) + (DispatchMessageW msg) + (loop)))) + + ;; Per-window checking lets us put an event in the right + ;; eventspace: + (EnumThreadWindows (GetCurrentThreadId) check_window_event 0)) (define (win32-start-event-pump) (thread (lambda () (let loop () - (sync queue-evt) + (sync queue-evt other-peek-evt) (as-entry dispatch-all-ready) (loop))))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index 3f19d936..e69f7e46 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -12,7 +12,9 @@ _UINT _BYTE _LONG + _SHORT _HRESULT + _WCHAR _HINSTANCE _HWND @@ -30,7 +32,11 @@ _permanent-string/utf-16 (struct-out POINT) _POINT _POINT-pointer - (struct-out RECT) _RECT _RECT-pointer) + (struct-out RECT) _RECT _RECT-pointer + (struct-out MSG) _MSG _MSG-pointer + + HIWORD + LOWORD) (define-syntax-rule (_wfun . a) (_fun #:abi 'stdcall . a)) @@ -44,6 +50,7 @@ (define _UINT _uint) (define _BYTE _uint8) (define _HRESULT _int32) +(define _WCHAR _int16) (define _HINSTANCE (_cpointer/null 'HINSTANCE)) (define _HWND (_cpointer/null 'HWND)) @@ -77,6 +84,7 @@ (cast p _pointer _string/utf-16))))) (define _LONG _long) +(define _SHORT _short) (define-cstruct _POINT ([x _LONG] [y _LONG])) @@ -85,3 +93,16 @@ [top _LONG] [right _LONG] [bottom _LONG])) + +(define-cstruct _MSG ([hwnd _HWND] + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) + +(define (HIWORD v) + (arithmetic-shift v -16)) +(define (LOWORD v) + (bitwise-and v #xFFFF)) + diff --git a/collects/mred/private/wx/win32/utils.rkt b/collects/mred/private/wx/win32/utils.rkt index 074f2068..72527101 100644 --- a/collects/mred/private/wx/win32/utils.rkt +++ b/collects/mred/private/wx/win32/utils.rkt @@ -1,14 +1,16 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define - "../common/utils.rkt") + "../common/utils.rkt" + "types.rkt") (provide define-gdi32 define-user32 define-kernel32 define-comctl32 define-uxtheme - define-mz) + define-mz + failed) (define gdi32-lib (ffi-lib "gdi32.dll")) (define user32-lib (ffi-lib "user32.dll")) @@ -21,3 +23,10 @@ (define-ffi-definer define-kernel32 kernel32-lib) (define-ffi-definer define-comctl32 comctl32-lib) (define-ffi-definer define-uxtheme uxtheme-lib) + +(define-kernel32 GetLastError (_wfun -> _DWORD)) + +(define (failed w who) + (error who "call failed (~s)" + (GetLastError))) + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index aa97a4cb..3f9dca95 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -3,12 +3,15 @@ racket/class racket/draw "../../syntax.rkt" + "../common/freeze.rkt" + "../common/queue.rkt" "utils.rkt" "types.rkt" "const.rkt" "wndclass.rkt" "queue.rkt" - "theme.rkt") + "theme.rkt" + "key.rkt") (provide window% queue-window-event @@ -17,6 +20,8 @@ CreateWindowExW GetWindowRect) +(define (unhide-cursor) (void)) + (define-user32 CreateWindowExW (_wfun _DWORD _string/utf-16 _string/utf-16 @@ -24,16 +29,20 @@ _int _int _int _int _HWND _HMENU _HINSTANCE _pointer -> _HWND)) -(define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) -(define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r)) +(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-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT)) (define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT)) -(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL)) +(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL) + -> (unless r (failed 'MoveWindow)))) + +(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void))) -(define-user32 ShowWindow (_wfun _HWND _int -> _BOOL)) (define SW_SHOW 5) (define SW_HIDE 0) @@ -48,38 +57,69 @@ (* 1/8 (arithmetic-shift v -16))))) (defclass window% object% - (init-field parent win32) + (init-field parent hwnd) (init style) - + (super-new) (define eventspace (current-eventspace)) - (set-win32-wx! win32 this) + (set-hwnd-wx! hwnd this) - (unless (memq 'invisible style) - (show #t)) - - (define/public (get-win32) win32) - (define/public (get-client-win32) win32) + (define/public (get-hwnd) hwnd) + (define/public (get-client-hwnd) hwnd) (define/public (get-eventspace) eventspace) - (define/public (wndproc w msg wparam lparam) - (DefWindowProcW w msg wparam lparam)) - + (define/public (wndproc w msg wParam lParam) + (cond + [(= msg WM_SETFOCUS) + (queue-window-event this (lambda () (on-set-focus))) + 0] + [(= msg WM_KILLFOCUS) + (queue-window-event this (lambda () (on-kill-focus))) + 0] + [(= msg WM_SYSKEYDOWN) + (when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close + (unhide-cursor) + (begin0 + (DefWindowProcW w msg wParam lParam) + (do-key wParam lParam #f #f)))] + [(= msg WM_KEYDOWN) + (do-key wParam lParam #f #f) + 0] + [(= msg WM_KEYUP) + (do-key wParam lParam #f #t) + 0] + [(= msg WM_SYSCHAR) + (when (= wParam VK_MENU) + (unhide-cursor) + (begin0 + (DefWindowProcW w msg wParam lParam) + (do-key wParam lParam #t #f)))] + [(= msg WM_CHAR) + (do-key wParam lParam #t #f) + 0] + [else + (DefWindowProcW w msg wParam lParam)])) + (define/public (show on?) (direct-show on?)) + (define shown? #f) (define/public (direct-show on?) - (void (ShowWindow win32 (if on? SW_SHOW SW_HIDE)))) - + (set! shown? (and on? #t)) + (unless on? (not-focus-child this)) + (ShowWindow hwnd (if on? SW_SHOW SW_HIDE))) + (unless (memq 'invisible style) + (show #t)) + (def/public-unimplemented on-drop-file) - (def/public-unimplemented pre-on-event) - (def/public-unimplemented pre-on-char) - (def/public-unimplemented on-size) - (def/public-unimplemented on-set-focus) - (def/public-unimplemented on-kill-focus) - (def/public-unimplemented get-handle) + + (define/public (on-size w h) (void)) + + (define/public (on-set-focus) (void)) + (define/public (on-kill-focus) (void)) + (define/public (get-handle) hwnd) (define/public (is-window-enabled?) #t) @@ -89,51 +129,54 @@ (send parent is-enabled-to-root?))) (define/public (is-shown-to-root?) - (and (is-shown?) + (and shown? (send parent is-shown-to-root?))) (define/public (is-shown?) - #t) + shown?) (def/public-unimplemented set-phantom-size) (define/public (paint-children) (void)) (define/public (get-x) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-left r) (send parent get-x)))) (define/public (get-y) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-top r) (send parent get-y)))) (define/public (get-width) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-right r) (RECT-left r)))) (define/public (get-height) - (let ([r (GetWindowRect win32)]) + (let ([r (GetWindowRect hwnd)]) (- (RECT-bottom r) (RECT-top r)))) (define/public (set-size x y w h) - (void - (if (or (= x -11111) - (= y -11111) - (= w -1) - (= h -1)) - (let ([r (GetWindowRect win32)]) - (MoveWindow win32 - (if (= x -11111) (RECT-left r) x) - (if (= y -11111) (RECT-right r) y) - (if (= w -1) (- (RECT-right r) (RECT-left r)) w) - (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) - #t)) - (MoveWindow win32 x y w h #t)))) + (if (or (= x -11111) + (= y -11111) + (= w -1) + (= h -1)) + (let ([r (GetWindowRect hwnd)]) + (MoveWindow hwnd + (if (= x -11111) (RECT-left r) x) + (if (= y -11111) (RECT-right r) y) + (if (= w -1) (- (RECT-right r) (RECT-left r)) w) + (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) + #t)) + (MoveWindow hwnd x y w h #t)) + (on-size w h) + (unless (and (= w -1) (= h -1)) + (on-resized)) + (refresh)) (define/public (move x y) (set-size x y -1 -1)) (define/public (auto-size label min-w min-h dw dh) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) + (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0) (unless measure-dc (let* ([bm (make-object bitmap% 1 1)] [dc (make-object bitmap-dc% bm)] @@ -151,7 +194,9 @@ (define/public (get-parent) parent) - (def/public-unimplemented refresh) + (define/public (refresh) (void)) + (define/public (on-resized) (void)) + (def/public-unimplemented screen-to-client) (def/public-unimplemented client-to-screen) @@ -162,16 +207,90 @@ (def/public-unimplemented get-position) (define/public (get-client-size w h) - (let ([r (GetClientRect (get-client-win32))]) + (let ([r (GetClientRect (get-client-hwnd))]) + (set-box! w (- (RECT-right r) (RECT-left r))) + (set-box! h (- (RECT-bottom r) (RECT-top r))))) + + (define/public (get-size w h) + (let ([r (GetWindowRect (get-client-hwnd))]) (set-box! w (- (RECT-right r) (RECT-left r))) (set-box! h (- (RECT-bottom r) (RECT-top r))))) - (def/public-unimplemented get-size) (def/public-unimplemented fit) (def/public-unimplemented set-cursor) - (def/public-unimplemented set-focus) + + (define/public (set-focus) + (when (can-accept-focus?) + (set-top-focus this null 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)) + (def/public-unimplemented gets-focus?) - (def/public-unimplemented centre)) + (def/public-unimplemented centre) + + (define/private (do-key wParam lParam is-char? is-up?) + (let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)]) + (and e + (if (definitely-wants-event? e) + (begin + (queue-window-event this (lambda () (dispatch-on-char/sync e))) + #t) + (constrained-reply (get-eventspace) + (lambda () (dispatch-on-char e #t)) + #t))))) + + (define/public (definitely-wants-event? e) + #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) #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 + ;; Cocoa 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. + (void))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index 1fd6c539..d06f8bad 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -1,6 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class + "../../lock.rkt" "utils.rkt" "types.rkt" "const.rkt" @@ -8,8 +9,9 @@ (provide hInstance DefWindowProcW - win32->wx - set-win32-wx! + hwnd->wx + any-hwnd->wx + set-hwnd-wx! MessageBoxW) ;; ---------------------------------------- @@ -17,12 +19,26 @@ (define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer)) (define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer)) -(define (win32->wx win32) - (let ([p (GetWindowLongW win32 GWLP_USERDATA)]) +(define all-cells (make-hash)) + +(define (hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) (and p (ptr-ref p _racket)))) -(define (set-win32-wx! win32 wx) - (SetWindowLongW win32 GWLP_USERDATA (malloc-immobile-cell wx))) +(define (set-hwnd-wx! hwnd wx) + (let ([c (malloc-immobile-cell wx)]) + (SetWindowLongW hwnd GWLP_USERDATA c) + (atomically (hash-set! all-cells (cast c _pointer _long) #t)))) + +(define (any-hwnd->wx hwnd) + (let ([p (GetWindowLongW hwnd GWLP_USERDATA)]) + (and p + (atomically (hash-ref all-cells (cast p _pointer _long) #f)) + (let ([wx (ptr-ref p _racket)]) + (and wx + (ptr-equal? hwnd (send wx get-hwnd)) + wx))))) + ;; ---------------------------------------- @@ -63,7 +79,7 @@ #;(define-user32 PostQuitMessage (_wfun _int -> _void)) (define (wind-proc w msg wparam lparam) - (let ([wx (win32->wx w)]) + (let ([wx (hwnd->wx w)]) (if wx (send wx wndproc w msg wparam lparam) (DefWindowProcW w msg wparam lparam))))