Implement documentation for mouse bindings.

1 files changed, 163 insertions, 91 deletions

diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs
index 7f06a74..03ace1b 100644
--- a/src/Rahm/Desktop/Keys/Dsl.hs
+++ b/src/Rahm/Desktop/Keys/Dsl.hs
@@ -1,12 +1,100 @@
--- Domain-specific language for configuring key/button bindings.
-module Rahm.Desktop.Keys.Dsl where
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Rahm.Desktop.Keys.Dsl
+  ( doc,
+    (-|-),
+    ButtonBinding (..),
+    ButtonBindings,
+    Documented (..),
+    HasConfig,
+    KeyBinding (..),
+    KeyBindings,
+    altAltgrMod,
+    altHyperAltgrMod,
+    altHyperMod,
+    altMask,
+    altMod,
+    altSuperAltgrMod,
+    altSuperHyperAltgrMod,
+    altSuperHyperMod,
+    altSuperMod,
+    altgrMask,
+    altgrMod,
+    bind,
+    buttonDocumentation,
+    controlAltAltgrMod,
+    controlAltHyperAltgrMod,
+    controlAltHyperMod,
+    controlAltMod,
+    controlAltSuperAltgrMod,
+    controlAltSuperHyperAltgrMod,
+    controlAltSuperHyperMod,
+    controlAltSuperMod,
+    controlAltgrMod,
+    controlHyperAltgrMod,
+    controlHyperMod,
+    controlMod,
+    controlSuperAltgrMod,
+    controlSuperHyperAltgrMod,
+    controlSuperHyperMod,
+    controlSuperMod,
+    documentation,
+    getConfig,
+    hyperAltgrMod,
+    hyperMask,
+    hyperMod,
+    justMod,
+    maskMod,
+    noMod,
+    rawMask,
+    runButtons,
+    runKeys,
+    shiftAltAltgrMod,
+    shiftAltHyperAltgrMod,
+    shiftAltHyperMod,
+    shiftAltMod,
+    shiftAltSuperAltgrMod,
+    shiftAltSuperHyperAltgrMod,
+    shiftAltSuperHyperMod,
+    shiftAltSuperMod,
+    shiftAltgrMod,
+    shiftControlAltAltgrMod,
+    shiftControlAltHyperAltgrMod,
+    shiftControlAltHyperMod,
+    shiftControlAltMod,
+    shiftControlAltSuperAltgrMod,
+    shiftControlAltSuperHyperAltgrMod,
+    shiftControlAltSuperHyperMod,
+    shiftControlAltSuperMod,
+    shiftControlAltgrMod,
+    shiftControlHyperAltgrMod,
+    shiftControlHyperMod,
+    shiftControlMod,
+    shiftControlSuperAltgrMod,
+    shiftControlSuperHyperAltgrMod,
+    shiftControlSuperHyperMod,
+    shiftControlSuperMod,
+    shiftHyperAltgrMod,
+    shiftHyperMod,
+    shiftMod,
+    shiftSuperAltgrMod,
+    shiftSuperHyperAltgrMod,
+    shiftSuperHyperMod,
+    shiftSuperMod,
+    superAltgrMod,
+    superHyperAltgrMod,
+    superHyperMod,
+    superMask,
+    superMod,
+  )
+where
 
 import Control.Arrow (first, second)
 import Control.Monad (void)
 import Control.Monad.State (State (..), execState, get, modify')
 import Control.Monad.Writer
 import Data.Bits ((.&.))
-import Data.List
+import Data.List hiding (group)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Text.Printf
@@ -28,7 +116,7 @@ data ButtonBinding
 
 -- Window -> X ()
 
-type ButtonBindings = Map (KeyMask, Button) ButtonBinding
+type ButtonBindings = Map (KeyMask, Button) (Documented ButtonBinding)
 
 {- Module that defines a DSL for binding keys. -}
 newtype KeysM l a = KeysM (State (XConfig l, KeyBindings) a)
@@ -57,8 +145,8 @@ class Binding k b where
   rawMask :: KeyMask -> k -> BindingBuilder b ()
   rawMask m x = BindingBuilder $ modify' (second ((m, toB x) :))
 
-instance Binding (Window -> X ()) ButtonBinding where
-  toB = ButtonAction
+instance Binding (Window -> X ()) (Documented ButtonBinding) where
+  toB = Documented "" . ButtonAction
 
 instance Binding (X ()) (Documented KeyBinding) where
   toB = Documented "" . Action
@@ -72,7 +160,19 @@ instance Binding a (Documented a) where
 instance Binding a a where
   toB = id
 
-doc :: (Binding k (Documented KeyBinding)) => String -> k -> Documented KeyBinding
+-- Relationships to witness which types can be used with the "doc" function,
+-- which is used to document actions in a safe and programmable way..
+class Relation k b | k -> b
+
+instance Relation (X ()) KeyBinding
+
+instance Relation KeyBinding KeyBinding
+
+instance Relation ButtonBinding ButtonBinding
+
+instance Relation (Window -> X ()) ButtonBinding
+
+doc :: (Relation k b, Binding k (Documented b)) => String -> k -> Documented b
 doc str k = let (Documented _ t) = toB k in Documented str t
 
 runKeys :: KeysM l a -> XConfig l -> KeyBindings
@@ -128,7 +228,7 @@ instance Bindable KeySym where
           flip (<>) (Map.fromList (map (\(m, v) -> ((m, key), v)) values))
 
 instance Bindable Button where
-  type BindableValue Button = ButtonBinding
+  type BindableValue Button = Documented ButtonBinding
   type BindableMonad Button = ButtonsM
 
   -- bind :: KeySym -> BindingBuilder (Window -> X ()) a -> ButtonsM l ()
@@ -397,75 +497,47 @@ altgrMod = maskMod altgrMask
   BindingBuilder b ()
 (-|-) fn1 fn2 f = fn1 f >> fn2 f
 
-{- Meant for submapping, binds all alphanumeric charactes to (fn c). -}
-mapNumbersAndAlpha :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapNumbersAndAlpha km fn = do
-  mapNumbers km fn
-  mapAlpha km fn
-
-{- Meant for submapping. This binds all numbers to (fn x) where x is the number
- - pressed and fn is the function provided. -}
-mapNumbers :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapNumbers km fn = do
-  mapM_
-    (\(key, ch) -> bind key $ rawMask km (fn ch))
-    [ (xK_0, '0'),
-      (xK_1, '1'),
-      (xK_2, '2'),
-      (xK_3, '3'),
-      (xK_4, '4'),
-      (xK_5, '5'),
-      (xK_6, '6'),
-      (xK_7, '7'),
-      (xK_8, '8'),
-      (xK_9, '9'),
-      -- Programmer Dvorak shifts the numbers so I have to map to their unshifted
-      -- form.
-      (xK_bracketright, '6'),
-      (xK_exclam, '8'),
-      (xK_bracketleft, '7'),
-      (xK_braceleft, '5'),
-      (xK_braceright, '3'),
-      (xK_parenleft, '1'),
-      (xK_equal, '9'),
-      (xK_asterisk, '0'),
-      (xK_parenright, '2'),
-      (xK_plus, '4')
-    ]
-
-{- Meant for submapping. This binds all alpha charactes to (fn c) where c is the
- - character pressed and fn is the function provided. -}
-mapAlpha :: KeyMask -> (Char -> X ()) -> KeysM l ()
-mapAlpha km fn =
-  mapM_
-    (\(key, ch) -> bind key $ rawMask km (fn ch))
-    [ (xK_a, 'a'),
-      (xK_b, 'b'),
-      (xK_c, 'c'),
-      (xK_d, 'd'),
-      (xK_e, 'e'),
-      (xK_f, 'f'),
-      (xK_g, 'g'),
-      (xK_h, 'h'),
-      (xK_i, 'i'),
-      (xK_j, 'j'),
-      (xK_k, 'k'),
-      (xK_l, 'l'),
-      (xK_m, 'm'),
-      (xK_n, 'n'),
-      (xK_o, 'o'),
-      (xK_p, 'p'),
-      (xK_q, 'q'),
-      (xK_r, 'r'),
-      (xK_s, 's'),
-      (xK_t, 't'),
-      (xK_u, 'u'),
-      (xK_v, 'v'),
-      (xK_w, 'w'),
-      (xK_x, 'x'),
-      (xK_y, 'y'),
-      (xK_z, 'z')
-    ]
+buttonDocumentation :: ButtonBindings -> String
+buttonDocumentation = execWriter . document' ""
+  where
+    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
+          ButtonAction _ -> return ()
+          ButtonSubmap submap -> document' (pref ++ "  ") submap
+          ButtonContinuous submap -> do
+            tell pref
+            tell "  (repeatable):\n"
+            document' (pref ++ "    ") submap
+
+    keyBindingsToList :: ButtonBindings -> Map String (ButtonBinding, [(ButtonMask, Button)])
+    keyBindingsToList b =
+      (\list -> ((\(_, Documented _ t) -> t) (head list), map fst list))
+        <$> group (\(_, Documented doc _) -> doc) (sortOn (snd . fst) $ Map.toList b)
+
+    prettyShow :: (ButtonMask, Button) -> String
+    prettyShow (mask, button) = printf "%s%s" (showMask mask) (buttonToString button)
+
+    buttonToString = \case
+      1 -> "Left Click"
+      2 -> "Middle Click"
+      3 -> "Right Click"
+      4 -> "Wheel Up"
+      5 -> "Wheel Down"
+      6 -> "Wheel Left"
+      7 -> "Wheel Right"
+      8 -> "Browser Back"
+      9 -> "Browser Forward"
+      13 -> "Thumb Target"
+      14 -> "Index Forward"
+      15 -> "Index Back"
+      b -> "Button " ++ show b
+
+    hasSubmap b = case b of
+      ButtonAction _ -> False
+      _ -> True
 
 documentation :: KeyBindings -> String
 documentation = execWriter . document' ""
@@ -494,17 +566,17 @@ documentation = execWriter . document' ""
       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])))
+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])))