move event loop out of mouseDrag.

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

Operations.hs

@@ -507,26 +507,30 @@ float w = withDisplay $ \d -> do
 -- Mouse handling
 
 -- | Accumulate mouse motion events
-mouseDrag :: (XMotionEvent -> IO ()) -> X ()
+mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
-mouseDrag f = do
+mouseDrag f done = do
-    XConf { theRoot = root, display = d } <- ask
+    drag <- gets dragging
-    io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
+    case drag of
-            grabModeAsync grabModeAsync none none currentTime
+      Just _ -> return () -- error case? we're already dragging
-    io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop
+      Nothing -> do XConf { theRoot = root, display = d } <- ask
-        maskEvent d (buttonReleaseMask .|. pointerMotionMask) p
+                    io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
-        et <- get_EventType p
+                       grabModeAsync grabModeAsync none none currentTime
-        when (et == motionNotify) $ get_MotionEvent p >>= f >> again
+                    let cleanup = do io $ ungrabPointer d currentTime
-    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
+    (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w
-    mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) ->
+    let ox = fromIntegral ox'
-       moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
+        oy = fromIntegral oy'
-                      (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))
+    mouseDrag (\ex ey -> do
-    float w
+                 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, _, _, _, _, _) ->
+    mouseDrag (\ex ey -> do
-        resizeWindow d w `uncurry`
+                 io $ resizeWindow d w `uncurry`
-             applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))),
+                    applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))),
-                                (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))))
+                                      (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))))
-    float w
+              (float w)
 
 -- ---------------------------------------------------------------------
 -- | Support for window size hints

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