From e6693986f24b9f8652c29195c45de4853ab74a99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Sep 2010 10:23:19 -0600 Subject: [PATCH] fix key-event problem and implement mouse wheel for Cocoa original commit: 8da4bbd52ddf6e42866cb5b338efc5048236593a --- collects/mred/private/wx/cocoa/window.rkt | 106 ++++++++++-------- collects/mred/private/wx/gtk/window.rkt | 7 +- .../scribblings/gui/key-event-class.scrbl | 7 +- 3 files changed, 68 insertions(+), 52 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 9ff5161c..28deb6d7 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -131,12 +131,17 @@ [-a _void (otherMouseDragged: [_id event]) (unless (do-mouse-event wxb event 'motion #f #t #f) (super-tell #:type _void otherMouseDragged: event))] + + [-a _void (scrollWheel: [_id event]) + (unless (and (not (zero? (tell #:type _CGFloat event deltaY))) + (do-key-event wxb event self #f #t)) + (super-tell #:type _void scrollWheel: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event self #t) + (unless (do-key-event wxb event self #t #f) (super-tell #:type _void keyDown: event))] [-a _void (keyUp: [_id event]) - (unless (do-key-event wxb event self #f) + (unless (do-key-event wxb event self #f #f) (super-tell #:type _void keyUp: event))] [-a _void (insertText: [_NSString str]) (let ([cit (current-insert-text)]) @@ -177,43 +182,51 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event self down?) +(define (do-key-event wxb event self down? wheel?) (let ([wx (->wx wxb)]) (and wx (let ([inserted-text (box #f)]) - ;; Calling `interpretKeyEvents:' allows key combinations to be - ;; handled, such as option-e followed by e to produce é. The - ;; call to `interpretKeyEvents:' typically calls `insertText:', - ;; so we set `current-insert-text' to tell `insertText:' to just - ;; give us back the text in the parameter. For now, we ignore the - ;; text and handle the event as usual, though probably we should - ;; be doing something with it. - (parameterize ([current-insert-text inserted-text]) - (tellv self interpretKeyEvents: (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event - count: #:type _NSUInteger 1))) - + (unless wheel? + ;; Calling `interpretKeyEvents:' allows key combinations to be + ;; handled, such as option-e followed by e to produce é. The + ;; call to `interpretKeyEvents:' typically calls `insertText:', + ;; so we set `current-insert-text' to tell `insertText:' to just + ;; give us back the text in the parameter. For now, we ignore the + ;; text and handle the event as usual, though probably we should + ;; be doing something with it. + (parameterize ([current-insert-text inserted-text]) + (tellv self interpretKeyEvents: (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)))) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (tell #:type _NSString event characters)] + [str (if wheel? + #f + (tell #:type _NSString event characters))] [control? (bit? modifiers NSControlKeyMask)] - [option? (bit? modifiers NSAlternateKeyMask)]) + [option? (bit? modifiers NSAlternateKeyMask)] + [delta-y (and wheel? + (tell #:type _CGFloat event deltaY))]) (let-values ([(x y) (send wx window-point-to-view pos)]) (let ([k (new key-event% - [key-code (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1a) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c))))] + [key-code (if wheel? + (if (positive? delta-y) + 'wheel-up + 'wheel-down) + (or + (map-key-code (tell #:type _ushort event keyCode)) + (if (string=? "" str) + #\nul + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1a) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0)))) + c)))))] [shift-down (bit? modifiers NSShiftKeyMask)] [control-down control?] [meta-down (bit? modifiers NSCommandKeyMask)] @@ -222,23 +235,24 @@ [y (->long y)] [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (when (and option? - special-option-key? - (send k get-other-altgr-key-code)) - ;; 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? - ;; swap altenate with main - (send k set-key-release-code (send k get-key-code)) - (send k set-key-code 'release)) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and option? + special-option-key? + (send k get-other-altgr-key-code)) + ;; 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? + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release))) (if (send wx definitely-wants-event? k) (begin (queue-window-event wx (lambda () diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 71ad4fdd..44d17d46 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -156,9 +156,10 @@ (when (or (not (equal? #\u0000 key-code)) (let-values ([(s ag sag cl) (get-alts event)] [(keyval->code*) (lambda (v) - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 key-code)) - c)))]) + (and v + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 key-code)) + c))))]) (let ([s (keyval->code* s)] [ag (keyval->code* ag)] [sag (keyval->code* sag)] diff --git a/collects/scribblings/gui/key-event-class.scrbl b/collects/scribblings/gui/key-event-class.scrbl index 9e0ddf41..6a9957a4 100644 --- a/collects/scribblings/gui/key-event-class.scrbl +++ b/collects/scribblings/gui/key-event-class.scrbl @@ -164,9 +164,10 @@ The special key symbols attempt to capture useful keys that have no If a suitable special key symbol or ASCII representation is not available, @scheme[#\nul] (the NUL character) is reported. -Under X, a @scheme['wheel-up] or @scheme['wheel-down] event may be sent - to a window other than the one with the keyboard focus, because X - generates wheel events based on the location of the mouse pointer. +A @scheme['wheel-up] or @scheme['wheel-down] event may be sent to a + window other than the one with the keyboard focus, because some + platforms generate wheel events based on the location of the mouse + pointer instead of the keyboard focus. Under Windows, when the Control key is pressed without Alt, the key code for ASCII characters is downcased, roughly cancelling the effect