1 files changed, 76 insertions, 0 deletions
diff --git a/src/Rahm/Desktop/Keys/KeyCodeMapping.hs b/src/Rahm/Desktop/Keys/KeyCodeMapping.hs
new file mode 100644
index 0000000..564cc18
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/KeyCodeMapping.hs
@@ -0,0 +1,76 @@
+module Rahm.Desktop.Keys.KeyCodeMapping where
+
+import Rahm.Desktop.Keys.Grab
+import Data.Map (Map)
+import qualified Data.Map as Map
+import XMonad
+import qualified XMonad.Util.ExtensibleConf as XC
+import Control.Monad (forM_)
+import Control.Monad.RWS (All(All))
+
+type KeyCodeActionMap = Map (KeyMask, KeyCode) (X ())
+
+getKeycodeMap :: X (Maybe KeyCodeActionMap)
+getKeycodeMap = XC.ask
+
+setupKeycodeMapping ::
+  (forall l. XConfig l -> KeyCodeActionMap) -> XConfig l -> XConfig l
+setupKeycodeMapping actionMap config =
+  XC.once
+    ( \c ->
+        c
+          { handleEventHook = handleEventHook c <> eventHandler,
+            startupHook = startupHook c >> startupHandler
+          }
+    )
+    (actionMap config)
+    config
+  where
+    startupHandler = grabKeycodes
+
+    eventHandler
+      e@( KeyEvent
+            { ev_event_type = t,
+              ev_keycode = kc,
+              ev_state = m
+            }
+          )
+        | t == keyPress = do
+          mapM_ (sequence_ . Map.lookup (m, kc))
+            =<< getKeycodeMap
+          return (All True)
+    eventHandler e@MappingNotifyEvent {} = do
+      -- Ideally, we'd like to grab the keys here, but XMonad regrabs its keys
+      -- after the user event handlers run and in the process ungrab any keys
+      -- we just grabbed.
+      --
+      -- So, we'll emit an X11 ClientMessage to tell us to regrab the keys
+      -- instead. This will then run after xmonad ungrabs the keys.
+      XConf {display = dpy, theRoot = rootw} <- ask
+      io $ do
+        at <- internAtom dpy "REGRAB_KEYCODES" False
+        m <- internAtom dpy "" False
+        allocaXEvent $ \ev -> do
+          setEventType ev clientMessage
+          setClientMessageEvent ev rootw at 32 m currentTime
+          sendEvent dpy rootw False structureNotifyMask ev
+          sync dpy False
+      return (All True)
+    eventHandler e@ClientMessageEvent {ev_message_type = atom} = do
+      -- We are asked to regrab the keycodes, so we'll do that.
+      dpy <- asks display
+      name <- io $ getAtomName dpy atom
+
+      if name == Just "REGRAB_KEYCODES"
+        then grabKeycodes >> return (All False)
+        else return (All True)
+    eventHandler _ = return (All True)
+
+grabKeycodes :: X ()
+grabKeycodes = do
+  XConf {display = dpy, theRoot = rootw} <- ask
+
+  mKeycodeBinds <- getKeycodeMap
+  forM_ mKeycodeBinds $ \keycodeBinds -> do
+    forM_ (Map.toList keycodeBinds) $ \((m, kc), _) -> do
+      doGrab dpy rootw (m, Kc kc)