aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Actions/MouseGestures.hs
blob: 49a7582eab7bf9b79822605ac452b93903847863 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
-----------------------------------------------------------------------------
-- |
-- 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:
--
-- >     , ((modMask x .|. 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)