diff options
Diffstat (limited to 'src/Rahm/Desktop/Keys.hs')
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 354 |
1 files changed, 123 insertions, 231 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 2cc3d79..412d8f5 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -60,29 +60,7 @@ import Rahm.Desktop.History historyForward, jumpToLastLocation, ) -import Rahm.Desktop.Keys.Dsl - ( ButtonBinding (..), - ButtonBindings, - Documented (..), - KeyBinding (..), - KeyBindings, - altMask, - altMod, - altgrMod, - bind, - buttonDocumentation, - controlMod, - doc, - documentation, - getConfig, - justMod, - noMod, - rawMask, - runButtons, - runKeys, - shiftMod, - (-|-), - ) +import Rahm.Desktop.Keys.Dsl2 import Rahm.Desktop.Keys.Wml ( addWindowToSelection, clearWindowSelection, @@ -186,9 +164,6 @@ spawnX = spawn safeSpawnX :: String -> [String] -> X () safeSpawnX = safeSpawn -noWindow :: b -> Window -> b -noWindow = const - selectedWindowsColor = BorderColor "#00ffff" "#00ffff" decreaseVolume = spawnX "pactl set-sink-volume @DEFAULT_SINK@ -5%" @@ -249,34 +224,6 @@ button14 = 14 button15 :: Button button15 = 15 -keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l -keyBindingToKeymap bindings config = Map.mapWithKey bindingToX (bindings config) - where - bindingToX :: (KeyMask, KeySym) -> Documented KeyBinding -> X () - bindingToX key b = - case b of - Documented _ (Action x) -> x - Documented _ (Submap mapping) -> - -- This is a submap, add it to the pending buffer. - -- - -- This could potentially use the current event in the XState and - -- lookupString to potentially recover the real string typed, but - -- for now, this will do. - pushAddPendingBuffer (keysymToString $ snd key) $ do - submap (Map.mapWithKey bindingToX mapping) - Documented _ (Repeat mapping) -> do - pushAddPendingBuffer (keysymToString $ snd key) $ do - mapM_ (bindingToX key) (Map.lookup key mapping) - fix $ \recur -> do - submap - ( Map.mapWithKey - ( \k b -> do - pushAddPendingBuffer (keysymToString $ snd k) $ - bindingToX k b >> recur - ) - mapping - ) - mapWindows :: (Ord b) => (a -> b) -> W.StackSet i l a s sd -> W.StackSet i l b s sd mapWindows fn (W.StackSet cur vis hidden float) = W.StackSet @@ -290,13 +237,8 @@ mapWindows fn (W.StackSet cur vis hidden float) = data ShiftType = JustShift | ShiftAndFollow | ShiftAndSwap -keymap :: XConfig l -> KeyBindings -keymap = runKeys $ do - config <- getConfig - - let subkeys keysM = Submap (runKeys keysM config) - repeatable keysM = Repeat (runKeys keysM config) - +bindings :: Binder () +bindings = do bind xK_apostrophe $ do justMod $ doc "Jump to a window/tile currently dragging window" $ do @@ -364,33 +306,33 @@ keymap = runKeys $ do doc "Move XMobar to another screen." $ spawnX "pkill -SIGUSR1 xmobar" - bind xK_F1 $ do - justMod $ - doc - "Print this documentation" - ( safeSpawn - "gxmessage" - [ "-fn", - "Source Code Pro", - "Key Bindings\n\n" - ++ documentation (keymap config) - ++ "\n\nButton Bindings\n\n" - ++ buttonDocumentation (mouseMap config) - ] :: - X () - ) - - bind xK_F7 $ do - justMod $ - doc - "Print this documentation to stdout (at LogLevel Info)" - ( logs - Info - "KeyBindings\n\n%s\n\nButtonBindings\n\n%s" - (documentation (keymap config)) - (buttonDocumentation (mouseMap config)) :: - X () - ) + -- bind xK_F1 $ do + -- justMod $ + -- doc + -- "Print this documentation" + -- ( safeSpawn + -- "gxmessage" + -- [ "-fn", + -- "Source Code Pro", + -- "Key Bindings\n\n" + -- ++ documentation (keymap config) + -- ++ "\n\nButton Bindings\n\n" + -- ++ buttonDocumentation (mouseMap config) + -- ] :: + -- X () + -- ) + + -- bind xK_F7 $ do + -- justMod $ + -- doc + -- "Print this documentation to stdout (at LogLevel Info)" + -- ( logs + -- Info + -- "KeyBindings\n\n%s\n\nButtonBindings\n\n%s" + -- (documentation (keymap config)) + -- (buttonDocumentation (mouseMap config)) :: + -- X () + -- ) bind xK_F10 $ do justMod playPauseDoc @@ -423,9 +365,6 @@ keymap = runKeys $ do doc ("Move the current window to screen " ++ show idx) $ withScreen W.shift idx - altgrMod - (logs Info "Test altgr" :: X ()) - bind xK_bracketright $ do justMod $ doc "Increase the gaps between windows." $ @@ -500,7 +439,7 @@ keymap = runKeys $ do bind xK_d $ justMod $ doc "Record (define) macros." $ - subkeys $ do + subbind $ do bind xK_w $ noMod $ doc @@ -746,7 +685,7 @@ keymap = runKeys $ do bind xK_space $ do justMod $ doc "Layout-related bindings" $ - subkeys $ do + subbind $ do bind xK_n $ (noMod -|- justMod) $ doc "Use the next layout in the layout list." $ do @@ -833,7 +772,7 @@ keymap = runKeys $ do bind xK_t $ do justMod $ doc "Spawn a terminal." $ - spawnX (terminal config) + spawnX =<< asks (terminal . config) shiftMod $ doc "Sink the current window into the tiling." $ @@ -843,26 +782,7 @@ keymap = runKeys $ do altMod $ doc "Spawn a floating terminal" $ - spawnX (terminal config ++ " -t Floating\\ Term") - - bind xK_v - $ - -- Allows repeated strokes of M-h and M-l to reduce and increase volume - -- respectively. - justMod - $ doc - "Allows repeated strokes of M-h and M-l to decrease and\n\ - \increase volume respectively" - $ repeatable - $ do - bind xK_h $ - justMod decreaseVolumeDoc - - bind xK_l $ - justMod increaseVolumeDoc - - bind xK_v $ - justMod (return () :: X ()) + spawnX =<< asks ((++ " -t Floating\\ Term") . terminal . config) bind xK_x $ do justMod $ @@ -872,7 +792,7 @@ keymap = runKeys $ do bind xK_z $ do justMod $ doc "Less often used keybindings." $ - subkeys $ do + subbind $ do bind xK_e $ do (justMod -|- noMod) $ doc "Select an emoji" $ @@ -955,7 +875,9 @@ keymap = runKeys $ do logs next "LogLevel set to %s." (show next) bind xF86XK_Calculator $ do - noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3" + noMod $ + spawnX + =<< asks ((++ " -t Floating\\ Term -e /usr/bin/env python3") . terminal . config) bind xF86XK_AudioLowerVolume $ do noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%" @@ -990,63 +912,6 @@ keymap = runKeys $ do noMod $ spawnX "set-backlight.sh -0.05" justMod $ spawnX "set-backlight.sh 0.01" rawMask shiftMask $ spawnX "set-backlight.sh 0" - -buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l -buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config) - where - bindingToX :: (ButtonMask, Button) -> Documented ButtonBinding -> (Window -> X ()) - bindingToX click@(mask, btn) = \case - Documented _ (ButtonAction action) -> action - Documented _ (ButtonSubmap sm) -> - pushAddPendingBuffer (printf "b%d " btn) - . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm) - Documented _ (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 - -myMouseMoveWindow = - D.mouseMoveWindowAndThen X.focus $ - mconcat - [ D.ifReleased button3 D.sinkOnRelease, - D.ifReleased' button2 $ \w _ -> X.killWindow w - ] - -myMouseResizeAction = - D.mouseResizeWindowAndThen X.focus $ - mconcat - [ D.ifReleased button1 D.sinkOnRelease - ] - -mouseMap :: forall l. XConfig l -> ButtonBindings -mouseMap = runButtons $ do - config <- getConfig - - -- let x button = Map.lookup button (mouseMap config) - - -- let defaultButtons button = - -- fromMaybe (\w -> return ()) $ - -- Map.lookup button (mouseMap config) - let subMouse = ButtonSubmap . flip runButtons config - - continuous buttons = do - let bindingMap = runButtons buttons config - in forM_ (Map.toList bindingMap) $ \((m, b), _) -> do - bind b $ - rawMask m $ - ButtonContinuous bindingMap - bind button1 $ do justMod $ doc @@ -1087,50 +952,63 @@ mouseMap = runButtons $ do doc "Media next" $ noWindow mediaNext - bind button14 $ do - noMod $ - doc "Additional Mouse Bindings" $ - subMouse $ do - bind button3 $ - noMod $ - doc "Drag a workspace to a different screen" $ - noWindow D.dragWorkspace + let button14Binder = do + bind button3 $ + noMod $ + doc "Drag a workspace to a different screen" $ + noWindow D.dragWorkspace + + bind button1 $ + noMod $ + doc "Swap a window with another window by dragging." $ + noWindow D.dragWindow + + bind button14 $ do + noMod $ + doc "Pop the window under the cursor" $ + noWindow $ + click >> sendMessage togglePop + + bind button15 $ do + noMod $ + doc "Spawn 'pavucontrol'" $ + noWindow $ + spawnX "pavucontrol" + + let mediaButtons = + [ (button4, "Increase volume", noWindow increaseVolume), + (button5, "Decrease volume", noWindow decreaseVolume), + (button2, "Play/Pause", noWindow playPause), + (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)), + (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)), + (button6, "Media Previous", noWindow mediaPrev), + (button7, "Media Next", noWindow mediaNext) + ] + + continuous $ do + forM_ mediaButtons $ \(b, d, a) -> + bind b $ noMod $ doc d a - bind button1 $ - noMod $ - doc "Swap a window with another window by dragging." $ - noWindow D.dragWindow + bind xK_h $ + justMod decreaseVolumeDoc - bind button14 $ do - noMod $ - doc "Pop the window under the cursor" $ - noWindow $ - click >> sendMessage togglePop + bind xK_l $ + justMod increaseVolumeDoc - bind button15 $ do - noMod $ - doc "Spawn 'pavucontrol'" $ - noWindow $ - spawnX "pavucontrol" - - let mediaButtons = - [ (button4, "Increase volume", noWindow increaseVolume), - (button5, "Decrease volume", noWindow decreaseVolume), - (button2, "Play/Pause", noWindow playPause), - (button9, "History Forward", noWindow (viewAdjacentTo pointerWorkspace next)), - (button8, "History Back", noWindow (viewAdjacentTo pointerWorkspace prev)), - (button6, "Media Previous", noWindow mediaPrev), - (button7, "Media Next", noWindow mediaNext) - ] + bind button14 $ do + noMod $ + doc "Additional Mouse Bindings" $ + subbind button14Binder - continuous $ - forM_ mediaButtons $ \(b, d, a) -> - bind b $ noMod $ doc d a + bind xK_v $ do + justMod $ + doc "Same as button14" $ + subbind button14Binder bind button13 $ noMod $ doc "General Window Management Extra Mouse Bindings" $ - subMouse $ do + subbind $ do bind button1 $ noMod $ doc @@ -1164,10 +1042,10 @@ mouseMap = runButtons $ do bind button13 $ noMod $ - subMouse $ do + subbind $ do bind button13 $ noMod $ - subMouse $ do + subbind $ do bind button13 $ noMod $ doc "Lock the screen" $ @@ -1182,7 +1060,7 @@ mouseMap = runButtons $ do bind button15 $ do noMod $ doc "General navigation extra mouse bindings" $ - subMouse $ do + subbind $ do bind button13 $ noMod $ doc "Goto the accompaning workspace to the current one." $ @@ -1220,7 +1098,7 @@ mouseMap = runButtons $ do bind button14 $ noMod $ - subMouse $ do + subbind $ do bind button1 $ noMod $ doc "Pin the selected windows" $ @@ -1273,19 +1151,42 @@ mouseMap = runButtons $ do ) in windows f >> escape --- 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. --- --- This is useful to create hotkeys in applications where hot keys are not --- configurable, or to remove keybindings that are irritating (looking at you, --- ctrl+w in Chrome!!). +myMouseMoveWindow = + D.mouseMoveWindowAndThen X.focus $ + mconcat + [ D.ifReleased button3 D.sinkOnRelease, + D.ifReleased' button2 $ \w _ -> X.killWindow w + ] + +myMouseResizeAction = + D.mouseResizeWindowAndThen X.focus $ + mconcat + [ D.ifReleased button1 D.sinkOnRelease + ] + +applyKeys :: XConfig l -> IO (XConfig l) +applyKeys c = + let conf' = withBindings bindings c + in return $ + windowBindings $ + conf' + { keys = + Map.insert + (modMask c .|. shiftMask, xK_q) + (spawnX "xmonad --recompile && xmonad --restart") + . keys conf' + } + windowSpecificBindings :: XConfig l -> WriterT (Map (KeyMask, KeySym) (X ())) Query () windowSpecificBindings config = do w <- lift ask + let altMask = mod1Mask let mods = permuteMods [shiftMask, controlMask, 0] - let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config)) + let configureIf b k = + let (keymap, _) = resolveBindings (runBinder config k) + in tell =<< lift (b --> return (keymap config)) emitKey = flip sendKey w configureIf (flip elem (browsers ++ spotify) <$> className) $ do @@ -1398,20 +1299,11 @@ windowBindings xconfig = map <- execWriterT $ windowSpecificBindings xconfig w <- ask - liftX $ logs Info "For Window: %s" (show w) + liftX $ logs Debug "For Window: %s" (show w) forM_ (Map.toList map) $ \(key, action) -> do - liftX $ logs Info " -- remap: %s" (show key) + liftX $ logs Debug " -- remap: %s" (show key) remapKey key action -applyKeys :: XConfig l -> IO (XConfig l) -applyKeys config = - return $ - windowBindings $ - config - { keys = keyBindingToKeymap keymap, - mouseBindings = buttonBindingsToButtonMap mouseMap - } - modifyWindowBorder :: Integer -> SpacingModifier modifyWindowBorder i = ModifyWindowBorder $ \(Border a b c d) -> Border (clip $ a + i) (clip $ b + i) (clip $ c + i) (clip $ d + i) |