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
|
module Rahm.Desktop.Submap (
mapNextString,
mapNextStringWithKeysym,
submapButtonsWithKey,
nextButton,
nextMotion,
nextMotionOrButton,
module X) where
import XMonad hiding (keys)
import Control.Monad.Fix (fix)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Concurrent (threadDelay)
import Data.Word (Word64)
import XMonad.Actions.Submap as X
getMaskEventWithTimeout ::
Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a)
getMaskEventWithTimeout timeout d mask fn =
allocaXEvent $ \ptr -> do
val <- getMaskEventWithTimeout' ptr timeout
if val
then Just <$> fn ptr
else return Nothing
where
getMaskEventWithTimeout' ptr t | t <= 0 = return False
getMaskEventWithTimeout' ptr timeout = do
b <- checkMaskEvent d mask ptr
if b
then return True
else threadDelay 10 >> getMaskEventWithTimeout' ptr (timeout - 10)
{-
- 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 -> X ()) -> X ()
mapNextStringWithKeysym fn = do
XConf { theRoot = root, display = d } <- ask
io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
ret <- io $ fix $ \nextkey -> do
ret <-
getMaskEventWithTimeout 150000 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
case ret of
Just (m, str, keysym) -> fn m keysym str
Nothing -> return ()
{- Like submap, but on the character typed rather than the kysym. -}
mapNextString :: (KeyMask -> String -> X ()) -> X ()
mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
{- Grabs the mouse and returns the next button press. -}
nextButton :: X (ButtonMask, Button)
nextButton = do
XConf { theRoot = root, display = d } <- ask
io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime
ret <- io $ allocaXEvent $ \xEv -> do
maskEvent d buttonPressMask xEv
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
arg <- nextButton
case Map.lookup arg actions of
Nothing -> defaultAction arg window
Just fn -> fn window
|
