From 8c9e2397986bf7fb51ff1f049b1c2a474a5fb588 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Sep 2010 19:25:11 -0600 Subject: [PATCH] key release events --- collects/mred/private/wx/cocoa/window.rkt | 11 ++- collects/mred/private/wx/gtk/canvas.rkt | 1 + collects/mred/private/wx/gtk/window.rkt | 97 +++++++++++++---------- 3 files changed, 65 insertions(+), 44 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index bd29c17a28..7dbac31ba4 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -126,7 +126,10 @@ (super-tell #:type _void otherMouseDragged: event))] [-a _void (keyDown: [_id event]) - (unless (do-key-event wxb event self) + (unless (do-key-event wxb event self #t) + (super-tell #:type _void keyDown: event))] + [-a _void (keyUp: [_id event]) + (unless (do-key-event wxb event self #f) (super-tell #:type _void keyDown: event))] [-a _void (insertText: [_NSString str]) (let ([cit (current-insert-text)]) @@ -167,7 +170,7 @@ (when wx (send wx reset-cursor-rects)))]) -(define (do-key-event wxb event self) +(define (do-key-event wxb event self down?) (let ([wx (->wx wxb)]) (and wx @@ -225,6 +228,10 @@ (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/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index a046cde194..33bf7755f7 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -296,6 +296,7 @@ (connect-key-and-mouse client-gtk) (connect-focus client-gtk) (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK + GDK_KEY_RELEASE_MASK GDK_BUTTON_PRESS_MASK GDK_BUTTON_RELEASE_MASK GDK_POINTER_MOTION_MASK diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 703bf58096..71ad4fdd7a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -125,48 +125,60 @@ (define-signal-handler connect-key-press "key-press-event" (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) (lambda (gtk event) - (let ([wx (gtk->wx gtk)]) - (and - wx - (let* ([modifiers (GdkEventKey-state event)] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [keyval->code (lambda (kv) - (or - (map-key-code kv) - (integer->char (gdk_keyval_to_unicode kv))))] - [key-code (keyval->code (GdkEventKey-keyval event))] - [k (new key-event% - [key-code key-code] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_META_MASK)] - [alt-down (bit? modifiers GDK_MOD1_MASK)] - [x 0] - [y 0] - [time-stamp (GdkEventKey-time event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (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)))]) - (let ([s (keyval->code* s)] - [ag (keyval->code* ag)] - [sag (keyval->code* sag)] - [cl (keyval->code* cl)]) - (when s (send k set-other-shift-key-code (keyval->code s))) - (when ag (send k set-other-altgr-key-code (keyval->code ag))) - (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) - (when cl (send k set-other-caps-key-code (keyval->code cl))) - (or s ag sag cl)))) - (if (send wx handles-events? gtk) - (begin - (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t)))))))) + (do-key-event gtk event #t))) + +(define-signal-handler connect-key-release "key-release-event" + (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) + (lambda (gtk event) + (do-key-event gtk event #f))) + +(define (do-key-event gtk event down?) + (let ([wx (gtk->wx gtk)]) + (and + wx + (let* ([modifiers (GdkEventKey-state event)] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [keyval->code (lambda (kv) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (keyval->code (GdkEventKey-keyval event))] + [k (new key-event% + [key-code key-code] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [x 0] + [y 0] + [time-stamp (GdkEventKey-time event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (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)))]) + (let ([s (keyval->code* s)] + [ag (keyval->code* ag)] + [sag (keyval->code* sag)] + [cl (keyval->code* cl)]) + (when s (send k set-other-shift-key-code (keyval->code s))) + (when ag (send k set-other-altgr-key-code (keyval->code ag))) + (when sag (send k set-other-shift-altgr-key-code (keyval->code sag))) + (when cl (send k set-other-caps-key-code (keyval->code cl))) + (or s ag sag cl)))) + (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 handles-events? gtk) + (begin + (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t))))))) (define-signal-handler connect-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) @@ -202,6 +214,7 @@ (define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) + (connect-key-release gtk) (connect-button-press gtk) (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk)