Add a bunch more documentation and ability to see that documentation

2 files changed, 226 insertions, 107 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index 88ec8cf..fcf233e 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE RankNTypes, FlexibleContexts, ViewPatterns #-}
 module Internal.Keys (applyKeys) where
 
+import XMonad.Util.Run (safeSpawn)
 import Data.Monoid (Endo(..))
 import Control.Monad.Trans.Class
 import Control.Monad.Reader
@@ -70,6 +71,12 @@ playPause = spawnX "spotify-control play"
 mediaPrev = spawnX "spotify-control prev"
 mediaNext = spawnX "spotify-control next"
 
+decreaseVolumeDoc = doc "Decrease volume" decreaseVolume
+increaseVolumeDoc = doc "Increase volume" increaseVolume
+playPauseDoc = doc "Play/Pause current media" playPause
+mediaPrevDoc = doc "Previous media" mediaPrev
+mediaNextDoc = doc "Next media" mediaNext
+
 
 button6 :: Button
 button6 = 6
@@ -131,19 +138,28 @@ keymap = runKeys $ do
             jumpToLast
         mapAlpha 0 jumpToMark
 
-    shiftMod $ subkeys $ do
+    shiftMod $
+      doc "Swap the current window with a mark." $
+      subkeys $ do
       bind xK_apostrophe $
-        (noMod -|- shiftMod -|- rawMask shiftMask) swapWithLastMark
+        (noMod -|- shiftMod -|- rawMask shiftMask) $
+          doc "Swap the current window with the last mark."
+          swapWithLastMark
+
       mapAlpha shiftMask swapWithMark
 
   bind xK_BackSpace $ do
     -- The only raw keybinding. Meant to get a terminal to unbrick XMonad if
     -- something goes wrong with the keyboard layout and for first-time boots
     -- where dmenu/alacritty may not be installed.
-    rawMask mod4Mask $ spawnX "xterm"
+    rawMask mod4Mask $
+      doc "Spawns XTerm as a fallback if xkb is messed up." $
+      spawnX "xterm"
 
     -- Moves xmobar to different monitors.
-    justMod $ spawnX "pkill -SIGUSR1 xmobar"
+    justMod $
+      doc "Move XMobar to another screen." $
+      spawnX "pkill -SIGUSR1 xmobar"
 
   bind xK_F1 $ do
     -- Experimental. Sends 'a' to all windows.
@@ -157,9 +173,11 @@ keymap = runKeys $ do
       logs $ "Try send to " ++ show w
       sendKey (0, xK_a) w
 
-    -- Experimental. Sends 'A' 10 times to the focused window.
     justMod $
-      replicateM_ 10 $ withFocused (sendKey (shiftMask, xK_a))
+      doc "Print this documentation" $
+      (safeSpawn "gxmessage" [
+        "-fn", "Source Code Pro",
+        documentation (keymap config)] :: X ())
 
   bind xK_F7 $
     
@@ -168,13 +186,13 @@ keymap = runKeys $ do
       logs (documentation (keymap config))
 
   bind xK_F10 $ do
-    justMod playPause
+    justMod playPauseDoc
 
   bind xK_F11 $ do
-    justMod mediaPrev
+    justMod mediaPrevDoc
 
   bind xK_F12 $ do
-    justMod mediaNext
+    justMod mediaNextDoc
 
   bind xK_Return $ do
     justMod swapMaster
@@ -188,28 +206,48 @@ keymap = runKeys $ do
   forM_ (zip [xK_a, xK_o, xK_e] [0..]) $ \(key, idx) ->
     bind key $ do
       -- Move focus to that screen.
-      justMod  $ withScreen W.view idx
+      justMod  $
+        doc ("Switch focus to screen " ++ show idx) $
+        withScreen W.view idx
       -- Swap the current screen with the one given
-      altMod   $ withScreen W.greedyView idx
+      altMod   $ 
+        doc ("Swap the current screen with screen " ++ show idx) $
+        withScreen W.greedyView idx
       -- Move the current window to the select screen.
-      shiftMod $ withScreen W.shift idx
+      shiftMod $
+        doc ("Move the current window to screne " ++ show idx) $
+        withScreen W.shift idx
 
-  bind xK_bracketright $ do
-    justMod $ sendMessage $ modifyWindowBorder 5
+      altgrMod $
+        logs "Test altgr"
 
+  bind xK_bracketright $ do
+    justMod $
+      doc "Increase the gaps between windows." $
+      sendMessage $ modifyWindowBorder 5
+ 
   bind xK_bracketleft $ do
-    justMod $ sendMessage $ modifyWindowBorder (-5)
+    justMod $ 
+      doc "Decrease the gaps between windows." $
+      sendMessage $ modifyWindowBorder (-5)
 
   bind xK_b $ do
     justMod $ spawnX "bluetooth-select.sh"
 
   bind xK_c $ do
-    justMod runPassMenu
-    shiftMod CopyWindow.kill1
+    justMod $
+      doc "Run PassMenu" runPassMenu
+
+    shiftMod $
+      doc "Kill the current window" CopyWindow.kill1
 
   bind xK_f $ do
-    justMod  $ sendMessage FlipLayout
-    shiftMod $ sendMessage HFlipLayout
+    justMod  $
+      doc "Flip the current layout vertically" $
+      sendMessage FlipLayout
+    shiftMod $
+      doc "Flip the current layout horizontally" $
+      sendMessage HFlipLayout
 
   bind xK_g $ do
     justMod $
@@ -312,22 +350,46 @@ keymap = runKeys $ do
       doc "Recompile and restart XMonad" $
       spawnX "xmonad --recompile && xmonad --restart"
 
-    justMod $ subkeys $ do
+    justMod $ 
+      doc "Experimental Bindings" $
+      subkeys $ do
 
       bind xK_q $
-        (justMod -|- noMod) $ do
+        (justMod -|- noMod) $
+          let fi = fromIntegral
+              mag (fi -> x₁, fi -> y₁) (fi -> x₂, fi -> y₂) =
+                sqrt ((x₂ - x₁) ^ 2 + (y₂ - y₁) ^ 2) in
+
+          doc "EXPERIMENTAL: Move mouse to control media." $ fix $ \recur -> do
+
+          -- Moving the mouse 100+ pixels to the right will go to the next song
+          -- Moving the mouse 100+ pixel to the left will go to the prior song
+          -- Moving the mouse vertically 100+ pixels will stop the loop
+          --
+          -- May mess up the mouse, requiring an XMonad reboot, which is why
+          -- this is experimental. It's not the most practical bindings in the
+          -- world, but it shows that it's theoretically possible to program
+          -- some neat mouse moptions to do cool things.
           firstMotion@(x, y) <- nextMotion
-          (x', y') <- iterateWhile (==firstMotion) nextMotion
+          (x', y') <- iterateWhile ((<100) . mag firstMotion) nextMotion
 
-          logs $ printf "Motion: (%d, %d) (%d, %d)" x y x' y'
 
-          if (x' - x) < 0
-            then mediaPrev
-            else mediaNext
+          if abs (y' - y) > abs (x' - x)
+            then 
+              if (y' - y) < 0
+                then logs "up"
+                else logs "down"
+            else do
+              if (x' - x) < 0
+                then mediaPrev
+                else mediaNext
+              recur
 
   bind xK_r $ do
-    justMod runDMenu
-    shiftMod $ sendMessage DoRotate
+    justMod $ doc "Run a command via Rofi" runDMenu
+    shiftMod $
+      doc "Rotate the current layout. (flips x, y coordinates)" $
+      sendMessage DoRotate
 
   bind xK_s $ do
     altMod $ spawnX "sudo -A systemctl suspend && xsecurelock"
@@ -350,106 +412,137 @@ keymap = runKeys $ do
         bind xK_h $
           justMod $
              doc "Decrease volume." $
-             decreaseVolume
+             decreaseVolumeDoc
 
         bind xK_l $
           justMod $
              doc "Increase volume." $
-             increaseVolume
+             increaseVolumeDoc
 
         bind xK_v $
           justMod $ (return () :: X ())
 
   bind xK_w $ do
-    justMod windowJump
+    justMod $ doc "Jump to a window (via rofi)" windowJump
 
   bind xK_x $ do
-    justMod $ sendMessage ToggleStruts
+    justMod $
+      doc "Toggles respect for struts." $
+      sendMessage ToggleStruts
 
   bind xK_z $ do
 
-    justMod $ subkeys $ do
-
-      bind xK_g $ do
-        (justMod -|- noMod) $ mapNextString $ \_ s ->
-          case s of
-            [ch] | isAlphaNum ch -> windows (CopyWindow.copy s)
-            _ -> return ()
-
-      bind xK_p $ do
-        (justMod -|- noMod) $ mapNextString $ \_ str ->
-          spawnX $ printf "gxmessage 'typed: \"%s\"\ncodes: \"%s\"\nunicode: á\n'"
-            str
-            (show (map ord str))
-
-      bind xK_t $ do
-        (justMod -|- noMod) $ logs "Test Log"
-
-      bind xK_n $ do
-        (justMod -|- noMod) $ spawnX (terminal config ++ " -t Notes -e notes new")
-
-      bind xK_c $ do
-        shiftMod CopyWindow.killAllOtherCopies
-
-      bind xK_e $ do
-        (justMod -|- noMod) $ spawnX "emoji-select.sh"
-        (shiftMod -|- rawMask shiftMask) $ spawnX "emoticon-select.sh"
-
-      bind xK_a $
-        (justMod -|- noMod) $ spawnX "set-sink.sh"
-
-      bind xK_w $
-        (justMod -|- noMod) $ spawnX "networkmanager_dmenu"
-
-      bind xK_o $
-        (justMod -|- noMod) $ spawnX "library-view.sh"
-
-      bind xK_s $
-        (justMod -|- noMod) toggleSwallowEnabled
-
-      bind xK_v $ do
-        (justMod -|- noMod) $ spawnX "set-volume.sh"
-        (shiftMod -|- rawMask shiftMask) $ spawnX "set-volume.sh -a"
-
-      -- Double-tap Z to toggle zoom.
-      bind xK_z $ do
-        noMod -|- justMod $ sendMessage ToggleZoom
+    justMod $
+      doc "Less often used keybindings." $
+      subkeys $ do
 
-      -- Z is reserved to create sub keybindings to do various things.
-      -- I don't really use these at the moment.
-      bind xK_h $ noMod mediaPrev
-      bind xK_j $ noMod playPause
-      bind xK_l $ noMod mediaNext
+        bind xK_g $ do
+          (justMod -|- noMod) $
+            doc "Copy a window to the given workspace" $
+            mapNextString $ \_ s ->
+              case s of
+                [ch] | isAlphaNum ch -> windows (CopyWindow.copy s)
+                _ -> return ()
+
+        bind xK_p $ do
+          (justMod -|- noMod) $ mapNextString $ \_ str ->
+            spawnX $ printf "gxmessage 'typed: \"%s\"\ncodes: \"%s\"\nunicode: á\n'"
+              str
+              (show (map ord str))
+
+        bind xK_t $ do
+          (justMod -|- noMod) $ logs "Test Log"
+
+        bind xK_n $ do
+          (justMod -|- noMod) $
+            doc "Take a note" $
+            spawnX (terminal config ++ " -t Notes -e notes new")
+
+        bind xK_c $ do
+          shiftMod $
+            doc "Kill all other copies of a window."
+            CopyWindow.killAllOtherCopies
+
+        bind xK_e $ do
+          (justMod -|- noMod) $
+            doc "Select an emoji" $
+            spawnX "emoji-select.sh"
+
+          (shiftMod -|- rawMask shiftMask) $
+            doc "Select an emoticon" $
+            spawnX "emoticon-select.sh"
+
+        bind xK_a $
+          (justMod -|- noMod) $
+            doc "Move the audio sink for an application." $
+            spawnX "set-sink.sh"
+
+        bind xK_w $
+          (justMod -|- noMod) $
+            doc "Select a network to connect to." $
+            spawnX "networkmanager_dmenu"
+
+        bind xK_o $
+          (justMod -|- noMod) $
+            doc "Open a file from the library" $
+            spawnX "library-view.sh"
+
+        bind xK_s $
+          (justMod -|- noMod) $
+            doc "Toggle the ability for terminals to swallow child windows." $
+            toggleSwallowEnabled
+
+        bind xK_v $ do
+          (justMod -|- noMod) $
+            doc "Set the volume via rofi." $
+            spawnX "set-volume.sh"
+          (shiftMod -|- rawMask shiftMask) $
+            doc "Set the volume of an application via rofi." $
+            spawnX "set-volume.sh -a"
+
+        -- Double-tap Z to toggle zoom.
+        bind xK_z $ do
+          noMod -|- justMod $
+            doc "Toggle zoom on the current window." $
+            sendMessage ToggleZoom
+
+        -- Z is reserved to create sub keybindings to do various things.
+        -- I don't really use these at the moment.
+        bind xK_h $ noMod mediaPrevDoc
+        bind xK_j $ noMod playPauseDoc
+        bind xK_l $ noMod mediaNextDoc
 
     -- Centers the current focused window. i.e. toggles the Zoom layout
     -- modifier.
-    shiftMod $ sendMessage ToggleZoom
+    shiftMod $
+      doc "Toggle zoom on the current window." $
+      sendMessage ToggleZoom
 
   bind xF86XK_Calculator $ do
     noMod $ spawnX $ terminal config ++ " -t Floating\\ Term -e /usr/bin/env python3"
 
   bind xF86XK_AudioLowerVolume $ do
     noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ -1%"
-    justMod mediaPrev
+    justMod mediaPrevDoc
 
   bind xF86XK_AudioRaiseVolume $ do
     noMod $ spawnX "pactl set-sink-volume @DEFAULT_SINK@ +1%"
-    justMod mediaNext
+    justMod mediaNextDoc
 
   bind xF86XK_AudioMute $ do
     noMod $ spawnX "pactl set-sink-mute @DEFAULT_SINK@ toggle"
 
   bind xF86XK_AudioPlay $ do
-    noMod playPause
+    noMod playPauseDoc
 
   bind xF86XK_AudioNext $ do
-    noMod mediaNext
+    noMod mediaNextDoc
 
   bind xF86XK_AudioPrev $ do
-    noMod mediaPrev
+    noMod mediaPrevDoc
 
   bind xF86XK_AudioPrev $ do
-    noMod mediaPrev
+    noMod mediaPrevDoc
 
   bind xF86XK_MonBrightnessUp $ do
     noMod $ spawnX "set-backlight.sh +0.05"
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])))
+
+