-
Notifications
You must be signed in to change notification settings - Fork 17
/
Keyboard.purs
142 lines (120 loc) · 4.18 KB
/
Keyboard.purs
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
module Test.Keyboard where
import Concur.Core.Types (Widget)
import Concur.React (HTML, affAction)
import Concur.React.DOM as D
import Concur.React.Props as P
import Control.Alt ((<|>))
import Control.Applicative (pure)
import Control.Bind (bind, discard)
import Data.BooleanAlgebra (not)
import Data.Eq (class Eq, (==))
import Data.Function (($))
import Data.Maybe (Maybe(..))
import Data.Monoid ((<>))
import Data.Show (class Show, show)
import Data.Unit (Unit)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff.Compat (EffectFnAff, fromEffectFnAff)
import Effect.Class (liftEffect)
import React.SyntheticEvent as R
-- A virtual keyboard, that also demonstrates how to handle document level events
-- Main Widget ----------------------------------------------------
-- A never-ending virtual keypad widget.
-- Allows the user to navigate and select a key. Displays the selected key.
keypadWidget :: forall a. Widget HTML a
keypadWidget = go Enter "" <|> toggleEvents
where
go focus msg = do
keyPressed <- virtualKeyInput focus <|> D.div' [D.text msg]
go keyPressed $ "You clicked: " <> show keyPressed
-- On off button for key events
toggleEvents :: forall a. Widget HTML a
toggleEvents = go false
where
go enabled = do
_ <- D.button [P.onClick] [D.text $ if enabled then "stop listening" else "start listening"]
liftEffect (if enabled then stopListening else startListening)
go (not enabled)
-- Displays a keypad with the supplied initial focus.
-- Allows the user to navigate and select a key. Returns the selected key.
virtualKeyInput :: Focus -> Widget HTML Key
virtualKeyInput focus = do
evt <- affAction awaitKey <|> keypadButtons focus
key <- liftEffect $ toKey evt
case key of
Just Enter -> pure focus
Nothing -> virtualKeyInput focus
Just ArrowUp -> virtualKeyInput (transition focus U)
Just ArrowDown -> virtualKeyInput (transition focus D)
Just ArrowLeft -> virtualKeyInput (transition focus L)
Just ArrowRight -> virtualKeyInput (transition focus R)
-- Dispay only. Renders the keypad buttons with the supplied focus
keypadButtons :: forall a. Focus -> Widget HTML a
keypadButtons focus = D.table [spanstyle] $ pure $ D.tbody'
[ D.tr' [ blank, but ArrowUp, blank ]
, D.tr' [ but ArrowLeft, but Enter, but ArrowRight ]
, D.tr' [ blank, but ArrowDown, blank ]
]
where
blank = D.td' [D.text ""]
but key = D.td [style key] [D.text (show key)]
spanstyle = P.style
{ verticalAlign: "middle"
}
style key = P.style
{ width: "50px"
, height: "40px"
, background: if key==focus then "lightblue" else "gray"
, textAlign: "center"
}
-- FFI ------------------------------------------------------------
-- Start and stop listening for keyboard events
foreign import startListening :: Effect Unit
foreign import stopListening :: Effect Unit
-- Await a key input. Requires that we are listening for events.
foreign import _awaitKey :: EffectFnAff R.SyntheticKeyboardEvent
awaitKey :: Aff R.SyntheticKeyboardEvent
awaitKey = fromEffectFnAff _awaitKey
-- Data structures ------------------------------------------------
data Key
= ArrowUp
| ArrowDown
| ArrowLeft
| ArrowRight
| Enter
instance showKey :: Show Key where
show ArrowUp = "Up"
show ArrowDown = "Down"
show ArrowLeft = "Left"
show ArrowRight = "Right"
show Enter = "Enter"
instance eqKey :: Eq Key where
eq ArrowUp ArrowUp = true
eq ArrowDown ArrowDown = true
eq ArrowLeft ArrowLeft = true
eq ArrowRight ArrowRight = true
eq Enter Enter = true
eq _ _ = false
type Focus = Key
data Dir = U | D | L | R
toKey :: R.SyntheticKeyboardEvent -> Effect (Maybe Key)
toKey event = do
k <- R.key event
pure $ case k of
"ArrowUp" -> Just ArrowUp
"ArrowDown" -> Just ArrowDown
"ArrowLeft" -> Just ArrowLeft
"ArrowRight" -> Just ArrowRight
"Enter" -> Just Enter
_ -> Nothing
transition :: Key -> Dir -> Key
transition ArrowRight L = Enter
transition Enter L = ArrowLeft
transition ArrowLeft R = Enter
transition Enter R = ArrowRight
transition ArrowUp D = Enter
transition Enter D = ArrowDown
transition ArrowDown U = Enter
transition Enter U = ArrowUp
transition k _ = k