From 8d077511f2d06a79e2dc638f46877a394c78d66e Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Fri, 2 Feb 2024 13:42:38 -0700 Subject: Add support for root-level keycode mappings. The code is a bit of a mess, and should probably be moved out of Dsl2 and into a dedicated place, but it works. I had to do a bit of a hack to get around XMonad's ungrabbing the keyboard after a Mapping event, which is not the best, but I don't have a better way of doing it. --- src/Rahm/Desktop/Keys/Dsl2.hs | 141 +++++++++++++++++++++++++++++++++++------- 1 file changed, 120 insertions(+), 21 deletions(-) (limited to 'src/Rahm/Desktop/Keys') 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 = -- cgit