blob: 56126f850d7e3f9c8012cb1edc1256fa34843c92 (
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
|
implementation module Gtk.Signal
import StdEnv
import StdMaybe
import StdDebug
import Control.Monad
import Data.Functor
import qualified Data.Map
import Gtk
import Gtk.Internal
instance signalHandler GSignalHandler
where
signalName h = case h of
DestroyHandler _ -> "destroy"
ActivateHandler _ -> "activate"
signalHandler h = case h of
DestroyHandler f -> SHI_Void f
ActivateHandler f -> SHI_Void f
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} ->
toState
(g_signal_connect
(type handler_internal)
(toPtr (gtkWidget widget))
(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 id)
Seconds s -> toState (g_timeout_add_seconds s id)
where
wrapped_callback id =
callback >>= \r ->
if r
getState
(modState \st -> {st & timeouts='Data.Map'.del id st.timeouts}) >>|
pure 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)
|
