Merge branch 'v017' of git.josher.dev:rde into v017

1 files changed, 45 insertions, 1 deletions

diff --git a/src/Internal/Submap.hs b/src/Internal/Submap.hs
index cdc2f95..e5968ff 100644
--- a/src/Internal/Submap.hs
+++ b/src/Internal/Submap.hs
@@ -1,7 +1,14 @@
-module Internal.Submap (mapNextString, module X) where
+module Internal.Submap (
+    mapNextString,
+    submapButtonsWithKey,
+    nextButton,
+    nextMotion,
+    module X) where
 
 import XMonad hiding (keys)
 import Control.Monad.Fix (fix)
+import qualified Data.Map as Map
+import Data.Map (Map)
 
 import XMonad.Actions.Submap as X
 
@@ -26,3 +33,40 @@ mapNextString fn = do
   io $ ungrabKeyboard d currentTime
 
   fn m str
+
+nextButton :: X (ButtonMask, Button)
+nextButton = do
+  XConf { theRoot = root, display = d } <- ask
+  io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- io $ allocaXEvent $ \xEv -> do
+    maskEvent d buttonPressMask xEv
+    ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv
+    return (m, button)
+
+  io $ ungrabPointer d currentTime
+
+  return ret
+
+nextMotion :: X (Int, Int)
+nextMotion = do
+  XConf { theRoot = root, display = d } <- ask
+  io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- io $ allocaXEvent $ \xEv -> do
+    maskEvent d pointerMotionMask xEv
+    MotionEvent { ev_x = x, ev_y = y } <- getEvent xEv
+    return (fromIntegral x, fromIntegral y)
+
+  io $ ungrabPointer d currentTime
+
+  return ret
+
+submapButtonsWithKey ::
+    ((ButtonMask, Button) -> Window -> X ()) -> (Map (ButtonMask, Button) (Window -> X ())) -> Window -> X ()
+submapButtonsWithKey defaultAction actions window = do
+  arg <- nextButton
+
+  case Map.lookup arg actions of
+    Nothing -> defaultAction arg window
+    Just fn -> fn window