Add limited ability to bind directly to keycodes.

Binding to keycodes is good for nonmnemonic key bindings -- where the
choice of key is due to its position on the keyboard rather than the
character associated with it.

Right now only window bindings and subbindings can use keycode bindings.
Root bindings can still only be keysyms and buttons.

I've been using this feature to map some movement keys to Hyper. This
emulates the function key on my M770 keyboard where fn+ijkl are used as
arrow keys. I use the tab key as my hyper key. With xcape it can operate
as a Tab key when release, or a modifier key when held down, which is
awesome.

4 files changed, 131 insertions, 38 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 0bf3ba0..3368a4f 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -198,6 +198,27 @@ mediaSeekBDoc = doc "Seek back 3 seconds" mediaSeekB
 
 mediaSeekFDoc = doc "Seek forward 12 seconds" mediaSeekF
 
+kcQ :: KeyCode
+kcQ = 24
+
+kcW :: KeyCode
+kcW = 25
+
+kcE :: KeyCode
+kcE = 26
+
+kcI :: KeyCode
+kcI = 31
+
+kcJ :: KeyCode
+kcJ = 44
+
+kcK :: KeyCode
+kcK = 45
+
+kcL :: KeyCode
+kcL = 46
+
 button6 :: Button
 button6 = 6
 
@@ -881,6 +902,10 @@ bindings = do
             noMod mediaNextDoc
             rawMask shiftMask mediaSeekFDoc
 
+          bind kcW $ do
+            (justMod -|- noMod) $
+              (logs Info "Testing keycode press!" :: X ())
+
           bindOtherKeys $ \(_, _, s) ->
             logs Info "Unhandled key pressed: %s" s
 
@@ -1223,34 +1248,35 @@ applyKeys c =
             }
 
 windowSpecificBindings ::
-  XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query ()
+  XConfig l -> WriterT (Map (KeyMask, KeySym) (X ()), Map (KeyMask, KeyCode) (X ())) Query ()
 windowSpecificBindings config = do
   w <- lift ask
 
   let altMask = mod1Mask
   let mods = permuteMods [shiftMask, controlMask, 0]
   let configureIf b k =
-        let (keymap, _) = resolveBindings (runBinder config k)
-         in tell =<< lift (b --> return (keymap config))
+        let (keymap, keycodemap, _) = resolveBindings (runBinder config k)
+         in tell =<< lift (b --> return (keymap config, keycodemap config))
       emitKey = flip sendKey w
+      mod3 = rawMask mod3Mask
 
   configureIf (return True) $ do
     -- The following are bindings that send keystrokes to the focused window. This
     -- makes navigating with arrow keys and whatnot much easier.
     forM_ (permuteMods [0, controlMask, shiftMask]) $ \mods -> do
-      bind xK_c $
+      bind kcI $
         rawMask (mod3Mask .|. mods) $
           emitKey (mods, xK_Up)
 
-      bind xK_t $
+      bind kcK $
         rawMask (mod3Mask .|. mods) $
           emitKey (mods, xK_Down)
 
-      bind xK_h $
+      bind kcJ $
         rawMask (mod3Mask .|. mods) $
           emitKey (mods, xK_Left)
 
-      bind xK_n $
+      bind kcL $
         rawMask (mod3Mask .|. mods) $
           emitKey (mods, xK_Right)
 
@@ -1291,6 +1317,15 @@ windowSpecificBindings config = do
         rawMask (m .|. mod3Mask) $
           emitKey (m .|. controlMask, xK_Page_Down)
 
+    bind kcQ $
+      mod3 mediaPrev
+
+    bind kcW $
+      mod3 playPause
+
+    bind kcE $
+      mod3 mediaNext
+
   configureIf (flip elem (browsers ++ spotify) <$> className) $ do
     bind xK_h $ do
       rawMask controlMask $ emitKey (0, xK_BackSpace)
@@ -1402,9 +1437,12 @@ windowBindings xconfig =
       w <- ask
 
       liftX $ logs Debug "For Window: %s" (show w)
-      forM_ (Map.toList map) $ \(key, action) -> do
+      forM_ (Map.toList (snd map)) $ \(kc, action) -> do
+        liftX $ logs Debug "   -- remap: %s" (show kc)
+        remapKey (fmap Kc kc) action
+      forM_ (Map.toList (fst map)) $ \(key, action) -> do
         liftX $ logs Debug "   -- remap: %s" (show key)
