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
|
{-# LANGUAGE ImpredicativeTypes #-}
-- | Small DSL for defining key bindings and nested sub-maps.
module Montis.Standard.Bindings.Dsl where
import Control.Monad.Loops (anyM)
import Data.Bits (shiftL, (.&.))
import Data.Word (Word32)
import Montis.Core (ButtonEvent (buttonEvent_button, buttonEvent_modifiers, buttonEvent_state), ButtonState (ButtonPressed), Config, KeyEvent (keyEvent_codepoint, keyEvent_modifiers), Montis (..), install)
import Montis.Standard.Bindings
import Montis.Standard.Bindings.Button
-- | A predicate over a key event.
class InputMatch a where
matches :: a -> InputEvent -> Montis Bool
instance InputMatch Char where
matches c (InputEvent (Left k)) = return $ keyEvent_codepoint k == c
matches _ _ = return False
-- | Modifier matches using wlroots bit positions.
data Modifier = Mod1 | Mod2 | Mod3 | Mod4 | Mod5 | Any | None
instance InputMatch Modifier where
matches Mod1 ev = return $ inputModifiers ev .&. (1 `shiftL` 3) /= 0
matches Mod2 ev = return $ inputModifiers ev .&. (1 `shiftL` 4) /= 0
matches Mod3 ev = return $ inputModifiers ev .&. (1 `shiftL` 5) /= 0
matches Mod4 ev = return $ inputModifiers ev .&. (1 `shiftL` 6) /= 0
matches Mod5 ev = return $ inputModifiers ev .&. (1 `shiftL` 7) /= 0
matches Any _ = return True
matches None ev = return $ inputModifiers ev == 0
instance InputMatch Button where
matches (Button b) (InputEvent (Right ev)) =
return $ buttonEvent_button ev == b && buttonEvent_state ev == ButtonPressed
matches _ _ = return False
inputModifiers :: InputEvent -> Word32
inputModifiers (InputEvent (Left k)) = keyEvent_modifiers k
inputModifiers (InputEvent (Right b)) = buttonEvent_modifiers b
-- | Actions run when a binding matches. Each action reports handled status.
class Action b where
run :: b -> Montis Bool
instance Action (Montis ()) where
run a = a >> return True
instance Action (InputEvent -> Montis ()) where
run f = subkeys (\e -> f e >> return True)
instance Action (KeyEvent -> Montis ()) where
run f =
subkeys
( \case
(InputEvent (Left k)) -> f k >> return True
_ -> return True
)
instance Action (ButtonEvent -> Montis ()) where
run f =
subkeys
( \case
(InputEvent (Right b)) -> f b >> return True
_ -> return True
)
-- | Submap to the first binding that matches.
instance Action [Binding] where
run bs = subkeys $ \ev ->
anyM
( \(Bind k a) -> do
m <- matches k ev
if m then run a >> return True else return False
)
bs
instance Action (Montis [Binding]) where
run mbs = do
bs <- mbs
run bs
-- | A single binding from a matcher to an action.
data Binding where
Bind :: forall k b. (InputMatch k, Action b) => k -> b -> Binding
-- | A matcher for key + modifier chords.
data ChordMatch where
ChordMatch :: forall k2 k1. (InputMatch k2, InputMatch k1) => k2 -> k1 -> ChordMatch
(.+) :: (InputMatch k1, InputMatch k2) => k1 -> k2 -> ChordMatch
(.+) = ChordMatch
instance InputMatch ChordMatch where
matches (ChordMatch a b) ev = do
ma <- matches a ev
mb <- matches b ev
return (ma && mb)
-- | Installs the bindings into a config as the starting key hook.
withBindings :: [Binding] -> Config Montis -> Config Montis
withBindings bs =
install
( InputsConfig
( \ev ->
anyM
( \(Bind k a) -> do
m <- matches k ev
if m then run a >> return True else return False
)
bs
)
)
|
