From 2567832c8518d5a0d7710b9142c62bae38a104fc Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 5 Sep 2010 09:00:34 -0600
Subject: [PATCH] gtk alternate key interpretetaions

original commit: 1270ba437eec0c02ad3f372f4c3ff35b17fb9e95
---
 collects/mred/private/wx/gtk/keymap.rkt | 42 +++++++++++++++++++++++++
 collects/mred/private/wx/gtk/window.rkt | 15 ++++++---
 2 files changed, 53 insertions(+), 4 deletions(-)
 create mode 100644 collects/mred/private/wx/gtk/keymap.rkt

diff --git a/collects/mred/private/wx/gtk/keymap.rkt b/collects/mred/private/wx/gtk/keymap.rkt
new file mode 100644
index 00000000..fc827e06
--- /dev/null
+++ b/collects/mred/private/wx/gtk/keymap.rkt
@@ -0,0 +1,42 @@
+#lang racket/base
+(require ffi/unsafe
+         "utils.rkt"
+         "const.rkt"
+         "types.rkt")
+
+(provide get-alts)
+
+(define _GdkKeymap (_cpointer 'GdkKeymap))
+
+(define-gdk gdk_keymap_get_default (_fun -> _GdkKeymap))
+
+(define-gdk gdk_keymap_translate_keyboard_state
+  (_fun _GdkKeymap
+        _uint ; hardware_keycode
+        _int ; GdkModifierType state
+        _int ; group
+        (keyval : (_ptr o _uint))
+        (effective_group : (_ptr o _int))
+        (level : (_ptr o _int))
+        (consumed_modifiers : (_ptr o _int))
+        -> (r : _gboolean)
+        -> (and r keyval)))
+                
+(define (get-alts event)
+  (define (get-one-alt mask)
+    (gdk_keymap_translate_keyboard_state (gdk_keymap_get_default)
+                                         (GdkEventKey-hardware_keycode event)
+                                         (let ([mods (GdkEventKey-state event)])
+                                           (bitwise-ior (- mods (bitwise-and mods mask))
+                                                        (bitwise-and mask (bitwise-not (bitwise-and mods mask)))))
+                                         (GdkEventKey-group event)))
+  (let ([alt-gr? (eq? (= (bitwise-and (GdkEventKey-state event) GDK_CONTROL_MASK)
+                         GDK_CONTROL_MASK)
+                      (= (bitwise-and (GdkEventKey-state event) GDK_MOD1_MASK)
+                         GDK_MOD1_MASK))])
+    (values (get-one-alt GDK_SHIFT_MASK)
+            (and alt-gr?
+                 (get-one-alt (bitwise-ior GDK_MOD1_MASK GDK_CONTROL_MASK)))
+            (and alt-gr?
+                 (get-one-alt (bitwise-ior GDK_SHIFT_MASK GDK_MOD1_MASK GDK_CONTROL_MASK)))
+            (get-one-alt GDK_LOCK_MASK))))
diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt
index 65f881b2..c843f68a 100644
--- a/collects/mred/private/wx/gtk/window.rkt
+++ b/collects/mred/private/wx/gtk/window.rkt
@@ -9,6 +9,7 @@
          "../common/queue.rkt"
          "../common/local.rkt"
          "keycode.rkt"
+         "keymap.rkt"
          "queue.rkt"
          "utils.rkt"
          "const.rkt"
@@ -128,11 +129,12 @@
        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))))]
               [k (new key-event%
-                      [key-code (let ([kv (GdkEventKey-keyval event)])
-                                  (or
-                                   (map-key-code kv)
-                                   (integer->char (gdk_keyval_to_unicode kv))))]
+                      [key-code (keyval->code (GdkEventKey-keyval event))]
                       [shift-down (bit? modifiers GDK_SHIFT_MASK)]
                       [control-down (bit? modifiers GDK_CONTROL_MASK)]
                       [meta-down (bit? modifiers GDK_META_MASK)]
@@ -141,6 +143,11 @@
                       [y 0]
                       [time-stamp (GdkEventKey-time event)]
                       [caps-down (bit? modifiers GDK_LOCK_MASK)])])
+         (let-values ([(s ag sag cl) (get-alts event)])
+           (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))))
          (if (send wx handles-events? gtk)
              (begin
                (queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))