From 3a87706dc6193636c8b5c5b37d1ca2d057a22f00 Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Mon, 28 Mar 2022 10:51:02 -0600 Subject: Move Intercept to RebindKeys. Remove the intercept subsystem as it was experimental and I do not have a real use for it anymore. --- src/Internal/Intercept.hs | 152 ------------------------------------------- src/Internal/Keys.hs | 8 +-- src/Internal/Logger.hs | 14 ++-- src/Internal/RebindKeys.hs | 114 ++++++++++++++++++++++++++++++++ src/Internal/ScreenRotate.hs | 8 +-- src/Main.hs | 4 +- 6 files changed, 126 insertions(+), 174 deletions(-) delete mode 100644 src/Internal/Intercept.hs create mode 100644 src/Internal/RebindKeys.hs diff --git a/src/Internal/Intercept.hs b/src/Internal/Intercept.hs deleted file mode 100644 index c99ce09..0000000 --- a/src/Internal/Intercept.hs +++ /dev/null @@ -1,152 +0,0 @@ - --- Module for intercepting key presses not explicity mapped in the key bindings. --- This uses some deep magic with grabKey and windows and everything else, but --- it makes window-specific key bindings awesome! -module Internal.Intercept where - -import XMonad - -import Text.Printf -import Data.Monoid (Endo(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad (forM, forM_) -import Data.Default (Default, def) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified XMonad.Util.ExtensibleState as XS -import Data.Monoid (All(..)) - -import Internal.Logger - -type WindowHook = Query () - -newtype NoPersist a = NoPersist a - deriving (Typeable) - -instance Show (NoPersist a) where - show (NoPersist _) = show () - -instance (Default a) => Read (NoPersist a) where - readsPrec i s = map (\(_, s) -> (NoPersist def, s)) (readsPrec i s :: [((), String)]) - -instance (Default a) => Default (NoPersist a) where - def = NoPersist def - -instance (Default a, Typeable a) => ExtensionClass (NoPersist a) where - initialValue = NoPersist def - - -data InterceptState = InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) - -data RemapState = RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) - -instance ExtensionClass InterceptState where - initialValue = InterceptState def - -instance ExtensionClass RemapState where - initialValue = RemapState def - -remapHook :: Event -> X All -remapHook event = do - RemapState (NoPersist map) <- XS.get - - case event of - KeyEvent { ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m } - | typ == keyPress-> do - XConf {display = dpy, theRoot = rootw} <- ask - keysym <- io $ keycodeToKeysym dpy code 0 - - case Map.lookup (win, (m, keysym)) map of - - Just xdo -> do - xdo - return (All False) - - Nothing -> return (All True) - - _ -> return (All True) - -interceptHook :: Event -> X All -interceptHook event = do - InterceptState (NoPersist map) <- XS.get - case event of - KeyEvent { ev_event_type = typ, ev_keycode = code, ev_state = m } - | typ == keyPress-> do - XConf {display = dpy, theRoot = rootw} <- ask - keysym <- io $ keycodeToKeysym dpy code 0 - - case Map.lookup (m, keysym) map of - - Just xdo -> do - xdo - mapM_ (\m' -> io $ ungrabKey dpy code (m .|. m') rootw) - =<< extraModifiers - return (All False) - - Nothing -> return (All True) - - _ -> return (All True) - -setIntercept :: (KeyMask, KeySym) -> X () -> X () -setIntercept (keyMask, keysym) action = do - XS.modify $ \(InterceptState (NoPersist m)) -> InterceptState $ NoPersist $ - Map.insert (keyMask, keysym) action m - XConf { display = dpy, theRoot = rootw } <- ask - - doGrab dpy rootw (keyMask, keysym) - - -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, KeySym) -> X () -doGrab dpy win (keyMask, keysym) = do - let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync - - codes <- io $ getKeyCodesForKeysym dpy keysym - - forM_ codes $ \kc -> - mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers - -disableKey :: (KeyMask, KeySym) -> WindowHook -disableKey key = remapKey key (return ()) - -remapKey :: (KeyMask, KeySym) -> X () -> WindowHook -remapKey keyFrom action = do - window <- ask - Query $ lift $ do - XConf { display = disp, theRoot = rootw } <- ask - doGrab disp window keyFrom - - XS.modify $ \(RemapState (NoPersist keyMap)) -> RemapState $ NoPersist $ - Map.insert (window, keyFrom) action keyMap - -rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook -rebindKey keyFrom keyTo = do - window <- ask - remapKey keyFrom $ do - XConf { display = disp, theRoot = rootw } <- ask - codes <- io $ getKeyCodesForKeysym disp (snd keyTo) - case codes of - (keyCode:_) -> do - io $ allocaXEvent $ \xEv -> do - setEventType xEv keyPress - setKeyEvent xEv window rootw none (fst keyTo) keyCode True - sendEvent disp window True keyPressMask xEv - setEventType xEv keyRelease - sendEvent disp window True keyPressMask xEv - - _ -> return () diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs index aeb3602..9a45f7e 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes #-} module Internal.Keys (applyKeys) where -import Internal.Intercept (setIntercept) import Control.Monad.Loops (iterateWhile) import Control.Monad.Fix (fix) import Graphics.X11.ExtraTypes.XF86; @@ -46,6 +45,7 @@ import Internal.Lib import Internal.DMenu import Internal.PassMenu import Internal.Logger +import Internal.RebindKeys import Internal.ScreenRotate (screenRotateForward, screenRotateBackward) type KeyMap l = XConfig l -> Map (KeyMask, KeySym) (X ()) @@ -246,12 +246,6 @@ keymap = runKeys $ do if (x' - x) < 0 then mediaPrev else mediaNext - - bind xK_t $ - - (justMod -|- noMod) $ - setIntercept (modMask config, xK_i) $ - logs $ "Intercepted!" bind xK_r $ do justMod runDMenu diff --git a/src/Internal/Logger.hs b/src/Internal/Logger.hs index f1960fb..cc52c7e 100644 --- a/src/Internal/Logger.hs +++ b/src/Internal/Logger.hs @@ -4,17 +4,13 @@ import XMonad import qualified XMonad.Util.ExtensibleState as XS import System.IO +import Internal.NoPersist + data LoggerState = LoggerState { - logHandle :: Maybe Handle + logHandle :: Maybe (NoPersist Handle) } -instance Read LoggerState where - readsPrec i s = map (\(_, s) -> (LoggerState Nothing, s)) (readsPrec i s :: [((), String)]) - -instance Show LoggerState where - show _ = show () - instance ExtensionClass LoggerState where initialValue = LoggerState Nothing @@ -26,10 +22,10 @@ logs s = do case handle' of Nothing -> do handle <- io $ openFile "/tmp/xmonad.log" AppendMode - XS.put $ LoggerState (Just handle) + XS.put $ LoggerState $ Just $ NoPersist handle return handle - Just h -> return h + Just (NoPersist h) -> return h io $ do hPutStrLn handle s diff --git a/src/Internal/RebindKeys.hs b/src/Internal/RebindKeys.hs new file mode 100644 index 0000000..22b0165 --- /dev/null +++ b/src/Internal/RebindKeys.hs @@ -0,0 +1,114 @@ + +-- Module for intercepting key presses not explicity mapped in the key bindings. +-- This uses some deep magic with grabKey and windows and everything else, but +-- it makes window-specific key bindings awesome! +module Internal.RebindKeys where + +import XMonad + +import Text.Printf +import Data.Monoid (Endo(..)) +import Control.Monad.Trans.Class (lift) +import Control.Monad (forM, forM_) +import Data.Default (Default, def) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified XMonad.Util.ExtensibleState as XS +import Data.Monoid (All(..)) + +import Internal.Logger +import Internal.NoPersist + +type WindowHook = Query () + +data InterceptState = + InterceptState (NoPersist (Map (KeyMask, KeySym) (X ()))) + +data RemapState = + RemapState (NoPersist (Map (Window, (KeyMask, KeySym)) (X ()))) + +instance ExtensionClass InterceptState where + initialValue = InterceptState def + +instance ExtensionClass RemapState where + initialValue = RemapState def + +remapHook :: Event -> X All +remapHook event = do + RemapState (NoPersist map) <- XS.get + + case event of + KeyEvent { ev_window = win, ev_event_type = typ, ev_keycode = code, ev_state = m } + | typ == keyPress-> do + XConf {display = dpy, theRoot = rootw} <- ask + keysym <- io $ keycodeToKeysym dpy code 0 + + case Map.lookup (win, (m, keysym)) map of + + Just xdo -> do + xdo + return (All False) + + Nothing -> return (All True) + + _ -> return (All True) + +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, KeySym) -> X () +doGrab dpy win (keyMask, keysym) = do + let grab kc m = io $ grabKey dpy kc m win True grabModeAsync grabModeAsync + + codes <- io $ getKeyCodesForKeysym dpy keysym + + forM_ codes $ \kc -> + mapM_ (grab kc . (keyMask .|.)) =<< extraModifiers + +disableKey :: (KeyMask, KeySym) -> WindowHook +disableKey key = remapKey key (return ()) + +remapKey :: (KeyMask, KeySym) -> X () -> WindowHook +remapKey keyFrom action = do + window <- ask + Query $ lift $ do + XConf { display = disp, theRoot = rootw } <- ask + doGrab disp window keyFrom + + XS.modify $ \(RemapState (NoPersist keyMap)) -> RemapState $ NoPersist $ + Map.insert (window, keyFrom) action keyMap + +sendKey :: (KeyMask, KeySym) -> Window -> X () +sendKey (keymask, keysym) w = do + XConf { display = disp, theRoot = rootw } <- ask + + codes <- io $ getKeyCodesForKeysym disp keysym + + case codes of + (keycode:_) -> + io $ allocaXEvent $ \xEv -> do + setEventType xEv keyPress + setKeyEvent xEv w rootw none keymask keycode True + sendEvent disp w True keyPressMask xEv + + setEventType xEv keyRelease + sendEvent disp w True keyReleaseMask xEv + + _ -> return () + +rebindKey :: (KeyMask, KeySym) -> (KeyMask, KeySym) -> WindowHook +rebindKey keyFrom keyTo = + (remapKey keyFrom . sendKey keyTo) =<< ask diff --git a/src/Internal/ScreenRotate.hs b/src/Internal/ScreenRotate.hs index ff6417c..8108381 100644 --- a/src/Internal/ScreenRotate.hs +++ b/src/Internal/ScreenRotate.hs @@ -2,15 +2,15 @@ module Internal.ScreenRotate where import XMonad.StackSet as W -screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd -screenRotateForward (W.StackSet current visible others floating) = do +screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateBackward (W.StackSet current visible others floating) = do let screens = current : visible workspaces = tail $ cycle $ map W.workspace screens (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces in W.StackSet current' visible' others floating -screenRotateBackward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd -screenRotateBackward (W.StackSet current visible others floating) = do +screenRotateForward :: W.StackSet i l a sid sd -> W.StackSet i l a sid sd +screenRotateForward (W.StackSet current visible others floating) = do let screens = current : visible workspaces = rcycle $ map W.workspace screens (current':visible') = zipWith (\s w -> s {workspace = w} ) screens workspaces diff --git a/src/Main.hs b/src/Main.hs index 379131c..b17f62a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,7 +16,7 @@ import Internal.Keys import Internal.Layout import Internal.Logger import Internal.DMenu (menuCommandString) -import Internal.Intercept +import Internal.RebindKeys import XMonad.Actions.WithAll (withAll) import qualified XMonad as X @@ -70,7 +70,7 @@ main = do ] , workspaces = map return (['0'..'9'] ++ ['a'..'z']) , handleEventHook = - composeAll [fullscreenEventHook, interceptHook, remapHook] + composeAll [fullscreenEventHook, remapHook] , focusFollowsMouse = False , clickJustFocuses = False , logHook = xMobarLogHook xmobar -- cgit