Add support for root-level keycode mappings.

The code is a bit of a mess, and should probably be moved out of Dsl2
and into a dedicated place, but it works.

I had to do a bit of a hack to get around XMonad's ungrabbing the
keyboard after a Mapping event, which is not the best, but I don't have
a better way of doing it.

3 files changed, 201 insertions, 114 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 3368a4f..8c78571 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -219,6 +219,9 @@ kcK = 45
 kcL :: KeyCode
 kcL = 46
 
+kcSpace :: KeyCode
+kcSpace = 65
+
 button6 :: Button
 button6 = 6
 
@@ -658,68 +661,73 @@ bindings = do
         sendMessage rotateLayout
 
   bind xK_s $ do
-    forM_ [(JustShift, justMod), (ShiftAndSwap, shiftMod), (ShiftAndFollow, controlMod)] $ \(shiftType, f) ->
-      f $
-        doc
-          ( case shiftType of
-              ShiftAndFollow ->
-                "Shift-and-follow: Like shift-and-swap with the implicit \
-                \third parameter being the current workspace (.)"
-              ShiftAndSwap ->
-                "Shift-and-swap: Shift a windowset to a workspace then swap \
-                \that workspace with another. Primary use case is to move a \
-                \that workspace to a different screen than the current screen. \
-                \Note that this command will only work with normal workspaces."
-              JustShift -> "Shift a windowset to a workspace"
-          )
-          $ pushPendingBuffer
+    forM_
+      [ (JustShift, justMod),
+        (ShiftAndSwap, shiftMod),
+        (ShiftAndFollow, controlMod)
+      ]
+      $ \(shiftType, f) ->
+        f $
+          doc
             ( case shiftType of
-                ShiftAndSwap -> "S "
-                JustShift -> "s "
-                ShiftAndFollow -> "^s "
+                ShiftAndFollow ->
+                  "Shift-and-follow: Like shift-and-swap with the implicit \
+                  \third parameter being the current workspace (.)"
+                ShiftAndSwap ->
+                  "Shift-and-swap: Shift a windowset to a workspace then swap \
+                  \that workspace with another. Primary use case is to move a \
+                  \that workspace to a different screen than the current screen. \
+                  \Note that this command will only work with normal workspaces."
+                JustShift -> "Shift a windowset to a workspace"
             )
-            $ runMaybeT_ $
-              do
-                stackset <- lift $ X.windowset <$> X.get
-                selection <- mapMaybe locationWindow <$> readNextLocationSet
-                withBorderColorM selectedWindowsColor selection $ do
-                  lift $ addStringToPendingBuffer " "
-                  ws <- readNextWorkspace
-                  finalSwap <-
-                    case shiftType of
-                      ShiftAndSwap -> do
-                        lift $ addStringToPendingBuffer " "
-                        wsName <- MaybeT . return $ workspaceName ws
-                        W.switchWorkspaces wsName <$> readNextWorkspaceName
-                      _ -> return id
-
-                  lift $ do
-                    (Endo allMovements) <-
-                      mconcat
-                        <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
-
-                    setAlternateWindows selection
-
-                    forM_ selection $ \win -> do
-                      mapM_
-                        ( \t -> do
-                            logs Debug "Set alternate workspace %s -> %s" (show win) t
-                            setAlternateWorkspace win t
-                        )
-                        (W.findTag win stackset)
-
-                    withWindowsUnpinned selection $
-                      windows $
-                        finalSwap
-                          . ( \ss ->
-                                case shiftType of
-                                  ShiftAndFollow
-                                    | (w : _) <- selection,
-                                      Just ws <- W.findTag w ss ->
-                                      W.greedyView ws ss
-                                  _ -> ss
-                            )
-                          . allMovements
+            $ pushPendingBuffer
+              ( case shiftType of
+                  ShiftAndSwap -> "S "
+                  JustShift -> "s "
+                  ShiftAndFollow -> "^s "
+              )
+              $ runMaybeT_ $
+                do
+                  stackset <- lift $ X.windowset <$> X.get
+                  selection <- mapMaybe locationWindow <$> readNextLocationSet
+                  withBorderColorM selectedWindowsColor selection $ do
+                    lift $ addStringToPendingBuffer " "
+                    ws <- readNextWorkspace
+                    finalSwap <-
+                      case shiftType of
+                        ShiftAndSwap -> do
+                          lift $ addStringToPendingBuffer " "
+                          wsName <- MaybeT . return $ workspaceName ws
+                          W.switchWorkspaces wsName <$> readNextWorkspaceName
+                        _ -> return id
+
+                    lift $ do
+                      (Endo allMovements) <-
+                        mconcat
+                          <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
+
+                      setAlternateWindows selection
+
+                      forM_ selection $ \win -> do
+                        mapM_
+                          ( \t -> do
+                              logs Debug "Set alternate workspace %s -> %s" (show win) t
+                              setAlternateWorkspace win t
+                          )
+                          (W.findTag win stackset)
+
+                      withWindowsUnpinned selection $
+                        windows $
+                          finalSwap
+                            . ( \ss ->
+                                  case shiftType of
+                                    ShiftAndFollow
+                                      | (w : _) <- selection,
+                                        Just ws <- W.findTag w ss ->
+                                        W.greedyView ws ss
+                                    _ -> ss
+                              )
+                            . allMovements
 
     altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
 
