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.

1 files changed, 64 insertions, 17 deletions

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)