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
|
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to
-- bind certain actions to other actions.
module Montis.Dsl.Bind
( bind,
(.+),
MatchEvent (..),
MatchModifiers (..),
Modifier (..),
released,
weak,
run,
modifierToMask,
module X,
)
where
import Control.Monad
import Data.Bits
import Data.Word
import Montis.Core.ButtonEvent (ButtonEvent(..))
import qualified Montis.Core.ButtonEvent as ButtonEvent
import Montis.Core.KeyEvent (KeyEvent(..))
import qualified Montis.Core.KeyEvent as KeyEvent
import Montis.Core.W
import Montis.Dsl.Buttons as X
import Montis.Dsl.Input
class MatchEvent m where
matches :: m -> InputEvent -> W Bool
instance MatchEvent (InputEvent -> W Bool) where
matches = ($)
instance MatchEvent Char where
matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch
matches _ _ = return False
instance MatchEvent Button where
matches (Button b) (InputButtonEvent be) =
return $ ButtonEvent.button be == b
matches _ _ = return False
-- | Enumeration of possible modifiers.
--
-- ModX can be used for extra user-defined modifiers which are not standard xkb
-- modifiers.
data Modifier
= Shift
| Lock
| Control
| Mod1
| Mod2
| Mod3
| Mod4
| Mod5
| ModX Int
deriving (Eq, Ord, Show, Read)
-- | Converts a modifier to its associated mask.
modifierToMask :: Modifier -> Word32
modifierToMask m =
1
`shiftL` case m of
Shift -> 0
Lock -> 1
Control -> 2
Mod1 -> 3
Mod2 -> 4
Mod3 -> 5
Mod4 -> 6
Mod5 -> 7
ModX b -> b + 8
released :: (MatchEvent m) => m -> InputEvent -> W Bool
released me ev | not (isPressEvent ev) = matches me ev
released _ _ = return False
data MatchModifiers = MatchModifiers
{ weakModifierMatch :: Bool,
modifierMask :: Word32,
baseMatch :: InputEvent -> W Bool
}
instance MatchEvent MatchModifiers where
matches (MatchModifiers weakMatch bits base) ev = do
mods <- getMods ev
b <- liftW $ base ev
return $
b
&& ( (not weakMatch && mods == bits)
|| (weakMatch && (bits .&. mods == bits))
)
where
getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods
getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods
class LiftMatchModifiers a where
toModifiers :: a -> MatchModifiers
default toModifiers :: (MatchEvent a) => a -> MatchModifiers
toModifiers = MatchModifiers False 0 . matches
instance LiftMatchModifiers MatchModifiers where
toModifiers = id
instance LiftMatchModifiers Char
instance LiftMatchModifiers Button
-- toModifiers ch = MatchModifiers False 0 (matches ch)
(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers
(.+) modifier (toModifiers -> (MatchModifiers b mask base)) =
MatchModifiers b (mask .|. modifierToMask modifier) base
infixr 9 .+
bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy ()
bind ev match action = do
matches' <- liftW $ matches match ev
when matches' (action >> continue)
weak :: MatchModifiers -> MatchModifiers
weak m = m {weakModifierMatch = True}
run :: W () -> InputM spy ()
run = liftW
|
