Add a Polling-style timeout to mapNextString.

It's not the best thing in the world, but it should help keep things in
a consistent state when dealing with many multi-stroke bindings.

1 files changed, 41 insertions, 12 deletions

diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index f3b9e23..5dc6fb0 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -11,9 +11,31 @@ import XMonad hiding (keys)
 import Control.Monad.Fix (fix)
 import qualified Data.Map as Map
 import Data.Map (Map)
+import Control.Concurrent (threadDelay)
+import Data.Word (Word64)
 
 import XMonad.Actions.Submap as X
 
+
+getMaskEventWithTimeout ::
+  Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a)
+
+getMaskEventWithTimeout timeout d mask fn =
+  allocaXEvent $ \ptr -> do
+    val <- getMaskEventWithTimeout' ptr timeout
+    if val
+      then Just <$> fn ptr
+      else return Nothing
+
+
+  where
+    getMaskEventWithTimeout' ptr t | t <= 0 = return False
+    getMaskEventWithTimeout' ptr timeout = do
+      b <- checkMaskEvent d mask ptr
+      if b
+        then return True
+        else threadDelay 10 >> getMaskEventWithTimeout' ptr (timeout - 10)
+
 {-
  - Like submap fram XMonad.Actions.Submap, but sends the string from
  - XLookupString to the function along side the keysym.
@@ -22,27 +44,34 @@ import XMonad.Actions.Submap as X
  - 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 :: (KeyMask -> KeySym -> String -> X ()) -> X ()
 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)
+  ret <- io $ fix $ \nextkey -> do
+    ret <-
+      getMaskEventWithTimeout 150000 d keyPressMask $ \p -> do
+        KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p
+        keysym <- keycodeToKeysym d code 0
+        (_, str) <- lookupString (asKeyEvent p)
+        return (m, str, keysym)
 
-    if isModifierKey keysym
-        then nextkey
-        else return (m, str, keysym)
+    case ret of
+      Just (m, str, keysym) ->
+        if isModifierKey keysym
+            then nextkey
+            else return ret
 
-  io $ ungrabKeyboard d currentTime
+      Nothing -> return Nothing
 
-  fn m keysym str
+  io $ ungrabKeyboard d currentTime
+  case ret of 
+    Just (m, str, keysym) -> fn m keysym str
+    Nothing -> return ()
 
 {- Like submap, but on the character typed rather than the kysym. -}
-mapNextString :: (KeyMask -> String -> X a) -> X a 
+mapNextString :: (KeyMask -> String -> X ()) -> X () 
 mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
 
 {- Grabs the mouse and returns the next button press. -}