blob: 3ed3bcaced9083eb889e485b17f6b90ce93ba252 (
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
|
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 (GtkWidget w) = gtkWidget widget in
toState (g_signal_connect (type handler_internal) w (signalName handler) id) >>|
pure widget
where
type handler = case handler of
SHI_Void _ -> 1
SHI_Int_Int_Bool _ -> 2
SHI_Pointer_Bool _ -> 3
SHI_Int_Int_Pointer_Pointer_Bool _ -> 4
instance tune w SignalHandler | gtkWidget w
where
tune (SignalHandler handler) widget = installSignalHandler handler widget
instance tune w GSignalHandler | gtkWidget w
where
tune handler widget = installSignalHandler handler widget
// 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])
withPossibleCallback :: !(GtkM a) -> GtkM a
withPossibleCallback m = saveState >>| m >>= \r -> retrieveState >>| pure r
foreign export handleSignal
handleSignal :: !Int !{#Int} -> Int
handleSignal id args
# 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
# (GtkM f) = runSignalHandler handler args
# (i,st) = f st
-> save_state st i
runSignalHandler :: !SignalHandlerInternal !{#Int} -> GtkM Int
runSignalHandler handler args = case handler of
SHI_Void f
-> toInt <$> f
SHI_Int_Int_Bool f
-> toInt <$> f args.[0] args.[1]
SHI_Pointer_Bool f
-> toInt <$> f args.[0]
SHI_Int_Int_Pointer_Pointer_Bool f
-> toInt <$> f args.[0] args.[1] args.[2] args.[3]
instance toInt Bool where toInt b = if b 1 0
instance toInt () where toInt _ = 0
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
}
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)
|
