234 lines
10 KiB
Racket
234 lines
10 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"../common/event.rkt")
|
|
|
|
(provide
|
|
(protect-out 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 (and is-up? (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
|
|
(if (equal? id #\033)
|
|
'escape
|
|
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))))))
|
|
|