aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Rahm/Desktop/Keys.hs142
-rw-r--r--src/Rahm/Desktop/Keys/Dsl2.hs141
-rw-r--r--src/Rahm/Desktop/RebindKeys.hs32
3 files changed, 201 insertions, 114 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 3368a4f..8c78571 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -219,6 +219,9 @@ kcK = 45
kcL :: KeyCode
kcL = 46
+kcSpace :: KeyCode
+kcSpace = 65
+
button6 :: Button
button6 = 6
@@ -658,68 +661,73 @@ bindings = do
sendMessage rotateLayout
bind xK_s $ do
- forM_ [(JustShift, justMod), (ShiftAndSwap, shiftMod), (ShiftAndFollow, controlMod)] $ \(shiftType, f) ->
- f $
- doc
- ( case shiftType of
- ShiftAndFollow ->
- "Shift-and-follow: Like shift-and-swap with the implicit \
- \third parameter being the current workspace (.)"
- ShiftAndSwap ->
- "Shift-and-swap: Shift a windowset to a workspace then swap \
- \that workspace with another. Primary use case is to move a \
- \that workspace to a different screen than the current screen. \
- \Note that this command will only work with normal workspaces."
- JustShift -> "Shift a windowset to a workspace"
- )
- $ pushPendingBuffer
+ forM_
+ [ (JustShift, justMod),
+ (ShiftAndSwap, shiftMod),
+ (ShiftAndFollow, controlMod)
+ ]
+ $ \(shiftType, f) ->
+ f $
+ doc
( case shiftType of
- ShiftAndSwap -> "S "
- JustShift -> "s "
- ShiftAndFollow -> "^s "
+ ShiftAndFollow ->
+ "Shift-and-follow: Like shift-and-swap with the implicit \
+ \third parameter being the current workspace (.)"
+ ShiftAndSwap ->
+ "Shift-and-swap: Shift a windowset to a workspace then swap \
+ \that workspace with another. Primary use case is to move a \
+ \that workspace to a different screen than the current screen. \
+ \Note that this command will only work with normal workspaces."
+ JustShift -> "Shift a windowset to a workspace"
)
- $ runMaybeT_ $
- do
- stackset <- lift $ X.windowset <$> X.get
- selection <- mapMaybe locationWindow <$> readNextLocationSet
- withBorderColorM selectedWindowsColor selection $ do
- lift $ addStringToPendingBuffer " "
- ws <- readNextWorkspace
- finalSwap <-
- case shiftType of
- ShiftAndSwap -> do
- lift $ addStringToPendingBuffer " "
- wsName <- MaybeT . return $ workspaceName ws
- W.switchWorkspaces wsName <$> readNextWorkspaceName
- _ -> return id
-
- lift $ do
- (Endo allMovements) <-
- mconcat
- <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
-
- setAlternateWindows selection
-
- forM_ selection $ \win -> do
- mapM_
- ( \t -> do
- logs Debug "Set alternate workspace %s -> %s" (show win) t
- setAlternateWorkspace win t
- )
- (W.findTag win stackset)
-
- withWindowsUnpinned selection $
- windows $
- finalSwap
- . ( \ss ->
- case shiftType of
- ShiftAndFollow
- | (w : _) <- selection,
- Just ws <- W.findTag w ss ->
- W.greedyView ws ss
- _ -> ss
- )
- . allMovements
+ $ pushPendingBuffer
+ ( case shiftType of
+ ShiftAndSwap -> "S "
+ JustShift -> "s "
+ ShiftAndFollow -> "^s "
+ )
+ $ runMaybeT_ $
+ do
+ stackset <- lift $ X.windowset <$> X.get
+ selection <- mapMaybe locationWindow <$> readNextLocationSet
+ withBorderColorM selectedWindowsColor selection $ do
+ lift $ addStringToPendingBuffer " "
+ ws <- readNextWorkspace
+ finalSwap <-
+ case shiftType of
+ ShiftAndSwap -> do
+ lift $ addStringToPendingBuffer " "
+ wsName <- MaybeT . return $ workspaceName ws
+ W.switchWorkspaces wsName <$> readNextWorkspaceName
+ _ -> return id
+
+ lift $ do
+ (Endo allMovements) <-
+ mconcat
+ <$> mapM (fmap Endo . moveWindowToWorkspaceFn ws) selection
+
+ setAlternateWindows selection
+
+ forM_ selection $ \win -> do
+ mapM_
+ ( \t -> do
+ logs Debug "Set alternate workspace %s -> %s" (show win) t
+ setAlternateWorkspace win t
+ )
+ (W.findTag win stackset)
+
+ withWindowsUnpinned selection $
+ windows $
+ finalSwap
+ . ( \ss ->
+ case shiftType of
+ ShiftAndFollow
+ | (w : _) <- selection,
+ Just ws <- W.findTag w ss ->
+ W.greedyView ws ss
+ _ -> ss
+ )
+ . allMovements
altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
@@ -830,6 +838,10 @@ bindings = do
bind xK_bracketleft $ noMod spaceResize
bind xK_bracketright $ noMod spaceResize
+ bind kcSpace $ do
+ rawMask mod3Mask
+ playPauseDoc
+
bind xK_t $ do
justMod $
doc "Spawn a terminal." $
@@ -845,6 +857,12 @@ bindings = do
doc "Spawn a floating terminal" $
spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config)
+ bind xK_i $ do
+ justMod $ do
+ XConf {display = dpy, theRoot = rootw} <- ask
+ io $ grabKey dpy 65 32 rootw True grabModeAsync grabModeAsync
+ (return () :: X ())
+
bind xK_z $ do
justMod $
doc "Less often used keybindings." $
@@ -1218,7 +1236,7 @@ bindings = do
in windows f >> escape
-- where
---
+--
-- permuteMods = map (foldl' (.|.) 0) . filterM (const [True, False])
myMouseMoveWindow =
@@ -1255,7 +1273,7 @@ windowSpecificBindings config = do
let altMask = mod1Mask
let mods = permuteMods [shiftMask, controlMask, 0]
let configureIf b k =
- let (keymap, keycodemap, _) = resolveBindings (runBinder config k)
+ let (Bindings keymap keycodemap _) = resolveBindings (runBinder config k)
in tell =<< lift (b --> return (keymap config, keycodemap config))
emitKey = flip sendKey w
mod3 = rawMask mod3Mask
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 =
diff --git a/src/Rahm/Desktop/RebindKeys.hs b/src/Rahm/Desktop/RebindKeys.hs
index fc75eb9..8712b31 100644
--- a/src/Rahm/Desktop/RebindKeys.hs
+++ b/src/Rahm/Desktop/RebindKeys.hs
@@ -3,8 +3,6 @@
-- it makes window-specific key bindings awesome!
module Rahm.Desktop.RebindKeys
( remapHook,
- getKeyCodesForKeysym,
- doGrab,
disableKey,
remapKey,
sendKeyQ,
@@ -27,7 +25,7 @@ import qualified Data.Map as Map
lookup,
)
import Data.Monoid (All (..))
-import Rahm.Desktop.Keys.Dsl2 (KeySymOrKeyCode (..))
+import Rahm.Desktop.Keys.Dsl2 (KeySymOrKeyCode (..), doGrab, getKeyCodesForKeysym)
import XMonad
( Default (def),
Display,
@@ -94,34 +92,6 @@ remapHook event = do
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, 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
-
disableKey :: (KeyMask, KeySym) -> WindowHook
disableKey key = remapKey (fmap Ks key) (return ())
generated by cgit (git 2.34.1) at 2026-02-22 20:07:56 +0000