@@ -830,6 +838,10 @@ bindings = do
           bind xK_bracketleft $ noMod spaceResize
           bind xK_bracketright $ noMod spaceResize
 
+  bind kcSpace $ do
+    rawMask mod3Mask
+      playPauseDoc
+
   bind xK_t $ do
     justMod $
       doc "Spawn a terminal." $
@@ -845,6 +857,12 @@ bindings = do
       doc "Spawn a floating terminal" $
         spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config)
 
+  bind xK_i $ do
+    justMod $ do
+      XConf {display = dpy, theRoot = rootw} <- ask
+      io $ grabKey dpy 65 32 rootw True grabModeAsync grabModeAsync
+      (return () :: X ())
+
   bind xK_z $ do
     justMod $
       doc "Less often used keybindings." $
@@ -1218,7 +1236,7 @@ bindings = do
                                in windows f >> escape
 
 --   where
--- 
+--
 --   permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False])
 
 myMouseMoveWindow =
@@ -1255,7 +1273,7 @@ windowSpecificBindings config = do
   let altMask = mod1Mask
   let mods = permuteMods [shiftMask, controlMask, 0]
   let configureIf b k =
-        let (keymap, keycodemap, _) = resolveBindings (runBinder config k)
+        let (Bindings keymap keycodemap _) = resolveBindings (runBinder config k)
          in tell =<< lift (b --> return (keymap config, keycodemap config))
       emitKey = flip sendKey w
       mod3 = rawMask mod3Mask
diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
index 16a1b89..d2eb662 100644
--- a/src/Rahm/Desktop/Keys/Dsl2.hs
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 -- | This module creates a DSL for binding keys in a succinct and expressive
 -- way. This DSL follows the pattern:
 --
@@ -21,7 +23,7 @@ module Rahm.Desktop.Keys.Dsl2 where
 
 import Control.Applicative ((<|>))
 import Control.Monad.Fix (fix)
-import Control.Monad.RWS (MonadTrans (lift), MonadWriter, forM_, when)
+import Control.Monad.RWS (All (All), MonadTrans (lift), MonadWriter, forM_, when, forM)
 import Control.Monad.Reader (Reader, ask, runReader)
 import Control.Monad.State (MonadTrans, StateT (StateT))
 import Control.Monad.Trans.Maybe (MaybeT (..))
