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
|
implementation module Gtk.State
import StdEnv
import Control.Monad
import Data.Bifunctor
import Data.Functor
import qualified Data.Map
from Data.Map import :: Map
import Data.Maybe
import Data.Tuple
import Gtk
import Gtk.Internal
newGtkState :: GtkState
newGtkState =
{ world = ()
, return = False
, signal_handlers = 'Data.Map'.newMap
, signal_counter = 0
, timeouts = 'Data.Map'.newMap
, timeout_counter = 0
, shares = 'Data.Map'.newMap
}
instance Functor GtkM
where
fmap f (GtkM m) = GtkM \st
#! (x,st) = m st
-> (f x,st)
instance pure GtkM where pure x = GtkM (tuple x)
instance <*> GtkM
where
<*> (GtkM f) (GtkM x) = GtkM \st
# (f,st) = f st
# (x,st) = x st
-> (f x, st)
instance Monad GtkM
where
bind (GtkM x) k = GtkM (left right)
where
// NB: we need these two helper functions to hide the tuple type. If
// not, tuple-(un)wrapping happens here already causing a stack
// overflow. These helpers obscure the types to change the calling
// convention, so that an endless bind chain can be executed in
// constant space.
left right s
#! (x,s) = x s
# k = right x
= k s
right x
# (GtkM k) = k x
= k
runGtk :: !(GtkM a) !*World -> (!a, !*World)
runGtk f w = (getResult (wrapped_f newGtkState), w)
where
getResult :: !(!a, !GtkState) -> a
getResult (r,_) = r
(GtkM wrapped_f) =
toState gtk_init >>|
f >>= \x ->
saveState >>|
main x
main x =
toStateR gtk_main_iteration >>|
retrieveState >>= \{return}
| return -> pure x
| otherwise -> main x
getState :: GtkM GtkState
getState = GtkM \st -> (st,st)
modState :: !(GtkState -> GtkState) -> GtkM GtkState
modState f = GtkM \st -> let st` = f st in (st`,st`)
toState :: !(A.a: a -> a) -> GtkM ()
toState f = GtkM \st -> case f st.world of w=:() -> (w, st)
toStateR :: !(A.a: a -> (r,a)) -> GtkM r
toStateR f = GtkM \st -> case f st.world of (r,()) -> (r, st)
appWorld :: !(*World -> *World) -> GtkM ()
appWorld f = GtkM \st
# w = f (voidToWorld st.world)
-> ((), {st & world=worldToVoid w})
accWorld :: !(*World -> (r,*World)) -> GtkM r
accWorld f = GtkM \st
# (r,w) = f (voidToWorld st.world)
-> (r, {st & world=worldToVoid w})
voidToWorld :: !() -> *World
voidToWorld _ = code {
fill_a 0 1
pop_a 1
}
worldToVoid :: !*World -> ()
worldToVoid _ = ()
quit :: GtkM ()
quit = modState (\st -> {st & return=True}) >>| pure ()
runWhileEventsPending :: GtkM ()
runWhileEventsPending = withPossibleCallback run
where
run =
toStateR gtk_events_pending >>= \pending
| not pending ->
pure ()
| otherwise ->
toStateR gtk_main_iteration >>|
run
|