-        remapKey key action
+        remapKey (fmap Ks key) action
 
 modifyWindowBorder :: Integer -> SpacingModifier
 modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) ->
diff --git a/src/Rahm/Desktop/Keys/Dsl2.hs b/src/Rahm/Desktop/Keys/Dsl2.hs
index bfa8b05..16a1b89 100644
--- a/src/Rahm/Desktop/Keys/Dsl2.hs
+++ b/src/Rahm/Desktop/Keys/Dsl2.hs
@@ -17,9 +17,9 @@
 --     continuous $ do
 --       bind xK_plus $ doc "increase volume" increaseVolume
 --       bind xK_minus $ doc "decrease volume" decreaseVolume
-
 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.Reader (Reader, ask, runReader)
@@ -55,11 +55,34 @@ instance Functor Documented where
 -- indicates what type of action a keytype can be bound to.
 type family Action t where
 -- KeySyms are bound to contextless actions with type X ()
-  Action KeySym = X ()
+  Action KeySymOrKeyCode = X ()
 -- Buttons are associated with actions with type Window -> X (). In other
 -- words, actions bound to a button have windows associated with it.
   Action Button = Window -> X ()
 
+class (Bind (Super k)) => LiftBinding k where
+  type Super k :: *
+  doLift :: k -> Super k
+
+instance LiftBinding KeySymOrKeyCode where
+  type Super KeySymOrKeyCode = KeySymOrKeyCode
+  doLift = id
+
+instance LiftBinding KeySym where
+  type Super KeySym = KeySymOrKeyCode
+  doLift = Ks
+
+instance LiftBinding KeyCode where
+  type Super KeyCode = KeySymOrKeyCode
+  doLift = Kc
+
+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
@@ -84,7 +107,7 @@ data Binding t
 -- | Compiled bindings map. This is the type built up by the Binder monad.
 data BindingsMap = BindingsMap
   { -- | Bindings for keys
-    key_bindings :: Map (KeyMask, KeySym) (Documented (Binding KeySym)),
+    key_bindings :: Map (KeyMask, KeySymOrKeyCode) (Documented (Binding KeySymOrKeyCode)),
     -- | Bindings for buttons.
     button_bindings :: Map (KeyMask, Button) (Documented (Binding Button)),
     -- | If no mapping for a key sym exists, this function is called to handle
@@ -108,7 +131,6 @@ instance Semigroup BindingsMap where
 instance Monoid BindingsMap where
   mempty = BindingsMap mempty mempty (\_ -> return ()) (\_ _ -> return ())
 
-
 -- | This type is an intermediate monad in the DSL. It binds an action to a key
 -- mask. This is all bound to a key or button in the Binder monad.
 newtype MaskBinder k a = MaskBinder
@@ -131,17 +153,18 @@ newtype Binder a = Binder (WriterT BindingsMap (Reader XConfigH) a)
 class BindingType a where
   -- | What key this action belongs to.
   type BoundTo a :: *
+
   -- | Convert the action into a Documented binding
   toBinding :: a -> Documented (Binding (BoundTo a))
 
--- | Bindings are trivially a BindingType. 
+-- | Bindings are trivially a BindingType.
 instance BindingType (Binding t) where
   type BoundTo (Binding t) = t
   toBinding = Documented ""
 
 -- | An X () can be bound to a Binding KeySym
 instance BindingType (X ()) where
-  type BoundTo (X ()) = KeySym
+  type BoundTo (X ()) = KeySymOrKeyCode
   toBinding = Documented "" . Action
 
 -- | A Window -> X () can be bound to a Binding Button.
@@ -166,7 +189,7 @@ instance Bind Button where
   rawMaskRaw mask act = tell (Map.singleton mask act)
 
 -- | For this, it adds the bindings to the keysMap
-instance Bind KeySym where
+instance Bind KeySymOrKeyCode where
   doBinding key mp = mempty {key_bindings = Map.mapKeys (,key) mp}
   rawMaskRaw mask act = tell (Map.singleton mask act)
 
@@ -196,12 +219,12 @@ altMod = withMod mod1Mask
 m1 -|- m2 = \act -> m1 act >> m2 act
 
 -- | Bind a key to a maksBinder.
-bind :: (Bind k) => k -> MaskBinder k () -> Binder ()
+bind :: (LiftBinding k) => k -> MaskBinder (Super k) () -> Binder ()
 bind k h =
-  tell . doBinding k . runReader (execWriterT $ unMaskBinder h) =<< ask
+  tell . doBinding (doLift k) . runReader (execWriterT $ unMaskBinder h) =<< ask
 
 -- | Bind multiple keys to the same mask binder.
-bindL :: (Bind k) => [k] -> MaskBinder k () -> Binder ()
+bindL :: (LiftBinding k) => [k] -> MaskBinder (Super k) () -> Binder ()
 bindL ks h = mapM_ (`bind` h) ks
 
 -- | Convenience function for Documented.
@@ -216,13 +239,23 @@ noWindow fn _ = fn
 resolveBindings ::
   BindingsMap ->
   ( XConfig l -> Map (KeyMask, KeySym) (X ()),
+    XConfig l -> Map (KeyMask, KeyCode) (X ()),
     XConfig l -> Map (ButtonMask, Button) (Window -> X ())
   )
-resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
+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
   )
   where
