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
|
module Montis.Standard.Bindings where
import Control.Monad (unless, when)
import Control.Monad.IO.Class (liftIO)
import Data.Data (Typeable)
import Data.Default.Class (Default (..))
import Data.Set qualified as Set
import Data.Word (Word32)
import Montis.Base.Foreign.WlRoots (seatKeyboardNotifyKey, seatPointerNotifyButton)
import Montis.Core.Events (ButtonEvent (..), ButtonState (..), KeyEvent (..), KeyState (..))
import Montis.Core.Monad (Montis, xConfigGet, xStateGet, xStateModify)
import Montis.Core.Runtime (getSeat)
import Montis.Core.State
( Config (startingHooks),
ConfigModule (..),
Hooks (keyHook, buttonHook),
StateExtension (..),
)
data InputEvent where
InputEvent :: Either KeyEvent ButtonEvent -> InputEvent
-- | Configuration for the keybindings.
data InputsConfig where
InputsConfig ::
{ startCont :: InputEvent -> Montis Bool
} ->
InputsConfig
deriving (Typeable)
instance Default InputsConfig where
def = InputsConfig $ \_ -> return False
subkeys :: (InputEvent -> Montis Bool) -> Montis Bool
subkeys fn = do
xStateModify $ \keyState ->
keyState
{ awaiting = Just fn
}
return True
-- | State of the keys right now.
data InputsState where
InputsState ::
{ awaiting :: Maybe (InputEvent -> Montis Bool),
ignoredKeys :: Set.Set Word32
} ->
InputsState
instance StateExtension InputsState where
initialValue = InputsState Nothing Set.empty
marshalExtension = const Nothing
demarshalExtension = const Nothing
-- | Configurable module for keys.
instance ConfigModule Montis InputsConfig where
alterConfig _ c =
let oh = keyHook (startingHooks c)
obh = buttonHook (startingHooks c)
in c
{ startingHooks =
(startingHooks c)
{ keyHook = \ev -> runEv (InputEvent (Left ev)) >> oh ev,
buttonHook = \ev -> runEv (InputEvent (Right ev)) >> obh ev
}
}
where
isKeyPress ev = keyEvent_state ev == KeyPressed
isKeyRelease ev = keyEvent_state ev == KeyReleased
shouldIgnoreEvent ev = do
InputsState {ignoredKeys} <- xStateGet
return $ Set.member (keyEvent_keycode ev) ignoredKeys
runEv :: InputEvent -> Montis ()
runEv iv@(InputEvent (Right ev)) = do
handler' <- awaiting <$> xStateGet
handler <- maybe (startCont <$> xConfigGet) return handler'
xStateModify $ \st ->
st {awaiting = Nothing}
handled <- handler iv
unless handled $
forwardButtonToSeat ev
runEv iv@(InputEvent (Left ev)) = do
shouldIgnore <- shouldIgnoreEvent ev
if isKeyRelease ev && shouldIgnore
then xStateModify $ \ks ->
ks {ignoredKeys = Set.delete (keyEvent_keycode ev) (ignoredKeys ks)}
else do
handled <-
if isKeyPress ev
then do
handler' <- awaiting <$> xStateGet
handler <- maybe (startCont <$> xConfigGet) return handler'
-- Reset the hadler.
xStateModify $ \st ->
st {awaiting = Nothing}
handler iv
else return False
if not handled
then forwardKeyToSeat ev
else when (isKeyPress ev) $
xStateModify $
\ks ->
ks
{ ignoredKeys =
Set.insert (keyEvent_keycode ev) (ignoredKeys ks)
}
forwardKeyToSeat :: KeyEvent -> Montis ()
forwardKeyToSeat ev = do
mseat <- getSeat
case mseat of
Nothing -> return ()
Just seat ->
liftIO $
seatKeyboardNotifyKey
seat
(keyEvent_timeMs ev)
(keyEvent_keycode ev)
(keyStateToWord32 (keyEvent_state ev))
forwardButtonToSeat :: ButtonEvent -> Montis ()
forwardButtonToSeat ev = do
mseat <- getSeat
case mseat of
Nothing -> return ()
Just seat ->
liftIO $
seatPointerNotifyButton
seat
(buttonEvent_timeMs ev)
(buttonEvent_button ev)
(buttonStateToWord32 (buttonEvent_state ev))
buttonStateToWord32 :: ButtonState -> Word32
buttonStateToWord32 ButtonReleased = 0
buttonStateToWord32 ButtonPressed = 1
keyStateToWord32 :: KeyState -> Word32
keyStateToWord32 KeyReleased = 0
keyStateToWord32 KeyPressed = 1
|
