Break out some stuff in Dsl2.

Create new Grab and KeyCodeMapping modules to support keycode mapping.
That subsystem did not belong in Dsl2.

3 files changed, 121 insertions, 101 deletions

diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
index d2eb662..c9cea83 100644
--- a/src/Rahm/Desktop/Keys/Dsl2.hs
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -35,13 +35,14 @@ import Data.List (intercalate)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
+import Rahm.Desktop.Keys.KeyCodeMapping (setupKeycodeMapping)
+import Rahm.Desktop.Keys.Grab
 import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
 import Rahm.Desktop.Logger (LogLevel (Debug, Info), logs)
 import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress, event_keycode, event_mask), getStringForKey, nextButtonOrKeyEvent)
 import Rahm.Desktop.XMobarLog (spawnXMobar)
 import Rahm.Desktop.XMobarLog.PendingBuffer (pushAddPendingBuffer, pushPendingBuffer)
 import XMonad
-import qualified XMonad.Util.ExtensibleConf as XC
 
 -- | A documented "thing." It is essentially an item with a string attached to
 -- it. A glorified tuple (String, t)
@@ -83,9 +84,6 @@ instance LiftBinding Button where
   type Super Button = Button
   doLift = id
 
-data KeySymOrKeyCode = Ks KeySym | Kc KeyCode
-  deriving (Ord, Eq, Show, Read)
-
 -- | An GADT for XConfig that hides the 'l' parameter. This keeps type
 -- signatures clean by not having to carry around a superfluous type variable.
 data XConfigH where
@@ -347,107 +345,16 @@ continuous (Binder b) = do
 runBinder :: XConfig l -> Binder a -> BindingsMap
 runBinder conf (Binder binder) = runReader (execWriterT binder) (XConfigH conf)
 
-type KeyCodeActionMap = Map (KeyMask, KeyCode) (X ())
-
 withBindings :: Binder a -> XConfig l -> XConfig l
 withBindings b config =
   let (Bindings keyBinds keycodeBinds buttonBinds) =
         resolveBindings $ runBinder config b
-   in XC.once
-        ( \c ->
-            c
-              { keys = keyBinds,
-                mouseBindings = buttonBinds,
-                handleEventHook = handleEventHook c <> eventHandler,
-                startupHook = startupHook c >> startupHandler
-              }
-        )
-        (keycodeBinds config :: KeyCodeActionMap)
-        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)
-
-getKeycodeMap :: X (Maybe KeyCodeActionMap)
-getKeycodeMap = XC.ask
-
-getKeyCodesForKeysym :: Display -> KeySym -> IO [KeyCode]
-getKeyCodesForKeysym dpy keysym = do
-  let (minCode, maxCode) = displayKeycodes dpy
-      allCodes = [fromIntegral minCode .. fromIntegral maxCode]
-
-  syms <- forM allCodes $ \code -> keycodeToKeysym dpy code 0
-  let keysymMap' = Map.fromListWith (++) (zip syms [[code] | code <- allCodes])
-
-  -- keycodeToKeysym returns noSymbol for all unbound keycodes, and we don't
-  -- want to grab those whenever someone accidentally uses def :: KeySym
-  let keysymMap = Map.delete noSymbol keysymMap'
-  let keysymToKeycodes sym = Map.findWithDefault [] keysym keysymMap
-
-  return $ keysymToKeycodes keysym
-
-
-doGrab :: Display -> Window -> (KeyMask, KeySymOrKeyCode) -> X ()
-doGrab dpy win (keyMask, keySymOrKeyCode) = do
-  let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync
-
-  codes <-
-    case keySymOrKeyCode of
-      Ks keysym ->
-        io $ getKeyCodesForKeysym dpy keysym
-      Kc keycode -> return [keycode]
-
-  forM_ codes $ \kc ->
-    mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers
-
-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)
+   in
+     setupKeycodeMapping keycodeBinds $
+       config {
+         keys = keyBinds,
+         mouseBindings = buttonBinds
+       }
 
 documentation :: XConfig l -> Binder () -> String
 documentation conf binder =
diff --git a/src/Rahm/Desktop/Keys/Grab.hs b/src/Rahm/Desktop/Keys/Grab.hs
new file mode 100644
index 0000000..b9b57cd
--- /dev/null
+++ b/src/Rahm/Desktop/Keys/Grab.hs
@@ -0,0 +1,37 @@
+module Rahm.Desktop.Keys.Grab where
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import XMonad
+import Control.Monad (forM_, forM)
+
+data KeySymOrKeyCode = Ks KeySym | Kc KeyCode
+  deriving (Ord, Eq, Show, Read)
+
+doGrab :: Display -> Window -> (KeyMask, KeySymOrKeyCode) -> X ()
+doGrab dpy win (keyMask, keySymOrKeyCode) = do
+  let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync
+
+  codes <-
+    case keySymOrKeyCode of
+      Ks keysym ->
+        io $ getKeyCodesForKeysym dpy keysym
+      Kc keycode -> return [keycode]
+
+  forM_ codes $ \kc ->
+    mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers
+
+getKeyCodesForKeysym :: Display -> KeySym -> IO [KeyCode]
+getKeyCodesForKeysym dpy keysym = do
+  let (minCode, maxCode) = displayKeycodes dpy
+      allCodes = [fromIntegral minCode .. fromIntegral maxCode]
+
+  syms <- forM allCodes $ \code -> keycodeToKeysym dpy code 0
+  let keysymMap' = Map.fromListWith (++) (zip syms [[code] | code <- allCodes])
+
+  -- keycodeToKeysym returns noSymbol for all unbound keycodes, and we don't
+  -- want to grab those whenever someone accidentally uses def :: KeySym
+  let keysymMap = Map.delete noSymbol keysymMap'
+  let keysymToKeycodes sym = Map.findWithDefault [] keysym keysymMap
+
+  return $ keysymToKeycodes keysym
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)