diff options
Diffstat (limited to 'testsuite/tests/indexed-types/should_compile/T3787.hs')
| -rw-r--r-- | testsuite/tests/indexed-types/should_compile/T3787.hs | 475 |
1 files changed, 475 insertions, 0 deletions
diff --git a/testsuite/tests/indexed-types/should_compile/T3787.hs b/testsuite/tests/indexed-types/should_compile/T3787.hs new file mode 100644 index 0000000000..955b6a1cdd --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T3787.hs @@ -0,0 +1,475 @@ +{- + Copyright 2009 Mario Blazevic + + This file is part of the Streaming Component Combinators (SCC) project. + + The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public + License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later + version. + + SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty + of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along with SCC. If not, see + <http://www.gnu.org/licenses/>. +-} + +-- | Module "Trampoline" defines the trampoline computations and their basic building blocks. + +{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, KindSignatures, + FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances + #-} + +module T3787 where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Monad (liftM, liftM2, when) +import Control.Monad.Identity +import Control.Monad.Trans (MonadTrans(..)) + +import Data.Foldable (toList) +import Data.Maybe (maybe) +import Data.Sequence (Seq, viewl) + +par, pseq :: a -> b -> b +par = error "urk" +pseq = error "urk" + +-- | Class of monads that can perform two computations in parallel. +class Monad m => ParallelizableMonad m where + -- | Combine two computations into a single parallel computation. Default implementation of `parallelize` is + -- @liftM2 (,)@ + parallelize :: m a -> m b -> m (a, b) + parallelize = liftM2 (,) + +-- | Any monad that allows the result value to be extracted, such as `Identity` or `Maybe` monad, can implement +-- `parallelize` by using `par`. +instance ParallelizableMonad Identity where + parallelize ma mb = let a = runIdentity ma + b = runIdentity mb + in a `par` (b `pseq` a `pseq` Identity (a, b)) + +instance ParallelizableMonad Maybe where + parallelize ma mb = case ma `par` (mb `pseq` (ma, mb)) + of (Just a, Just b) -> Just (a, b) + _ -> Nothing + +-- | IO is parallelizable by `forkIO`. +instance ParallelizableMonad IO where + parallelize ma mb = do va <- newEmptyMVar + vb <- newEmptyMVar + forkIO (ma >>= putMVar va) + forkIO (mb >>= putMVar vb) + a <- takeMVar va + b <- takeMVar vb + return (a, b) + +-- | Suspending monadic computations. +newtype Trampoline s m r = Trampoline { + -- | Run the next step of a `Trampoline` computation. + bounce :: m (TrampolineState s m r) + } + +data TrampolineState s m r = + -- | Trampoline computation is finished with final value /r/. + Done r + -- | Computation is suspended, its remainder is embedded in the functor /s/. + | Suspend! (s (Trampoline s m r)) + +instance (Functor s, Monad m) => Monad (Trampoline s m) where + return x = Trampoline (return (Done x)) + t >>= f = Trampoline (bounce t >>= apply f) + where apply f (Done x) = bounce (f x) + apply f (Suspend s) = return (Suspend (fmap (>>= f) s)) + +instance (Functor s, ParallelizableMonad m) => ParallelizableMonad (Trampoline s m) where + parallelize t1 t2 = Trampoline $ liftM combine $ parallelize (bounce t1) (bounce t2) where + combine (Done x, Done y) = Done (x, y) + combine (Suspend s, Done y) = Suspend (fmap (liftM $ \x-> (x, y)) s) + combine (Done x, Suspend s) = Suspend (fmap (liftM $ (,) x) s) + combine (Suspend s1, Suspend s2) = Suspend (fmap (parallelize $ suspend s1) s2) + +instance Functor s => MonadTrans (Trampoline s) where + lift = Trampoline . liftM Done + +data Yield x y = Yield! x y +instance Functor (Yield x) where + fmap f (Yield x y) = Yield x (f y) + +data Await x y = Await! (x -> y) +instance Functor (Await x) where + fmap f (Await g) = Await (f . g) + +data EitherFunctor l r x = LeftF (l x) | RightF (r x) +instance (Functor l, Functor r) => Functor (EitherFunctor l r) where + fmap f (LeftF l) = LeftF (fmap f l) + fmap f (RightF r) = RightF (fmap f r) + +newtype NestedFunctor l r x = NestedFunctor (l (r x)) +instance (Functor l, Functor r) => Functor (NestedFunctor l r) where + fmap f (NestedFunctor lr) = NestedFunctor ((fmap . fmap) f lr) + +data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x) +instance (Functor l, Functor r) => Functor (SomeFunctor l r) where + fmap f (LeftSome l) = LeftSome (fmap f l) + fmap f (RightSome r) = RightSome (fmap f r) + fmap f (Both lr) = Both (fmap f lr) + +type TryYield x = EitherFunctor (Yield x) (Await Bool) + +suspend :: (Monad m, Functor s) => s (Trampoline s m x) -> Trampoline s m x +suspend s = Trampoline (return (Suspend s)) + +yield :: forall m x. Monad m => x -> Trampoline (Yield x) m () +yield x = suspend (Yield x (return ())) + +await :: forall m x. Monad m => Trampoline (Await x) m x +await = suspend (Await return) + +tryYield :: forall m x. Monad m => x -> Trampoline (TryYield x) m Bool +tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return))))) + +canYield :: forall m x. Monad m => Trampoline (TryYield x) m Bool +canYield = suspend (RightF (Await return)) + +fromTrampoline :: Monad m => Trampoline s m x -> m x +fromTrampoline t = bounce t >>= \(Done x)-> return x + +runTrampoline :: Monad m => Trampoline Identity m x -> m x +runTrampoline = fromTrampoline + +pogoStick :: (Functor s, Monad m) => (s (Trampoline s m x) -> Trampoline s m x) -> Trampoline s m x -> m x +pogoStick reveal t = bounce t + >>= \s-> case s + of Done result -> return result + Suspend c -> pogoStick reveal (reveal c) + +pogoStickNested :: (Functor s1, Functor s2, Monad m) => + (s2 (Trampoline (EitherFunctor s1 s2) m x) -> Trampoline (EitherFunctor s1 s2) m x) + -> Trampoline (EitherFunctor s1 s2) m x -> Trampoline s1 m x +pogoStickNested reveal t = + Trampoline{bounce= bounce t + >>= \s-> case s + of Done result -> return (Done result) + Suspend (LeftF s) -> return (Suspend (fmap (pogoStickNested reveal) s)) + Suspend (RightF c) -> bounce (pogoStickNested reveal (reveal c)) + } + +nest :: (Functor a, Functor b) => a x -> b y -> NestedFunctor a b (x, y) +nest a b = NestedFunctor $ fmap (\x-> fmap ((,) x) b) a + +-- couple :: (Monad m, Functor s1, Functor s2) => +-- Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (NestedFunctor s1 s2) m (x, y) +-- couple t1 t2 = Trampoline{bounce= do ts1 <- bounce t1 +-- ts2 <- bounce t2 +-- case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y) +-- (Suspend s1, Suspend s2) -> return $ Suspend $ +-- fmap (uncurry couple) (nest s1 s2) +-- } + +coupleAlternating :: (Monad m, Functor s1, Functor s2) => + Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y) +coupleAlternating t1 t2 = + Trampoline{bounce= do ts1 <- bounce t1 + ts2 <- bounce t2 + case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y) + (Suspend s1, Suspend s2) -> + return $ Suspend $ fmap (uncurry coupleAlternating) (Both $ nest s1 s2) + (Done x, Suspend s2) -> + return $ Suspend $ fmap (coupleAlternating (return x)) (RightSome s2) + (Suspend s1, Done y) -> + return $ Suspend $ fmap (flip coupleAlternating (return y)) (LeftSome s1) + } + +coupleParallel :: (ParallelizableMonad m, Functor s1, Functor s2) => + Trampoline s1 m x -> Trampoline s2 m y -> Trampoline (SomeFunctor s1 s2) m (x, y) +coupleParallel t1 t2 = + Trampoline{bounce= parallelize (bounce t1) (bounce t2) + >>= \pair-> case pair + of (Done x, Done y) -> return $ Done (x, y) + (Suspend s1, Suspend s2) -> + return $ Suspend $ fmap (uncurry coupleParallel) (Both $ nest s1 s2) + (Done x, Suspend s2) -> + return $ Suspend $ fmap (coupleParallel (return x)) (RightSome s2) + (Suspend s1, Done y) -> + return $ Suspend $ fmap (flip coupleParallel (return y)) (LeftSome s1) + } + +coupleNested :: (Monad m, Functor s0, Functor s1, Functor s2) => + Trampoline (EitherFunctor s0 s1) m x -> Trampoline (EitherFunctor s0 s2) m y -> + Trampoline (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y) +coupleNested t1 t2 = + Trampoline{bounce= do ts1 <- bounce t1 + ts2 <- bounce t2 + case (ts1, ts2) of (Done x, Done y) -> return $ Done (x, y) + (Suspend (RightF s), Done y) -> + return $ Suspend $ RightF $ fmap (flip coupleNested (return y)) (LeftSome s) + (Done x, Suspend (RightF s)) -> + return $ Suspend $ RightF $ fmap (coupleNested (return x)) (RightSome s) + (Suspend (RightF s1), Suspend (RightF s2)) -> + return $ Suspend $ RightF $ fmap (uncurry coupleNested) (Both $ nest s1 s2) + (Suspend (LeftF s), Done y) -> + return $ Suspend $ LeftF $ fmap (flip coupleNested (return y)) s + (Done x, Suspend (LeftF s)) -> + return $ Suspend $ LeftF $ fmap (coupleNested (return x)) s + (Suspend (LeftF s1), Suspend (LeftF s2)) -> + return $ Suspend $ LeftF $ fmap (coupleNested $ suspend $ LeftF s1) s2 + } + +seesaw :: (Monad m, Functor s1, Functor s2) => + (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t) + -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y) +seesaw resolve t1 t2 = pogoStick resolve (coupleAlternating t1 t2) + +seesawParallel :: (ParallelizableMonad m, Functor s1, Functor s2) => + (forall x y s t. (s ~ SomeFunctor s1 s2, t ~ Trampoline s m (x, y)) => s t -> t) + -> Trampoline s1 m x -> Trampoline s2 m y -> m (x, y) +seesawParallel resolve t1 t2 = pogoStick resolve (coupleParallel t1 t2) + +resolveProducerConsumer :: forall a s s0 t t' m x. + (Functor s0, Monad m, s ~ SomeFunctor (TryYield a) (Await (Maybe a)), + t ~ Trampoline (EitherFunctor s0 s) m x) => + s t -> t +-- Arg :: s t +-- (LeftSome (LeftF ...)) : SomeFunctor (EitherFunctor .. ..) (...) t +resolveProducerConsumer (LeftSome (LeftF (Yield _ c))) = c +resolveProducerConsumer (LeftSome (RightF (Await c))) = c False +resolveProducerConsumer (RightSome (Await c)) = c Nothing +resolveProducerConsumer (Both (NestedFunctor (LeftF (Yield x (Await c))))) = c (Just x) +resolveProducerConsumer (Both (NestedFunctor (RightF (Await c)))) = suspend (RightF $ RightSome $ c True) + +couplePC :: ParallelizableMonad m => Trampoline (Yield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y) +couplePC t1 t2 = parallelize (bounce t1) (bounce t2) + >>= \(s1, s2)-> case (s1, s2) + of (Done x, Done y) -> return (x, y) + (Suspend (Yield x c1), Suspend (Await c2)) -> couplePC c1 (c2 $ Just x) + (Suspend (Yield _ c1), Done y) -> couplePC c1 (return y) + (Done x, Suspend (Await c2)) -> couplePC (return x) (c2 Nothing) + +coupleFinite :: ParallelizableMonad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y) +coupleFinite t1 t2 = + parallelize (bounce t1) (bounce t2) + >>= \(s1, s2)-> case (s1, s2) + of (Done x, Done y) -> return (x, y) + (Done x, Suspend (Await c2)) -> coupleFinite (return x) (c2 Nothing) + (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFinite c1 (c2 $ Just x) + (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFinite c1 (return y) + (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFinite (c1 True) (suspend s2) + (Suspend (RightF (Await c1)), Done y) -> coupleFinite (c1 False) (return y) + +coupleFiniteSequential :: Monad m => Trampoline (TryYield a) m x -> Trampoline (Await (Maybe a)) m y -> m (x, y) +coupleFiniteSequential t1 t2 = + bounce t1 + >>= \s1-> bounce t2 + >>= \s2-> case (s1, s2) + of (Done x, Done y) -> return (x, y) + (Done x, Suspend (Await c2)) -> coupleFiniteSequential (return x) (c2 Nothing) + (Suspend (LeftF (Yield x c1)), Suspend (Await c2)) -> coupleFiniteSequential c1 (c2 $ Just x) + (Suspend (LeftF (Yield _ c1)), Done y) -> coupleFiniteSequential c1 (return y) + (Suspend (RightF (Await c1)), Suspend s2@Await{}) -> coupleFiniteSequential (c1 True) (suspend s2) + (Suspend (RightF (Await c1)), Done y) -> coupleFiniteSequential (c1 False) (return y) + +-- coupleNested :: (Functor s, Monad m) => +-- Trampoline (EitherFunctor s (Yield a)) m x +-- -> Trampoline (EitherFunctor s (Await (Maybe a))) m y -> Trampoline s m (x, y) + +-- coupleNested t1 t2 = +-- lift (liftM2 (,) (bounce t1) (bounce t2)) +-- >>= \(s1, s2)-> case (s1, s2) +-- of (Done x, Done y) -> return (x, y) +-- (Suspend (RightF (Yield _ c1)), Done y) -> coupleNested c1 (return y) +-- (Done x, Suspend (RightF (Await c2))) -> coupleNested (return x) (c2 Nothing) +-- (Suspend (RightF (Yield x c1)), Suspend (RightF (Await c2))) -> coupleNested c1 (c2 $ Just x) +-- (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNested (return y)) s) +-- (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNested (return x)) s) +-- (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNested $ suspend $ LeftF s1) s2) + +coupleNestedFinite :: (Functor s, ParallelizableMonad m) => + Trampoline (SinkFunctor s a) m x -> Trampoline (SourceFunctor s a) m y -> Trampoline s m (x, y) +coupleNestedFinite t1 t2 = lift (parallelize (bounce t1) (bounce t2)) + >>= stepCouple coupleNestedFinite + +coupleNestedFiniteSequential :: (Functor s, Monad m) => + Trampoline (SinkFunctor s a) m x + -> Trampoline (SourceFunctor s a) m y + -> Trampoline s m (x, y) +coupleNestedFiniteSequential producer consumer = + pogoStickNested resolveProducerConsumer (coupleNested producer consumer) +-- coupleNestedFiniteSequential t1 t2 = lift (liftM2 (,) (bounce t1) (bounce t2)) +-- >>= stepCouple coupleNestedFiniteSequential + +stepCouple :: (Functor s, Monad m) => + (Trampoline (EitherFunctor s (TryYield a)) m x + -> Trampoline (EitherFunctor s (Await (Maybe a))) m y + -> Trampoline s m (x, y)) + -> (TrampolineState (EitherFunctor s (TryYield a)) m x, + TrampolineState (EitherFunctor s (Await (Maybe a))) m y) + -> Trampoline s m (x, y) +stepCouple f couple = case couple + of (Done x, Done y) -> return (x, y) + (Done x, Suspend (RightF (Await c2))) -> f (return x) (c2 Nothing) + (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> f c1 (return y) + (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> f c1 (c2 $ Just x) + (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> f (c1 True) (suspend s2) + (Suspend (RightF (RightF (Await c1))), Done y) -> f (c1 False) (return y) + (Suspend (LeftF s), Done y) -> suspend (fmap (flip f (return y)) s) + (Done x, Suspend (LeftF s)) -> suspend (fmap (f (return x)) s) + (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (f $ suspend $ LeftF s1) s2) + (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip f (suspend $ RightF s2)) s1) + (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (f (suspend $ RightF s1)) s2) + +local :: forall m l r x. (Functor r, Monad m) => Trampoline r m x -> Trampoline (EitherFunctor l r) m x +local (Trampoline mr) = Trampoline (liftM inject mr) + where inject :: TrampolineState r m x -> TrampolineState (EitherFunctor l r) m x + inject (Done x) = Done x + inject (Suspend r) = Suspend (RightF $ fmap local r) + +out :: forall m l r x. (Functor l, Monad m) => Trampoline l m x -> Trampoline (EitherFunctor l r) m x +out (Trampoline ml) = Trampoline (liftM inject ml) + where inject :: TrampolineState l m x -> TrampolineState (EitherFunctor l r) m x + inject (Done x) = Done x + inject (Suspend l) = Suspend (LeftF $ fmap out l) + +-- | Class of functors that can be lifted. +class (Functor a, Functor d) => AncestorFunctor a d where + -- | Convert the ancestor functor into its descendant. The descendant functor typically contains the ancestor. + liftFunctor :: a x -> d x + +instance Functor a => AncestorFunctor a a where + liftFunctor = id +instance (Functor a, Functor d', Functor d, d ~ EitherFunctor d' s, AncestorFunctor a d') => AncestorFunctor a d where + liftFunctor = LeftF . (liftFunctor :: a x -> d' x) + +liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline a m x -> Trampoline d m x +liftOut (Trampoline ma) = Trampoline (liftM inject ma) + where inject :: TrampolineState a m x -> TrampolineState d m x + inject (Done x) = Done x + inject (Suspend a) = Suspend (liftFunctor $ fmap liftOut a) + +type SourceFunctor a x = EitherFunctor a (Await (Maybe x)) +type SinkFunctor a x = EitherFunctor a (TryYield x) + +-- | A 'Sink' can be used to yield values from any nested `Trampoline` computation whose functor provably descends from +-- the functor /a/. It's the write-only end of a 'Pipe' communication channel. +data Sink (m :: * -> *) a x = + Sink + { + -- | Function 'put' tries to put a value into the given `Sink`. The intervening 'Trampoline' computations suspend up + -- to the 'pipe' invocation that has created the argument sink. The result of 'put' indicates whether the operation + -- succeded. + put :: forall d. (AncestorFunctor a d) => x -> Trampoline d m Bool, + -- | Function 'canPut' checks if the argument `Sink` accepts values, i.e., whether a 'put' operation would succeed on + -- the sink. + canPut :: forall d. (AncestorFunctor a d) => Trampoline d m Bool + } + +-- | A 'Source' can be used to read values into any nested `Trampoline` computation whose functor provably descends from +-- the functor /a/. It's the read-only end of a 'Pipe' communication channel. +newtype Source (m :: * -> *) a x = + Source + { + -- | Function 'get' tries to get a value from the given 'Source' argument. The intervening 'Trampoline' computations + -- suspend all the way to the 'pipe' function invocation that created the source. The function returns 'Nothing' if + -- the argument source is empty. + get :: forall d. (AncestorFunctor a d) => Trampoline d m (Maybe x) + } + +-- | Converts a 'Sink' on the ancestor functor /a/ into a sink on the descendant functor /d/. +liftSink :: forall m a d x. (Monad m, AncestorFunctor a d) => Sink m a x -> Sink m d x +liftSink s = Sink {put= liftOut . (put s :: x -> Trampoline d m Bool), + canPut= liftOut (canPut s :: Trampoline d m Bool)} + +-- | Converts a 'Source' on the ancestor functor /a/ into a source on the descendant functor /d/. +liftSource :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Source m d x +liftSource s = Source {get= liftOut (get s :: Trampoline d m (Maybe x))} + +-- | The 'pipe' function splits the computation into two concurrent parts, /producer/ and /consumer/. The /producer/ is +-- given a 'Sink' to put values into, and /consumer/ a 'Source' to get those values from. Once producer and consumer +-- both complete, 'pipe' returns their paired results. +pipe :: forall m a a1 a2 x r1 r2. (Monad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => + (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2) +pipe producer consumer = coupleNestedFiniteSequential (producer sink) (consumer source) where + sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool), + canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x + source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x + +-- | The 'pipeP' function is equivalent to 'pipe', except the /producer/ and /consumer/ are run in parallel. +pipeP :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => + (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> Trampoline a m (r1, r2) +pipeP producer consumer = coupleNestedFinite (producer sink) (consumer source) where + sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline a1 m Bool), + canPut= liftOut (local canYield :: Trampoline a1 m Bool)} :: Sink m a1 x + source = Source (liftOut (local await :: Trampoline a2 m (Maybe x))) :: Source m a2 x + +-- | The 'pipePS' function acts either as 'pipeP' or as 'pipe', depending on the argument /parallel/. +pipePS :: forall m a a1 a2 x r1 r2. (ParallelizableMonad m, Functor a, a1 ~ SinkFunctor a x, a2 ~ SourceFunctor a x) => + Bool -> (Sink m a1 x -> Trampoline a1 m r1) -> (Source m a2 x -> Trampoline a2 m r2) -> + Trampoline a m (r1, r2) +pipePS parallel = if parallel then pipeP else pipe + +getSuccess :: forall m a d x . (Monad m, AncestorFunctor a d) + => Source m a x -> (x -> Trampoline d m ()) {- ^ Success continuation -} -> Trampoline d m () +getSuccess source succeed = get source >>= maybe (return ()) succeed + +-- | Function 'get'' assumes that the argument source is not empty and returns the value the source yields. If the +-- source is empty, the function throws an error. +get' :: forall m a d x . (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m x +get' source = get source >>= maybe (error "get' failed") return + +-- | 'pour' copies all data from the /source/ argument into the /sink/ argument, as long as there is anything to copy +-- and the sink accepts it. +pour :: forall m a1 a2 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) + => Source m a1 x -> Sink m a2 x -> Trampoline d m () +pour source sink = fill' + where fill' = canPut sink >>= flip when (getSuccess source (\x-> put sink x >> fill')) + +-- | 'pourMap' is like 'pour' that applies the function /f/ to each argument before passing it into the /sink/. +pourMap :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) + => (x -> y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m () +pourMap f source sink = loop + where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> put sink (f x) >> loop)) + +-- | 'pourMapMaybe' is to 'pourMap' like 'Data.Maybe.mapMaybe' is to 'Data.List.Map'. +pourMapMaybe :: forall m a1 a2 d x y . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d) + => (x -> Maybe y) -> Source m a1 x -> Sink m a2 y -> Trampoline d m () +pourMapMaybe f source sink = loop + where loop = canPut sink >>= flip when (get source >>= maybe (return ()) (\x-> maybe (return False) (put sink) (f x) >> loop)) + +-- | 'tee' is similar to 'pour' except it distributes every input value from the /source/ arguments into both /sink1/ +-- and /sink2/. +tee :: forall m a1 a2 a3 d x . (Monad m, AncestorFunctor a1 d, AncestorFunctor a2 d, AncestorFunctor a3 d) + => Source m a1 x -> Sink m a2 x -> Sink m a3 x -> Trampoline d m () +tee source sink1 sink2 = distribute + where distribute = do c1 <- canPut sink1 + c2 <- canPut sink2 + when (c1 && c2) + (get source >>= maybe (return ()) (\x-> put sink1 x >> put sink2 x >> distribute)) + +-- | 'putList' puts entire list into its /sink/ argument, as long as the sink accepts it. The remainder that wasn't +-- accepted by the sink is the result value. +putList :: forall m a d x. (Monad m, AncestorFunctor a d) => [x] -> Sink m a x -> Trampoline d m [x] +putList [] sink = return [] +putList l@(x:rest) sink = put sink x >>= cond (putList rest sink) (return l) + +-- | 'getList' returns the list of all values generated by the source. +getList :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m [x] +getList source = getList' return + where getList' f = get source >>= maybe (f []) (\x-> getList' (f . (x:))) + +-- | 'consumeAndSuppress' consumes the entire source ignoring the values it generates. +consumeAndSuppress :: forall m a d x. (Monad m, AncestorFunctor a d) => Source m a x -> Trampoline d m () +consumeAndSuppress source = get source + >>= maybe (return ()) (const (consumeAndSuppress source)) + +-- | A utility function wrapping if-then-else, useful for handling monadic truth values +cond :: a -> a -> Bool -> a +cond x y test = if test then x else y + +-- | A utility function, useful for handling monadic list values where empty list means success +whenNull :: forall a m. Monad m => m [a] -> [a] -> m [a] +whenNull action list = if null list then action else return list + +-- | Like 'putList', except it puts the contents of the given 'Data.Sequence.Seq' into the sink. +putQueue :: forall m a d x. (Monad m, AncestorFunctor a d) => Seq x -> Sink m a x -> Trampoline d m [x] +putQueue q sink = putList (toList (viewl q)) sink |