monad-coroutine 0.5.1 → 0.6

raw patch · 6 files changed

+358/−87 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Control/Cofunctor/Ticker.hs +85/−0
• Control/Monad/Coroutine.hs +69/−43
• Control/Monad/Coroutine/Nested.hs +45/−22
• Control/Monad/Coroutine/SuspensionFunctors.hs +144/−6
• TestCoroutine.hs +12/−14
• monad-coroutine.cabal +3/−2

@@ -0,0 +1,85 @@+{- +    Copyright 2010 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/>.+-}++-- | This module defines the Ticker cofunctor, useful for 'ticking off' a prefix of the input.+-- ++module Control.Cofunctor.Ticker+   (+    -- * The Ticker type+    Ticker(Ticker), +    -- * Using a Ticker+    cofmap, splitTicked, +    -- * Various Ticker constructors+    tickNone, tickOne, tickCount, tickPrefixOf, tickWhilePrefixOf, tickWhile, tickUntil, tickAll, andThen+   )+where++-- | This is a cofunctor data type for selecting a prefix of an input stream. If the next input item is acceptable, the+-- ticker function returns the ticker for the rest of the stream. If not, it returns 'Nothing'.+newtype Ticker x = Ticker (x -> Maybe (Ticker x))++-- | 'Ticker' happens to be a cofunctor, but there is no standard class declaration to declare it an instance of.+cofmap :: (x -> y) -> Ticker y -> Ticker x+cofmap f (Ticker g) = Ticker (fmap (cofmap f) . g . f)++-- | Extracts a list prefix accepted by the 'Ticker' argument. Returns the modified ticker, the prefix, and the+-- remainder of the list.+splitTicked :: Ticker x -> [x] -> (Ticker x, [x], [x])+splitTicked t [] = (t, [], [])+splitTicked t@(Ticker f) l@(x:rest) =+   maybe (t, [], l) (\t' -> let (t'', xs1, xs2) = splitTicked t' rest in (t'', x:xs1, xs2)) (f x)++-- | A ticker that accepts no input.+tickNone :: Ticker x+tickNone = Ticker (const Nothing)++-- | A ticker that accepts a single input item.+tickOne :: Ticker x+tickOne = Ticker (const $ Just tickNone)++-- | A ticker that accepts a given number of input items.+tickCount :: Int -> Ticker x+tickCount n | n > 0 = Ticker (const $ Just $ tickCount (pred n))+            | otherwise = tickNone++-- | A ticker that accepts the longest prefix of input that matches a prefix of the argument list.+tickPrefixOf :: Eq x => [x] -> Ticker x+tickPrefixOf list = tickWhilePrefixOf (map (==) list)++-- | A ticker that accepts a prefix of input as long as each item satisfies the predicate at the same position in the+-- argument list. The length of the predicate list thus determines the maximum number of acepted values.+tickWhilePrefixOf :: [x -> Bool] -> Ticker x+tickWhilePrefixOf (p : tail) = Ticker $ \x-> if p x then Just (tickWhilePrefixOf tail) else Nothing+tickWhilePrefixOf [] = tickNone++-- | A ticker that accepts all input as long as it matches the given predicate.+tickWhile :: (x -> Bool) -> Ticker x+tickWhile p = t+   where t = Ticker (\x-> if p x then Just t else Nothing)++-- | A ticker that accepts all input items until one matches the given predicate.+tickUntil :: (x -> Bool) -> Ticker x+tickUntil p = t+   where t = Ticker (\x-> if p x then Nothing else Just t)++-- | A ticker that accepts all input.+tickAll :: Ticker x+tickAll = Ticker (const $ Just tickAll)++-- | Sequential ticker combinator: when the first argument ticker stops ticking, the second takes over.+andThen :: Ticker x -> Ticker x -> Ticker x+andThen (Ticker t1) t@(Ticker t2) = Ticker (\x-> maybe (t2 x) (\t1'-> Just (andThen t1' t)) (t1 x))

