-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.MouseGestures
-- Description :  Support for simple mouse gestures.
-- 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.Prelude
import XMonad
import XMonad.Util.Types (Direction2D(..))

import Data.IORef
import qualified Data.Map as M
import Data.Map (Map)

-- $usage
--
-- You can use this module with the following in your @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 :: Pos -> Pos -> Position
delta (Position
ax, Position
ay) (Position
bx, Position
by) = forall a. Ord a => a -> a -> a
max (forall {a}. Num a => a -> a -> a
d Position
ax Position
bx) (forall {a}. Num a => a -> a -> a
d Position
ay Position
by)
    where
    d :: a -> a -> a
d a
a a
b = forall a. Num a => a -> a
abs (a
a forall {a}. Num a => a -> a -> a
- a
b)

dir :: Pos -> Pos -> Direction2D
dir :: Pos -> Pos -> Direction2D
dir (Position
ax, Position
ay) (Position
bx, Position
by) = Double -> Direction2D
trans forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi) forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => a -> a -> a
atan2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Position
ay forall {a}. Num a => a -> a -> a
- Position
by) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Position
bx forall {a}. Num a => a -> a -> a
- Position
ax)
    where
    trans :: Double -> Direction2D
    trans :: Double -> Direction2D
trans Double
x
        | forall {a}. Ord a => a -> a -> a -> Bool
rg (-Double
3forall a. Fractional a => a -> a -> a
/Double
4) (-Double
1forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
D
        | forall {a}. Ord a => a -> a -> a -> Bool
rg (-Double
1forall a. Fractional a => a -> a -> a
/Double
4)  (Double
1forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
R
        | forall {a}. Ord a => a -> a -> a -> Bool
rg  (Double
1forall a. Fractional a => a -> a -> a
/Double
4)  (Double
3forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
U
        | Bool
otherwise          = Direction2D
L
    rg :: a -> a -> a -> Bool
rg a
a a
z a
x = a
a forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
< a
z

gauge :: (Direction2D -> X ()) -> Pos -> IORef (Maybe (Direction2D, Pos)) -> Position -> Position -> X ()
gauge :: (Direction2D -> X ())
-> Pos
-> IORef (Maybe (Direction2D, Pos))
-> Position
-> Position
-> X ()
gauge Direction2D -> X ()
hook Pos
op IORef (Maybe (Direction2D, Pos))
st Position
nx Position
ny = do
    let np :: Pos
np = (Position
nx, Position
ny)
    Maybe (Direction2D, Pos)
stx <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe (Direction2D, Pos))
st
    let pivot :: Pos
pivot = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pos
op forall a b. (a, b) -> b
snd Maybe (Direction2D, Pos)
stx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Pos -> Pos -> Bool
significant Pos
np Pos
pivot) forall a b. (a -> b) -> a -> b
$ do
        let d' :: Direction2D
d' = Pos -> Pos -> Direction2D
dir Pos
pivot Pos
np
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Direction2D, Pos)
stx) forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Direction2D
d') forall a b. (a -> b) -> a -> b
$ Direction2D -> X ()
hook Direction2D
d'
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Direction2D, Pos))
st (forall a. a -> Maybe a
Just (Direction2D
d', Pos
np))
    where
    significant :: Pos -> Pos -> Bool
significant Pos
a Pos
b = Pos -> Pos -> Position
delta Pos
a Pos
b forall a. Ord a => a -> a -> Bool
>= Position
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 :: (Direction2D -> X ()) -> X () -> X ()
mouseGestureH Direction2D -> X ()
moveHook X ()
endHook = do
    Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Window
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    (Pos
pos, IORef (Maybe (Direction2D, Pos))
acc) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
        (Bool
_, Window
_, Window
_, CInt
ix, CInt
iy, CInt
_, CInt
_, Modifier
_) <- Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
dpy Window
root
        IORef (Maybe (Direction2D, Pos))
r <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ix, forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
iy), IORef (Maybe (Direction2D, Pos))
r)
    (Position -> Position -> X ()) -> X () -> X ()
mouseDrag ((Direction2D -> X ())
-> Pos
-> IORef (Maybe (Direction2D, Pos))
-> Position
-> Position
-> X ()
gauge Direction2D -> X ()
moveHook Pos
pos IORef (Maybe (Direction2D, Pos))
acc) X ()
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 :: Map [Direction2D] (Window -> X ()) -> Window -> X ()
mouseGesture Map [Direction2D] (Window -> X ())
tbl Window
win = do
    (Direction2D -> X [Direction2D]
mov, X [Direction2D]
end) <- forall (m :: * -> *) (m' :: * -> *).
(MonadIO m, MonadIO m') =>
m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect
    (Direction2D -> X ()) -> X () -> X ()
mouseGestureH (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction2D -> X [Direction2D]
mov) forall a b. (a -> b) -> a -> b
$ X [Direction2D]
end forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Direction2D]
gest ->
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Direction2D]
gest Map [Direction2D] (Window -> X ())
tbl of
            Maybe (Window -> X ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Window -> X ()
f -> Window -> X ()
f Window
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 :: forall (m :: * -> *) (m' :: * -> *).
(MonadIO m, MonadIO m') =>
m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    IORef [Direction2D]
acc <- forall a. a -> IO (IORef a)
newIORef []
    let
        mov :: Direction2D -> m [Direction2D]
mov Direction2D
d = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            [Direction2D]
ds <- forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
            let ds' :: [Direction2D]
ds' = Direction2D
d forall a. a -> [a] -> [a]
: [Direction2D]
ds
            forall a. IORef a -> a -> IO ()
writeIORef IORef [Direction2D]
acc [Direction2D]
ds'
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Direction2D]
ds'
        end :: m' [Direction2D]
end = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            [Direction2D]
ds <- forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
            forall a. IORef a -> a -> IO ()
writeIORef IORef [Direction2D]
acc []
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Direction2D]
ds
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall {m :: * -> *}. MonadIO m => Direction2D -> m [Direction2D]
mov, m' [Direction2D]
end)