    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Actions.MouseGestures
    -- Copyright   :  (c) Lukas Mai
    -- License     :  BSD3-style (see LICENSE)
    --
    -- Maintainer  :  <l.mai@web.de>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- Support for simple mouse gestures.
    --
    -----------------------------------------------------------------------------

    module XMonad.Actions.MouseGestures (
        -- * Usage
        -- $usage
        Direction2D(..),
        mouseGestureH,
        mouseGesture,
        mkCollect
    ) where

    import XMonad
    import XMonad.Util.Types (Direction2D(..))

    import Data.IORef
    import qualified Data.Map as M
    import Data.Map (Map)
    import Data.Maybe
    import Control.Monad

    -- $usage
    --
    -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
    --
    -- > import XMonad.Actions.MouseGestures
    -- > import qualified XMonad.StackSet as W
    --
    -- then add an appropriate mouse binding:
    --
    -- >     , ((modm .|. shiftMask, button3), mouseGesture gestures)
    --
    -- where @gestures@ is a 'Data.Map.Map' from gestures to actions on
    -- windows, for example:
    --
    -- >     gestures = M.fromList
    -- >         [ ([], focus)
    -- >         , ([U], \w -> focus w >> windows W.swapUp)
    -- >         , ([D], \w -> focus w >> windows W.swapDown)
    -- >         , ([R, D], \_ -> sendMessage NextLayout)
    -- >         ]
    --
    -- This is just an example, of course; you can use any mouse button and
    -- gesture definitions you want.
    --
    -- For detailed instructions on editing your mouse bindings, see
    -- "XMonad.Doc.Extending#Editing_mouse_bindings".

    type Pos = (Position, Position)

    delta :: Pos -> Pos -> Position
    delta (ax, ay) (bx, by) = max (d ax bx) (d ay by)
        where
        d a b = abs (a - b)

    dir :: Pos -> Pos -> Direction2D
    dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromIntegral $ bx - ax)
        where
        trans :: Double -> Direction2D
        trans x
            | rg (-3/4) (-1/4) x = D
            | rg (-1/4)  (1/4) x = R
            | rg  (1/4)  (3/4) x = U
            | otherwise          = L
        rg a z x = a <= x && x < z

    gauge :: (Direction2D -> X ()) -> Pos -> IORef (Maybe (Direction2D, Pos)) -> Position -> Position -> X ()
    gauge hook op st nx ny = do
        let np = (nx, ny)
        stx <- io $ readIORef st
        let
            (~(Just od), pivot) = case stx of
                Nothing -> (Nothing, op)
                Just (d, zp) -> (Just d, zp)
            cont = do
                guard $ significant np pivot
                return $ do
                    let d' = dir pivot np
                    when (isNothing stx || od /= d') $ hook d'
                    io $ writeIORef st (Just (d', np))
        fromMaybe (return ()) cont
        where
        significant a b = delta a b >= 10

    -- | @'mouseGestureH' moveHook endHook@ is a mouse button
    -- event handler. It collects mouse movements, calling @moveHook@ for each
    -- update; when the button is released, it calls @endHook@.
    mouseGestureH :: (Direction2D -> X ()) -> X () -> X ()
    mouseGestureH moveHook endHook = do
        dpy <- asks display
        root <- asks theRoot
        (pos, acc) <- io $ do
            (_, _, _, ix, iy, _, _, _) <- queryPointer dpy root
            r <- newIORef Nothing
            return ((fromIntegral ix, fromIntegral iy), r)
        mouseDrag (gauge moveHook pos acc) endHook

    -- | A utility function on top of 'mouseGestureH'. It uses a 'Data.Map.Map' to
    -- look up the mouse gesture, then executes the corresponding action (if any).
    mouseGesture :: Map [Direction2D] (Window -> X ()) -> Window -> X ()
    mouseGesture tbl win = do
        (mov, end) <- mkCollect
        mouseGestureH (\d -> mov d >> return ()) $ end >>= \gest ->
            case M.lookup gest tbl of
                Nothing -> return ()
                Just f -> f win

    -- | A callback generator for 'mouseGestureH'. 'mkCollect' returns two
    -- callback functions for passing to 'mouseGestureH'. The move hook will
    -- collect mouse movements (and return the current gesture as a list); the end
    -- hook will return a list of the completed gesture, which you can access with
    -- 'Control.Monad.>>='.
    mkCollect :: (MonadIO m, MonadIO m') => m (Direction2D -> m' [Direction2D], m' [Direction2D])
    mkCollect = liftIO $ do
        acc <- newIORef []
        let
            mov d = liftIO $ do
                ds <- readIORef acc
                let ds' = d : ds
                writeIORef acc ds'
                return $ reverse ds'
            end = liftIO $ do
                ds <- readIORef acc
                writeIORef acc []
                return $ reverse ds
        return (mov, end)