basic ability teo generate config

1 files changed, 42 insertions, 9 deletions

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