/
Events.hs
334 lines (278 loc) · 10.9 KB
/
Events.hs
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
--------------------------------------------------------------------------------
{-| Module : Events
Copyright : (c) Daan Leijen 2003
(c) Shelarcy (shelarcy@gmail.com) 2006
License : wxWindows
Maintainer : wxhaskell-devel@lists.sourceforge.net
Stability : provisional
Portability : portable
Define event handling. Events are parametrised by the widget that can
correspond to a certain event and the type of the event handler.
For example, the 'resize' event has type:
> Reactive w => Event w (IO ())
This means that all widgets in the 'Reactive' class can respond to
'resize' events. (and since 'Window' is an instance of this class, this
means that basically all visible widgets are reactive).
An @Event w a@ can be transformed into an attribute of type 'Attr' @w a@
using the 'on' function.
> do f <- frame [text := "test"]
> set f [on resize := set f [text := "resizing"]]
For convenience, the 'mouse' and 'keyboard' have a serie of /event filters/:
'click', 'drag', 'enterKey', 'charKey', etc. These filters are write-only
and do not overwrite any previous mouse or keyboard handler but all stay
active at the same time. However, all filter will be overwritten again
when 'mouse' or 'keyboard' is set again. For example, the following program
makes sense:
> set w [on click := ..., on drag := ...]
But in the following program, only the handler for 'mouse' will be called:
> set w [on click := ..., on mouse := ...]
If you want to set the 'mouse' later but retain the old event filters,
you can first read the current 'mouse' handler and call it in the
new handler (and the same for the 'keyboard' of course). This implemenation
technique is used to implement event filters themselves and is also
very useful when setting an event handler for a 'closing' event:
> set w [on closing :~ \previous -> do{ ...; previous }]
Note that you should call 'propagateEvent' (or 'Graphics.UI.WXCore.Events.skipCurrentEvent') whenever
you do not process the event yourself in an event handler. This propagates
the event to the parent event handlers and give them a chance to
handle the event in an appropiate way. This gives another elegant way to install
a 'closing' event handler:
> set w [on closing := do{ ...; propagateEvent }]
-}
--------------------------------------------------------------------------------
module Graphics.UI.WX.Events
( -- * Event
Event
, on
, mapEvent
, propagateEvent
-- * Basic events
-- ** Selecting
, Selecting, select
-- ** Commanding
, Commanding, command
-- ** Reactive
, Reactive
, mouse, keyboard
, closing, idle, resize, focus, activate
, Paint
, paint, paintRaw, repaint
-- * Event filters
-- ** Mouse filters
, enter, leave, motion, drag
, click, unclick, doubleClick
, clickRight, unclickRight
-- * Keyboard event filters
, anyKey, key, charKey
, enterKey,tabKey,escKey,helpKey
, delKey,homeKey,endKey
, pgupKey,pgdownKey
, downKey,upKey,leftKey,rightKey
, rebind
-- * Types
-- ** Modifiers
, Modifiers(..)
, showModifiers
, noneDown, justShift, justAlt, justControl, justMeta, isNoneDown
, isNoShiftAltControlDown
-- ** Mouse events
, EventMouse (..)
, showMouse
, mousePos, mouseModifiers
-- ** Calender event
, EventCalendar(..)
, calendarEvent
-- ** Keyboard events
, EventKey (..), Key(..)
, keyKey, keyModifiers, keyPos
, showKey, showKeyModifiers
-- * Internal
, newEvent
) where
import Graphics.UI.WXCore hiding (Event)
import Graphics.UI.WX.Types
import Graphics.UI.WX.Attributes
import Graphics.UI.WX.Layout
import Graphics.UI.WX.Classes
{--------------------------------------------------------------------
Basic events
--------------------------------------------------------------------}
-- | An event for a widget @w@ that expects an event handler of type @a@.
data Event w a = Event (Attr w a)
-- | Transform an event to an attribute.
on :: Event w a -> Attr w a
on (Event attr)
= attr
-- | Change the event type.
mapEvent :: (a -> b) -> (a -> b -> a) -> Event w a -> Event w b
mapEvent get set (Event attr)
= Event (mapAttr get set attr)
{--------------------------------------------------------------------
Event classes
--------------------------------------------------------------------}
-- | 'Selecting' widgets fire a 'select' event when an item is selected.
class Selecting w where
-- | A 'select' event is fired when an item is selected.
select :: Event w (IO ())
-- | 'Commanding' widgets fire a 'command' event.
class Commanding w where
-- | A commanding event, for example a button press.
command :: Event w (IO ())
-- | 'Reactive' widgets are almost all visible widgets on the screen.
class Reactive w where
mouse :: Event w (EventMouse -> IO ())
keyboard :: Event w (EventKey -> IO ())
closing :: Event w (IO ())
idle :: Event w (IO Bool)
resize :: Event w (IO ())
focus :: Event w (Bool -> IO ())
activate :: Event w (Bool -> IO ())
-- | 'Paint' widgets can serve as a canvas.
-- /Note:/ it is illegal to use both a 'paint' and 'paintRaw'
-- event handler at the same widget.
class Paint w where
-- | Paint double buffered to a device context. The context is always
-- cleared before drawing. Takes the current view rectangle (adjusted
-- for scrolling) as an argument.
paint :: Event w (DC () -> Rect -> IO ())
-- | Paint directly to the on-screen device context. Takes the current
-- view rectangle and a list of dirty rectangles as arguments.\
paintRaw :: Event w (DC () -> Rect -> [Rect] -> IO ())
-- | Emit a paint event to the specified widget.
repaint :: w -> IO ()
{--------------------------------------------------------------------
Mouse event filters
--------------------------------------------------------------------}
click :: Reactive w => Event w (Point -> IO ())
click
= mouseFilter "click" filter
where
filter (MouseLeftDown point mod) = isNoShiftAltControlDown mod
filter other = False
unclick :: Reactive w => Event w (Point -> IO ())
unclick
= mouseFilter "unclick" filter
where
filter (MouseLeftUp point mod) = isNoShiftAltControlDown mod
filter other = False
doubleClick :: Reactive w => Event w (Point -> IO ())
doubleClick
= mouseFilter "doubleClick" filter
where
filter (MouseLeftDClick point mod) = isNoShiftAltControlDown mod
filter other = False
drag :: Reactive w => Event w (Point -> IO ())
drag
= mouseFilter "drag" filter
where
filter (MouseLeftDrag point mod) = isNoShiftAltControlDown mod
filter other = False
motion :: Reactive w => Event w (Point -> IO ())
motion
= mouseFilter "motion" filter
where
filter (MouseMotion point mod) = isNoShiftAltControlDown mod
filter other = False
clickRight :: Reactive w => Event w (Point -> IO ())
clickRight
= mouseFilter "clickRight" filter
where
filter (MouseRightDown point mod) = isNoShiftAltControlDown mod
filter other = False
unclickRight :: Reactive w => Event w (Point -> IO ())
unclickRight
= mouseFilter "unclickRight" filter
where
filter (MouseRightUp point mod) = isNoShiftAltControlDown mod
filter other = False
enter :: Reactive w => Event w (Point -> IO ())
enter
= mouseFilter "enter" filter
where
filter (MouseEnter point mod) = True
filter other = False
leave :: Reactive w => Event w (Point -> IO ())
leave
= mouseFilter "leave" filter
where
filter (MouseLeave point mod) = True
filter other = False
mouseFilter :: Reactive w => String -> (EventMouse -> Bool) -> Event w (Point -> IO ())
mouseFilter name filter
= mapEvent get set mouse
where
get prev x
= ioError (userError ("WX.Events: the " ++ name ++ " event is write-only."))
set prev new mouseEvent
= if (filter mouseEvent)
then new (mousePos mouseEvent)
else prev mouseEvent
{--------------------------------------------------------------------
Keyboard filter events
--------------------------------------------------------------------}
rebind :: Event w (IO ()) -> Event w (IO ())
rebind event
= mapEvent get set event
where
get prev
= prev
set new prev
= new
enterKey,tabKey,escKey,helpKey,delKey,homeKey,endKey :: Reactive w => Event w (IO ())
pgupKey,pgdownKey,downKey,upKey,leftKey,rightKey :: Reactive w => Event w (IO ())
enterKey = key KeyReturn
tabKey = key KeyTab
escKey = key KeyEscape
helpKey = key KeyHelp
delKey = key KeyDelete
homeKey = key KeyHome
endKey = key KeyEnd
pgupKey = key KeyPageUp
pgdownKey = key KeyPageDown
downKey = key KeyDown
upKey = key KeyUp
leftKey = key KeyLeft
rightKey = key KeyRight
charKey :: Reactive w => Char -> Event w (IO ())
charKey c
= key (KeyChar c)
key :: Reactive w => Key -> Event w (IO ())
key k
= keyboardFilter "key" filter
where
filter (EventKey x mod pt) = k==x
anyKey :: Reactive w => Event w (Key -> IO ())
anyKey
= keyboardFilter1 "anyKey" (const True)
keyboardFilter :: Reactive w => String -> (EventKey -> Bool) -> Event w (IO ())
keyboardFilter name filter
= mapEvent get set keyboard
where
get prev
= ioError (userError ("WX.Events: the " ++ name ++ " event is write-only."))
set prev new keyboardEvent
= do when (filter keyboardEvent) new
prev keyboardEvent
keyboardFilter1 :: Reactive w => String -> (EventKey -> Bool) -> Event w (Key -> IO ())
keyboardFilter1 name filter
= mapEvent get set keyboard
where
get prev key
= ioError (userError ("WX.Events: the " ++ name ++ " event is write-only."))
set prev new keyboardEvent
= if (filter keyboardEvent)
then new (keyKey keyboardEvent)
else prev keyboardEvent
{--------------------------------------------------------------------
Calender event filters
--------------------------------------------------------------------}
calendarEvent :: Event (CalendarCtrl a) (EventCalendar -> IO ())
calendarEvent
= newEvent "calendarEvent" calendarCtrlGetOnCalEvent calendarCtrlOnCalEvent
{--------------------------------------------------------------------
Generic event creators
-------------------------------------------------------------------}
-- | Create a new event from a get and set function.
newEvent :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Event w a
newEvent name getter setter
= Event (newAttr name getter setter)