From 444cf3dd778b2e688e06a6e174b8ee813c8f4c9b Mon Sep 17 00:00:00 2001
From: David Roundy <droundy@darcs.net>
Date: Tue, 7 Aug 2007 22:16:16 +0200
Subject: move event loop out of mouseDrag.

darcs-hash:20070807201616-72aca-80f5d15118592f79aca8a2e928c4ad4f29fdf8b1.gz
---
 Operations.hs | 44 ++++++++++++++++++++++++--------------------
 1 file changed, 24 insertions(+), 20 deletions(-)

(limited to 'Operations.hs')

diff --git a/Operations.hs b/Operations.hs
index 5654505..c8a9d7a 100644
--- a/Operations.hs
+++ b/Operations.hs
@@ -507,26 +507,30 @@ float w = withDisplay $ \d -> do
 -- Mouse handling
 
 -- | Accumulate mouse motion events
-mouseDrag :: (XMotionEvent -> IO ()) -> X ()
-mouseDrag f = do
-    XConf { theRoot = root, display = d } <- ask
-    io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
-            grabModeAsync grabModeAsync none none currentTime
-    io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop
-        maskEvent d (buttonReleaseMask .|. pointerMotionMask) p
-        et <- get_EventType p
-        when (et == motionNotify) $ get_MotionEvent p >>= f >> again
-    io $ ungrabPointer d currentTime
+mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
+mouseDrag f done = do
+    drag <- gets dragging
+    case drag of
+      Just _ -> return () -- error case? we're already dragging
+      Nothing -> do XConf { theRoot = root, display = d } <- ask
+                    io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
+                       grabModeAsync grabModeAsync none none currentTime
+                    let cleanup = do io $ ungrabPointer d currentTime
+                                     modify $ \s -> s { dragging = Nothing }
+                                     done
+                    modify $ \s -> s { dragging = Just (f, cleanup) }
 
 mouseMoveWindow :: Window -> X ()
 mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
     io $ raiseWindow d w
     wa <- io $ getWindowAttributes d w
-    (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w
-    mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) ->
-       moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
-                      (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))
-    float w
+    (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w
+    let ox = fromIntegral ox'
+        oy = fromIntegral oy'
+    mouseDrag (\ex ey -> do
+                 io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
+                                     (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))))
+              (float w)
 
 mouseResizeWindow :: Window -> X ()
 mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
@@ -534,11 +538,11 @@ mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
     wa <- io $ getWindowAttributes d w
     sh <- io $ getWMNormalHints d w
     io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))
-    mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) ->
-        resizeWindow d w `uncurry`
-             applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))),
-                                (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))))
-    float w
+    mouseDrag (\ex ey -> do
+                 io $ resizeWindow d w `uncurry`
+                    applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))),
+                                      (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))))
+              (float w)
 
 -- ---------------------------------------------------------------------
 -- | Support for window size hints
-- 
cgit v1.2.3