move event loop out of mouseDrag.

darcs-hash:20070807201616-72aca-80f5d15118592f79aca8a2e928c4ad4f29fdf8b1

3 files changed, 44 insertions, 22 deletions

diff --git a/Main.hs b/Main.hs
index efa7ab1..fc12bce 100644
--- a/Main.hs
+++ b/Main.hs
@@ -65,7 +65,8 @@ main = do
             { windowset     = winset
             , layouts       = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]]
             , mapped        = S.empty
-            , waitingUnmap  = M.empty }
+            , waitingUnmap  = M.empty
+            , dragging      = Nothing }
 
     xSetErrorHandler -- in C, I'm too lazy to write the binding: dons
 
@@ -183,6 +184,22 @@ handle e@(MappingNotifyEvent {ev_window = w}) = do
     io $ refreshKeyboardMapping e
     when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w
 
+-- handle button release, which may finish dragging.
+handle e@(ButtonEvent {ev_event_type = t})
+    | t == buttonRelease = do
+    drag <- gets dragging
+    case drag of
+      Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f
+          -- we're done dragging and have released the mouse
+      Nothing -> broadcastMessage e
+
+-- handle motionNotify event, which may mean we are dragging.
+handle e@(MotionEvent {ev_event_type = t, ev_x = x, ev_y = y}) = do
+    drag <- gets dragging
+    case drag of
+      Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging
+      Nothing -> broadcastMessage e
+
 -- click on an unfocused window, makes it focused on this workspace
 handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b })
     | t == buttonPress = do
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
diff --git a/XMonad.hs b/XMonad.hs
index 8eec7b1..28f763d 100644
--- a/XMonad.hs
+++ b/XMonad.hs
@@ -43,7 +43,8 @@ data XState = XState
     { windowset    :: !WindowSet           -- ^ workspace list
     , mapped       :: !(S.Set Window)      -- ^ the Set of mapped windows
     , waitingUnmap :: !(M.Map Window Int)  -- ^ the number of expected UnmapEvents
-    , layouts      :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) }
+    , layouts      :: !(M.Map WorkspaceId (Layout Window, [Layout Window]))
+    , dragging     :: !(Maybe (Position -> Position -> X (), X ())) }
                        -- ^ mapping of workspaces to descriptions of their layouts
 data XConf = XConf
     { display       :: Display      -- ^ the X11 display