Add a bunch more documentation and ability to see that documentation

1 files changed, 42 insertions, 16 deletions

diff --git a/src/Internal/KeysM.hs b/src/Internal/KeysM.hs
index f33d9d0..fa9b49f 100644
--- a/src/Internal/KeysM.hs
+++ b/src/Internal/KeysM.hs
@@ -3,9 +3,10 @@
 module Internal.KeysM where
 
 import Data.List
+import Data.Bits ((.&.))
 import Control.Monad.Writer
 import Text.Printf
-import Control.Arrow (second)
+import Control.Arrow (second, first)
 import Control.Monad (void)
 import Control.Monad.State (State(..), modify', get, execState)
 import XMonad
@@ -42,6 +43,7 @@ class Bindable k where
   type BindableMonad k :: (* -> *) -> * -> *
 
   bind :: k -> BindingBuilder (BindableValue k) a -> BindableMonad k l ()
+  -- section :: String -> BindableMonad k l () -> BindableMonad k l ()
 
 class Binding k b where
   toB :: k -> b
@@ -64,13 +66,6 @@ instance Binding a a where
 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
-
-instance Monoid (KeysM l ()) where
-  mempty = return ()
-  mappend = (>>)
-
 runKeys :: KeysM l a -> XConfig l -> KeyBindings
 runKeys (KeysM stateM) config =
   snd $ execState stateM (config, Map.empty)
@@ -101,7 +96,7 @@ hyperMask :: KeyMask
 hyperMask = mod3Mask
 
 altgrMask :: KeyMask
-altgrMask = mod2Mask
+altgrMask = 0x80
 
 superMask :: KeyMask
 superMask = mod4Mask
@@ -121,6 +116,7 @@ instance Bindable KeySym where
     KeysM $ modify' $ second $
       flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values))
 
+
 instance Bindable Button where
   type BindableValue Button = ButtonBinding
   type BindableMonad Button = ButtonsM
@@ -456,16 +452,46 @@ mapAlpha km fn =
 
 
 documentation :: KeyBindings -> String
-documentation = execWriter . document' "" []
+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
+    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
           Action _ -> return ()
-          Submap submap -> document' (pref ++ "  ") (priorKeys ++ [key]) submap
+          Submap submap -> document' (pref ++ "  ") submap
           Repeat submap -> do
             tell pref
             tell "  (repeatable):\n"
-            document' (pref ++ "    ") (priorKeys ++ [key]) submap
+            document' (pref ++ "    ") submap
+
+    keyBindingsToList :: KeyBindings -> Map String (KeyBinding, [(KeyMask, KeySym)])
+    keyBindingsToList b =
+      fmap (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list)) $
+        group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b)
+
+    prettyShow :: (KeyMask, KeySym) -> String
+    prettyShow (mask, key) = printf "<%s%s>" (showMask mask) (keysymToString key)
+
+    hasSubmap b = case b of
+      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])))
+
+