aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Internal/Keys.hs183
-rw-r--r--src/Internal/KeysM.hs51
2 files changed, 167 insertions, 67 deletions
diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 467ed24..88ec8cf 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -101,24 +101,35 @@ button14 = 14
button15 :: Button
button15 = 15
-resolveSubmaps :: (XConfig l -> KeyBindings) -> KeyMap l
-resolveSubmaps bindings config = (fmap $ \binding ->
- case binding of
- Action x -> x
- Submap _ -> logs "") (bindings config)
-
-keymap :: KeyMap l
-keymap = resolveSubmaps $ runKeys $ do
+keyBindingToKeymap :: (XConfig l -> KeyBindings) -> KeyMap l
+keyBindingToKeymap bindings config = fmap bindingToX (bindings config)
+
+ where
+ bindingToX b =
+ case b of
+ Documented _ (Action x) -> x
+ Documented _ (Submap mapping) ->
+ submap (fmap bindingToX mapping)
+ Documented _ (Repeat mapping) ->
+ fix $ \recur ->
+ submap (fmap (\b -> bindingToX b >> recur) mapping)
+
+keymap :: XConfig l -> KeyBindings
+keymap = runKeys $ do
config <- getConfig
- let defaultKey key = fromMaybe (return ()) $ Map.lookup key (keymap config)
- subkeys keysM = submapDefaultWithKey defaultKey $ (resolveSubmaps (runKeys keysM)) config
+ let subkeys keysM = Submap (runKeys keysM config)
+ repeatable keysM = Repeat (runKeys keysM config)
bind xK_apostrophe $ do
- justMod $ subkeys $ do
- bind xK_apostrophe $
- (noMod -|- justMod) jumpToLast
- mapAlpha 0 jumpToMark
+ justMod $
+ doc "Jumps between marks." $
+ subkeys $ do
+ bind xK_apostrophe $
+ (noMod -|- justMod) $
+ doc "Jumps to the last window." $
+ jumpToLast
+ mapAlpha 0 jumpToMark
shiftMod $ subkeys $ do
bind xK_apostrophe $
@@ -150,6 +161,12 @@ keymap = resolveSubmaps $ runKeys $ do
justMod $
replicateM_ 10 $ withFocused (sendKey (shiftMask, xK_a))
+ bind xK_F7 $
+
+ justMod $
+ doc "Print this documentation." $
+ logs (documentation (keymap config))
+
bind xK_F10 $ do
justMod playPause
@@ -195,57 +212,105 @@ keymap = resolveSubmaps $ runKeys $ do
shiftMod $ sendMessage HFlipLayout
bind xK_g $ do
- justMod $ mapNextString $ \_ str ->
- case str of
- [ch] | isAlphaNum ch -> gotoWorkspace ch
- [' '] -> gotoAccompaningWorkspace
- _ -> return ()
- shiftMod $ mapNextString $ \_ str ->
- case str of
- [ch] | isAlphaNum ch -> shiftToWorkspace ch
- _ -> return ()
- shiftAltMod $ mapNextString $ \_ str ->
- case str of
- [ch] | isAlphaNum ch -> swapWorkspace ch
- _ -> return ()
+ justMod $
+ doc ("Go to a workspace. The next typed character is the workspace " ++
+ "must be alpha-numeric.") $
+ mapNextString $ \_ str ->
+ case str of
+ [ch] | isAlphaNum ch -> gotoWorkspace ch
+ [' '] -> gotoAccompaningWorkspace
+ _ -> return ()
+ shiftMod $
+ doc "Move the currently focused window to another workspace" $
+ mapNextString $ \_ str ->
+ case str of
+ [ch] | isAlphaNum ch -> shiftToWorkspace ch
+ _ -> return ()
+ shiftAltMod $
+ doc "Swap this workspace with another workspace (rename)." $
+ mapNextString $ \_ str ->
+ case str of
+ [ch] | isAlphaNum ch -> swapWorkspace ch
+ _ -> return ()
bind xK_h $ do
- justMod $ windows W.focusDown
- shiftMod $ windows W.swapDown
- controlMod rotAllDown
+ justMod $
+ doc "Focus on the next window down in the stack" $
+ windows W.focusDown
+
+ shiftMod $
+ doc "Swap the current window with the next one down in the stack" $
+ windows W.swapDown
+
+ controlMod $
+ doc "Rotate all the windows down the stack"
+ rotAllDown
bind xK_j $ do
- justMod $ sendMessage ShrinkZoom
+ justMod $
+ doc "Shrink the size of the zoom region" $
+ sendMessage ShrinkZoom
bind xK_k $ do
- justMod $ sendMessage ExpandZoom
+ justMod $
+ doc "Expand the size of the zoom region" $
+ sendMessage ExpandZoom
bind xK_l $ do
- justMod $ windows W.focusUp
- shiftMod $ windows W.swapUp
- controlMod rotAllUp
- altMod $ spawnX "xsecurelock"
+ justMod $
+ doc "Focus the next window in the stack" $
+ windows W.focusUp
+
+ shiftMod $
+ doc "Swap the currently focused window with the next window in the stack." $
+ windows W.swapUp
+
+ controlMod $
+ doc "Rotate the windows up."
+ rotAllUp
+
+ altMod $
+ doc "Lock the screen" $
+ spawnX "xsecurelock"
bind xK_minus $ do
- justMod $ sendMessage (IncMasterN (-1))
- shiftMod $ withFocused $ sendMessage . shrinkWindowAlt
+ justMod $
+ doc "Decrease the number of windows in the master region." $
+ sendMessage (IncMasterN (-1))
+
+ shiftMod $
+ doc "For mosaic layout, shrink the size-share of the current window" $
+ withFocused $ sendMessage . shrinkWindowAlt
bind xK_m $ do
- justMod $ subkeys $
- mapAlpha 0 markCurrentWindow
+ justMod $
+ doc "Mark the current window with the next typed character." $
+ subkeys $
+ mapAlpha 0 markCurrentWindow
bind xK_n $ do
- justMod $ relativeWorkspaceShift next
+ justMod $
+ doc "Shift to the next workspace." $
+ relativeWorkspaceShift next
bind xK_p $ do
- justMod $ relativeWorkspaceShift prev
+ justMod $
+ doc "Shift to the previous workspace." $
+ relativeWorkspaceShift prev
bind xK_plus $ do
- justMod $ sendMessage (IncMasterN 1)
- shiftMod $ withFocused $ sendMessage . expandWindowAlt
+ justMod $
+ doc "Increase the number of windows in the master region." $
+ sendMessage (IncMasterN 1)
+
+ shiftMod $
+ doc "For mosaic layout, increase the size-share of the current window." $
+ withFocused $ sendMessage . expandWindowAlt
bind xK_q $ do
- shiftMod $ spawnX "xmonad --recompile && xmonad --restart"
+ shiftMod $
+ doc "Recompile and restart XMonad" $
+ spawnX "xmonad --recompile && xmonad --restart"
justMod $ subkeys $ do
@@ -279,19 +344,21 @@ keymap = resolveSubmaps $ runKeys $ do
bind xK_v $
-- Allows repeated strokes of M-h and M-l to reduce and increase volume
-- respectively.
- justMod $ fix $ \recur -> subkeys $ do
- bind xK_h $ do
- justMod $ do
- decreaseVolume
- recur
+ justMod $
+ doc "Changes the volume." $
+ repeatable $ do
+ bind xK_h $
+ justMod $
+ doc "Decrease volume." $
+ decreaseVolume
- bind xK_l $ do
- justMod $ do
- increaseVolume
- recur
+ bind xK_l $
+ justMod $
+ doc "Increase volume." $
+ increaseVolume
- bind xK_v $ do
- justMod recur
+ bind xK_v $
+ justMod $ (return () :: X ())
bind xK_w $ do
justMod windowJump
@@ -505,7 +572,7 @@ windowSpecificBindings config = do
w <- lift ask
- let configureIf b k = tell =<< lift (b --> return (resolveSubmaps (runKeys k) config))
+ let configureIf b k = tell =<< lift (b --> return (keyBindingToKeymap (runKeys k) config))
emitKey = flip sendKey w
configureIf (flip elem browsers <$> className) $ do
@@ -617,7 +684,7 @@ windowBindings xconfig =
applyKeys :: XConfig l -> IO (XConfig l)
applyKeys config =
- return $ windowBindings $ config { keys = keymap, mouseBindings = mouseMap }
+ return $ windowBindings $ config { keys = keyBindingToKeymap keymap, mouseBindings = mouseMap }
click :: X ()
click = do
diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs
index b394552..f33d9d0 100644
--- a/src/Internal/KeysM.hs
+++ b/src/Internal/KeysM.hs
@@ -1,7 +1,10 @@
{-# Language GeneralizedNewtypeDeriving, MultiParamTypeClasses,
- FunctionalDependencies, FlexibleInstances, TypeFamilies #-}
+ FunctionalDependencies, FlexibleInstances, TypeFamilies, FlexibleContexts #-}
module Internal.KeysM where
+import Data.List
+import Control.Monad.Writer
+import Text.Printf
import Control.Arrow (second)
import Control.Monad (void)
import Control.Monad.State (State(..), modify', get, execState)
@@ -9,8 +12,14 @@ import XMonad
import Data.Map (Map)
import qualified Data.Map as Map
-data KeyBinding = Action (X ()) | Submap KeyBindings
-type KeyBindings = Map (KeyMask, KeySym) KeyBinding
+data Documented t = Documented String t
+
+data KeyBinding =
+ Action (X ()) |
+ Submap KeyBindings |
+ Repeat KeyBindings
+
+type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding)
type ButtonBinding = Window -> X ()
type ButtonBindings = Map (KeyMask, Button) ButtonBinding
@@ -35,16 +44,25 @@ class Bindable k where
bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l ()
class Binding k b where
+ toB :: k -> b
+
rawMask :: KeyMask -> k -> BindingBuilder b ()
+ rawMask m x = BindingBuilder $ modify' (second ((m, toB x):))
-instance Binding (X ()) KeyBinding where
- rawMask m x = BindingBuilder $ modify' (second ((m, Action x):))
+instance Binding (X ()) (Documented KeyBinding) where
+ toB = Documented "" . Action
-instance Binding KeyBindings KeyBinding where
- rawMask m x = BindingBuilder $ modify' (second ((m, Submap x):))
+instance Binding KeyBindings (Documented KeyBinding) where
+ toB = Documented "" . Submap
+
+instance Binding a (Documented a) where
+ toB = Documented ""
instance Binding a a where
- rawMask m x = BindingBuilder $ modify' (second ((m, x):))
+ toB = id
+
+doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding
+doc str k = let (Documented _ t) = toB k in Documented str t
instance Semigroup (KeysM l ()) where
(<>) = mappend
@@ -92,7 +110,7 @@ justMod :: (Binding k b) => k -> BindingBuilder b ()
justMod = maskMod 0
instance Bindable KeySym where
- type BindableValue KeySym = KeyBinding
+ type BindableValue KeySym = Documented KeyBinding
type BindableMonad KeySym = KeysM
-- bind :: KeySym -> BindingBuilder (X x) a -> KeysM l ()
@@ -436,3 +454,18 @@ mapAlpha km fn =
, (xK_z, 'z')
]
+
+documentation :: KeyBindings -> String
+documentation = execWriter . document' "" []
+ where
+ document' pref priorKeys keybindings =
+ forM_ (Map.toList keybindings) $ \(key, Documented doc thing) -> do
+ when (not $ null doc) $
+ tell $ printf "%s%s%s: %s\n" pref (intercalate " " $ map show priorKeys) (show key) doc
+ case thing of
+ Action _ -> return ()
+ Submap submap -> document' (pref ++ " ") (priorKeys ++ [key]) submap
+ Repeat submap -> do
+ tell pref
+ tell " (repeatable):\n"
+ document' (pref ++ " ") (priorKeys ++ [key]) submap
generated by cgit (git 2.34.1) at 2026-02-22 12:16:40 +0000