basic ability teo generate config

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