add 'shift, 'control, 'rshift, and 'rcontrol events

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)))
+                      (send k set-key-code other))))
-                  (unless down?
+                (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)))

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))
 

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)))]
+  (let* ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))]
-        [shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))]
+         [rcontrol-down? (and control-down?
-        [caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))]
+                              (not (zero? (arithmetic-shift (GetKeyState VK_RCONTROL) -1))))]
-        [alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)])
+         [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
+                                         (list VK_ESCAPE VK_SPACE VK_RETURN VK_TAB VK_BACK)))
-                                               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)
+		      [key-id (case id
-				  'escape
+                                [(#\033) 'escape]
-				  id)]
+                                [(shift) (if rshift-down?
+                                             'rshift
+                                             id)]
+                                [(control) (if rcontrol-down?
+                                               'rcontrol
+                                               id)]
+                                [else id])]
                       [e (new key-event%
                               [key-code (if is-up?
                                            'release

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['shift] --- Shift key}
-@item{@indexed-racket['control]}
+@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]}