-----------------------------------------------------------------------------
-- |
-- 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\/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) = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max (Position -> Position -> Position
forall a. Num a => a -> a -> a
d Position
ax Position
bx) (Position -> Position -> Position
forall a. Num a => a -> a -> a
d Position
ay Position
by)
    where
    d :: a -> a -> a
d a
a a
b = a -> a
forall a. Num a => a -> a
abs (a
a a -> 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 (Double -> Direction2D)
-> (Double -> Double) -> Double -> Direction2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi) (Double -> Direction2D) -> Double -> Direction2D
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 (Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Double) -> Position -> Double
forall a b. (a -> b) -> a -> b
$ Position
ay Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
by) (Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Double) -> Position -> Double
forall a b. (a -> b) -> a -> b
$ Position
bx Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
ax)
    where
    trans :: Double -> Direction2D
    trans :: Double -> Direction2D
trans Double
x
        | Double -> Double -> Double -> Bool
forall a. Ord a => a -> a -> a -> Bool
rg (-Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
D
        | Double -> Double -> Double -> Bool
forall a. Ord a => a -> a -> a -> Bool
rg (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4)  (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
R
        | Double -> Double -> Double -> Bool
forall a. Ord a => a -> a -> a -> Bool
rg  (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4)  (Double
3Double -> Double -> Double
forall 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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x a -> a -> Bool
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 <- IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos)))
-> IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos))
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Direction2D, Pos)) -> IO (Maybe (Direction2D, Pos))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Direction2D, Pos))
st
    let
        (~(Just Direction2D
od), Pos
pivot) = case Maybe (Direction2D, Pos)
stx of
            Maybe (Direction2D, Pos)
Nothing -> (Maybe Direction2D
forall a. Maybe a
Nothing, Pos
op)
            Just (Direction2D
d, Pos
zp) -> (Direction2D -> Maybe Direction2D
forall a. a -> Maybe a
Just Direction2D
d, Pos
zp)
        cont :: Maybe (X ())
cont = do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Pos -> Pos -> Bool
significant Pos
np Pos
pivot
            X () -> Maybe (X ())
forall (m :: * -> *) a. Monad m => a -> m a
return (X () -> Maybe (X ())) -> X () -> Maybe (X ())
forall a b. (a -> b) -> a -> b
$ do
                let d' :: Direction2D
d' = Pos -> Pos -> Direction2D
dir Pos
pivot Pos
np
                Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Direction2D, Pos) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Direction2D, Pos)
stx Bool -> Bool -> Bool
|| Direction2D
od Direction2D -> Direction2D -> Bool
forall a. Eq a => a -> a -> Bool
/= Direction2D
d') (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Direction2D -> X ()
hook Direction2D
d'
                IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Direction2D, Pos))
-> Maybe (Direction2D, Pos) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe (Direction2D, Pos))
st ((Direction2D, Pos) -> Maybe (Direction2D, Pos)
forall a. a -> Maybe a
Just (Direction2D
d', Pos
np))
    X () -> Maybe (X ()) -> X ()
forall a. a -> Maybe a -> a
fromMaybe (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe (X ())
cont
    where
    significant :: Pos -> Pos -> Bool
significant Pos
a Pos
b = Pos -> Pos -> Position
delta Pos
a Pos
b Position -> Position -> Bool
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 <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Window
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
    (Pos
pos, IORef (Maybe (Direction2D, Pos))
acc) <- IO (Pos, IORef (Maybe (Direction2D, Pos)))
-> X (Pos, IORef (Maybe (Direction2D, Pos)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Pos, IORef (Maybe (Direction2D, Pos)))
 -> X (Pos, IORef (Maybe (Direction2D, Pos))))
-> IO (Pos, IORef (Maybe (Direction2D, Pos)))
-> X (Pos, IORef (Maybe (Direction2D, Pos)))
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 <- Maybe (Direction2D, Pos) -> IO (IORef (Maybe (Direction2D, Pos)))
forall a. a -> IO (IORef a)
newIORef Maybe (Direction2D, Pos)
forall a. Maybe a
Nothing
        (Pos, IORef (Maybe (Direction2D, Pos)))
-> IO (Pos, IORef (Maybe (Direction2D, Pos)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
ix, CInt -> Position
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) <- X (Direction2D -> X [Direction2D], X [Direction2D])
forall (m :: * -> *) (m' :: * -> *).
(MonadIO m, MonadIO m') =>
m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect
    (Direction2D -> X ()) -> X () -> X ()
mouseGestureH (X [Direction2D] -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X [Direction2D] -> X ())
-> (Direction2D -> X [Direction2D]) -> Direction2D -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction2D -> X [Direction2D]
mov) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ X [Direction2D]
end X [Direction2D] -> ([Direction2D] -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Direction2D]
gest ->
        case [Direction2D]
-> Map [Direction2D] (Window -> X ()) -> Maybe (Window -> X ())
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 -> () -> X ()
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 :: m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect = IO (Direction2D -> m' [Direction2D], m' [Direction2D])
-> m (Direction2D -> m' [Direction2D], m' [Direction2D])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Direction2D -> m' [Direction2D], m' [Direction2D])
 -> m (Direction2D -> m' [Direction2D], m' [Direction2D]))
-> IO (Direction2D -> m' [Direction2D], m' [Direction2D])
-> m (Direction2D -> m' [Direction2D], m' [Direction2D])
forall a b. (a -> b) -> a -> b
$ do
    IORef [Direction2D]
acc <- [Direction2D] -> IO (IORef [Direction2D])
forall a. a -> IO (IORef a)
newIORef []
    let
        mov :: Direction2D -> m [Direction2D]
mov Direction2D
d = IO [Direction2D] -> m [Direction2D]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Direction2D] -> m [Direction2D])
-> IO [Direction2D] -> m [Direction2D]
forall a b. (a -> b) -> a -> b
$ do
            [Direction2D]
ds <- IORef [Direction2D] -> IO [Direction2D]
forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
            let ds' :: [Direction2D]
ds' = Direction2D
d Direction2D -> [Direction2D] -> [Direction2D]
forall a. a -> [a] -> [a]
: [Direction2D]
ds
            IORef [Direction2D] -> [Direction2D] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Direction2D]
acc [Direction2D]
ds'
            [Direction2D] -> IO [Direction2D]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Direction2D] -> IO [Direction2D])
-> [Direction2D] -> IO [Direction2D]
forall a b. (a -> b) -> a -> b
$ [Direction2D] -> [Direction2D]
forall a. [a] -> [a]
reverse [Direction2D]
ds'
        end :: m' [Direction2D]
end = IO [Direction2D] -> m' [Direction2D]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Direction2D] -> m' [Direction2D])
-> IO [Direction2D] -> m' [Direction2D]
forall a b. (a -> b) -> a -> b
$ do
            [Direction2D]
ds <- IORef [Direction2D] -> IO [Direction2D]
forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
            IORef [Direction2D] -> [Direction2D] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [Direction2D]
acc []
            [Direction2D] -> IO [Direction2D]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Direction2D] -> IO [Direction2D])
-> [Direction2D] -> IO [Direction2D]
forall a b. (a -> b) -> a -> b
$ [Direction2D] -> [Direction2D]
forall a. [a] -> [a]
reverse [Direction2D]
ds
    (Direction2D -> m' [Direction2D], m' [Direction2D])
-> IO (Direction2D -> m' [Direction2D], m' [Direction2D])
forall (m :: * -> *) a. Monad m => a -> m a
return (Direction2D -> m' [Direction2D]
forall (m :: * -> *). MonadIO m => Direction2D -> m [Direction2D]
mov, m' [Direction2D]
end)