Ticket #3591: Trampoline.hs

File Trampoline.hs, 7.9 KB (added by blamario, 6 years ago)

The test module

Line 
1{-
2    Copyright 2009 Mario Blazevic
3
4    This file is part of the Streaming Component Combinators (SCC) project.
5
6    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
7    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
8    version.
9
10    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
11    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12
13    You should have received a copy of the GNU General Public License along with SCC.  If not, see
14    <http://www.gnu.org/licenses/>.
15-}
16
17-- | Module "Trampoline" defines the pipe computations and their basic building blocks.
18
19{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, KindSignatures,
20             FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances
21 #-}
22
23module Main where
24
25import Control.Monad (liftM, liftM2, when)
26import Control.Monad.Identity
27
28import Debug.Trace (trace)
29
30newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
31data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r))
32
33instance (Monad m, Functor s) => Monad (Trampoline m s) where
34   return x = Trampoline (return (Done x))
35   t >>= f = Trampoline (bounce t >>= apply f)
36      where apply f (Done x) = bounce (f x)
37            apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
38
39data Yield x y = Yield! x y
40instance Functor (Yield x) where
41   fmap f (Yield x y) = Yield x (f y)
42
43data Await x y = Await! (x -> y)
44instance Functor (Await x) where
45   fmap f (Await g) = Await (f . g)
46
47data EitherFunctor l r x = LeftF (l x) | RightF (r x)
48instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
49   fmap f (LeftF l) = LeftF (fmap f l)
50   fmap f (RightF r) = RightF (fmap f r)
51
52type TryYield x = EitherFunctor (Yield x) (Await Bool)
53
54suspend :: (Monad m, Functor s) => s (Trampoline m s x) -> Trampoline m s x
55suspend s = Trampoline (return (Suspend s))
56
57yield :: forall m x. Monad m => x -> Trampoline m (Yield x) ()
58yield x = suspend (Yield x (return ()))
59
60await :: forall m x. Monad m => Trampoline m (Await x) x
61await = suspend (Await return)
62
63tryYield :: forall m x. Monad m => x -> Trampoline m (TryYield x) Bool
64tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))
65
66canYield :: forall m x. Monad m => Trampoline m (TryYield x) Bool
67canYield = suspend (RightF (Await return))
68
69liftBounce :: Monad m => m x -> Trampoline m s x
70liftBounce = Trampoline . liftM Done
71
72fromTrampoline :: Monad m => Trampoline m s x -> m x
73fromTrampoline t = bounce t >>= \(Done x)-> return x
74
75runTrampoline :: Monad m => Trampoline m Maybe x -> m x
76runTrampoline = fromTrampoline
77
78coupleNestedFinite :: (Functor s, Monad m) =>
79                      Trampoline m (EitherFunctor s (TryYield a)) x
80                   -> Trampoline m (EitherFunctor s (Await (Maybe a))) y -> Trampoline m s (x, y)
81coupleNestedFinite t1 t2 =
82   trace "bounce start" $
83   liftBounce (liftM2 (,) (bounce t1) (bounce t2))
84   >>= \(s1, s2)-> trace "bounce end" $
85                   case (s1, s2)
86                   of (Done x, Done y) -> return (x, y)
87                      (Done x, Suspend (RightF (Await c2))) -> coupleNestedFinite (return x) (c2 Nothing)
88                      (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> coupleNestedFinite c1 (return y)
89                      (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> coupleNestedFinite c1 (c2 $ Just x)
90                      (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> coupleNestedFinite (c1 True) (suspend s2)
91                      (Suspend (RightF (RightF (Await c1))), Done y) -> coupleNestedFinite (c1 False) (return y)
92                      (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNestedFinite (return y)) s)
93                      (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNestedFinite (return x)) s)
94                      (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite $ suspend $ LeftF s1) s2)
95                      (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip coupleNestedFinite (suspend $ RightF s2)) s1)
96                      (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite (suspend $ RightF s1)) s2)
97
98local :: forall m l r x. (Monad m, Functor r) => Trampoline m r x -> Trampoline m (EitherFunctor l r) x
99local (Trampoline mr) = Trampoline (liftM inject mr)
100   where inject :: TrampolineState m r x -> TrampolineState m (EitherFunctor l r) x
101         inject (Done x) = Done x
102         inject (Suspend r) = Suspend (RightF $ fmap local r)
103
104out :: forall m l r x. (Monad m, Functor l) => Trampoline m l x -> Trampoline m (EitherFunctor l r) x
105out (Trampoline ml) = Trampoline (liftM inject ml)
106   where inject :: TrampolineState m l x -> TrampolineState m (EitherFunctor l r) x
107         inject (Done x) = Done x
108         inject (Suspend l) = Suspend (LeftF $ fmap out l)
109
110class (Functor a, Functor d) => AncestorFunctor a d where
111   liftFunctor :: a x -> d x
112
113instance Functor a => AncestorFunctor a a where
114   liftFunctor = id
115instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where
116   liftFunctor = LeftF . (trace "liftFunctor" . liftFunctor :: a x -> d' x)
117
118liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline m a x -> Trampoline m d x
119liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
120   where inject :: TrampolineState m a x -> TrampolineState m d x
121         inject (Done x) = Done x
122         inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ fmap liftOut a)
123
124data Sink (m :: * -> *) a x =
125   Sink   {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool,
126           canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool}
127newtype Source (m :: * -> *) a x =
128   Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)}
129
130pipe :: forall m a x r1 r2. (Monad m, Functor a) =>
131        (Sink m a x -> Trampoline m (EitherFunctor a (TryYield x)) r1)
132     -> (Source m a x -> Trampoline m (EitherFunctor a (Await (Maybe x))) r2) -> Trampoline m a (r1, r2)
133pipe producer consumer = coupleNestedFinite (producer sink) (consumer source) where
134   sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline m (EitherFunctor a (TryYield x)) Bool),
135                canPut= liftOut (local canYield :: Trampoline m (EitherFunctor a (TryYield x)) Bool)} :: Sink m a x
136   source = Source (liftOut (local await :: Trampoline m (EitherFunctor a (Await (Maybe x))) (Maybe x))) :: Source m a x
137
138pipeProducer sink = do put sink 1
139                       (c, d) <- pipe
140                                    (\sink'-> do put sink' 2
141                                                 put sink 3
142                                                 put sink' 4
143                                                 return 5)
144                                    (\source'-> do Just n <- get source'
145                                                   put sink n
146                                                   put sink 6
147                                                   return n)
148                       put sink c
149                       put sink d
150                       return (c, d)
151
152testPipe = print $
153           runIdentity $
154           runTrampoline $
155           do (a, b) <- pipe
156                           pipeProducer
157                           (\source-> do Just n1 <- get source
158                                         Just n2 <- get source
159                                         Just n3 <- get source
160                                         return (n1, n2, n3))
161              return (a, b)
162
163main = testPipe