+    (keyBindings, keycodeBindings) =
+      partitionMap
+        ( \case
+            (m, Kc keyCode) -> Right (m, keyCode)
+            (m, Ks keySym) -> Left (m, keySym)
+        )
+        keyAndKeyCodeBindings
+
     pushB (_, b) fn binding win =
       if isRepeatOrSubmap binding
         then pushPendingBuffer ("b" ++ show b ++ " ") $ fn binding win
@@ -235,7 +268,7 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
           pushPendingBuffer (s ++ " ") $ fn binding
         else fn binding
 
-    bindingToX :: forall l. XConfig l -> Binding KeySym -> X ()
+    bindingToX :: forall l. XConfig l -> Binding KeySymOrKeyCode -> X ()
     bindingToX conf = \case
       NoBinding -> return ()
       Action a -> a
@@ -260,8 +293,8 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
                 bindingToWinX conf (undocument binding) win
                 after
               Nothing -> catb (m, b) win
-          (KeyPress m k s) -> do
-            case Map.lookup (m, k) kbind of
+          (KeyPress m k c s) -> do
+            case Map.lookup (m, Kc c) kbind <|> Map.lookup (m, Ks k) kbind of
               (Just binding) -> do
                 bindingToX conf (undocument binding)
                 after
@@ -276,7 +309,7 @@ resolveBindings (BindingsMap keyBindings buttonBindings _ _) =
       ev <- nextButtonOrKeyEvent
       let str = case ev of
             ButtonPress m b -> "b" ++ show b
-            KeyPress _ _ s -> s
+            KeyPress _ _ _ s -> s
       lift $
         pushAddPendingBuffer (str ++ " ") $
           fn ev
@@ -310,7 +343,7 @@ runBinder conf (Binder binder) = runReader (execWriterT binder) (XConfigH conf)
 
 withBindings :: Binder a -> XConfig l -> XConfig l
 withBindings b config =
-  let (keyBinds, buttonBinds) =
+  let (keyBinds, _, buttonBinds) =
         resolveBindings $ runBinder config b
    in config
         { keys = keyBinds,
@@ -351,7 +384,10 @@ documentation conf binder =
     tindent (lines -> (h : t)) = unlines (h : map ("  " ++) t)
     tindent x = x
 
-    keyToStr (m, k) = showMask m ++ keysymToString k
+    keyToStr (m, k) = showMask m ++ keysymOrKeyCodeToString k
+    keysymOrKeyCodeToString (Kc code) = show code
+    keysymOrKeyCodeToString (Ks sym) = keysymToString sym
+
     showMask mask =
       let masks =
             [ (shiftMask, "S"),
@@ -386,3 +422,14 @@ bindOtherKeys fn = Binder $ tell (mempty {no_match_catch_key = fn})
 
 bindOtherButtons :: ((KeyMask, Button) -> Window -> X ()) -> Binder ()
 bindOtherButtons fn = Binder $ tell (mempty {no_match_catch_button = fn})
+
+partitionMap :: (Ord k, Ord k1, Ord k2) => (k -> Either k1 k2) -> Map k a -> (Map k1 a, Map k2 a)
+partitionMap f mp =
+  foldl
+    ( \(mp1, mp2) (k, v) ->
+        case f k of
+          Left k1 -> (Map.insert k1 v mp1, mp2)
+          Right k2 -> (mp1, Map.insert k2 v mp2)
+    )
+    (mempty, mempty)
+    (Map.toList mp)
diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs
index 25162ba..fc75eb9 100644
--- a/src/Rahm/Desktop/RebindKeys.hs
+++ b/src/Rahm/Desktop/RebindKeys.hs
@@ -14,6 +14,7 @@ module Rahm.Desktop.RebindKeys
   )
 where
 
+import Control.Applicative ((<|>))
 import Control.Monad (forM, forM_)
 import Control.Monad.Trans.Class (lift)
 import Data.Default (def)
@@ -26,6 +27,7 @@ import qualified Data.Map as Map
     lookup,
   )
 import Data.Monoid (All (..))
