diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Rahm/Desktop/Keys.hs | 306 | ||||
| -rw-r--r-- | src/Rahm/Desktop/Keys/Dsl.hs | 254 |
2 files changed, 352 insertions, 208 deletions
diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs index 49fe1fb..8ed0b06 100644 --- a/src/Rahm/Desktop/Keys.hs +++ b/src/Rahm/Desktop/Keys.hs @@ -197,11 +197,26 @@ keymap = runKeys $ do "gxmessage" [ "-fn", "Source Code Pro", - documentation (keymap config) + "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 @@ -289,12 +304,12 @@ keymap = runKeys $ do shiftMod $ doc "Switch to a different theater.\n\n\t\ - \Theaters are like super-workspaces. They are used for different\n\ - \'contexts'. Theaters share all the windows with eachother, but\n\ - \but each theater has its own mappings for window -> workspace. i.e.\n\ - \one theater can have window 'x' on workspace 'y', but another might\n\ - \have 'x' on 'z' instead. If a theater does explicity place a window,\n\ - \the window is placed in the hidden workspace (which is '*')" + \Theaters are like super-workspaces. They are used for different\n\t\ + \'contexts'. Theaters share all the windows with eachother, but\n\t\ + \but each theater has its own mappings for window -> workspace. i.e.\n\t\ + \one theater can have window 'x' on workspace 'y', but another might\n\t\ + \have 'x' on 'z' instead. If a theater does explicity place a window,\n\t\ + \the window is placed in the hidden workspace (which is '*')\n" $ pushPendingBuffer "G " $ runMaybeT_ $ do mapNextString $ \_ str -> lift $ @@ -311,13 +326,13 @@ keymap = runKeys $ do noMod $ doc "Record a windowset macro.\n\n\t\ - \To record a 'windowset' macro, type <M-d>w<key> and then\n\ - \type a character sequence followed by Enter. Now <key> can\n\ - \be used anywhere a 'windowset' is required and that macro\n\ + \To record a 'windowset' macro, type <M-d>w<key> and then\n\t\ + \type a character sequence followed by Enter. Now <key> can\n\t\ + \be used anywhere a 'windowset' is required and that macro\n\t\ \will be used.\n\n\t\ - \For example, if one wants to define '+' as 'all windows \n\ + \For example, if one wants to define '+' as 'all windows \n\t\ \not on the current workspace, one can type:\n\n\t\ - \<M-d>w+\\%@.<Enter>" + \<M-d>w+\\%@.<Enter>\n" $ pushPendingBuffer "Win Macro " $ runMaybeT_ readWindowsetMacro @@ -325,14 +340,14 @@ keymap = runKeys $ do noMod $ doc "Record a workspace macro\n\n\t\ - \To record a 'workspace' macro, type <M-d>t<key> and then\n\ - \type a character sequence followed by Enter. Now <key> can\n\ - \be used anywhere a 'workspace' is required and that macro\n\ + \To record a 'workspace' macro, type <M-d>t<key> and then\n\t\ + \type a character sequence followed by Enter. Now <key> can\n\t\ + \be used anywhere a 'workspace' is required and that macro\n\t\ \will be used.\n\n\t\ - \For example, if one wants to define '<c-s>' as 'the workspace with\n\ - \the window 's' on it or the last workspace if already on that \n\ + \For example, if one wants to define '<c-s>' as 'the workspace with\n\t\ + \the window 's' on it or the last workspace if already on that \n\t\ \workspace (more useful that one would think):\n\n\t\ - \<M-d>t<c-s>?&s@.'s<Enter>" + \<M-d>t<c-s>?&s@.'s<Enter>\n" $ pushPendingBuffer "Wksp Macro " $ runMaybeT_ readWorkspaceMacro @@ -387,8 +402,8 @@ keymap = runKeys $ do bind xK_minus $ do justMod $ doc - "Decrease the number of windows in the master region, or decrease\n\ - \the size of the master region if the current layout cannot have more\n\ + "Decrease the number of windows in the master region, or decrease\n\t\ + \the size of the master region if the current layout cannot have more\n\t\ \than one window in the master region." $ sendMessage $ IncMasterN (-1) @@ -399,9 +414,9 @@ keymap = runKeys $ do bind xK_m $ do justMod $ doc - "Mark the windows described by the window set with a given character.\n\n\ - \For example, to mark the current window use <M-m>.<character>. That window\n\n\ - \can then be recalled anywhere that requires a WML window." + "Mark the windows described by the window set with a given character.\n\n\t\ + \For example, to mark the current window use <M-m>.<character>. That window\n\n\t\ + \can then be recalled anywhere that requires a WML window.\n" $ do pushPendingBuffer "m " $ do locs <- fromMaybe [] <$> runMaybeT readNextLocationSet @@ -417,9 +432,9 @@ keymap = runKeys $ do bind xK_plus $ do justMod $ doc - "Increase the number of windows in the master region, or increase\n\ - \the size of the master region if the current layout cannot have more\n\ - \than one window in the master region." + "Increase the number of windows in the master region, or increase\n\t\ + \the size of the master region if the current layout cannot have more\n\t\ + \than one window in the master region.\n" $ sendMessage $ IncMasterN 1 shiftMod $ @@ -556,16 +571,10 @@ keymap = runKeys $ do \increase volume respectively" $ repeatable $ do bind xK_h $ - justMod $ - doc - "Decrease volume." - decreaseVolumeDoc + justMod decreaseVolumeDoc bind xK_l $ - justMod $ - doc - "Increase volume." - increaseVolumeDoc + justMod increaseVolumeDoc bind xK_v $ justMod (return () :: X ()) @@ -695,13 +704,13 @@ keymap = runKeys $ do buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config) where - bindingToX :: (ButtonMask, Button) -> ButtonBinding -> (Window -> X ()) + bindingToX :: (ButtonMask, Button) -> Documented ButtonBinding -> (Window -> X ()) bindingToX click@(mask, btn) = \case - (ButtonAction action) -> action - (ButtonSubmap sm) -> + Documented _ (ButtonAction action) -> action + Documented _ (ButtonSubmap sm) -> pushAddPendingBuffer (printf "b%d " btn) . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm) - (ButtonContinuous sm) -> \window -> + Documented _ (ButtonContinuous sm) -> \window -> pushAddPendingBuffer (printf "b%d " btn) $ do mapM_ (flip (bindingToX click) window) (Map.lookup click sm) fix $ \recur -> do @@ -735,113 +744,176 @@ mouseMap = runButtons $ do rawMask m $ ButtonContinuous bindingMap - action :: X () -> (Window -> X ()) - action = const - bind button1 $ do - justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster + justMod $ + doc "Float and move a window" $ + \w -> + pushPendingBuffer "Dragging" $ + focus w >> mouseMoveWindow w >> windows W.shiftMaster bind button2 $ do justMod $ windows . (W.shiftMaster .) . W.focusWindow bind button3 $ do - justMod $ \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster + justMod $ + doc "Float and resize a window" $ + \w -> focus w >> mouseResizeWindow w >> windows W.shiftMaster bind button6 $ justMod $ - noWindow (viewAdjacent prev) + doc "Move to the workspace to the left" $ + noWindow (viewAdjacent prev) bind button7 $ justMod $ - noWindow (viewAdjacent next) + doc "Move to the workspace to the right" $ + noWindow (viewAdjacent next) bind button8 $ - justMod $ noWindow mediaPrev + justMod $ + doc "Media previous" $ + noWindow mediaPrev bind button9 $ - justMod $ noWindow mediaNext + justMod $ + doc "Media next" $ + noWindow mediaNext bind button14 $ do noMod $ - subMouse $ do - bind button3 $ - noMod $ noWindow (gotoWorkspace "s") - - bind button13 $ do - noMod $ noWindow $ click >> CopyWindow.kill1 - - bind button14 $ do - noMod $ noWindow $ click >> sendMessage togglePop + doc "Additional Mouse Bindings" $ + subMouse $ do + bind button3 $ + noMod $ + doc "Move to workspace 's' (Spotify)" $ + noWindow (gotoWorkspace "s") - bind button15 $ do - noMod $ noWindow $ spawnX "pavucontrol" + bind button13 $ do + noMod $ + doc "Kill the window under the cursor" $ + noWindow $ click >> CopyWindow.kill1 - let mediaButtons = - [ (button4, action increaseVolume), - (button5, action decreaseVolume), - (button2, action playPause), - (button9, action historyForward), - (button8, action historyBack), - (button6, action mediaPrev), - (button7, action mediaNext) - ] + bind button14 $ do + noMod $ + doc "Pop the window under the cursor" $ + noWindow $ click >> sendMessage togglePop - continuous $ - forM_ mediaButtons $ \(b, a) -> - bind b $ noMod a + 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 historyForward), + (button8, "History Back", noWindow historyBack), + (button6, "Media Previous", noWindow mediaPrev), + (button7, "Media Next", noWindow mediaNext) + ] + + continuous $ + forM_ mediaButtons $ \(b, d, a) -> + bind b $ noMod $ doc d a bind button13 $ noMod $ - subMouse $ do - bind button1 $ noMod mouseMoveWindow - bind button2 $ noMod $ windows . W.sink - bind button3 $ noMod mouseResizeWindow - - let swapButtons = - [ (button6, action $ windows W.swapDown), - (button7, action $ windows W.swapUp) - ] - - continuous $ - forM_ swapButtons $ \(b, a) -> - bind b $ noMod a - - bind button13 $ - noMod $ - subMouse $ do - bind button13 $ - noMod $ - subMouse $ do - bind button13 $ noMod $ noWindow $ spawnX "xsecurelock" - bind button1 $ - noMod $ - noWindow $ - spawnX "sudo -A systemctl suspend && xsecurelock" + doc "General Window Management Extra Mouse Bindings" $ + subMouse $ do + bind button1 $ + noMod $ + doc "Start moving the window under the cursor" mouseMoveWindow + + bind button2 $ + noMod $ + doc "Sink the window under the cursor into the tiling" $ + windows . W.sink + + bind button3 $ + noMod $ + doc "Resize the window under the cursor" mouseResizeWindow + + let swapButtons = + [ ( button6, + "Swap the current window with the next one in the stack", + noWindow $ windows W.swapDown + ), + ( button7, + "Swap the current window with the last one in the stack", + noWindow $ windows W.swapUp + ) + ] + + continuous $ + forM_ swapButtons $ \(b, d, a) -> + bind b $ noMod $ doc d a + + bind button13 $ + noMod $ + subMouse $ do + bind button13 $ + noMod $ + subMouse $ do + bind button13 $ + noMod $ + doc "Lock the screen" $ + noWindow $ spawnX "xsecurelock" + bind button1 $ + noMod $ + doc "Suspend the system" $ + noWindow $ + spawnX "sudo -A systemctl suspend && xsecurelock" bind button15 $ do noMod $ - subMouse $ do - bind button13 $ - noMod $ - noWindow $ - gotoWorkspace . accompaningWorkspace =<< getCurrentWorkspace - - bind button15 $ do - noMod $ noWindow jumpToLastLocation - - let workspaceButtons = - [ (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) - ] - - continuous $ - forM_ workspaceButtons $ \(b, a) -> - bind b $ noMod a + doc "General navigation extra mouse bindings" $ + subMouse $ do + bind button13 $ + noMod $ + doc "Goto the accompaning workspace to the current one." $ + noWindow $ + gotoWorkspace . accompaningWorkspace =<< getCurrentWorkspace + + bind button15 $ do + noMod $ + doc "Jump to the last location." $ + noWindow jumpToLastLocation + + let workspaceButtons = + [ ( button2, + "Swap the master window with the one under the cursor", + noWindow swapMaster + ), + ( button9, + "View the next workspace", + noWindow $ viewAdjacent next + ), + ( button8, + "View the previous workspace", + noWindow $ viewAdjacent prev + ), + ( button4, + "Focus the previous window in the stack", + noWindow $ windows W.focusUp + ), + ( button5, + "Focus the next window in the stack", + noWindow $ windows W.focusDown + ), + ( button7, + "Rotate the visible workspaces on the screens to the right", + noWindow $ windows W.screenRotateForward + ), + ( button6, + "Rotate the visible workspaces on the screens to the left", + noWindow $ windows W.screenRotateBackward + ) + ] + + continuous $ + forM_ workspaceButtons $ \(b, d, a) -> + bind b $ noMod $ doc d 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. diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs index 7f06a74..03ace1b 100644 --- a/src/Rahm/Desktop/Keys/Dsl.hs +++ b/src/Rahm/Desktop/Keys/Dsl.hs @@ -1,12 +1,100 @@ --- Domain-specific language for configuring key/button bindings. -module Rahm.Desktop.Keys.Dsl where +{-# LANGUAGE FunctionalDependencies #-} + +module Rahm.Desktop.Keys.Dsl + ( doc, + (-|-), + ButtonBinding (..), + ButtonBindings, + Documented (..), + HasConfig, + KeyBinding (..), + KeyBindings, + altAltgrMod, + altHyperAltgrMod, + altHyperMod, + altMask, + altMod, + altSuperAltgrMod, + altSuperHyperAltgrMod, + altSuperHyperMod, + altSuperMod, + altgrMask, + altgrMod, + bind, + buttonDocumentation, + controlAltAltgrMod, + controlAltHyperAltgrMod, + controlAltHyperMod, + controlAltMod, + controlAltSuperAltgrMod, + controlAltSuperHyperAltgrMod, + controlAltSuperHyperMod, + controlAltSuperMod, + controlAltgrMod, + controlHyperAltgrMod, + controlHyperMod, + controlMod, + controlSuperAltgrMod, + controlSuperHyperAltgrMod, + controlSuperHyperMod, + controlSuperMod, + documentation, + getConfig, + hyperAltgrMod, + hyperMask, + hyperMod, + justMod, + maskMod, + noMod, + rawMask, + runButtons, + runKeys, + shiftAltAltgrMod, + shiftAltHyperAltgrMod, + shiftAltHyperMod, + shiftAltMod, + shiftAltSuperAltgrMod, + shiftAltSuperHyperAltgrMod, + shiftAltSuperHyperMod, + shiftAltSuperMod, + shiftAltgrMod, + shiftControlAltAltgrMod, + shiftControlAltHyperAltgrMod, + shiftControlAltHyperMod, + shiftControlAltMod, + shiftControlAltSuperAltgrMod, + shiftControlAltSuperHyperAltgrMod, + shiftControlAltSuperHyperMod, + shiftControlAltSuperMod, + shiftControlAltgrMod, + shiftControlHyperAltgrMod, + shiftControlHyperMod, + shiftControlMod, + shiftControlSuperAltgrMod, + shiftControlSuperHyperAltgrMod, + shiftControlSuperHyperMod, + shiftControlSuperMod, + shiftHyperAltgrMod, + shiftHyperMod, + shiftMod, + shiftSuperAltgrMod, + shiftSuperHyperAltgrMod, + shiftSuperHyperMod, + shiftSuperMod, + superAltgrMod, + superHyperAltgrMod, + superHyperMod, + superMask, + superMod, + ) +where import Control.Arrow (first, second) import Control.Monad (void) import Control.Monad.State (State (..), execState, get, modify') import Control.Monad.Writer import Data.Bits ((.&.)) -import Data.List +import Data.List hiding (group) import Data.Map (Map) import qualified Data.Map as Map import Text.Printf @@ -28,7 +116,7 @@ data ButtonBinding -- Window -> X () -type ButtonBindings = Map (KeyMask, Button) ButtonBinding +type ButtonBindings = Map (KeyMask, Button) (Documented ButtonBinding) {- Module that defines a DSL for binding keys. -} newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a) @@ -57,8 +145,8 @@ 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 (Window -> X ()) (Documented ButtonBinding) where + toB = Documented "" . ButtonAction instance Binding (X ()) (Documented KeyBinding) where toB = Documented "" . Action @@ -72,7 +160,19 @@ instance Binding a (Documented a) where instance Binding a a where toB = id -doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding +-- Relationships to witness which types can be used with the "doc" function, +-- which is used to document actions in a safe and programmable way.. +class Relation k b | k -> b + +instance Relation (X ()) KeyBinding + +instance Relation KeyBinding KeyBinding + +instance Relation ButtonBinding ButtonBinding + +instance Relation (Window -> X ()) ButtonBinding + +doc :: (Relation k b, Binding k (Documented b)) => String -> k -> Documented b doc str k = let (Documented _ t) = toB k in Documented str t runKeys :: KeysM l a -> XConfig l -> KeyBindings @@ -128,7 +228,7 @@ instance Bindable KeySym where flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values)) instance Bindable Button where - type BindableValue Button = ButtonBinding + type BindableValue Button = Documented ButtonBinding type BindableMonad Button = ButtonsM -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l () @@ -397,75 +497,47 @@ altgrMod = maskMod altgrMask BindingBuilder b () (-|-) fn1 fn2 f = fn1 f >> fn2 f -{- Meant for submapping, binds all alphanumeric charactes to (fn c). -} -mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () -mapNumbersAndAlpha km fn = do - mapNumbers km fn - mapAlpha km fn - -{- Meant for submapping. This binds all numbers to (fn x) where x is the number - - pressed and fn is the function provided. -} -mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l () -mapNumbers km fn = do - mapM_ - (\(key, ch) -> bind key $ rawMask km (fn ch)) - [ (xK_0, '0'), - (xK_1, '1'), - (xK_2, '2'), - (xK_3, '3'), - (xK_4, '4'), - (xK_5, '5'), - (xK_6, '6'), - (xK_7, '7'), - (xK_8, '8'), - (xK_9, '9'), - -- Programmer Dvorak shifts the numbers so I have to map to their unshifted - -- form. - (xK_bracketright, '6'), - (xK_exclam, '8'), - (xK_bracketleft, '7'), - (xK_braceleft, '5'), - (xK_braceright, '3'), - (xK_parenleft, '1'), - (xK_equal, '9'), - (xK_asterisk, '0'), - (xK_parenright, '2'), - (xK_plus, '4') - ] - -{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the - - character pressed and fn is the function provided. -} -mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l () -mapAlpha km fn = - mapM_ - (\(key, ch) -> bind key $ rawMask km (fn ch)) - [ (xK_a, 'a'), - (xK_b, 'b'), - (xK_c, 'c'), - (xK_d, 'd'), - (xK_e, 'e'), - (xK_f, 'f'), - (xK_g, 'g'), - (xK_h, 'h'), - (xK_i, 'i'), - (xK_j, 'j'), - (xK_k, 'k'), - (xK_l, 'l'), - (xK_m, 'm'), - (xK_n, 'n'), - (xK_o, 'o'), - (xK_p, 'p'), - (xK_q, 'q'), - (xK_r, 'r'), - (xK_s, 's'), - (xK_t, 't'), - (xK_u, 'u'), - (xK_v, 'v'), - (xK_w, 'w'), - (xK_x, 'x'), - (xK_y, 'y'), - (xK_z, 'z') - ] +buttonDocumentation :: ButtonBindings -> String +buttonDocumentation = execWriter . document' "" + where + document' pref keybindings = + forM_ (sortOn (map (\(a, b) -> (b, a)) . snd . snd) $ Map.toList (keyBindingsToList keybindings)) $ \(doc, (thing, keys)) -> do + when (not (null doc) || hasSubmap thing) $ + tell $ printf "%s%s: %s\n" pref (intercalate " or " $ map prettyShow keys) doc + case thing of + ButtonAction _ -> return () + ButtonSubmap submap -> document' (pref ++ " ") submap + ButtonContinuous submap -> do + tell pref + tell " (repeatable):\n" + document' (pref ++ " ") submap + + keyBindingsToList :: ButtonBindings -> Map String (ButtonBinding, [(ButtonMask, Button)]) + keyBindingsToList b = + (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) + <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b) + + prettyShow :: (ButtonMask, Button) -> String + prettyShow (mask, button) = printf "%s%s" (showMask mask) (buttonToString button) + + buttonToString = \case + 1 -> "Left Click" + 2 -> "Middle Click" + 3 -> "Right Click" + 4 -> "Wheel Up" + 5 -> "Wheel Down" + 6 -> "Wheel Left" + 7 -> "Wheel Right" + 8 -> "Browser Back" + 9 -> "Browser Forward" + 13 -> "Thumb Target" + 14 -> "Index Forward" + 15 -> "Index Back" + b -> "Button " ++ show b + + hasSubmap b = case b of + ButtonAction _ -> False + _ -> True documentation :: KeyBindings -> String documentation = execWriter . document' "" @@ -494,17 +566,17 @@ documentation = execWriter . document' "" Action _ -> False _ -> True - showMask :: KeyMask -> String - showMask mask = - let masks = - [ (shiftMask, "S"), - (altMask, "A"), - (mod3Mask, "H"), - (mod4Mask, "M"), - (altgrMask, "AGr"), - (controlMask, "C") - ] - in concatMap ((++ "-") . snd) $ filter ((/= 0) . (.&. mask) . fst) masks - - group :: (Ord b) => (a -> b) -> [a] -> Map b [a] - group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) +showMask :: KeyMask -> String +showMask mask = + let masks = + [ (shiftMask, "S"), + (altMask, "A"), + (mod3Mask, "H"), + (mod4Mask, "M"), + (altgrMask, "AGr"), + (controlMask, "C") + ] + in concatMap ((++ "-") . snd) $ filter ((/= 0) . (.&. mask) . fst) masks + +group :: (Ord b) => (a -> b) -> [a] -> Map b [a] +group fn = Map.fromListWith (++) . map (first fn . (\a -> (a, [a]))) |