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
138
139
140
141
142
143
|
-----------------------------------------------------------------------------
-- |
-- 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(..),
mouseGesture,
mouseGestureH
) where
import XMonad
import Data.IORef
import qualified Data.Map as M
import Data.Map (Map)
import Control.Monad
import System.IO
-- $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".
-- | The four cardinal screen directions. A \"gesture\" is a sequence of
-- directions.
data Direction = L | U | R | D
deriving (Eq, Ord, Show, Read, Enum, Bounded)
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
debugging :: Int
debugging = 0
collect :: ([Direction] -> X ()) -> IORef (Pos, [(Direction, Pos, Pos)]) -> Position -> Position -> X ()
collect hook st nx ny = do
let np = (nx, ny)
stx@(op, ds) <- io $ readIORef st
let
stx' =
case ds of
[]
| insignificant np op -> stx
| otherwise -> (op, [(dir op np, np, op)])
(d, zp, ap_) : ds'
| insignificant np zp -> stx
| otherwise ->
let
d' = dir zp np
ds''
| d == d' = (d, np, ap_) : ds'
| otherwise = (d', np, zp) : ds
in (op, ds'')
when (debugging > 0)
. io . hPutStrLn stderr $ show "Mouse Gesture" ++ unwords (map show (extract stx')) ++ (if debugging > 1 then "; " ++ show op ++ "-" ++ show np else "")
hook (extract stx')
io $ writeIORef st stx'
where
insignificant a b = delta a b < 10
extract :: (Pos, [(Direction, Pos, Pos)]) -> [Direction]
extract (_, xs) = reverse . map (\(x, _, _) -> x) $ xs
-- | 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 =
mouseGestureH (const . const $ return ()) $ \win gest ->
case M.lookup gest tbl of
Nothing -> return ()
Just f -> f win
-- | @'mouseGestureH' moveHook endHook gestures window@ is a mouse button
-- event handler. It collects mouse movements, calling @moveHook@ for each
-- update; when the button is released, it calls @endHook@ with the resulting
-- gesture.
mouseGestureH :: (Window -> [Direction] -> X ()) -> (Window -> [Direction] -> X ()) -> Window -> X ()
mouseGestureH moveHook endHook win = withDisplay $ \dpy -> do
when (debugging > 1)
. io . hPutStrLn stderr $ "mouseGesture " ++ show (win, dpy)
root <- asks theRoot
let win' = if win == none then root else win
acc <- io $ do
qp@(_, _, _, ix, iy, _, _, _) <- queryPointer dpy win'
when (debugging > 1)
. hPutStrLn stderr $ show "queryPointer" ++ show qp
when (debugging > 1 && win' == none)
. hPutStrLn stderr $ show "mouseGesture" ++ "zomg none"
newIORef ((fromIntegral ix, fromIntegral iy), [])
mouseDrag (collect (moveHook win') acc) $ do
when (debugging > 0) . io . hPutStrLn stderr $ show ""
gest <- io $ liftM extract $ readIORef acc
endHook win' gest
|
