blob: 301e8441b6a314900313c3707ef3ab5fa35e91a9 (
plain)
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
|
module Thread
( ThreadTree (..)
, ContM (..)
, atom
, stop
, buildThread
)
where
----------------------------------
data ThreadTree req rsp m =
Atom (m (ThreadTree req rsp m))
| Stop
----------------------------------
newtype ContM req rsp m a = ContM ((a-> ThreadTree req rsp m)-> ThreadTree req rsp m)
instance Functor (ContM req rsp m) where
fmap = undefined
instance Applicative (ContM req rsp m) where
pure = undefined
(<*>) = undefined
instance Monad m => Monad (ContM req rsp m) where
m >>= f = contmBind m f
return = contmReturn
contmBind :: (ContM req rsp m a) -> (a -> (ContM req rsp m b)) -> (ContM req rsp m b)
contmBind (ContM x) f =
ContM(\y-> x (\z-> let ContM f' = f z in f' y))
contmReturn :: a -> (ContM req rsp m a)
contmReturn x = ContM(\c -> c x)
{-- how to build primitive ContM blocks... --}
atom :: Monad m => (m a) -> (ContM req rsp m a)
atom mx = ContM( \c -> Atom( do x <- mx; return (c x) ))
stop :: (ContM req rsp m a)
stop = ContM( \c -> Stop )
buildThread :: (ContM req rsp m a) -> ThreadTree req rsp m
buildThread (ContM f) = f (\c->Stop)
----------------------------------
|
