Fix issue where pointer and keyboard were not being properly ungrabbed.

1 files changed, 30 insertions, 25 deletions

diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs
index 9c20381..246d85c 100644
--- a/src/Rahm/Desktop/Submap.hs
+++ b/src/Rahm/Desktop/Submap.hs
@@ -16,7 +16,7 @@ module Rahm.Desktop.Submap
 where
 
 import Control.Concurrent (threadDelay)
-import Control.Exception (SomeException (SomeException), catch)
+import Control.Exception (SomeException (SomeException), catch, finally)
 import Control.Monad (when)
 import Control.Monad.Fix (fix)
 import Control.Monad.Trans (MonadTrans (lift))
@@ -130,30 +130,35 @@ nextButtonOrKeyEvent = do
   when b (MaybeT (return Nothing))
 
   XConf {theRoot = root, display = d} <- ask
-  io $ do
-    grabKeyboard d root False grabModeAsync grabModeAsync currentTime
-    grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
-
-  ret <- MaybeT $
-    io $
-      fix $ \tryAgain -> do
-        ret <-
-          getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do
-            ev <- getEvent p
-            case ev of
-              ButtonEvent {ev_button = b, ev_state = m} ->
-                return $ ButtonPress m b
-              KeyEvent {ev_keycode = code, ev_state = m} -> do
-                keysym <- keycodeToKeysym d code 0
-                (_, str) <- lookupString (asKeyEvent p)
-                return $ KeyPress m keysym str
-        case ret of
-          Just (KeyPress m sym str) | isModifierKey sym -> tryAgain
-          x -> return x
-
-  io $ do
-    ungrabKeyboard d currentTime
-    ungrabPointer d currentTime
+
+  ret <-
+    MaybeT $
+      io $
+        ( do
+            grabKeyboard d root False grabModeAsync grabModeAsync currentTime
+            grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
+            fix
+              ( \tryAgain ->
+                  do
+                    ret <-
+                      getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do
+                        ev <- getEvent p
+                        case ev of
+                          ButtonEvent {ev_button = b, ev_state = m} ->
+                            return $ ButtonPress m b
+                          KeyEvent {ev_keycode = code, ev_state = m} -> do
+                            keysym <- keycodeToKeysym d code 0
+                            (_, str) <- lookupString (asKeyEvent p)
+                            return $ KeyPress m keysym str
+                    case ret of
+                      Just (KeyPress m sym str) | isModifierKey sym -> tryAgain
+                      x -> return x
+              )
+        )
+          `finally` ( do
+                        ungrabKeyboard d currentTime
+                        ungrabPointer d currentTime
+                    )
 
   m' <- lift $ cleanMask (event_mask ret)
   return ret {event_mask = m'}