From cf51fa2e89b92754fda0664e57ba647491eac610 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Wed, 31 Jan 2024 12:11:44 -0700 Subject: 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. --- src/Rahm/Desktop/Keys.hs | 56 ++++++++++++++++++++++++----- src/Rahm/Desktop/Keys/Dsl2.hs | 81 +++++++++++++++++++++++++++++++++--------- src/Rahm/Desktop/RebindKeys.hs | 25 ++++++++----- src/Rahm/Desktop/Submap.hs | 7 ++-- 4 files changed, 131 insertions(+), 38 deletions(-) (limited to 'src') 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 ) ) -- cgit