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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
module Rahm.Desktop.Submap
( mapNextString,
mapNextStringWithKeysym,
submapButtonsWithKey,
nextButton,
nextMotion,
nextMotionOrButton,
submap,
submapDefault,
submapDefaultWithKey,
)
where
import Control.Concurrent (threadDelay)
import Control.Monad.Fix (fix)
import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import Data.Map (Map)
import qualified Data.Map as Map (findWithDefault, lookup)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word64)
import Rahm.Desktop.Common (runMaybeT_)
import XMonad
( Button,
ButtonMask,
Display,
Event (..),
KeyMask,
KeySym,
MonadReader (ask),
Window,
X,
XConf (..),
XEventPtr,
allocaXEvent,
asKeyEvent,
buttonPressMask,
checkMaskEvent,
currentTime,
getEvent,
grabKeyboard,
grabModeAsync,
grabPointer,
io,
isModifierKey,
keyPressMask,
keycodeToKeysym,
lookupString,
maskEvent,
pointerMotionMask,
ungrabKeyboard,
ungrabPointer,
(.|.),
)
currentTimeMillis :: IO Int
currentTimeMillis = round . (* 1000) <$> getPOSIXTime
getMaskEventWithTimeout ::
Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a)
getMaskEventWithTimeout timeout d mask fn = do
curTime <- currentTimeMillis
allocaXEvent $ \ptr -> do
val <- getMaskEventWithTimeout' ptr (curTime + timeout)
if val
then Just <$> fn ptr
else return Nothing
where
getMaskEventWithTimeout' ptr timeout = do
curTime <- currentTimeMillis
if curTime >= timeout
then return False
else do
b <- checkMaskEvent d mask ptr
if b
then return True
else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout
{-
- Like submap fram XMonad.Actions.Submap, but sends the string from
- XLookupString to the function along side the keysym.
-
- This function allows mappings where the mapped string might be important,
- but also allows submappings for keys that may not have a character associated
- with them (for example, the function keys).
-}
mapNextStringWithKeysym ::
(KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a
mapNextStringWithKeysym fn = do
XConf {theRoot = root, display = d} <- ask
io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
ret <- io $
fix $ \nextkey -> do
ret <-
getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do
KeyEvent {ev_keycode = code, ev_state = m} <- getEvent p
keysym <- keycodeToKeysym d code 0
(_, str) <- lookupString (asKeyEvent p)
return (m, str, keysym)
case ret of
Just (m, str, keysym) ->
if isModifierKey keysym
then nextkey
else return ret
Nothing -> return Nothing
io $ ungrabKeyboard d currentTime
(m, str, keysym) <- MaybeT $ return ret
fn m keysym str
{- Like submap, but on the character typed rather than the kysym. -}
mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a
mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X ()
submapDefaultWithKey def m = runMaybeT_ $
mapNextStringWithKeysym $ \mask sym _ -> lift $ do
Map.findWithDefault (def (mask, sym)) (mask, sym) m
submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X ()
submapDefault def = submapDefaultWithKey (const def)
submap :: Map (KeyMask, KeySym) (X ()) -> X ()
submap = submapDefault (return ())
-- Returns the next button press, or Nothing if the timeout expires before the
-- next button is pressed.
nextButton :: X (Maybe (ButtonMask, Button))
nextButton = do
XConf {theRoot = root, display = d} <- ask
io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
ret <- io $
getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do
ButtonEvent {ev_button = button, ev_state = m} <- getEvent xEv
return (m, button)
io $ ungrabPointer d currentTime
return ret
{- Grabs the mouse and reports the next mouse motion. -}
nextMotion :: X (Int, Int)
nextMotion = do
XConf {theRoot = root, display = d} <- ask
io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime
ret <- io $
allocaXEvent $ \xEv -> do
maskEvent d pointerMotionMask xEv
MotionEvent {ev_x = x, ev_y = y} <- getEvent xEv
return (fromIntegral x, fromIntegral y)
io $ ungrabPointer d currentTime
return ret
{- Grabs the mouse and reports the next mouse motion or button press. -}
nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button))
nextMotionOrButton = do
XConf {theRoot = root, display = d} <- ask
io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime
ret <- io $
allocaXEvent $ \xEv -> do
maskEvent d (pointerMotionMask .|. buttonPressMask) xEv
ev <- getEvent xEv
case ev of
MotionEvent {ev_x = x, ev_y = y} ->
return $ Left (fromIntegral x, fromIntegral y)
ButtonEvent {ev_button = button, ev_state = m} ->
return $ Right (m, button)
io $ ungrabPointer d currentTime
return ret
submapButtonsWithKey ::
((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X ()
submapButtonsWithKey defaultAction actions window = do
maybe
(return ())
( \arg@(_, button) ->
case Map.lookup arg actions of
Nothing -> defaultAction arg window
Just fn -> fn window
)
=<< nextButton
|
