aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm')
-rw-r--r--src/Rahm/Desktop/Keys.hs56
-rw-r--r--src/Rahm/Desktop/Keys/Dsl2.hs81
-rw-r--r--src/Rahm/Desktop/RebindKeys.hs25
-rw-r--r--src/Rahm/Desktop/Submap.hs7
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
)
)
generated by cgit (git 2.34.1) at 2026-02-22 09:29:05 +0000