aboutsummaryrefslogtreecommitdiff
path: root/src/Rahm/Desktop
diff options
context:
space:
mode:
Diffstat (limited to 'src/Rahm/Desktop')
-rw-r--r--src/Rahm/Desktop/Keys.hs109
-rw-r--r--src/Rahm/Desktop/Keys/Dsl.hs10
-rw-r--r--src/Rahm/Desktop/Submap.hs4
3 files changed, 82 insertions, 41 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 4fdddac..49fe1fb 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -692,28 +692,51 @@ keymap = runKeys $ do
justMod $ spawnX "set-backlight.sh 0.01"
rawMask shiftMask $ spawnX "set-backlight.sh 0"
-mouseMap :: ButtonsMap l
+buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l
+buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config)
+ where
+ bindingToX :: (ButtonMask, Button) -> ButtonBinding -> (Window -> X ())
+ bindingToX click@(mask, btn) = \case
+ (ButtonAction action) -> action
+ (ButtonSubmap sm) ->
+ pushAddPendingBuffer (printf "b%d " btn)
+ . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm)
+ (ButtonContinuous sm) -> \window ->
+ pushAddPendingBuffer (printf "b%d " btn) $ do
+ mapM_ (flip (bindingToX click) window) (Map.lookup click sm)
+ fix $ \recur -> do
+ submapButtonsWithKey
+ ( \_ _ -> return ()
+ )
+ ( Map.mapWithKey
+ ( \k b w ->
+ pushAddPendingBuffer (printf "b%d " (snd k)) $
+ bindingToX k b w >> recur
+ )
+ sm
+ )
+ window
+
+mouseMap :: forall l. XConfig l -> ButtonBindings
mouseMap = runButtons $ do
config <- getConfig
- let x button = Map.lookup button (mouseMap config)
+ -- let x button = Map.lookup button (mouseMap config)
- let defaultButtons button =
- fromMaybe (\w -> return ()) $
- Map.lookup button (mouseMap config)
- subMouse = submapButtonsWithKey defaultButtons . flip runButtons config
+ -- let defaultButtons button =
+ -- fromMaybe (\w -> return ()) $
+ -- Map.lookup button (mouseMap config)
+ let subMouse = ButtonSubmap . flip runButtons config
- let continuous :: [(Button, X ())] -> Button -> Window -> X ()
- continuous actions button w = do
- case find ((== button) . fst) actions of
- Just (_, action) -> action
- Nothing -> return ()
+ continuous buttons = do
+ let bindingMap = runButtons buttons config
+ in forM_ (Map.toList bindingMap) $ \((m, b), _) -> do
+ bind b $
+ rawMask m $
+ ButtonContinuous bindingMap
- ( subMouse $
- forM_ (map fst actions) $ \b ->
- bind b $ noMod $ \w -> continuous actions b w
- )
- w
+ action :: X () -> (Window -> X ())
+ action = const
bind button1 $ do
justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster
@@ -754,17 +777,18 @@ mouseMap = runButtons $ do
noMod $ noWindow $ spawnX "pavucontrol"
let mediaButtons =
- [ (button4, increaseVolume),
- (button5, decreaseVolume),
- (button2, playPause),
- (button9, historyForward),
- (button8, historyBack),
- (button6, mediaPrev),
- (button7, mediaNext)
+ [ (button4, action increaseVolume),
+ (button5, action decreaseVolume),
+ (button2, action playPause),
+ (button9, action historyForward),
+ (button8, action historyBack),
+ (button6, action mediaPrev),
+ (button7, action mediaNext)
]
- forM_ (map fst mediaButtons) $ \b ->
- bind b $ noMod $ continuous mediaButtons b
+ continuous $
+ forM_ mediaButtons $ \(b, a) ->
+ bind b $ noMod a
bind button13 $
noMod $
@@ -774,12 +798,13 @@ mouseMap = runButtons $ do
bind button3 $ noMod mouseResizeWindow
let swapButtons =
- [ (button6, windows W.swapDown),
- (button7, windows W.swapUp)
+ [ (button6, action $ windows W.swapDown),
+ (button7, action $ windows W.swapUp)
]
- forM_ (map fst swapButtons) $ \b ->
- bind b $ noMod $ \w -> click >> continuous swapButtons b w
+ continuous $
+ forM_ swapButtons $ \(b, a) ->
+ bind b $ noMod a
bind button13 $
noMod $
@@ -805,17 +830,18 @@ mouseMap = runButtons $ do
noMod $ noWindow jumpToLastLocation
let workspaceButtons =
- [ (button2, swapMaster),
- (button9, viewAdjacent next),
- (button8, viewAdjacent prev),
- (button4, windows W.focusUp),
- (button5, windows W.focusDown),
- (button7, windows W.screenRotateForward),
- (button6, windows W.screenRotateBackward)
+ [ (button2, action swapMaster),
+ (button9, action $ viewAdjacent next),
+ (button8, action $ viewAdjacent prev),
+ (button4, action $ windows W.focusUp),
+ (button5, action $ windows W.focusDown),
+ (button7, action $ windows W.screenRotateForward),
+ (button6, action $ windows W.screenRotateBackward)
]
- forM_ (map fst workspaceButtons) $ \b ->
- bind b $ noMod $ continuous workspaceButtons b
+ continuous $
+ forM_ workspaceButtons $ \(b, a) ->
+ bind b $ noMod a
-- Bindings specific to a window. These are set similarly to th ekeymap above,
-- but uses a Query monad to tell which windows the keys will apply to.
@@ -943,7 +969,12 @@ windowBindings xconfig =
applyKeys :: XConfig l -> IO (XConfig l)
applyKeys config =
- return $ windowBindings $ config {keys = keyBindingToKeymap keymap, mouseBindings = mouseMap}
+ return $
+ windowBindings $
+ config
+ { keys = keyBindingToKeymap keymap,
+ mouseBindings = buttonBindingsToButtonMap mouseMap
+ }
click :: X ()
click = do
diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs
index adb2668..7f06a74 100644
--- a/src/Rahm/Desktop/Keys/Dsl.hs
+++ b/src/Rahm/Desktop/Keys/Dsl.hs
@@ -21,7 +21,12 @@ data KeyBinding
type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding)
-type ButtonBinding = Window -> X ()
+data ButtonBinding
+ = ButtonAction (Window -> X ())
+ | ButtonSubmap ButtonBindings
+ | ButtonContinuous ButtonBindings
+
+-- Window -> X ()
type ButtonBindings = Map (KeyMask, Button) ButtonBinding
@@ -52,6 +57,9 @@ class Binding k b where
rawMask :: KeyMask -> k -> BindingBuilder b ()
rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :))
+instance Binding (Window -> X ()) ButtonBinding where
+ toB = ButtonAction
+
instance Binding (X ()) (Documented KeyBinding) where
toB = Documented "" . Action
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index aabc35b..ca767e3 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -21,6 +21,8 @@ import qualified Data.Map as Map
import Data.Time.Clock.POSIX
import Data.Word (Word64)
import Rahm.Desktop.Common
+import Rahm.Desktop.XMobarLog.PendingBuffer
+import Text.Printf (printf)
import XMonad hiding (keys)
currentTimeMillis :: IO Int
@@ -154,7 +156,7 @@ submapButtonsWithKey ::
submapButtonsWithKey defaultAction actions window = do
maybe
(return ())
- ( \arg ->
+ ( \arg@(_, button) ->
case Map.lookup arg actions of
Nothing -> defaultAction arg window
Just fn -> fn window
generated by cgit (git 2.34.1) at 2026-02-22 17:41:52 +0000