More consistent handling with button mapping.

Button mapping is now similar in architecture to KeyMapping. As a
consequence it works with the pending buffer.

3 files changed, 82 insertions, 41 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index 4fdddac..49fe1fb 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -692,28 +692,51 @@ keymap = runKeys $ do
     justMod $ spawnX "set-backlight.sh 0.01"
     rawMask shiftMask $ spawnX "set-backlight.sh 0"
 
-mouseMap :: ButtonsMap l
+buttonBindingsToButtonMap :: (XConfig l -> ButtonBindings) -> ButtonsMap l
+buttonBindingsToButtonMap bindings config = Map.mapWithKey bindingToX (bindings config)
+  where
+    bindingToX :: (ButtonMask, Button) -> ButtonBinding -> (Window -> X ())
+    bindingToX click@(mask, btn) = \case
+      (ButtonAction action) -> action
+      (ButtonSubmap sm) ->
+        pushAddPendingBuffer (printf "b%d " btn)
+          . submapButtonsWithKey (\_ _ -> return ()) (Map.mapWithKey bindingToX sm)
+      (ButtonContinuous sm) -> \window ->
+        pushAddPendingBuffer (printf "b%d " btn) $ do
+          mapM_ (flip (bindingToX click) window) (Map.lookup click sm)
+          fix $ \recur -> do
+            submapButtonsWithKey
+              ( \_ _ -> return ()
+              )
+              ( Map.mapWithKey
+                  ( \k b w ->
+                      pushAddPendingBuffer (printf "b%d " (snd k)) $
+                        bindingToX k b w >> recur
+                  )
+                  sm
+              )
+              window
+
+mouseMap :: forall l. XConfig l -> ButtonBindings
 mouseMap = runButtons $ do
   config <- getConfig
 
-  let x button = Map.lookup button (mouseMap config)
+  -- let x button = Map.lookup button (mouseMap config)
 
-  let defaultButtons button =
-        fromMaybe (\w -> return ()) $
-          Map.lookup button (mouseMap config)
-      subMouse = submapButtonsWithKey defaultButtons . flip runButtons config
+  -- let defaultButtons button =
+  --       fromMaybe (\w -> return ()) $
+  --         Map.lookup button (mouseMap config)
+  let subMouse = ButtonSubmap . flip runButtons config
 
-  let continuous :: [(Button, X ())] -> Button -> Window -> X ()
-      continuous actions button w = do
-        case find ((== button) . fst) actions of
-          Just (_, action) -> action
-          Nothing -> return ()
+      continuous buttons = do
+        let bindingMap = runButtons buttons config
+         in forM_ (Map.toList bindingMap) $ \((m, b), _) -> do
+              bind b $
+                rawMask m $
+                  ButtonContinuous bindingMap
 
-        ( subMouse $
-            forM_ (map fst actions) $ \b ->
-              bind b $ noMod $ \w -> continuous actions b w
-          )
-          w
+      action :: X () -> (Window -> X ())
+      action = const
 
   bind button1 $ do
     justMod $ \w -> focus w >> mouseMoveWindow w >> windows W.shiftMaster
@@ -754,17 +777,18 @@ mouseMap = runButtons $ do
           noMod $ noWindow $ spawnX "pavucontrol"
 
         let mediaButtons =
