1 files changed, 104 insertions, 0 deletions
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
new file mode 100644
index 0000000..f3b9e23
--- /dev/null
+++ b/src/Rahm/Desktop/Submap.hs
@@ -0,0 +1,104 @@
+module Rahm.Desktop.Submap (
+    mapNextString,
+    mapNextStringWithKeysym,
+    submapButtonsWithKey,
+    nextButton,
+    nextMotion,
+    nextMotionOrButton,
+    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
+
+{-
+ - Like submap fram XMonad.Actions.Submap, but sends the string from
+ - XLookupString to the function along side the keysym.
+ -
+ - This function allows mappings where the mapped string might be important,
+ - but also allows submappings for keys that may not have a character associated
+ - with them (for example, the function keys).
+ -}
+mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X a) -> X a
+mapNextStringWithKeysym fn = do
+  XConf { theRoot = root, display = d } <- ask
+  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+
+  (m, str, keysym) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do
+    maskEvent d keyPressMask p
+    KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p
+    keysym <- keycodeToKeysym d code 0
+    (_, str) <- lookupString (asKeyEvent p)
+
+    if isModifierKey keysym
+        then nextkey
+        else return (m, str, keysym)
+
+  io $ ungrabKeyboard d currentTime
+
+  fn m keysym str
+
+{- Like submap, but on the character typed rather than the kysym. -}
+mapNextString :: (KeyMask -> String -> X a) -> X a 
+mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
+
+{- Grabs the mouse and returns the next button press. -}
+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
+
+{- Grabs the mouse and reports the next mouse motion. -}
+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
+
+{- Grabs the mouse and reports the next mouse motion or button press. -}
+nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button))
+nextMotionOrButton = do
+  XConf { theRoot = root, display = d } <- ask
+  io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- io $ allocaXEvent $ \xEv -> do
+    maskEvent d (pointerMotionMask .|. buttonPressMask) xEv
+    ev <- getEvent xEv
+    case ev of
+      MotionEvent { ev_x = x, ev_y = y } ->
+        return $ Left (fromIntegral x, fromIntegral y)
+      ButtonEvent { ev_button = button, ev_state = m } ->
+        return $ Right (m, button)
+
+  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