@@ -38,9 +38,10 @@ -- printProduce producer = pogoStick (\\(Yield x cont) -> lift (print x) >> cont) producer -- @ -- --- Multiple concurrent coroutines can be run as well, and this module provides two different ways. The function 'seesaw'--- can be used to run two interleaved computations. Another possible way is to use the functions 'couple' or 'merge' to--- weave together steps of different coroutines into a single coroutine, which can then be executed by 'pogoStick'.+-- Multiple concurrent coroutines can be run as well, and this module provides two different ways. Functions 'seesaw'+-- and 'seesawSteps' can be used to run two interleaved computations. Another possible way is to use the functions+-- 'couple' or 'merge' to weave together steps of different coroutines into a single coroutine, which can then be+-- executed by 'pogoStick'. --  -- For other uses of trampoline-style coroutines, see -- @@ -56,14 +57,13 @@ module Control.Monad.Coroutine    (     -- * Coroutine definition-    Coroutine(Coroutine),-    resume, suspend,+    Coroutine(Coroutine, resume), CoroutineStepResult, suspend,     -- * Coroutine operations     mapMonad, mapSuspension,      -- * Running Coroutine computations-    Naught, runCoroutine, pogoStick, foldRun, seesaw, SeesawResolver(..),+    Naught, runCoroutine, bounce, pogoStick, foldRun, seesaw, SeesawResolver(..), seesawSteps,     -- * Coupled Coroutine computations-    SomeFunctor(..), composePair,+    PairBinder, sequentialBinder, parallelBinder, liftBinder, SomeFunctor(..), composePair,     couple, merge    ) where@@ -93,11 +93,7 @@ --   t >>= f = Coroutine (resume t >>= either (return . Left . fmap (>>= f)) (resume . f))  instance (Functor s, MonadParallel m) => MonadParallel (Coroutine s m) where-   bindM2 f t1 t2 = Coroutine (bindM2 combine (resume t1) (resume t2)) where-      combine (Right x) (Right y) = resume (f x y)-      combine (Left s) (Right y) = return $ Left (fmap (flip f y =<<) s)-      combine (Right x) (Left s) = return $ Left (fmap (f x =<<) s)-      combine (Left s1) (Left s2) = return $ Left (fmap (bindM2 f $ suspend s1) s2)+   bindM2 = liftBinder bindM2  instance Functor s => MonadTrans (Coroutine s) where    lift = Coroutine . liftM Right@@ -143,31 +139,55 @@ runCoroutine :: Monad m => Coroutine Naught m x -> m x runCoroutine = pogoStick (error "runCoroutine can run only a non-suspending coroutine!") --- | Run a suspendable 'Coroutine', using a function that extracts the coroutine resumption from each suspension.+-- | Runs a single step of a suspendable 'Coroutine', using a function that extracts the coroutine resumption from its+-- suspension functor.+bounce :: (Monad m, Functor s) => (s (Coroutine s m x) -> Coroutine s m x) -> Coroutine s m x -> Coroutine s m x+bounce spring c = lift (resume c) >>= either spring return++-- | Runs a suspendable 'Coroutine' to its completion. pogoStick :: Monad m => (s (Coroutine s m x) -> Coroutine s m x) -> Coroutine s m x -> m x-pogoStick reveal t = resume t-                     >>= \s-> case s -                              of Right result -> return result-                                 Left c -> pogoStick reveal (reveal c)+pogoStick spring c = resume c >>= either (pogoStick spring . spring) return  -- | Runs a suspendable coroutine much like 'pogoStick', but allows the resumption function to thread an arbitrary -- state as well. foldRun :: Monad m => (a -> s (Coroutine s m x) -> (a, Coroutine s m x)) -> a -> Coroutine s m x -> m (a, x)-foldRun f a t = resume t+foldRun f a c = resume c                 >>= \s-> case s                           of Right result -> return (a, result)                             Left c -> uncurry (foldRun f) (f a c) --- | Weaves two coroutines into one. The two coroutines suspend and resume in lockstep.+-- | Type of functions that can bind two monadic values together; used to combine two coroutines' step results.+type PairBinder m = forall x y r. (x -> y -> m r) -> m x -> m y -> m r++-- | A 'PairBinder' that runs the two steps sequentially before combining their results.+sequentialBinder :: Monad m => PairBinder m+sequentialBinder f mx my = do {x <- mx; y <- my; f x y}++-- | A 'PairBinder' that runs the two steps in parallel.+parallelBinder :: MonadParallel m => PairBinder m+parallelBinder = bindM2++-- | Lifting a 'PairBinder' onto a 'Coroutine' monad transformer.+liftBinder :: forall s m. (Functor s, Monad m) => PairBinder m -> PairBinder (Coroutine s m)+liftBinder binder f t1 t2 = Coroutine (binder combine (resume t1) (resume t2)) where+   combine (Right x) (Right y) = resume (f x y)+   combine (Left s) (Right y) = return $ Left (fmap (flip f y =<<) s)+   combine (Right x) (Left s) = return $ Left (fmap (f x =<<) s)+   combine (Left s1) (Left s2) = return $ Left (fmap (liftBinder binder f $ suspend s1) s2)++-- | Weaves two coroutines into one. The two coroutines suspend and resume in lockstep. The combined coroutine suspends+-- as long as either argument coroutine suspends, and it completes execution when both arguments do. couple :: forall s1 s2 m x y r. (Monad m, Functor s1, Functor s2) => -          (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-       -> Coroutine s1 m x -> Coroutine s2 m y -> Coroutine (SomeFunctor s1 s2) m (x, y)+          PairBinder m -> Coroutine s1 m x -> Coroutine s2 m y -> Coroutine (SomeFunctor s1 s2) m (x, y) couple runPair t1 t2 = Coroutine{resume= runPair proceed (resume t1) (resume t2)} where-   proceed :: CoroutineStepResult s1 m x -> CoroutineStepResult s2 m y -> m (CoroutineStepResult (SomeFunctor s1 s2) m (x, y))+   proceed :: CoroutineStepResult s1 m x -> CoroutineStepResult s2 m y+           -> m (CoroutineStepResult (SomeFunctor s1 s2) m (x, y))    proceed (Right x) (Right y) = return $ Right (x, y)-   proceed (Left s1) (Left s2) = return $ Left $ fmap (uncurry (couple runPair)) (Both $ composePair s1 s2)+   proceed (Left s1) (Left s2) = return $ Left+                                 $ fmap (uncurry (couple runPair)) (Both $ composePair s1 s2)    proceed (Right x) (Left s2) = return $ Left $ fmap (couple runPair (return x)) (RightSome s2)-   proceed (Left s1) (Right y) = return $ Left $ fmap (flip (couple runPair) (return y)) (LeftSome s1)+   proceed (Left s1) (Right y) = return $ Left+                                 $ fmap (flip (couple runPair) (return y)) (LeftSome s1)  -- | Weaves a list of coroutines with the same suspension functor type into a single coroutine. The coroutines suspend -- and resume in lockstep.@@ -182,15 +202,15 @@                                          sequence2 suspensions  -- | A simple record containing the resolver functions for all possible coroutine pair suspensions.-data SeesawResolver s1 s2 = SeesawResolver {-   resumeLeft  :: forall t. s1 t -> t,    -- ^ resolves the left suspension functor into the resumption it contains-   resumeRight :: forall t. s2 t -> t,    -- ^ resolves the right suspension into its resumption-   resumeAny   :: forall t1 t2 r.-                  (t1 -> r)       --  ^ continuation to resume only the left suspended coroutine-               -> (t2 -> r)       --  ^ continuation to resume the right coroutine only-               -> (t1 -> t2 -> r) --  ^ continuation to resume both coroutines-               -> s1 t1           --  ^ left suspension-               -> s2 t2           --  ^ right suspension+data SeesawResolver s1 s2 s1' s2' = SeesawResolver {+   resumeLeft  :: forall m t. (Monad m) => s1 (Coroutine s1' m t) -> Coroutine s1' m t,+   -- ^ resolves the left suspension functor into the resumption it contains+   resumeRight :: forall m t. (Monad m) => s2 (Coroutine s2' m t) -> Coroutine s2' m t,+   -- ^ resolves the right suspension into its resumption+   resumeBoth  :: forall m t1 t2 r. (Monad m) =>+                  (Coroutine s1' m t1 -> Coroutine s2' m t2 -> r) --  ^ continuation to resume both coroutines+               -> s1 (Coroutine s1' m t1)                         --  ^ left suspension+               -> s2 (Coroutine s2' m t2)                         --  ^ right suspension                -> r    -- ^ invoked when both coroutines are suspended, resolves both suspensions or either one }@@ -198,13 +218,19 @@ -- | Runs two coroutines concurrently. The first argument is used to run the next step of each coroutine, the next to -- convert the left, right, or both suspensions into the corresponding resumptions. seesaw :: (Monad m, Functor s1, Functor s2) => -          (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-       -> SeesawResolver s1 s2-       -> Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)-seesaw runPair resolver t1 t2 = seesaw' t1 t2 where-   seesaw' t1 t2 = runPair proceed (resume t1) (resume t2)-   proceed (Right x) (Right y) = return (x, y)-   proceed (Right x) (Left s2) = seesaw' (return x) (resumeRight resolver s2)-   proceed (Left s1) (Right y) = seesaw' (resumeLeft resolver s1) (return y)-   proceed (Left s1) (Left s2) =-      resumeAny resolver (flip seesaw' (suspend s2)) (seesaw' (suspend s1)) seesaw' s1 s2+          PairBinder m -> SeesawResolver s1 s2 s1 s2 -> Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)+seesaw runPair resolver t1 t2 = seesawSteps runPair proceed t1 t2 where+   proceed cont (Left s1) (Left s2) = resumeBoth resolver cont s1 s2+   proceed _ (Right x) (Left s2) = liftM ((,) x) $ pogoStick (resumeRight resolver) (resumeRight resolver s2)+   proceed _ (Left s1) (Right y) = liftM (flip (,) y) $ pogoStick (resumeLeft resolver) (resumeLeft resolver s1)+   proceed _ (Right x) (Right y) = return (x, y)++-- | Runs two coroutines concurrently. The first argument is used to run the next step of each coroutine, the next to+-- convert their step results into the corresponding resumptions.+seesawSteps :: (Monad m, Functor s1, Functor s2) => +               PairBinder m+            -> ((Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)) +                -> CoroutineStepResult s1 m x -> CoroutineStepResult s2 m y -> m (x, y))+            -> Coroutine s1 m x -> Coroutine s2 m y -> m (x, y)+seesawSteps runPair proceed t1 t2 = seesaw' t1 t2 where+   seesaw' t1 t2 = runPair (proceed seesaw') (resume t1) (resume t2)

@@ -23,7 +23,7 @@ -- coroutines. --  -- Nestable coroutines of this kind should group their suspension functors into an 'EitherFunctor'. You can adjust a--- normal suspension, such as the one produced by 'yield', using functions 'mapSuspension' and 'liftOut'. To run nested+-- normal suspension, such as the one produced by 'yield', using functions 'mapSuspension' and 'liftAncestor'. To run nested -- coroutines, use functions 'pogoStickNested', 'seesawNested', and 'coupleNested'.  {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies,@@ -32,9 +32,9 @@  module Control.Monad.Coroutine.Nested    (-    pogoStickNested, coupleNested, seesawNested, -    AncestorFunctor,-    liftOut+    pogoStickNested, coupleNested, seesawNested, seesawNestedSteps,+    ChildFunctor(..), AncestorFunctor(..),+    liftParent, liftAncestor    ) where @@ -42,8 +42,10 @@ import Control.Monad.Trans.Class (lift)  import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors+import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..)) +import Data.Functor.Compose (Compose(..))+ -- | Run a nested 'Coroutine' that can suspend both itself and the current 'Coroutine'. pogoStickNested :: forall s1 s2 m x. (Functor s1, Functor s2, Monad m) =>                     (s2 (Coroutine (EitherFunctor s1 s2) m x) -> Coroutine (EitherFunctor s1 s2) m x)@@ -55,9 +57,9 @@                                   Left (LeftF s) -> return (Left (fmap (pogoStickNested reveal) s))                                   Left (RightF c) -> resume (pogoStickNested reveal (reveal c))} --- | Weaves two nested coroutines into one.+-- | Much like 'couple', but with two nested coroutines. coupleNested :: forall s0 s1 s2 m x y r. (Monad m, Functor s0, Monad s0, Functor s1, Functor s2) => -                (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)+                PairBinder m              -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y              -> Coroutine (EitherFunctor s0 (SomeFunctor s1 s2)) m (x, y) coupleNested runPair = coupleNested' where@@ -65,8 +67,7 @@    proceed (Right x) (Right y) = Right (x, y)    proceed (Left (RightF s)) (Right y) = Left $ RightF $ fmap (flip coupleNested' (return y)) (LeftSome s)    proceed (Right x) (Left (RightF s)) = Left $ RightF $ fmap (coupleNested' (return x)) (RightSome s)-   proceed (Left (RightF s1)) (Left (RightF s2)) =-      Left $ RightF $ fmap (uncurry coupleNested') (Both $ composePair s1 s2)+   proceed (Left (RightF s1)) (Left (RightF s2)) = Left $ RightF $ fmap (uncurry coupleNested') (Both $ composePair s1 s2)    proceed l (Left (LeftF s)) = Left $ LeftF $ fmap (coupleNested' (Coroutine $ return l)) s    proceed (Left (LeftF s)) r = Left $ LeftF $ fmap (flip coupleNested' (Coroutine $ return r)) s @@ -74,19 +75,37 @@ -- If both coroutines try to suspend the current coroutine in the same step, the left coroutine's suspension will have -- precedence. seesawNested :: (Monad m, Functor s0, Functor s1, Functor s2) =>-                (forall x y r. (x -> y -> m r) -> m x -> m y -> m r)-             -> SeesawResolver s1 s2+                PairBinder m+             -> SeesawResolver s1 s2 (EitherFunctor s0 s1) (EitherFunctor s0 s2)              -> Coroutine (EitherFunctor s0 s1) m x -> Coroutine (EitherFunctor s0 s2) m y -> Coroutine s0 m (x, y)-seesawNested runPair resolver t1 t2 = seesaw' t1 t2 where+seesawNested runPair resolver t1 t2 = seesawNestedSteps runPair proceed t1 t2 where+   proceed cont (Left s1) (Left s2) = resumeBoth resolver cont s1 s2+   proceed _ (Left s) (Right y) = liftM (flip (,) y) $ pogoStickNested (resumeLeft resolver) (resumeLeft resolver s)+   proceed _ (Right x) (Left s) = liftM ((,) x) $ pogoStickNested (resumeRight resolver) (resumeRight resolver s)+   proceed _ (Right x) (Right y) = return (x, y)++-- | Like 'seesawSteps', but for nested coroutines that are allowed to suspend the current coroutine as well+-- as themselves.  If both coroutines try to suspend the current coroutine in the same step, the left coroutine's+-- suspension will have precedence.+seesawNestedSteps :: forall m c1 c2 s0 s1 s2 s1' s2' x y. +                     (Monad m, Functor s0, Functor s1, Functor s2, +                      s1' ~ EitherFunctor s0 s1, s2' ~ EitherFunctor s0 s2,+                      c1 ~ Coroutine s1' m x, c2 ~ Coroutine s2' m y) =>+                     PairBinder m+                  -> ((c1 -> c2 -> Coroutine s0 m (x, y)) +                      -> Either (s1 c1) x -> Either (s2 c2) y -> Coroutine s0 m (x, y))+                  -> c1 -> c2 -> Coroutine s0 m (x, y)+seesawNestedSteps runPair proceed t1 t2 = seesaw' t1 t2 where    seesaw' t1 t2 = Coroutine{resume= bouncePair t1 t2}-   bouncePair t1 t2 = runPair proceed (resume t1) (resume t2)-   proceed (Left (LeftF s1)) state2 = return $ Left $ fmap ((flip seesaw' (Coroutine $ return state2))) s1-   proceed state1 (Left (LeftF s2)) = return $ Left $ fmap (seesaw' (Coroutine $ return state1)) s2-   proceed (Right x) (Right y) = return $ Right (x, y)-   proceed state1@(Right x) (Left (RightF s2)) = proceed state1 =<< resume (resumeRight resolver s2)-   proceed (Left (RightF s1)) state2@(Right y) = flip proceed state2 =<< resume (resumeLeft resolver s1)-   proceed state1@(Left (RightF s1)) state2@(Left (RightF s2)) =-      resumeAny resolver ((flip proceed state2 =<<) . resume) ((proceed state1 =<<) . resume) bouncePair s1 s2+   bouncePair t1 t2 = runPair proceed' (resume t1) (resume t2)+   proceed' :: CoroutineStepResult s1' m x -> CoroutineStepResult s2' m y -> m (CoroutineStepResult s0 m (x, y))+   proceed' (Left (LeftF s1)) step2 = return $ Left $ fmap ((flip seesaw' (Coroutine $ return step2))) s1+   proceed' step1 (Left (LeftF s2)) = return $ Left $ fmap (seesaw' (Coroutine $ return step1)) s2+   proceed' step1 step2 = resume $ proceed seesaw' (local step1) (local step2)+   local :: forall s x. +            CoroutineStepResult (EitherFunctor s0 s) m x -> Either (s (Coroutine (EitherFunctor s0 s) m x)) x+   local (Left (RightF s)) = Left s+   local (Right r) = Right r  -- | Class of functors that can contain another functor. class Functor c => ChildFunctor c where@@ -106,6 +125,10 @@ instance (Functor a, ChildFunctor d, d' ~ Parent d, AncestorFunctor a d') => AncestorFunctor a d where    liftFunctor = wrap . (liftFunctor :: a x -> d' x) +-- | Converts a coroutine into a child nested coroutine.+liftParent :: forall m p c x. (Monad m, Functor p, ChildFunctor c, p ~ Parent c) => Coroutine p m x -> Coroutine c m x+liftParent cort = mapSuspension wrap cort+ -- | Converts a coroutine into a descendant nested coroutine.-liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x-liftOut cort = mapSuspension liftFunctor cort+liftAncestor :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Coroutine a m x -> Coroutine d m x+liftAncestor cort = mapSuspension liftFunctor cort

@@ -14,20 +14,33 @@     <http://www.gnu.org/licenses/>. -} --- | This module defines suspension functors for use with the "Control.Monad.Coroutine" module.+-- | This module defines some common suspension functors for use with the "Control.Monad.Coroutine" module. --  +{-# LANGUAGE Rank2Types #-}+ module Control.Monad.Coroutine.SuspensionFunctors    (     -- * Suspension functors     Yield(Yield), Await(Await), Request(Request), EitherFunctor(LeftF, RightF),-    yield, await, request+    yield, await, request,+    -- * Utility functions+    concatYields, concatAwaits,+    -- * Resolvers for running pairs of coroutines+    awaitYieldResolver, awaitMaybeYieldResolver, awaitYieldChunkResolver, requestsResolver, +    tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver,+    liftedTickerYieldResolver, liftedTickerRequestResolver, liftedLazyTickerRequestResolver,    ) where -import Control.Monad (Monad)-import Control.Monad.Coroutine (Coroutine, resume, suspend)+import Prelude hiding (foldl, foldr)+import Control.Monad (Monad, liftM)+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Foldable (Foldable, foldl, foldr) +import Control.Monad.Coroutine+import Control.Cofunctor.Ticker (Ticker, splitTicked)+ -- | The 'Yield' functor instance is equivalent to (,) but more descriptive. data Yield x y = Yield x y instance Functor (Yield x) where@@ -49,14 +62,139 @@    fmap f (LeftF l) = LeftF (fmap f l)    fmap f (RightF r) = RightF (fmap f r) --- | Suspend yielding a value.+-- | Suspend the current coroutine yielding a value. yield :: Monad m => x -> Coroutine (Yield x) m () yield x = suspend (Yield x (return ())) --- | Suspend until a value is provided.+-- | Suspend the current coroutine until a value is provided. await :: Monad m => Coroutine (Await x) m x await = suspend (Await return)  -- | Suspend yielding a request and awaiting the response. request :: Monad m => x -> Coroutine (Request x y) m y request x = suspend (Request x return)++-- | Converts a coroutine yielding collections of values into one yielding single values.+concatYields :: (Monad m, Foldable f) => Coroutine (Yield (f x)) m r -> Coroutine (Yield x) m r+concatYields c = Coroutine{resume= resume c >>= foldChunk}+   where foldChunk (Right r) = return (Right r)+         foldChunk (Left (Yield s c)) = foldr f (resume $ concatYields c) s+         f x rest = return (Left $ Yield x (Coroutine rest))++-- | Converts a coroutine awaiting single values into one awaiting collections of values.+concatAwaits :: (Monad m, Foldable f) => Coroutine (Await x) m r -> Coroutine (Await (f x)) m r+concatAwaits c = lift (resume c) >>= either concat return+   where concat s = do chunk <- await+                       concatAwaits (feedAll chunk (suspend s))++-- | A 'SeesawResolver' for running two coroutines in parallel, one of which 'await's values while the other 'yield's+-- them. The yielding coroutine must not terminate before the other one.+awaitYieldResolver :: SeesawResolver (Await x) (Yield x) s1 s2+awaitYieldResolver = SeesawResolver {+   resumeLeft= undefined,+   resumeRight= \(Yield _ c)-> c,+   resumeBoth= \cont (Await f) (Yield x c2)-> cont (f x) c2+}++-- | A 'SeesawResolver' for running two coroutines in parallel, one of which 'await's values while the other 'yield's+-- them. If the yielding coroutine terminates before the awaiting one, the latter will receive 'Nothing'.+awaitMaybeYieldResolver :: SeesawResolver (Await (Maybe x)) (Yield x) s1 s2+awaitMaybeYieldResolver = SeesawResolver {+   resumeLeft= \(Await f)-> f Nothing,+   resumeRight= \(Yield _ c)-> c,+   resumeBoth= \cont (Await f) (Yield x c2)-> cont (f $ Just x) c2+}++-- | A 'SeesawResolver' for running two coroutines in parallel, one of which 'await's non-empty lists of values while+-- the other 'yield's them. If the yielding coroutine dies, the awaiting coroutine receives empty lists.+awaitYieldChunkResolver :: SeesawResolver (Await [x]) (Yield [x]) s1 s2+awaitYieldChunkResolver = SeesawResolver {+   resumeLeft= \(Await f)-> f [],+   resumeRight= \(Yield _ c)-> c,+   resumeBoth= \cont (Await f) (Yield chunk c2)-> cont (f chunk) c2+}++-- | A 'SeesawResolver' for running two 'request'ing coroutines in parallel. One coroutine's request becomes the other's+-- response, and vice versa.+requestsResolver :: SeesawResolver (Request x y) (Request y x) s1 s2+requestsResolver = SeesawResolver {+   resumeLeft= undefined,+   resumeRight= undefined,+   resumeBoth= \cont (Request x c1) (Request y c2)-> cont (c1 y) (c2 x)+}++-- | A 'SeesawResolver' for running two coroutines in parallel. One coroutine produces data in chunks, the other+-- consumes data in chunks. The boundaries of the two kinds of chunks need not be the same, as the consumed chunks+-- are determined by a 'Ticker' provided by the consumer's input request.+tickerYieldResolver :: SeesawResolver (Request (Ticker x) [x]) (Yield [x]) (Request (Ticker x) [x]) (Yield [x])+tickerYieldResolver = liftedTickerYieldResolver id id++-- | A generic version of 'tickerYieldResolver', allowing coroutines with 'Request' and 'Yield' functors embedded in+-- other functors.+liftedTickerYieldResolver :: (Functor s1, Functor s2) =>+                             (forall a. Request (Ticker x) [x] a -> s1 a) -> (forall a. Yield [x] a -> s2 a)+                             -> SeesawResolver (Request (Ticker x) [x]) (Yield [x]) s1 s2+liftedTickerYieldResolver lift1 lift2 = SeesawResolver {+   resumeLeft= \(Request _ c)-> c [],+   resumeRight= \(Yield _ c)-> c,+   resumeBoth= \cont (Request t c1) (Yield xs c2)->+               let (t', chunk, rest) = splitTicked t xs+               in case rest+                  of [] -> cont (suspend $ lift1 $ Request t' c1) c2+                     _ -> cont (c1 chunk) (suspend $ lift2 $ Yield rest c2)+}++-- | Like 'tickerYieldResolver', the only difference being that the producing coroutine sends its chunks using 'request'+-- rather than 'yield'. The feedback received from 'request' is the unconsumed remainder of the chunk, which lets the+-- coroutine know when its sibling terminates.+tickerRequestResolver :: SeesawResolver (Request (Ticker x) [x]) (Request [x] [x])+                                        (Request (Ticker x) [x]) (Request [x] [x])+tickerRequestResolver = liftedTickerRequestResolver id id++-- | A generic version of 'tickerRequestResolver', allowing coroutines with 'Request' functors embedded in other+-- functors.+liftedTickerRequestResolver :: (Functor s1, Functor s2) =>+                               (forall a. Request (Ticker x) [x] a -> s1 a) -> (forall a. Request [x] [x] a -> s2 a)+                               -> SeesawResolver (Request (Ticker x) [x]) (Request [x] [x]) s1 s2+liftedTickerRequestResolver lift1 lift2 = SeesawResolver {+   resumeLeft= \(Request _ c)-> c [],+   resumeRight= \(Request chunk c)-> c chunk,+   resumeBoth= \cont (Request t c1) (Request xs c2)->+               let (t', chunk, rest) = splitTicked t xs+               in case rest+                  of [] -> cont (suspend $ lift1 $ Request t' c1) (c2 [])+                     _ -> cont (c1 chunk) (suspend $ lift2 $ Request rest c2)+}++-- | Like 'tickerRequestResolver', except the consuming coroutine requests receive both the selected prefix of the input+-- chunk and a peek at either the next unconsumed input item, if any, or the final 'Ticker' value. Chunks sent by the+-- producing coroutine never get combined for the consuming coroutine. This allows better synchronization between the+-- two coroutines. It also leaks the information about the produced chunk boundaries into the consuming coroutine, so+-- this resolver should be used with caution.+lazyTickerRequestResolver :: SeesawResolver (Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x])+                                            (Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x])+lazyTickerRequestResolver = liftedLazyTickerRequestResolver id++-- | A generic version of 'lazyTickerRequestResolver', allowing coroutines with 'Request' functors embedded in other+-- functors.+liftedLazyTickerRequestResolver :: +   (Functor s1, Functor s2) => +   (forall a. Request [x] [x] a -> s2 a)+   -> SeesawResolver (Request (Ticker x) ([x], Either x (Ticker x))) (Request [x] [x]) s1 s2+liftedLazyTickerRequestResolver lift = SeesawResolver {+   resumeLeft= \(Request t c)-> c ([], Right t),+   resumeRight= \(Request chunk c)-> c chunk,+   resumeBoth= \cont (Request t c1) (Request xs c2)->+               let (t', chunk, rest) = splitTicked t xs+               in case rest+                  of [] -> cont (c1 (chunk, Right t')) (c2 [])+                     next:_ -> cont (c1 (chunk, Left next)) (suspend $ lift $ Request rest c2)+}++-- | Feeds a single value to an awaiting coroutine.+feed :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r+feed x c = bounce (\(Await f)-> f x) c++-- | Feeds a collection of values to an awaiting coroutine.+feedAll :: (Foldable f, Monad m) => f x -> Coroutine (Await x) m r -> Coroutine (Await x) m r+feedAll chunk c = foldl (flip feed) c chunk

@@ -31,7 +31,7 @@ import Control.Monad.Coroutine import Control.Monad.Coroutine.SuspensionFunctors import Control.Monad.Coroutine.Nested-import Control.Monad.Parallel (MonadParallel(..), sequence)+import Control.Monad.Parallel (MonadParallel, bindM2, liftM2, sequence)  factors n = maybe [n] (\k-> (k : factors (n `div` k))) (find (\k-> n `mod` k == 0) [2 .. n - 1]) @@ -41,7 +41,7 @@  factorFibs :: MonadParallel m => [Int] -> m Integer factorFibs nums = liftM snd $-                  seesaw bindM2 (SeesawResolver resumeLeft resumeRight resumeAny)+                  seesaw bindM2 (SeesawResolver resumeLeft resumeRight resumeBoth)                      (mapM_ (yieldApply (fib 0)) nums)                      (factorize 0)    where factorize :: MonadParallel m => Integer -> Coroutine (Await (Maybe Integer)) m Integer@@ -51,16 +51,14 @@                                 (\n-> factorize (sum + n {-product (factors n)-}))          resumeLeft (Yield _ c) = c          resumeRight (Await c) = c Nothing-         resumeAny _ _ c (Yield x c1) (Await c2) = c c1 (c2 (Just x))+         resumeBoth c (Yield x c1) (Await c2) = c c1 (c2 (Just x))  twoFibs :: MonadParallel m => [Int] -> m Integer-twoFibs nums = liftM (uncurry (+)) $-               pogoStick-                  resume-                  (couple bindM2 (fibs 1) (fibs 2))+twoFibs nums = pogoStick resume (couple bindM2 (fibs 1) (fibs 2))+               >>= \(x, y)-> return (x + y)    where resume :: SomeFunctor (Yield Integer) (Yield Integer) c -> c          resume (Both (Compose (Yield n1 (Yield n2 c)))) = assert (n1 == n2) c-         fibs ix = mapM_ (yieldApply (fib ix)) nums >> return (fib ix $ last nums)+         fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums)  twoFibsSeesaw :: MonadParallel m => [Int] -> m Integer twoFibsSeesaw nums = liftM (uncurry (+)) $@@ -68,10 +66,9 @@    where resolver = SeesawResolver{                       resumeLeft= undefined,                       resumeRight= undefined,-                      resumeAny= \resumeLeft resumeRight resumeBoth (Yield left c1) (Yield right c2)->-                                 assert (left == right) $ resumeBoth c1 c2+                      resumeBoth= \cont (Yield left c1) (Yield right c2)-> assert (left == right) $ cont c1 c2                     }-         fibs ix = mapM_ (yieldApply (fib ix)) nums >> return (fib ix $ last nums)+         fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums)  fibs :: MonadParallel m => Int -> [Int] -> m Integer fibs coroutineCount nums = liftM sum $@@ -80,11 +77,12 @@                               (merge sequence appendYields $ replicateIx coroutineCount fibs)    where resume :: Yield [Integer] (Coroutine (Yield [Integer]) m [Integer]) -> Coroutine (Yield [Integer]) m [Integer]          resume (Yield (x:xs) c) = assert (all (==x) xs) c-         fibs ix = mapM_ (yieldApply ((:[]) . fib ix)) nums >> return (fib ix $ last nums)+         fibs ix = mapM_ (yieldApply ((:[]) . fib ix)) nums >> applyM (fib ix) (last nums)          appendYields :: [Yield [s] x] -> Yield [s] [x]          appendYields yields = uncurry Yield $ foldr (\(Yield s x) (ss, xs)-> (s ++ ss, x:xs)) ([], []) yields  yieldApply f n = let result = f n in result `pseq` yield result+applyM f n = let result = f n in result `pseq` return result  replicateIx :: Int -> (Int -> x) -> [x] replicateIx n f = map f [1..n]@@ -92,8 +90,8 @@ nested :: (Monad m, Functor p) =>           Int -> (Integer -> Coroutine p m ()) -> Coroutine (EitherFunctor p (Yield Integer)) m () nested level suspendParent = do mapSuspension RightF (yield 1)-                                liftOut (suspendParent 2)-                                when (level > 0) (pogoStickNested cont $ nested (pred level) (liftOut . suspendParent))+                                liftAncestor (suspendParent 2)+                                when (level > 0) (pogoStickNested cont $ nested (pred level) (liftAncestor . suspendParent))    where cont (Yield x c) = c  main = do args <- getArgs

@@ -1,5 +1,5 @@ Name:                monad-coroutine-Version:             0.5.1+Version:             0.6 Cabal-Version:       >= 1.2 Build-Type:          Simple Synopsis:            Coroutine monad transformer for suspending and resuming monadic computations@@ -22,6 +22,7 @@ --   location:          http://code.haskell.org/SCC/  Library-  Exposed-Modules:   Control.Monad.Coroutine, Control.Monad.Coroutine.SuspensionFunctors, Control.Monad.Coroutine.Nested+  Exposed-Modules:   Control.Cofunctor.Ticker,+                     Control.Monad.Coroutine, Control.Monad.Coroutine.SuspensionFunctors, Control.Monad.Coroutine.Nested   Build-Depends:     base < 5, monad-parallel, transformers >= 0.2 && < 0.3   GHC-prof-options:  -auto-all