-              [ (button4, increaseVolume),
-                (button5, decreaseVolume),
-                (button2, playPause),
-                (button9, historyForward),
-                (button8, historyBack),
-                (button6, mediaPrev),
-                (button7, mediaNext)
+              [ (button4, action increaseVolume),
+                (button5, action decreaseVolume),
+                (button2, action playPause),
+                (button9, action historyForward),
+                (button8, action historyBack),
+                (button6, action mediaPrev),
+                (button7, action mediaNext)
               ]
 
-        forM_ (map fst mediaButtons) $ \b ->
-          bind b $ noMod $ continuous mediaButtons b
+        continuous $
+          forM_ mediaButtons $ \(b, a) ->
+            bind b $ noMod a
 
   bind button13 $
     noMod $
@@ -774,12 +798,13 @@ mouseMap = runButtons $ do
         bind button3 $ noMod mouseResizeWindow
 
         let swapButtons =
-              [ (button6, windows W.swapDown),
-                (button7, windows W.swapUp)
+              [ (button6, action $ windows W.swapDown),
+                (button7, action $ windows W.swapUp)
               ]
 
-        forM_ (map fst swapButtons) $ \b ->
-          bind b $ noMod $ \w -> click >> continuous swapButtons b w
+        continuous $
+          forM_ swapButtons $ \(b, a) ->
+            bind b $ noMod a
 
         bind button13 $
           noMod $
@@ -805,17 +830,18 @@ mouseMap = runButtons $ do
           noMod $ noWindow jumpToLastLocation
 
         let workspaceButtons =
-              [ (button2, swapMaster),
-                (button9, viewAdjacent next),
-                (button8, viewAdjacent prev),
-                (button4, windows W.focusUp),
-                (button5, windows W.focusDown),
-                (button7, windows W.screenRotateForward),
-                (button6, windows W.screenRotateBackward)
+              [ (button2, action swapMaster),
+                (button9, action $ viewAdjacent next),
+                (button8, action $ viewAdjacent prev),
+                (button4, action $ windows W.focusUp),
+                (button5, action $ windows W.focusDown),
+                (button7, action $ windows W.screenRotateForward),
+                (button6, action $ windows W.screenRotateBackward)
               ]
 
-        forM_ (map fst workspaceButtons) $ \b ->
-          bind b $ noMod $ continuous workspaceButtons b
+        continuous $
+          forM_ workspaceButtons $ \(b, a) ->
+            bind b $ noMod a
 
 -- Bindings specific to a window. These are set similarly to th ekeymap above,
 -- but uses a Query monad to tell which windows the keys will apply to.
@@ -943,7 +969,12 @@ windowBindings xconfig =
 
 applyKeys :: XConfig l -> IO (XConfig l)
 applyKeys config =
-  return $ windowBindings $ config {keys = keyBindingToKeymap keymap, mouseBindings = mouseMap}
+  return $
+    windowBindings $
+      config
+        { keys = keyBindingToKeymap keymap,
+          mouseBindings = buttonBindingsToButtonMap mouseMap
+        }
 
 click :: X ()
 click = do
diff --git a/src/Rahm/Desktop/Keys/Dsl.hs b/src/Rahm/Desktop/Keys/Dsl.hs
index adb2668..7f06a74 100644
--- a/src/Rahm/Desktop/Keys/Dsl.hs
+++ b/src/Rahm/Desktop/Keys/Dsl.hs
@@ -21,7 +21,12 @@ data KeyBinding
 
 type KeyBindings = Map (KeyMask, KeySym) (Documented KeyBinding)
 
-type ButtonBinding = Window -> X ()
+data ButtonBinding
+  = ButtonAction (Window -> X ())
+  | ButtonSubmap ButtonBindings
+  | ButtonContinuous ButtonBindings
+
+-- Window -> X ()
 
 type ButtonBindings = Map (KeyMask, Button) ButtonBinding
 
@@ -52,6 +57,9 @@ 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 (X ()) (Documented KeyBinding) where
   toB = Documented "" . Action
 
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index aabc35b..ca767e3 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -21,6 +21,8 @@ import qualified Data.Map as Map
 import Data.Time.Clock.POSIX
 import Data.Word (Word64)
 import Rahm.Desktop.Common
+import Rahm.Desktop.XMobarLog.PendingBuffer
+import Text.Printf (printf)
 import XMonad hiding (keys)
 
 currentTimeMillis :: IO Int
@@ -154,7 +156,7 @@ submapButtonsWithKey ::
 submapButtonsWithKey defaultAction actions window = do
   maybe
     (return ())
-    ( \arg ->
+    ( \arg@(_, button) ->
         case Map.lookup arg actions of
           Nothing -> defaultAction arg window
           Just fn -> fn window