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
|
module Rahm.Desktop.Submap (
mapNextString,
mapNextStringWithKeysym,
submapButtonsWithKey,
nextButton,
nextMotion,
nextMotionOrButton,
submap,
submapDefault,
submapDefaultWithKey) where
import Rahm.Desktop.Common
import Control.Monad.Trans.Maybe
import Control.Monad.Trans
import Control.Monad (void)
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 Data.Time.Clock.POSIX
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 2000 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 ->
case Map.lookup arg actions of
Nothing -> defaultAction arg window
Just fn -> fn window) =<< nextButton
|
