491ba5fa17cfe4024bd71981c233cb1b8cba702f
[ghc.git] / testsuite / tests / simplCore / should_run / T3591.hs
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
7 modify it under the terms of the GNU General Public License as
8 published by the Free Software Foundation, either version 3 of the
9 License, or (at your option) any later version.
10
11 SCC is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
13 or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
14 License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with SCC. If not, see <http://www.gnu.org/licenses/>.
18 -}
19
20 -- | Module "Trampoline" defines the pipe computations and their basic building blocks.
21
22 {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
23 TypeFamilies, KindSignatures, FlexibleContexts,
24 FlexibleInstances, OverlappingInstances, UndecidableInstances
25 #-}
26
27 {- Somewhere we get:
28
29 Wanted: AncestorFunctor (EitherFunctor a (TryYield a)) d
30 This should not reduce because of overlapping instances
31
32 If it (erroneously) does reduce, via dfun2 we get
33 Wanted: Functor (EitherFunctor a (TryYield a)
34 Functor d'
35 Functor d
36 d ~ EitherFunctor d' s
37 AncestorFunctor (EitherFunctor a (TryYield a) d'
38
39
40 And that gives an infinite loop in the type checker!
41 -}
42
43
44 module Main where
45
46 import Control.Monad (liftM, liftM2, when)
47 -- import Control.Monad.Identity
48
49 import Debug.Trace (trace)
50
51
52 -------------
53 class (Functor a, Functor d) => AncestorFunctor a d where
54 liftFunctor :: a x -> d x
55
56 -- dfun 1
57 instance Functor a => AncestorFunctor a a where
58 liftFunctor = trace "liftFunctor id" . id
59
60 -- dfun 2
61 instance ( Functor a
62 , Functor d'
63 , Functor d
64 , d ~ EitherFunctor d' s
65 , AncestorFunctor a d')
66 => AncestorFunctor a d where
67 liftFunctor = LeftF . (trace "liftFunctor other" . liftFunctor :: a x -> d' x)
68
69
70
71
72 -------------
73 newtype Identity a = Identity { runIdentity :: a }
74 instance Monad Identity where
75 return a = Identity a
76 m >>= k = k (runIdentity m)
77
78 newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
79 data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r))
80
81 instance (Monad m, Functor s) => Monad (Trampoline m s) where
82 return x = Trampoline (return (Done x))
83 t >>= f = Trampoline (bounce t >>= apply f)
84 where apply f (Done x) = bounce (f x)
85 apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
86
87 data Yield x y = Yield! x y
88 instance Functor (Yield x) where
89 fmap f (Yield x y) = trace "fmap yield" $ Yield x (f y)
90
91 data Await x y = Await! (x -> y)
92 instance Functor (Await x) where
93 fmap f (Await g) = trace "fmap await" $ Await (f . g)
94
95 data EitherFunctor l r x = LeftF (l x) | RightF (r x)
96 instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
97 fmap f v = trace "fmap Either" $
98 case v of
99 LeftF l -> trace "fmap LeftF" $ LeftF (fmap f l)
100 RightF r -> trace "fmap RightF" $ RightF (fmap f r)
101
102 type TryYield x = EitherFunctor (Yield x) (Await Bool)
103
104 suspend :: (Monad m, Functor s) => s (Trampoline m s x) -> Trampoline m s x
105 suspend s = Trampoline (return (Suspend s))
106
107 yield :: forall m x. Monad m => x -> Trampoline m (Yield x) ()
108 yield x = suspend (Yield x (return ()))
109
110 await :: forall m x. Monad m => Trampoline m (Await x) x
111 await = suspend (Await return)
112
113 tryYield :: forall m x. Monad m => x -> Trampoline m (TryYield x) Bool
114 tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))
115
116 canYield :: forall m x. Monad m => Trampoline m (TryYield x) Bool
117 canYield = suspend (RightF (Await return))
118
119 liftBounce :: Monad m => m x -> Trampoline m s x
120 liftBounce = Trampoline . liftM Done
121
122 fromTrampoline :: Monad m => Trampoline m s x -> m x
123 fromTrampoline t = bounce t >>= \(Done x)-> return x
124
125 runTrampoline :: Monad m => Trampoline m Maybe x -> m x
126 runTrampoline = fromTrampoline
127
128 coupleNestedFinite :: (Functor s, Monad m) =>
129 Trampoline m (EitherFunctor s (TryYield a)) x
130 -> Trampoline m (EitherFunctor s (Await (Maybe a))) y -> Trampoline m s (x, y)
131 coupleNestedFinite t1 t2 =
132 trace "bounce start" $
133 liftBounce (liftM2 (,) (bounce t1) (bounce t2))
134 >>= \(s1, s2)-> trace "bounce end" $
135 case (s1, s2)
136 of (Done x, Done y) -> return (x, y)
137 (Done x, Suspend (RightF (Await c2))) -> coupleNestedFinite (return x) (c2 Nothing)
138 (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> coupleNestedFinite c1 (return y)
139 (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> coupleNestedFinite c1 (c2 $ Just x)
140 (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> coupleNestedFinite (c1 True) (suspend s2)
141 (Suspend (RightF (RightF (Await c1))), Done y) -> coupleNestedFinite (c1 False) (return y)
142 (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNestedFinite (return y)) s)
143 (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNestedFinite (return x)) s)
144 (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite $ suspend $ LeftF s1) s2)
145 (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip coupleNestedFinite (suspend $ RightF s2)) s1)
146 (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite (suspend $ RightF s1)) s2)
147
148 local :: forall m l r x. (Monad m, Functor r) => Trampoline m r x -> Trampoline m (EitherFunctor l r) x
149 local (Trampoline mr) = Trampoline (liftM inject mr)
150 where inject :: TrampolineState m r x -> TrampolineState m (EitherFunctor l r) x
151 inject (Done x) = Done x
152 inject (Suspend r) = Suspend (RightF $ fmap local r)
153
154 out :: forall m l r x. (Monad m, Functor l) => Trampoline m l x -> Trampoline m (EitherFunctor l r) x
155 out (Trampoline ml) = Trampoline (liftM inject ml)
156 where inject :: TrampolineState m l x -> TrampolineState m (EitherFunctor l r) x
157 inject (Done x) = Done x
158 inject (Suspend l) = Suspend (LeftF $ fmap out l)
159
160 liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline m a x -> Trampoline m d x
161 liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
162 where inject :: TrampolineState m a x -> TrampolineState m d x
163 inject (Done x) = Done x
164 inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $
165 fmap liftOut (trace "poking a" a))
166
167 data Sink (m :: * -> *) a x =
168 Sink {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool,
169 canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool}
170 newtype Source (m :: * -> *) a x =
171 Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)}
172
173 pipe :: forall m a x r1 r2. (Monad m, Functor a) =>
174 (Sink m a x -> Trampoline m (EitherFunctor a (TryYield x)) r1)
175 -> (Source m a x -> Trampoline m (EitherFunctor a (Await (Maybe x))) r2) -> Trampoline m a (r1, r2)
176 pipe producer consumer = coupleNestedFinite (producer sink) (consumer source) where
177 sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline m (EitherFunctor a (TryYield x)) Bool),
178 canPut= liftOut (local canYield :: Trampoline m (EitherFunctor a (TryYield x)) Bool)} :: Sink m a x
179 source = Source (liftOut (local await :: Trampoline m (EitherFunctor a (Await (Maybe x))) (Maybe x))) :: Source m a x
180
181 pipeProducer sink = do put sink 1
182 (c, d) <- pipe
183 (\sink'-> do put sink' 2
184 put sink 3
185 put sink' 4
186 return 5)
187 (\source'-> do Just n <- get source'
188 put sink n
189 put sink 6
190 return n)
191 put sink c
192 put sink d
193 return (c, d)
194
195 testPipe = print $
196 runIdentity $
197 runTrampoline $
198 do (a, b) <- pipe
199 pipeProducer
200 (\source-> do Just n1 <- get source
201 Just n2 <- get source
202 Just n3 <- get source
203 return (n1, n2, n3))
204 return (a, b)
205
206 main = testPipe