diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index b2d2488116..ccebd61a7c 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -169,15 +169,18 @@ [(positive? delta-x) '(wheel-left)] [else '(wheel-right)]))]) (unless (and (pair? evts) - (do-key-event wxb event self #f evts)) + (do-key-event wxb event self #f #f evts)) (super-tell #:type _void scrollWheel: event))))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event self #t #f) + (unless (do-key-event wxb event self #t #f #f) (super-tell #:type _void keyDown: event))] [-a _void (keyUp: [_id event]) - (unless (do-key-event wxb event self #f #f) + (unless (do-key-event wxb event self #f #f #f) (super-tell #:type _void keyUp: event))] + [-a _void (flagsChanged: [_id event]) + (unless (do-key-event wxb event self #f #t #f) + (super-tell #:type _void flagsChanged: event))] [-a _void (insertText: [_NSStringOrAttributed str]) (set-saved-marked! wxb #f #f) (let ([cit (current-insert-text)]) @@ -291,7 +294,7 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event self down? wheel) +(define (do-key-event wxb event self down? mod-change? wheel) (let ([wx (->wx wxb)]) (and wx @@ -318,6 +321,7 @@ [pos (tell #:type _NSPoint event locationInWindow)] [str (cond [wheel #f] + [mod-change? #f] [(unbox set-mark) ""] ; => dead key for composing characters [(unbox inserted-text)] [else @@ -327,6 +331,12 @@ [option? (bit? modifiers NSAlternateKeyMask)] [codes (cond [wheel wheel] + [mod-change? (case (tell #:type _ushort event keyCode) + [(56) '(shift)] + [(59) '(control)] + [(60) '(rshift)] + [(62) '(rcontrol)] + [else '()])] [had-saved-text? str] [(map-key-code (tell #:type _ushort event keyCode)) => list] @@ -355,7 +365,7 @@ [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (unless wheel + (unless (or wheel mod-change?) (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) (when (and (string? alt-str) (= 1 (string-length alt-str))) @@ -370,8 +380,13 @@ ;; swap altenate with main (let ([other (send k get-other-altgr-key-code)]) (send k set-other-altgr-key-code (send k get-key-code)) - (send k set-key-code other))) - (unless down? + (send k set-key-code other)))) + (unless wheel + (unless (or down? (and mod-change? + (case (send k get-key-code) + [(shift rshift) (send k get-shift-down)] + [(control rcontrol) (send k get-control-down)] + [else #t]))) ;; swap altenate with main (send k set-key-release-code (send k get-key-code)) (send k set-key-code 'release))) diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt index 02c5b9a48b..6f86ca189a 100644 --- a/collects/mred/private/wx/gtk/keycode.rkt +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -66,7 +66,11 @@ (#xffc9 . f12) (#xffca . f13) (#xffcb . f14) - (#xffcc . f15)) + (#xffcc . f15) + (#xffe1 . shift) + (#xffe2 . rshift) + (#xffe3 . control) + (#xffe4 . rcontrol)) v #f)) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index 1eeb2a744c..4b97bed2df 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -127,10 +127,14 @@ (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* ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))] + [rcontrol-down? (and control-down? + (not (zero? (arithmetic-shift (GetKeyState VK_RCONTROL) -1))))] + [shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))] + [rshift-down? (and shift-down? + (not (zero? (arithmetic-shift (GetKeyState VK_RSHIFT) -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) (cond [(symbol? wParam) @@ -212,15 +216,11 @@ (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))) + (list VK_ESCAPE 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)] @@ -230,9 +230,15 @@ (if just-check? #t (let* ([id (if (number? id) (integer->char id) id)] - [key-id (if (equal? id #\033) - 'escape - id)] + [key-id (case id + [(#\033) 'escape] + [(shift) (if rshift-down? + 'rshift + id)] + [(control) (if rcontrol-down? + 'rcontrol + id)] + [else id])] [e (new key-event% [key-code (if is-up? 'release diff --git a/collects/scribblings/gui/key-event-class.scrbl b/collects/scribblings/gui/key-event-class.scrbl index 740854ba8d..910ede0434 100644 --- a/collects/scribblings/gui/key-event-class.scrbl +++ b/collects/scribblings/gui/key-event-class.scrbl @@ -71,8 +71,10 @@ Gets the virtual key code for the key event. The virtual key code is @item{@indexed-racket['start]} @item{@indexed-racket['cancel]} @item{@indexed-racket['clear]} -@item{@indexed-racket['shift]} -@item{@indexed-racket['control]} +@item{@indexed-racket['shift] --- Shift key} +@item{@indexed-racket['rshift] --- right Shift key} +@item{@indexed-racket['control] --- Control key} +@item{@indexed-racket['rcontrol] --- right Control key} @item{@indexed-racket['menu]} @item{@indexed-racket['pause]} @item{@indexed-racket['capital]}