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
|
module Rahm.Desktop.Submap (
mapNextString,
mapNextStringWithKeysym,
submapButtonsWithKey,
nextButton,
nextMotion,
nextMotionOrButton,
submap,
submapDefault,
submapDefaultWithKey) where
import XMonad hiding (keys)
import Control.Monad.Fix (fix)
import Control.Monad (void)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Concurrent (threadDelay)
import Data.Word (Word64)
import Data.Time.Clock.POSIX
import Rahm.Desktop.RebindKeys
import Data.Set (Set, (\\))
import qualified Data.Set as Set
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
data KeysToGrab = OnlyKeys [(KeyMask, KeySym)] | AllKeys
grabKeys :: KeysToGrab -> X ()
grabKeys AllKeys = do
XConf { theRoot = root, display = d } <- ask
void $ io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
grabKeys (OnlyKeys (Set.fromList -> keys)) = do
ks <- (Set.fromList . Map.keys) <$> asks keyActions
let keysToGrab = keys \\ ks -- Avoid grabbing already bound keys
XConf { theRoot = root, display = d } <- ask
mapM_ (doGrab d root) keysToGrab
ungrabKeys :: KeysToGrab -> X ()
ungrabKeys AllKeys = do
XConf { display = d } <- ask
io $ ungrabKeyboard d currentTime
ungrabKeys (OnlyKeys (Set.fromList -> keys)) = do
ks <- (Set.fromList . Map.keys) <$> asks keyActions
let keysToUngrab = keys \\ ks -- Don't ungrab unbound keys!
XConf { display = d, theRoot = root } <- ask
mapM_ (doUngrab d root) keysToUngrab
{-
-
- 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).
-}
mapNextStringWithKeysymOnlyGrabbing :: KeysToGrab -> (KeyMask -> KeySym -> String -> X ()) -> X ()
mapNextStringWithKeysymOnlyGrabbing keysToGrab fn = do
XConf { theRoot = root, display = d } <- ask
grabKeys keysToGrab
ret <- io $ fix $ \nextkey -> do
ret <-
getMaskEventWithTimeout 1000 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
ungrabKeys keysToGrab
case ret of
Just (m, str, keysym) -> fn m keysym str
Nothing -> return ()
mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> X ()) -> X ()
mapNextStringWithKeysym = mapNextStringWithKeysymOnlyGrabbing AllKeys
{- Like submap, but on the character typed rather than the kysym. -}
mapNextString :: (KeyMask -> String -> X ()) -> X ()
mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s)
submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X ()
submapDefaultWithKey def m =
mapNextStringWithKeysymOnlyGrabbing (OnlyKeys $ Map.keys m) $ \mask sym _ -> 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 ->
case Map.lookup arg actions of
Nothing -> defaultAction arg window
Just fn -> fn window) =<< nextButton
|
