Testsuite: fixup lots of tests
[ghc.git] / testsuite / tests / indexed-types / should_compile / T3787.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 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 trampoline computations and their basic building blocks.
18
19 {-# LANGUAGE ScopedTypeVariables, RankNTypes, MultiParamTypeClasses, TypeFamilies, KindSignatures,
20 FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances
21 #-}
22
23 module T3787 where
24
25 import Control.Concurrent (forkIO)
26 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
27 import Control.Monad (liftM, liftM2, when, ap)
28 import Control.Monad.Identity
29 import Control.Monad.Trans (MonadTrans(..))
30
31 import Data.Foldable (toList)
32 import Data.Maybe (maybe)
33 import Data.Sequence (Seq, viewl)
34
35 par, pseq :: a -> b -> b
36 par = error "urk"
37 pseq = error "urk"
38
39 -- | Class of monads that can perform two computations in parallel.
40 class Monad m => ParallelizableMonad m where
41 -- | Combine two computations into a single parallel computation. Default implementation of `parallelize` is
42 -- @liftM2 (,)@
43 parallelize :: m a -> m b -> m (a, b)
44 parallelize = liftM2 (,)
45
46 -- | Any monad that allows the result value to be extracted, such as `Identity` or `Maybe` monad, can implement
47 -- `parallelize` by using `par`.
48 instance ParallelizableMonad Identity where
49 parallelize ma mb = let a = runIdentity ma
50 b = runIdentity mb
51 in a `par` (b `pseq` a `pseq` Identity (a, b))
52
53 instance ParallelizableMonad Maybe where
54 parallelize ma mb = case ma `par` (mb `pseq` (ma, mb))
55 of (Just a, Just b) -> Just (a, b)
56 _ -> Nothing
57
58 -- | IO is parallelizable by `forkIO`.
59 instance ParallelizableMonad IO where
60 parallelize ma mb = do va <- newEmptyMVar
61 vb <- newEmptyMVar
62 forkIO (ma >>= putMVar va)
63 forkIO (mb >>= putMVar vb)
64 a <- takeMVar va
65 b <- takeMVar vb
66 return (a, b)
67
68 -- | Suspending monadic computations.
69 newtype Trampoline s m r = Trampoline {
70 -- | Run the next step of a `Trampoline` computation.
71 bounce :: m (TrampolineState s m r)
72 }
73
74 data TrampolineState s m r =
75 -- | Trampoline computation is finished with final value /r/.
76 Done r
77 -- | Computation is suspended, its remainder is embedded in the functor /s/.
78 | Suspend! (s (Trampoline s m r))
79
80 instance (Functor s, Monad m) => Functor (Trampoline s m) where
81 fmap = liftM
82
83 instance (Functor s, Monad m) => Applicative (Trampoline s m) where
84 pure x = Trampoline (pure (Done x))
85 (<*>) = ap
86
87 instance (Functor s, Monad m) => Monad (Trampoline s m) where
88 return = pure
89 t >>= f = Trampoline (bounce t >>= apply f)
90 where apply f (Done x) = bounce (f x)
91 apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
92
93 instance (Functor s, ParallelizableMonad m) => ParallelizableMonad (Trampoline s m) where
94 parallelize t1 t2 = Trampoline $ liftM combine $ parallelize (bounce t1) (bounce t2) where
95 combine (Done x, Done y) = Done (x, y)
96 combine (Suspend s, Done y) = Suspend (fmap (liftM $ \x-> (x, y)) s)
97 combine (Done x, Suspend s) = Suspend (fmap (liftM $ (,) x) s)
98 combine (Suspend s1, Suspend s2) = Suspend (fmap (parallelize $ suspend s1) s2)
99
100 instance Functor s => MonadTrans (Trampoline s) where
101 lift = Trampoline . liftM Done
102
103 data Yield x y = Yield! x y
104 instance Functor (Yield x) where
105 fmap f (Yield x y) = Yield x (f y)
106
107 data Await x y = Await! (x -> y)
108 instance Functor (Await x) where
109 fmap f (Await g) = Await (f . g)
110
111 data EitherFunctor l r x = LeftF (l x) | RightF (r x)
112 instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
113 fmap f (LeftF l) = LeftF (fmap f l)
114 fmap f (RightF r) = RightF (fmap f r)
115
116 newtype NestedFunctor l r x = NestedFunctor (l (r x))
117 instance (Functor l, Functor r) => Functor (NestedFunctor l r) where
118 fmap f (NestedFunctor lr) = NestedFunctor ((fmap . fmap) f lr)
119
120 data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x)
121 instance (Functor l, Functor r) => Functor (SomeFunctor l r) where
122 fmap f (LeftSome l) = LeftSome (fmap f l)
123 fmap f (RightSome r) = RightSome (fmap f r)
124 fmap f (Both lr) = Both (fmap f lr)
125
126 type TryYield x = EitherFunctor (Yield x) (Await Bool)
127
128 suspend :: (Monad m, Functor s) => s (Trampoline s m x) -> Trampoline s m x
129 suspend s = Trampoline (return (Suspend s))
130
131 yield :: forall m x. Monad m => x -> Trampoline (Yield x) m ()
132 yield x = suspend (Yield x (return ()))
133
134 await :: forall m x. Monad m => Trampoline (Await x) m x
135 await = suspend (Await return)
136
137 tryYield :: forall m x. Monad m => x -> Trampoline (TryYield x) m Bool
138 tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))
139
140 canYield :: forall m x. Monad m => Trampoline (TryYield x) m Bool
141 canYield = suspend (RightF (Await return))
142
143 fromTrampoline :: Monad m => Trampoline s m x -> m x
144 fromTrampoline t = bounce t >>= \(Done x)-> return x
145
146 runTrampoline :: Monad m => Trampoline Identity m x -> m x
147 runTrampoline = fromTrampoline
148
149 pogoStick :: (Functor s, Monad m) => (s (Trampoline s m x) -> Trampoline s m x) -> Trampoline s m x -> m x
150 pogoStick reveal t = bounce t
151 >>= \s-> case s
152 of Done result -> return result
153 Suspend c -> pogoStick reveal (reveal c)
154
155 pogoStickNested :: (Functor s1, Functor s2, Monad m) =>
156 (s2 (Trampoline (EitherFunctor s1 s2) m x) -> Trampoline (EitherFunctor s1 s2) m x)
157 -> Trampoline (EitherFunctor s1 s2) m x -> Trampoline s1 m x
158 pogoStickNested reveal t =
159 Trampoline{bounce= bounce t
160 >>= \s-> case s
161 of Done result -> return (Done result)
162 Suspend (LeftF s) -> return (Suspend (fmap (pogoStickNested reveal) s))
163 Suspend (RightF c) -> bounce (pogoStickNested reveal (reveal c))
164 }
165
166 nest :: (Functor a, Functor b) => a x -> b y -> NestedFunctor a b (x, y)
167 nest a b = NestedFunctor $ fmap (\x-> fmap ((,) x) b) a
168
169 -- couple :: (Monad m, Functor s1, Functor s2) =>
170 -- Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (NestedFunctor s1 s2) m (x, y)
171 -- couple t1 t2 = Trampoline{bounce= do ts1 <- bounce t1
172 -- ts2 <- bounce t2
173 -- case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
174 -- (Suspend s1, Suspend s2) -> return $ Suspend $
175 -- fmap (uncurry couple) (nest s1 s2)
176 -- }
177
178 coupleAlternating :: (Monad m, Functor s1, Functor s2) =>
179 Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y)
180 coupleAlternating t1 t2 =
181 Trampoline{bounce= do ts1 <- bounce t1
182 ts2 <- bounce t2
183 case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
184 (Suspend s1, Suspend s2) ->
185 return $ Suspend $ fmap (uncurry coupleAlternating) (Both $ nest s1 s2)
186 (Done x, Suspend s2) ->
187 return $ Suspend $ fmap (coupleAlternating (return x)) (RightSome s2)
188 (Suspend s1, Done y) ->
189 return $ Suspend $ fmap (flip coupleAlternating (return y)) (LeftSome s1)
190 }
191
192 coupleParallel :: (ParallelizableMonad m, Functor s1, Functor s2) =>
193 Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y)
194 coupleParallel t1 t2 =
195 Trampoline{bounce= parallelize (bounce t1) (bounce t2)
196 >>= \pair-> case pair
197 of (Done x, Done y) -> return $ Done (x, y)
198 (Suspend s1, Suspend s2) ->
199 return $ Suspend $ fmap (uncurry coupleParallel) (Both $ nest s1 s2)
200 (Done x, Suspend s2) ->
201 return $ Suspend $ fmap (coupleParallel (return x)) (RightSome s2)
202 (Suspend s1, Done y) ->
203 return $ Suspend $ fmap (flip coupleParallel (return y)) (LeftSome s1)
204 }
205
206 coupleNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>
207 Trampoline (EitherFunctor s0 s1) m x -> Trampoline (EitherFunctor s0 s2) m y ->
208 Trampoline (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y)
209 coupleNested t1 t2 =
210 Trampoline{bounce= do ts1 <- bounce t1
211 ts2 <- bounce t2
212 case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y)
213 (Suspend (RightF s), Done y) ->
214 return $ Suspend $ RightF $ fmap (flip coupleNested (return y)) (LeftSome s)
215 (Done x, Suspend (RightF s)) ->
216 return $ Suspend $ RightF $ fmap (coupleNested (return x)) (RightSome s)
217 (Suspend (RightF s1), Suspend (RightF s2)) ->
218 return $ Suspend $ RightF $ fmap (uncurry coupleNested) (Both $ nest s1 s2)
219 (Suspend (LeftF s), Done y) ->
220 return $ Suspend $ LeftF $ fmap (flip coupleNested (return y)) s
221 (Done x, Suspend (LeftF s)) ->
222 return $ Suspend $ LeftF $ fmap (coupleNested (return x)) s
223 (Suspend (LeftF s1), Suspend (LeftF s2)) ->
224 return $ Suspend $ LeftF $ fmap (coupleNested $ suspend $ LeftF s1) s2
225 }
226
227 seesaw :: (Monad m, Functor s1, Functor s2) =>
228 (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t)
229 -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y)
230 seesaw resolve t1 t2 = pogoStick resolve (coupleAlternating t1 t2)
231
232 seesawParallel :: (ParallelizableMonad m, Functor s1, Functor s2) =>
233 (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t)
234 -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y)
235 seesawParallel resolve t1 t2 = pogoStick resolve (coupleParallel t1 t2)
236
237 resolveProducerConsumer :: forall a s s0 t t' m x.
238 (Functor s0, Monad m, s ~ SomeFunctor (TryYield a) (Await (Maybe a)),
239 t ~ Trampoline (EitherFunctor s0 s) m x) =>
240 s t -> t
241 -- Arg :: s t
242 -- (LeftSome (LeftF ...)) : SomeFunctor (EitherFunctor .. ..) (...) t
243 resolveProducerConsumer (LeftSome (LeftF (Yield _ c))) = c
244 resolveProducerConsumer (LeftSome (RightF (Await c))) = c False
245 resolveProducerConsumer (RightSome (Await c)) = c Nothing
246 resolveProducerConsumer (Both (NestedFunctor (LeftF (Yield x (Await c))))) = c (Just x)
247 resolveProducerConsumer (Both (NestedFunctor (RightF (Await c)))) = suspend (RightF $ RightSome $ c True)
248
249 couplePC :: ParallelizableMonad m => Trampoline (Yield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
250 couplePC t1 t2 = parallelize (bounce t1) (bounce t2)
251 >>= \(s1, s2)-> case (s1, s2)
252 of (Done x, Done y) -> return (x, y)
253 (Suspend (Yield x c1), Suspend (Await c2)) -> couplePC c1 (c2 $ Just x)
254 (Suspend (Yield _ c1), Done y) -> couplePC c1 (return y)
255 (Done x, Suspend (Await c2)) -> couplePC (return x) (c2 Nothing)
256
257 coupleFinite :: ParallelizableMonad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
258 coupleFinite t1 t2 =
259 parallelize (bounce t1) (bounce t2)
260 >>= \(s1, s2)-> case (s1, s2)
261 of (Done x, Done y) -> return (x, y)
262 (Done x, Suspend (Await c2)) -> coupleFinite (return x) (c2 Nothing)
263 (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFinite c1 (c2 $ Just x)
264 (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFinite c1 (return y)
265 (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFinite (c1 True) (suspend s2)
266 (Suspend (RightF (Await c1)), Done y) -> coupleFinite (c1 False) (return y)
267
268 coupleFiniteSequential :: Monad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y)
269 coupleFiniteSequential t1 t2 =
270 bounce t1
271 >>= \s1-> bounce t2
272 >>= \s2-> case (s1, s2)
273 of (Done x, Done y) -> return (x, y)
274 (Done x, Suspend (Await c2)) -> coupleFiniteSequential (return x) (c2 Nothing)
275 (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFiniteSequential c1 (c2 $ Just x)
276 (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFiniteSequential c1 (return y)
277 (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFiniteSequential (c1 True) (suspend s2)
278 (Suspend (RightF (Await c1)), Done y) -> coupleFiniteSequential (c1 False) (return y)
279
280 -- coupleNested :: (Functor s, Monad m) =>
281 -- Trampoline (EitherFunctor s (Yield a)) m x
282 -- -> Trampoline (EitherFunctor s (Await (Maybe a))) m y -> Trampoline s m (x, y)
283
284 -- coupleNested t1 t2 =
285 -- lift (liftM2 (,) (bounce t1) (bounce t2))
286 -- >>= \(s1, s2)-> case (s1, s2)
287 -- of (Done x, Done y) -> return (x, y)
288 -- (Suspend (RightF (Yield _ c1)), Done y) -> coupleNested c1 (return y)
289 -- (Done x, Suspend (RightF (Await c2))) -> coupleNested (return x) (c2 Nothing)
290 -- (Suspend (RightF (Yield x c1)), Suspend (RightF (Await c2))) -> coupleNested c1 (c2 $ Just x)
291 -- (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNested (return y)) s)
292 -- (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNested (return x)) s)
293 -- (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNested $ suspend $ LeftF s1) s2)
294
295 coupleNestedFinite :: (Functor s, ParallelizableMonad m) =>
296 Trampoline (SinkFunctor s a) m x -> Trampoline (SourceFunctor s a) m y -> Trampoline s m (x, y)
297 coupleNestedFinite t1 t2 = lift (parallelize (bounce t1) (bounce t2))
298 >>= stepCouple coupleNestedFinite
299
300 coupleNestedFiniteSequential :: (Functor s, Monad m) =>
301 Trampoline (SinkFunctor s a) m x
302 -> Trampoline (SourceFunctor s a) m y
303 -> Trampoline s m (x, y)
304 coupleNestedFiniteSequential producer consumer =
305 pogoStickNested resolveProducerConsumer (coupleNested producer consumer)
306 -- coupleNestedFiniteSequential t1 t2 = lift (liftM2 (,) (bounce t1) (bounce t2))
307 -- >>= stepCouple coupleNestedFiniteSequential
308
309 stepCouple :: (Functor s, Monad m) =>
310 (Trampoline (EitherFunctor s (TryYield a)) m x
311 -> Trampoline (EitherFunctor s (Await (Maybe a))) m y
312 -> Trampoline s m (x, y))
313 -> (TrampolineState (EitherFunctor s (TryYield a)) m x,
314 TrampolineState (EitherFunctor s (Await (Maybe a))) m y)
315 -> Trampoline s m (x, y)
316 stepCouple f couple = case couple
317 of (Done x, Done y) -> return (x, y)
318 (Done x, Suspend (RightF (Await c2))) -> f (return x) (c2 Nothing)
319 (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> f c1 (return y)
320 (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> f c1 (c2 $ Just x)
321 (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> f (c1 True) (suspend s2)
322 (Suspend (RightF (RightF (Await c1))), Done y) -> f (c1 False) (return y)
323 (Suspend (LeftF s), Done y) -> suspend (fmap (flip f (return y)) s)
324 (Done x, Suspend (LeftF s)) -> suspend (fmap (f (return x)) s)
325 (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (f $ suspend $ LeftF s1) s2)
326 (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip f (suspend $ RightF s2)) s1)
327 (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (f (suspend $ RightF s1)) s2)
328
329 local :: forall m l r x. (Functor r, Monad m) => Trampoline r m x -> Trampoline (EitherFunctor l r) m x
330 local (Trampoline mr) = Trampoline (liftM inject mr)
331 where inject :: TrampolineState r m x -> TrampolineState (EitherFunctor l r) m x
332 inject (Done x) = Done x
333 inject (Suspend r) = Suspend (RightF $ fmap local r)
334
335 out :: forall m l r x. (Functor l, Monad m) => Trampoline l m x -> Trampoline (EitherFunctor l r) m x
336 out (Trampoline ml) = Trampoline (liftM inject ml)
337 where inject :: TrampolineState l m x -> TrampolineState (EitherFunctor l r) m x
338 inject (Done x) = Done x
339 inject (Suspend l) = Suspend (LeftF $ fmap out l)
340
341 -- | Class of functors that can be lifted.
342 class (Functor a, Functor d) => AncestorFunctor a d where
343 -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor.
344 liftFunctor :: a x -> d x
345
346 instance Functor a => AncestorFunctor a a where
347 liftFunctor = id
348 instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where
349 liftFunctor = LeftF . (liftFunctor :: a x -> d' x)
350
351 liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline a m x -> Trampoline d m x
352 liftOut (Trampoline ma) = Trampoline (liftM inject ma)
353 where inject :: TrampolineState a m x -> TrampolineState d m x
354 inject (Done x) = Done x
355 inject (Suspend a) = Suspend (liftFunctor $ fmap liftOut a)
356
357 type SourceFunctor a x = EitherFunctor a (Await (Maybe x))
358 type SinkFunctor a x = EitherFunctor a (TryYield x)
359
360 -- | A 'Sink' can be used to yield values from any nested `Trampoline` computation whose functor provably descends from
361 -- the functor /a/. It's the write-only end of a 'Pipe' communication channel.
362 data Sink (m :: * -> *) a x =
363 Sink
364 {
365 -- | Function 'put' tries to put a value into the given `Sink`. The intervening 'Trampoline' computations suspend up
366 -- to the 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation
367 -- succeded.
368 put :: forall d. (AncestorFunctor a d) => x -> Trampoline d m Bool,
369 -- | Function 'canPut' checks if the argument `Sink` accepts values, i.e., whether a 'put' operation would succeed on
370 -- the sink.
371 canPut :: forall d. (AncestorFunctor a d) => Trampoline d m Bool
372 }
373
374 -- | A 'Source' can be used to read values into any nested `Trampoline` computation whose functor provably descends from
375 -- the functor /a/. It's the read-only end of a 'Pipe' communication channel.
376 newtype Source (m :: * -> *) a x =
377 Source
378 {
379 -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Trampoline' computations
380 -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if
381 -- the argument source is empty.
382 get :: forall d. (AncestorFunctor a d) => Trampoline d m (Maybe x)
383 }
384
385 -- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/.
386 liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x
387 liftSink s = Sink {put= liftOut . (put s :: x -> Trampoline d m Bool),
388 canPut= liftOut (canPut s :: Trampoline d m Bool)}
389
390 -- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/.
391 liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x
392 liftSource s = Source {get= liftOut (get s :: Trampoline d m (Maybe x))}
393
394 -- | The 'pipe' function splits the computation into two concurrent parts, /producer/ and /consumer/. The /producer/ is
395 -- given a 'Sink' to put values into, and /consumer/ a 'Source' to get those values from. Once producer and consumer
396 -- both complete, 'pipe' returns their paired results.
397 pipe :: forall m a a1 a2 x r1 r2. (Monad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
398 (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2)
399 pipe producer consumer = coupleNestedFiniteSequential (producer sink) (consumer source) where
400 sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool),
401 canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x
402 source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x
403
404 -- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel.
405 pipeP :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
406 (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2)
407 pipeP producer consumer = coupleNestedFinite (producer sink) (consumer source) where
408 sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool),
409 canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x
410 source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x
411
412 -- | The 'pipePS' function acts either as 'pipeP' or as 'pipe', depending on the argument /parallel/.
413 pipePS :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) =>
414 Bool -> (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) ->
415 Trampoline a m (r1, r2)
416 pipePS parallel = if parallel then pipeP else pipe
417
418 getSuccess :: forall m a d x . (Monad m, AncestorFunctor a d)
419 => Source m a x -> (x -> Trampoline d m ()) {- ^ Success continuation -} -> Trampoline d m ()
420 getSuccess source succeed = get source >>= maybe (return ()) succeed
421
422 -- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the
423 -- source is empty, the function throws an error.
424 get' :: forall m a d x . (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m x
425 get' source = get source >>= maybe (error "get' failed") return
426
427 -- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy
428 -- and the sink accepts it.
429 pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
430 => Source m a1 x -> Sink m a2 x -> Trampoline d m ()
431 pour source sink = fill'
432 where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill'))
433
434 -- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/.
435 pourMap :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
436 => (x -> y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m ()
437 pourMap f source sink = loop
438 where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop))
439
440 -- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'.
441 pourMapMaybe :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d)
442 => (x -> Maybe y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m ()
443 pourMapMaybe f source sink = loop
444 where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop))
445
446 -- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/
447 -- and /sink2/.
448 tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d)
449 => Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Trampoline d m ()
450 tee source sink1 sink2 = distribute
451 where distribute = do c1 <- canPut sink1
452 c2 <- canPut sink2
453 when (c1 && c2)
454 (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute))
455
456 -- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't
457 -- accepted by the sink is the result value.
458 putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Trampoline d m [x]
459 putList [] sink = return []
460 putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l)
461
462 -- | 'getList' returns the list of all values generated by the source.
463 getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m [x]
464 getList source = getList' return
465 where getList' f = get source >>= maybe (f []) (\x-> getList' (f . (x:)))
466
467 -- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates.
468 consumeAndSuppress :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m ()
469 consumeAndSuppress source = get source
470 >>= maybe (return ()) (const (consumeAndSuppress source))
471
472 -- | A utility function wrapping if-then-else, useful for handling monadic truth values
473 cond :: a -> a -> Bool -> a
474 cond x y test = if test then x else y
475
476 -- | A utility function, useful for handling monadic list values where empty list means success
477 whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a]
478 whenNull action list = if null list then action else return list
479
480 -- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink.
481 putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Trampoline d m [x]
482 putQueue q sink = putList (toList (viewl q)) sink