Ticket #3787: Trampoline.hs

File Trampoline.hs, 24.9 KB (added by blamario, 4 years ago)

The module that's causing all the panic

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