+import Rahm.Desktop.Keys.Dsl2 (KeySymOrKeyCode (..))
 import XMonad
   ( Default (def),
     Display,
@@ -63,10 +65,10 @@ import qualified XMonad.Util.ExtensibleState as XS (get, modify)
 type WindowHook = Query ()
 
 newtype InterceptState
-  = InterceptState (Map (KeyMask, KeySym) (X ()))
+  = InterceptState (Map (KeyMask, KeySymOrKeyCode) (X ()))
 
 newtype RemapState
-  = RemapState (Map (Window, (KeyMask, KeySym)) (X ()))
+  = RemapState (Map (Window, (KeyMask, KeySymOrKeyCode)) (X ()))
 
 instance ExtensionClass InterceptState where
   initialValue = InterceptState def
@@ -84,7 +86,8 @@ remapHook event = do
         XConf {display = dpy, theRoot = rootw} <- ask
         keysym <- io $ keycodeToKeysym dpy code 0
 
-        case Map.lookup (win, (m, keysym)) map of
+        case Map.lookup (win, (m, Kc code)) map
+          <|> Map.lookup (win, (m, Ks keysym)) map of
           Just xdo -> do
             xdo
             return (All False)
@@ -106,19 +109,23 @@ getKeyCodesForKeysym dpy keysym = do
 
   return $ keysymToKeycodes keysym
 
-doGrab :: Display -> Window -> (KeyMask, KeySym) -> X ()
-doGrab dpy win (keyMask, keysym) = do
+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 <- io $ getKeyCodesForKeysym dpy keysym
+  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 key (return ())
+disableKey key = remapKey (fmap Ks key) (return ())
 
-remapKey :: (KeyMask, KeySym) -> X () -> WindowHook
+remapKey :: (KeyMask, KeySymOrKeyCode) -> X () -> WindowHook
 remapKey keyFrom action = do
   window <- ask
   Query $
@@ -156,4 +163,4 @@ sendKey (keymask, keysym) w = do
 
 rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook
 rebindKey keyFrom keyTo =
-  (remapKey keyFrom . sendKey keyTo) =<< ask
+  (remapKey (fmap Ks keyFrom) . sendKey keyTo) =<< ask
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index 246d85c..46508d7 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -68,7 +68,7 @@ import XMonad
     shiftMask,
     ungrabKeyboard,
     ungrabPointer,
-    (.|.),
+    (.|.), KeyCode,
   )
 import qualified XMonad.Util.ExtensibleState as XS
 import XMonad.Util.Loggers (logSp)
@@ -121,6 +121,7 @@ data ButtonOrKeyEvent
   | KeyPress
       { event_mask :: KeyMask,
         event_keysym :: KeySym,
+        event_keycode :: KeyCode,
         event_string :: String
       }
 
@@ -149,9 +150,9 @@ nextButtonOrKeyEvent = do
                           KeyEvent {ev_keycode = code, ev_state = m} -> do
                             keysym <- keycodeToKeysym d code 0
                             (_, str) <- lookupString (asKeyEvent p)
-                            return $ KeyPress m keysym str
+                            return $ KeyPress m keysym code str
                     case ret of
-                      Just (KeyPress m sym str) | isModifierKey sym -> tryAgain
+                      Just (KeyPress m sym _ str) | isModifierKey sym -> tryAgain
                       x -> return x
               )
         )