@@ -34,11 +36,12 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Rahm.Desktop.Common (pointerWindow, runMaybeT_)
-import Rahm.Desktop.Logger (LogLevel (Debug), logs)
-import Rahm.Desktop.Submap (ButtonOrKeyEvent (ButtonPress, KeyPress), getStringForKey, nextButtonOrKeyEvent)
+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)
@@ -69,12 +72,12 @@ instance LiftBinding KeySymOrKeyCode where
   doLift = id
 
 instance LiftBinding KeySym where
-  type Super KeySym = KeySymOrKeyCode
-  doLift = Ks
+  type Super KeySym = Super KeySymOrKeyCode
+  doLift = doLift . Ks
 
 instance LiftBinding KeyCode where
-  type Super KeyCode = KeySymOrKeyCode
-  doLift = Kc
+  type Super KeyCode = Super KeySymOrKeyCode
+  doLift = doLift . Kc
 
 instance LiftBinding Button where
   type Super Button = Button
@@ -235,18 +238,21 @@ doc = Documented
 noWindow :: X () -> Window -> X ()
 noWindow fn _ = fn
 
+data Bindings where
+  Bindings ::
+    (forall l. XConfig l -> Map (KeyMask, KeySym) (X ())) ->
+    (forall l. XConfig l -> Map (KeyMask, KeyCode) (X ())) ->
+    (forall l. XConfig l -> Map (ButtonMask, Button) (Window -> X ())) ->
+    Bindings
+
 -- | Turn a BindingsMap into two values usable values for the XMonad config.
 resolveBindings ::
-  BindingsMap ->
-  ( XConfig l -> Map (KeyMask, KeySym) (X ()),
-    XConfig l -> Map (KeyMask, KeyCode) (X ()),
-    XConfig l -> Map (ButtonMask, Button) (Window -> X ())
-  )
+  BindingsMap -> Bindings
 resolveBindings (BindingsMap keyAndKeyCodeBindings buttonBindings _ _) =
-  ( \c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings,
-    \c -> Map.mapWithKey (\k -> bindingToX c . undocument) keycodeBindings,
-    \c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings
-  )
+  Bindings
+    (\c -> Map.mapWithKey (\k -> pushK k (bindingToX c) . undocument) keyBindings)
+    (\c -> Map.mapWithKey (\k -> bindingToX c . undocument) keycodeBindings)
+    (\c -> Map.mapWithKey (\k -> pushB k (bindingToWinX c) . undocument) buttonBindings)
   where
     (keyBindings, keycodeBindings) =
       partitionMap
@@ -341,14 +347,107 @@ 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 (keyBinds, _, buttonBinds) =
+  let (Bindings keyBinds keycodeBinds buttonBinds) =
         resolveBindings $ runBinder config b
-   in config
-        { keys = keyBinds,
-          mouseBindings = buttonBinds
-        }
+   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)
 
 documentation :: XConfig l -> Binder () -> String
 documentation conf binder =
diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs
index fc75eb9..8712b31 100644
--- a/src/Rahm/Desktop/RebindKeys.hs
+++ b/src/Rahm/Desktop/RebindKeys.hs
@@ -3,8 +3,6 @@
 -- it makes window-specific key bindings awesome!
 module Rahm.Desktop.RebindKeys
   ( remapHook,
-    getKeyCodesForKeysym,
-    doGrab,
     disableKey,
     remapKey,
     sendKeyQ,
@@ -27,7 +25,7 @@ import qualified Data.Map as Map
     lookup,
   )
 import Data.Monoid (All (..))
-import Rahm.Desktop.Keys.Dsl2 (KeySymOrKeyCode (..))
+import Rahm.Desktop.Keys.Dsl2 (KeySymOrKeyCode (..), doGrab, getKeyCodesForKeysym)
 import XMonad
   ( Default (def),
     Display,
@@ -94,34 +92,6 @@ remapHook event = do
           Nothing -> return (All True)
     _ -> return (All True)
 
-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
-
 disableKey :: (KeyMask, KeySym) -> WindowHook
 disableKey key = remapKey (fmap Ks key) (return ())