aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop/Keys
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop/Keys')
-rw-r--r--src/Rahm/Desktop/Keys/Dsl2.hs141
1 files changed, 120 insertions, 21 deletions
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 =
generated by cgit (git 2.34.1) at 2026-02-22 22:22:14 +0000