blob: be019b53d4725034879a95e5584e3f81c6a32155 (
plain) (
blame)
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
|
implementation module Gtk.Signal
import StdEnv
import StdMaybe
import StdDebug
import Control.Monad
import Data.Functor
import qualified Data.Map
import Gdk.Events
import Gtk
import Gtk.Internal
instance signalHandler GSignalHandler
where
signalName h = case h of
ActivateHandler _ -> "activate"
ChangedHandler _ -> "changed"
ClickedHandler _ -> "clicked"
DeleteEventHandler _ -> "delete-event"
DestroyHandler _ -> "destroy"
KeyPressHandler _ -> "key-press-event"
NextMatchHandler _ -> "next-match"
PreviousMatchHandler _ -> "previous-match"
SearchChangedHandler _ -> "search-changed"
StopSearchHandler _ -> "stop-search"
signalHandler h = case h of
ActivateHandler f -> SHI_Void f
ChangedHandler f -> SHI_Void f
ClickedHandler f -> SHI_Void f
DeleteEventHandler f -> SHI_Pointer_Bool \ev -> toBool <$> f (GdkEvent ev)
DestroyHandler f -> SHI_Void f
KeyPressHandler f -> SHI_Pointer_Bool \ev -> toBool <$> f (GdkEvent ev)
NextMatchHandler f -> SHI_Void f
PreviousMatchHandler f -> SHI_Void f
SearchChangedHandler f -> SHI_Void f
StopSearchHandler f -> SHI_Void f
where
toBool :: !GtkPropagate -> Bool
toBool p = p=:StopPropagation
installSignalHandler :: !h !w -> GtkM w | signalHandler h & gtkWidget w
installSignalHandler handler widget =
let handler_internal = signalHandler handler in
modState (\st ->
{ st
& signal_handlers = 'Data.Map'.put (st.signal_counter+1) handler_internal st.signal_handlers
, signal_counter = st.signal_counter+1
}) >>= \{signal_counter=id} ->
let w = toPtr widget in
toState (g_signal_connect w (signalName handler) (callback handler_internal) id) >>|
pure widget
where
callback handler = case handler of
SHI_Void _ -> callback_void
SHI_Int_Int_Bool _ -> callback_int_int_bool
SHI_Pointer_Bool _ -> callback_pointer_bool
SHI_Int_Int_Pointer_Pointer_Bool _ -> callback_int_int_pointer_pointer_bool
callback_void :: Pointer
callback_void = code {
pushLc handleSignal_void
}
callback_int_int_bool :: Pointer
callback_int_int_bool = code {
pushLc handleSignal_int_int_bool
}
callback_pointer_bool :: Pointer
callback_pointer_bool = code {
pushLc handleSignal_pointer_bool
}
callback_int_int_pointer_pointer_bool :: Pointer
callback_int_int_pointer_pointer_bool = code {
pushLc handleSignal_int_int_pointer_pointer_bool
}
instance tune w GSignalHandler | gtkWidget w
where
tune handler widget = installSignalHandler handler widget
addTimeout :: !GtkTimeout !(GtkM Bool) -> GtkM ()
addTimeout interval callback =
modState (\st ->
let id = st.timeout_counter+1 in
{ st
& timeouts = 'Data.Map'.put id (wrapped_callback id) st.timeouts
, timeout_counter = id
}) >>= \{timeout_counter=id} ->
case interval of
Milliseconds ms -> toState (g_timeout_add ms get_handleTimeout_address id)
Seconds s -> toState (g_timeout_add_seconds s get_handleTimeout_address id)
where
wrapped_callback id =
callback >>= \r ->
if r
getState
(modState \st -> {st & timeouts='Data.Map'.del id st.timeouts}) >>|
pure r
get_handleTimeout_address :: Pointer
get_handleTimeout_address = code {
pushLc handleTimeout
}
withPossibleCallback :: !(GtkM a) -> GtkM a
withPossibleCallback m = saveState >>| m >>= \r -> retrieveState >>| pure r
// NB: low-level hacking to use and modify the GtkState from within callbacks.
// We use a CAF to keep track of the state. In runGtk, the state is saved with
// saveState. This state is retrieved with retrieveState there (to check
// whether the application should quit), but is also used here (in
// handleSignal) to be used and modified from signal callbacks.
saved_state :: {!GtkState}
saved_state =: {newGtkState}
save_state :: !GtkState !.a -> .a
save_state state env
# saved_state = mk_unique saved_state
saved_state & [0] = state
| saved_state.[0].return <> state.return
= abort "internal error in saveState\n"
= env
where
mk_unique :: !{!GtkState} -> *{!GtkState}
mk_unique _ = code {
no_op
}
saveState :: GtkM ()
saveState = getState >>= \state -> toState (save_state state)
retrieveState :: GtkM GtkState
retrieveState = modState (const saved_state.[0])
foreign export handleSignal_void
handleSignal_void :: !Pointer !Int -> Int
handleSignal_void _ id = handleSignal id \h -> case h of
SHI_Void f
-> Just (toInt <$> f)
-> Nothing
foreign export handleSignal_pointer_bool
handleSignal_pointer_bool :: !Pointer !Pointer !Int -> Int
handleSignal_pointer_bool _ p id = handleSignal id \h -> case h of
SHI_Pointer_Bool f
-> Just (toInt <$> f p)
-> Nothing
foreign export handleSignal_int_int_bool
handleSignal_int_int_bool :: !Pointer !Int !Int !Int -> Int
handleSignal_int_int_bool _ i1 i2 id = handleSignal id \h -> case h of
SHI_Int_Int_Bool f
-> Just (toInt <$> f i1 i2)
-> Nothing
foreign export handleSignal_int_int_pointer_pointer_bool
handleSignal_int_int_pointer_pointer_bool :: !Pointer !Int !Int !Pointer !Pointer !Int -> Int
handleSignal_int_int_pointer_pointer_bool _ i1 i2 p1 p2 id = handleSignal id \h -> case h of
SHI_Int_Int_Pointer_Pointer_Bool f
-> Just (toInt <$> f i1 i2 p1 p2)
-> Nothing
instance toInt () where toInt () = 0
instance toInt Bool where toInt b = if b 1 0
handleSignal :: !Int !(SignalHandlerInternal -> Maybe (GtkM Int)) -> Int
handleSignal id handle
# st = saved_state.[0]
= case 'Data.Map'.get id st.signal_handlers of
Nothing
-> trace_n ("handleSignal: missing signal handler #"+++toString id) 0
Just handler
-> case handle handler of
Nothing
-> trace_n "handleSignal: signal handler does not match" 0
Just (GtkM f)
# (r,st) = f st
-> save_state st r
foreign export handleTimeout
handleTimeout :: !Int -> Int
handleTimeout id
# st = saved_state.[0]
= case 'Data.Map'.get id st.timeouts of
Nothing
-> trace_n ("handleTimeout: missing function #"+++toString id) 0
Just (GtkM f)
# (b,st) = f st
-> save_state st (if b 1 0)
|
