diff options
Diffstat (limited to 'src/Internal')
| -rw-r--r-- | src/Internal/Intercept.hs | 157 | ||||
| -rw-r--r-- | src/Internal/Keys.hs | 12 |
2 files changed, 168 insertions, 1 deletions
diff --git a/src/Internal/Intercept.hs b/src/Internal/Intercept.hs new file mode 100644 index 0000000..987733b --- /dev/null +++ b/src/Internal/Intercept.hs @@ -0,0 +1,157 @@ +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 + (minCode, maxCode) = displayKeycodes dpy + allCodes = [fromIntegral minCode .. fromIntegral maxCode] + + -- build a map from keysyms to lists of keysyms (doing what + -- XGetKeyboardMapping would do if the X11 package bound it) + syms <- forM allCodes $ \code -> io (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 + + forM_ (keysymToKeycodes keysym) $ \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 1118788..c40c346 100644 --- a/src/Internal/Keys.hs +++ b/src/Internal/Keys.hs @@ -1,6 +1,7 @@ {-# 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; @@ -246,6 +247,12 @@ keymap = runKeys $ do then mediaPrev else mediaNext + bind xK_t $ + + (justMod -|- noMod) $ + setIntercept (modMask config, xK_i) $ + logs $ "Intercepted!" + bind xK_r $ do justMod runDMenu shiftMod $ sendMessage DoRotate @@ -470,4 +477,7 @@ click = do modifyWindowBorder :: Integer -> SpacingModifier modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> - Border (a + i) (b + i) (c + i) (d + i) + Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) + + where clip i | i < 0 = 0 + clip i | otherwise = i |