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
Direction(..),
mouseGestureH,
mouseGesture,
mkCollect
) where
import XMonad
import XMonad.Layout.WindowNavigation (Direction(..))
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 -> Direction
dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromIntegral $ bx - ax)
where
trans :: Double -> Direction
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 :: (Direction -> X ()) -> Pos -> IORef (Maybe (Direction, 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 :: (Direction -> 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 [Direction] (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 (Direction -> m' [Direction], m' [Direction])
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)
|
