monad-coroutine 0.7.1 → 0.8
raw patch · 6 files changed
+206/−483 lines, 6 filesdep −contravariantdep −incremental-parserdep ~transformers
Dependencies removed: contravariant, incremental-parser
Dependency ranges changed: transformers
Files
- Control/Monad/Coroutine.hs +38/−78
- Control/Monad/Coroutine/Nested.hs +36/−65
- Control/Monad/Coroutine/SuspensionFunctors.hs +97/−210
- Data/Functor/Contravariant/Ticker.hs +0/−102
- Test/BenchmarkCoroutine.hs +25/−18
- monad-coroutine.cabal +10/−10
Control/Monad/Coroutine.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2009-2010 Mario Blazevic+ Copyright 2009-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -17,7 +17,7 @@ -- | This module defines the 'Coroutine' monad transformer. -- -- A 'Coroutine' monadic computation can 'suspend' its execution at any time, returning control to its invoker. The--- returned coroutine suspension is a 'Functor' containing the resumption of the coroutine. Here is an example of a+-- returned suspension value contains the coroutine's resumption wrapped in a 'Functor'. Here is an example of a -- coroutine in the 'IO' monad that suspends computation using the functor 'Yield' from the -- "Control.Monad.Coroutine.SuspensionFunctors" module: -- @@ -29,22 +29,24 @@ -- return \"Finished\" -- @ -- --- To continue the execution of a suspended 'Coroutine', apply its 'resume' method. The easiest way to run a coroutine--- to completion is by using the 'pogoStick' function, which keeps resuming the coroutine in trampolined style until it--- completes. Here is an example of 'pogoStick' applied to the /producer/ example above:+-- To continue the execution of a suspended 'Coroutine', extract it from the suspension functor and apply its 'resume'+-- method. The easiest way to run a coroutine to completion is by using the 'pogoStick' function, which keeps resuming+-- the coroutine in trampolined style until it completes. Here is one way to apply 'pogoStick' to the /producer/ example+-- above: -- -- @ -- printProduce :: Show x => Coroutine (Yield x) IO r -> IO r -- 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. 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'.+-- Multiple concurrent coroutines can be run as well, and this module provides two different ways. To run two+-- interleaved computations, use a 'WeaveStepper' to 'weave' together steps of two different coroutines into a single+-- coroutine, which can then be executed by 'pogoStick'. -- --- For other uses of trampoline-style coroutines, see+-- For various uses of trampoline-style coroutines, see -- +-- > Coroutine Pipelines - Mario Blažević, The Monad.Reader issue 19, pages 29-50+-- -- > Trampolined Style - Ganz, S. E. Friedman, D. P. Wand, M, ACM SIGPLAN NOTICES, 1999, VOL 34; NUMBER 9, pages 18-27 -- -- and@@ -60,20 +62,19 @@ Coroutine(Coroutine, resume), CoroutineStepResult, suspend, -- * Coroutine operations mapMonad, mapSuspension, mapFirstSuspension,- -- * Running Coroutine computations- Naught, runCoroutine, bounce, pogoStick, foldRun, seesaw, SeesawResolver(..), seesawSteps,- -- * Coupled Coroutine computations- PairBinder, sequentialBinder, parallelBinder, liftBinder, SomeFunctor(..), composePair,- couple, merge+ -- * Running coroutines+ Naught, runCoroutine, bounce, pogoStick, foldRun,+ -- * Weaving coroutines together+ PairBinder, sequentialBinder, parallelBinder, liftBinder,+ Weaver, WeaveStepper, weave, merge ) where -import Control.Applicative (Applicative(..), (<$>), liftA2)+import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), ap, liftM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Either (partitionEithers)-import Data.Functor.Compose (Compose(..)) import Control.Monad.Parallel (MonadParallel(..)) @@ -101,7 +102,7 @@ where apply fc (Right x) = resume (fc x) apply fc (Left s) = return (Left (fmap (>>= fc) s)) t >> f = Coroutine (resume t >>= apply f)- where apply fc (Right x) = resume fc+ where apply fc (Right _) = resume fc apply fc (Left s) = return (Left (fmap (>> fc) s)) instance (Functor s, MonadParallel m) => MonadParallel (Coroutine s m) where@@ -119,20 +120,10 @@ instance Functor Naught where fmap _ _ = undefined --- | Combines two functors into one, applying either or both of them. Used for coupled coroutines.-data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (Compose 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)---- | Combines two values under two functors into a pair of values under a single 'Compose'.-composePair :: (Functor a, Functor b) => a x -> b y -> Compose a b (x, y)-composePair a b = Compose $ fmap (\x-> fmap ((,) x) b) a- -- | Suspend the current 'Coroutine'. suspend :: (Monad m, Functor s) => s (Coroutine s m x) -> Coroutine s m x suspend s = Coroutine (return (Left s))+{-# INLINE suspend #-} -- | Change the base monad of a 'Coroutine'. mapMonad :: forall s m m' x. (Functor s, Monad m, Monad m') =>@@ -146,9 +137,10 @@ mapSuspension f cort = Coroutine {resume= liftM map' (resume cort)} where map' (Right r) = Right r map' (Left s) = Left (f $ fmap (mapSuspension f) s)+{-# INLINE mapSuspension #-} -- | Modify the first upcoming suspension of a 'Coroutine'.-mapFirstSuspension :: forall s s' m x. (Functor s, Monad m) => +mapFirstSuspension :: forall s m x. (Functor s, Monad m) => (forall y. s y -> s y) -> Coroutine s m x -> Coroutine s m x mapFirstSuspension f cort = Coroutine {resume= liftM map' (resume cort)} where map' (Right r) = Right r@@ -175,7 +167,8 @@ of Right result -> return (a, result) Left c' -> uncurry (foldRun f) (f a c') --- | Type of functions that can bind two monadic values together; used to combine two coroutines' step results.+-- | Type of functions that can bind two monadic values together, used to combine two coroutines' step results. The two+-- functions provided here are 'sequentialBinder' and 'parallelBinder'. 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.@@ -194,20 +187,21 @@ 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. (Monad m, Functor s1, Functor s2) => - 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 (Right x) (Right y) = return $ Right (x, y)- 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)+-- | Type of functions that can weave two coroutines into a single coroutine.+type Weaver s1 s2 s3 m x y z = Coroutine s1 m x -> Coroutine s2 m y -> Coroutine s3 m z +-- | Type of functions capable of combining two coroutines' 'CoroutineStepResult' values into a third one. Module+-- "Monad.Coroutine.SuspensionFunctors" contains several 'WeaveStepper' examples.+type WeaveStepper s1 s2 s3 m x y z =+ Weaver s1 s2 s3 m x y z -> CoroutineStepResult s1 m x -> CoroutineStepResult s2 m y -> Coroutine s3 m z++-- | Weaves two coroutines into one, given a 'PairBinder' to run the next step of each coroutine and a 'WeaveStepper' to+-- combine the results of the steps.+weave :: forall s1 s2 s3 m x y z. (Monad m, Functor s1, Functor s2, Functor s3) =>+ PairBinder m -> WeaveStepper s1 s2 s3 m x y z -> Weaver s1 s2 s3 m x y z+weave runPair weaveStep c1 c2 = zipC c1 c2 where+ zipC c1 c2 = Coroutine{resume= runPair (\c1' c2'-> resume $ weaveStep zipC c1' c2') (resume c1) (resume c2)}+ -- | Weaves a list of coroutines with the same suspension functor type into a single coroutine. The coroutines suspend -- and resume in lockstep. merge :: forall s m x. (Monad m, Functor s) =>@@ -219,37 +213,3 @@ of ([], ends) -> Right ends (suspensions, ends) -> Left $ fmap (merge sequence1 sequence2 . (map return ends ++)) $ sequence2 suspensions---- | A simple record containing the resolver functions for all possible coroutine pair suspensions.-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-}---- | 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) => - 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 = seesaw' where- seesaw' t1 t2 = runPair (proceed seesaw') (resume t1) (resume t2)
Control/Monad/Coroutine/Nested.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2010 Mario Blazevic+ Copyright 2010-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -14,17 +14,14 @@ <http://www.gnu.org/licenses/>. -} --- | This module defines nestable suspension functors for use with the 'Coroutine' monad transformer, as well as--- functions for running nested coroutines of this sort.--- --- Coroutines can be run from within another coroutine. In this case, the nested coroutines always suspend to their+-- | A coroutine can choose to launch another coroutine. In this case, the nested coroutines always suspend to their -- invoker. If a function from this module, such as 'pogoStickNested', is used to run a nested coroutine, the parent -- coroutine can be automatically suspended as well. A single suspension can thus suspend an entire chain of nested -- 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 'liftAncestor'. To run nested--- coroutines, use functions 'pogoStickNested', 'seesawNested', and 'coupleNested'.+-- Nestable coroutines of this kind should group their suspension functors into an 'EitherFunctor'. A simple coroutine+-- suspension can be converted to a nested one using functions 'mapSuspension' and 'liftAncestor'. To run nested+-- coroutines, use 'pogoStickNested', or 'weave' with a 'NestWeaveStepper'. {-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances@@ -32,17 +29,36 @@ module Control.Monad.Coroutine.Nested (- pogoStickNested, coupleNested, seesawNested, seesawNestedSteps,- ChildFunctor(..), AncestorFunctor(..),- liftParent, liftAncestor+ EitherFunctor(..), eitherFunctor, mapNestedSuspension,+ pogoStickNested,+ NestWeaveStepper,+ ChildFunctor(..), AncestorFunctor(..),+ liftParent, liftAncestor ) where import Control.Monad (liftM)- import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors (EitherFunctor(..)) +-- | Combines two alternative functors into one, applying one or the other. Used for nested coroutines.+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)++-- | Like 'either' for the EitherFunctor data type.+eitherFunctor :: (l x -> y) -> (r x -> y) -> EitherFunctor l r x -> y+eitherFunctor left _ (LeftF f) = left f+eitherFunctor _ right (RightF f) = right f++-- | Change the suspension functor of a nested 'Coroutine'.+mapNestedSuspension :: (Functor s0, Functor s, Monad m) => (forall y. s y -> s' y) ->+ Coroutine (EitherFunctor s0 s) m x -> Coroutine (EitherFunctor s0 s') m x+mapNestedSuspension f cort = Coroutine {resume= liftM map' (resume cort)}+ where map' (Right r) = Right r+ map' (Left (LeftF s)) = Left (LeftF $ fmap (mapNestedSuspension f) s)+ map' (Left (RightF s)) = Left (RightF (f $ fmap (mapNestedSuspension f) s))+ -- | 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)@@ -54,56 +70,9 @@ Left (LeftF s') -> return (Left (fmap (pogoStickNested reveal) s')) Left (RightF c) -> resume (pogoStickNested reveal (reveal c))} --- | Much like 'couple', but with two nested coroutines.-coupleNested :: forall s0 s1 s2 m x y. (Monad m, Functor s0, Monad s0, Functor s1, Functor s2) => - 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- coupleNested' t1 t2 = Coroutine{resume= runPair (\ st1 st2 -> return (proceed st1 st2)) (resume t1) (resume t2)}- 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 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---- | Like 'seesaw', 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.-seesawNested :: (Monad m, Functor s0, Functor s1, Functor 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 = 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 = seesaw' where- seesaw' t1 t2 = Coroutine{resume= bouncePair t1 t2}- 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 r. - CoroutineStepResult (EitherFunctor s0 s) m r -> Either (s (Coroutine (EitherFunctor s0 s) m r)) r- local (Left (RightF s)) = Left s- local (Left (LeftF _)) = undefined- local (Right r) = Right r+-- | Type of functions capable of combining two child coroutines' 'CoroutineStepResult' values into a parent coroutine.+-- Use with the function 'weave'.+type NestWeaveStepper s0 s1 s2 m x y z = WeaveStepper (EitherFunctor s0 s1) (EitherFunctor s0 s2) s0 m x y z -- | Class of functors that can contain another functor. class Functor c => ChildFunctor c where@@ -125,8 +94,10 @@ -- | 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+liftParent = mapSuspension wrap+{-# INLINE liftParent #-} -- | Converts a coroutine into a descendant nested coroutine. 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+liftAncestor = mapSuspension liftFunctor+{-# INLINE liftAncestor #-}
Control/Monad/Coroutine/SuspensionFunctors.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2010-2011 Mario Blazevic+ Copyright 2010-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -22,35 +22,36 @@ module Control.Monad.Coroutine.SuspensionFunctors ( -- * Suspension functors- Yield(Yield), Await(Await), Request(Request), ParseRequest, EitherFunctor(LeftF, RightF), eitherFunctor,- yield, await, request, requestParse,+ Yield(Yield), Await(Await), Request(Request),+ ReadRequest, ReadingResult(..), Reader, Reading(..),+ EitherFunctor(LeftF, RightF), eitherFunctor,+ yield, await, request, requestRead, -- * Utility functions concatYields, concatAwaits,- -- * Resolvers for running pairs of coroutines- awaitYieldResolver, awaitMaybeYieldResolver, awaitYieldChunkResolver, requestsResolver, - tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver, - parserRequestResolver, lazyParserRequestResolver,- liftedTickerYieldResolver, liftedTickerRequestResolver, liftedLazyTickerRequestResolver,- liftedParserRequestResolver, nestedLazyParserRequestResolver,+ -- * WeaveSteppers for weaving pairs of coroutines+ weaveAwaitYield, weaveAwaitMaybeYield, weaveRequests,+ weaveReadWriteRequests, weaveNestedReadWriteRequests ) where import Prelude hiding (foldl, foldr)-import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad (liftM)+import Control.Monad.Trans.Class (lift) import Data.Foldable (Foldable, foldl, foldr)+import Data.Functor.Identity (Identity(..)) import Data.Monoid (Monoid, mempty)-import Data.Monoid.Null (MonoidNull, mnull)-import Text.ParserCombinators.Incremental (Parser, feed, feedEof, results, (><)) import Control.Monad.Coroutine-import Data.Functor.Contravariant.Ticker (Ticker, splitTicked)+import Control.Monad.Coroutine.Nested (EitherFunctor(..), eitherFunctor, NestWeaveStepper, pogoStickNested) --- | The 'Yield' functor instance is equivalent to (,) but more descriptive.+-- | The 'Yield' functor instance is equivalent to (,) but more descriptive. A coroutine with this suspension functor+-- provides a value with every suspension. data Yield x y = Yield x y instance Functor (Yield x) where fmap f (Yield x y) = Yield x (f y) --- | The 'Await' functor instance is equivalent to (->) but more descriptive.+-- | The 'Await' functor instance is equivalent to (->) but more descriptive. A coroutine with this suspension functor+-- demands a value whenever it suspends, before it can resume its execution. newtype Await x y = Await (x -> y) instance Functor (Await x) where fmap f (Await g) = Await (f . g)@@ -60,22 +61,20 @@ instance Functor (Request x f) where fmap f (Request x g) = Request x (f . g) -data ParseRequest x z = forall a y. MonoidNull y => - ParseRequest ([x] -> [x]) (Parser a [x] y) ((y, Maybe (Parser a [x] y)) -> z)-instance Functor (ParseRequest x) where- fmap f (ParseRequest b p g) = ParseRequest b p (f . g)+data Reading x py y = Final x y -- ^ Final result chunk with the unconsumed portion of the input+ | Advance (Reader x py y) y py -- ^ A part of the result with the reader of more input and the EOF+ | Deferred (Reader x py y) y -- ^ Reader of more input, plus the result if there isn't any. --- | Combines two alternative functors into one, applying one or the other. Used for nested coroutines.-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)+data ReadingResult x py y = ResultPart py (Reader x py y) -- ^ A part of the result with the reader of more input+ | FinalResult y -- ^ Final result chunk --- | Like 'either' for the EitherFunctor data type.-eitherFunctor :: (l x -> y) -> (r x -> y) -> EitherFunctor l r x -> y-eitherFunctor left _ (LeftF f) = left f-eitherFunctor _ right (RightF f) = right f+type Reader x py y = x -> Reading x py y +-- | Combines a 'Yield' of a 'Reader' with an 'Await' for a 'ReadingResult'.+data ReadRequest x z = forall a py y. ReadRequest (Reader x py y) y (ReadingResult x py y -> z)+instance Functor (ReadRequest x) where+ fmap f (ReadRequest r y g) = ReadRequest r y (f . g)+ -- | Suspend the current coroutine yielding a value. yield :: Monad m => x -> Coroutine (Yield x) m () yield x = suspend (Yield x (return ()))@@ -88,9 +87,13 @@ request :: Monad m => x -> Coroutine (Request x y) m y request x = suspend (Request x return) --- | Suspend yielding a request and awaiting the response.-requestParse :: (Monad m, MonoidNull y) => Parser a [x] y -> Coroutine (ParseRequest x) m (y, Maybe (Parser a [x] y))-requestParse p = suspend (ParseRequest id p return)+-- | Suspend yielding a 'ReadRequest' and awaiting the 'ReadingResult'.+requestRead :: (Monad m, Monoid x) => Reader x py y -> Coroutine (ReadRequest x) m (ReadingResult x py y)+requestRead p = suspend (ReadRequest p eof return)+ where eof = case p mempty+ of Deferred _ r -> r+ Advance _ r rp -> r+ Final _ r -> r -- | 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@@ -106,187 +109,71 @@ concatAwaits (feedAll chunk (suspend s)) feedAll :: (Foldable f, Monad m) => f x -> Coroutine (Await x) m r -> Coroutine (Await x) m r feedAll chunk c = foldl (flip feedCoroutine) c chunk---- | 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 lifter = 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 $ lifter $ Request rest c2)-}---- | Like 'parserYieldResolver', 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.-parserRequestResolver :: Monoid y => SeesawResolver (Request (Parser a [x] y) y) (Request [x] [x])- (Request (Parser a [x] y) y) (Request [x] [x])-parserRequestResolver = liftedParserRequestResolver id id+ feedCoroutine :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r+ feedCoroutine x c = bounce (\(Await f)-> f x) c --- | A generic version of 'parserRequestResolver', allowing coroutines with 'Request' functors embedded in other--- functors.-liftedParserRequestResolver :: (Functor s1, Functor s2, Monoid y) =>- (forall b. Request (Parser a [x] y) y b -> s1 b) -> (forall b. Request [x] [x] b -> s2 b)- -> SeesawResolver (Request (Parser a [x] y) y) (Request [x] [x]) s1 s2-liftedParserRequestResolver lift1 lift2 = SeesawResolver {- resumeLeft= \(Request _ c)-> c mempty,- resumeRight= \(Request chunk c)-> c chunk,- resumeBoth= \cont (Request p c1) (Request xs c2)->- case results (feed xs p)- of ([], Just (r, p')) -> cont (suspend $ lift1 $ Request (return r >< p') c1) (c2 [])- ([(r, [])], Nothing) -> cont (c1 r) (c2 [])- ([(r, rest)], Nothing) -> cont (c1 r) (suspend $ lift2 $ Request rest c2)- _ -> error "Multiple results!"-}+-- | Weaves the suspensions of a 'Yield' and an 'Await' coroutine together into a plain 'Identity' coroutine. If the+-- 'Yield' coroutine terminates first, the 'Await' one is resumed using the argument default value.+weaveAwaitYield :: Monad m => x -> WeaveStepper (Await x) (Yield x) Identity m r1 r2 (r1, r2)+weaveAwaitYield _ weave (Left (Await f)) (Left (Yield x c)) = weave (f x) c+weaveAwaitYield x _ (Left (Await f)) (Right r2) = liftM (\r1-> (r1, r2)) $ mapSuspension proceed (f x)+ where proceed (Await f) = Identity (f x)+weaveAwaitYield _ _ (Right r1) (Left (Yield _ c)) = liftM ((,) r1) $ mapSuspension discardYield c+ where discardYield (Yield _ c) = Identity c+weaveAwaitYield _ _ (Right r1) (Right r2) = return (r1, r2) --- | Like 'parserRequestResolver', 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 'Parser' 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.-lazyParserRequestResolver :: SeesawResolver (ParseRequest x) (Request [x] [x]) (ParseRequest x) (Request [x] [x])-lazyParserRequestResolver = SeesawResolver {- resumeLeft= \(ParseRequest b p c)-> mapFirstSuspension (prependToParseRequest b) $- case results (feedEof p)- of ([], Nothing) -> c (mempty, Nothing)- ([(r, _)], Nothing) -> c (r, Nothing)- _ -> error "Multiple results!",- resumeRight= \(Request chunk c)-> c chunk,- resumeBoth= \cont (ParseRequest b p c1) (Request xs c2)->- case results (if null xs then feedEof p else feed xs p)- of ([], Nothing) -> - cont (c1 (mempty, Nothing)) (if null xs then c2 $ b [] else suspend $ Request (b xs) c2)- ([], Just (r, p')) -> - cont (if mnull r then suspend $ ParseRequest (b . (xs ++)) p' c1 else c1 (r, Just p')) (c2 [])- ([(r, [])], Nothing) -> cont (c1 (r, Nothing)) (c2 [])- ([(r, rest)], Nothing) -> cont (c1 (r, Nothing)) (suspend $ Request rest c2)- (_, Nothing) -> error "Multiple results!"-}+-- | Like 'weaveAwaitYield', except the 'Await' coroutine expects 'Maybe'-wrapped values. After the 'Yield' coroutine+-- terminates, the 'Await' coroutine receives only 'Nothing'.+weaveAwaitMaybeYield :: Monad m => WeaveStepper (Await (Maybe x)) (Yield x) Identity m r1 r2 (r1, r2)+weaveAwaitMaybeYield weave (Left (Await f)) (Left (Yield x c)) = weave (f $ Just x) c+weaveAwaitMaybeYield _ (Left (Await f)) (Right r2) = liftM (\r1-> (r1, r2)) $ mapSuspension proceed (f Nothing)+ where proceed (Await f) = Identity (f Nothing)+weaveAwaitMaybeYield _ (Right r1) (Left (Yield _ c)) = liftM ((,) r1) $ mapSuspension discardYield c+ where discardYield (Yield _ c) = Identity c+weaveAwaitMaybeYield _ (Right r1) (Right r2) = return (r1, r2) --- | A generic version of 'lazyParserRequestResolver', allowing coroutines with 'Request' functors embedded in other--- functors.-nestedLazyParserRequestResolver ::- (Functor s1, Functor s2) => - SeesawResolver (ParseRequest x) (Request [x] [x])- (EitherFunctor s1 (ParseRequest x)) (EitherFunctor s2 (Request [x] [x]))-nestedLazyParserRequestResolver = SeesawResolver {- resumeLeft= \(ParseRequest b p c)-> case results (feedEof p)- of ([], Nothing) -> mapFirstSuspension (retry b) $ c (mempty, Nothing)- ([(r, t)], Nothing) -> mapFirstSuspension (retry (t ++)) $ c (r, Nothing)- (_, Nothing) -> error "Multiple results!",- resumeRight= \(Request chunk c)-> c chunk,- resumeBoth= \cont (ParseRequest b p c1) (Request xs c2)->- case results (if null xs then feedEof p else feed xs p)- of ([], Nothing) ->- cont (c1 (mempty, Nothing)) (if null xs then c2 (b []) else suspend $ RightF $ Request (b xs) c2)- ([], Just (r, p')) ->- cont- (if mnull r then suspend $ RightF $ ParseRequest (b . (xs ++)) p' c1 else c1 (r, Just p'))- (c2 [])- ([(r, rest)], Nothing) ->- cont (c1 (r, Nothing)) (if null rest then c2 [] else suspend $ RightF $ Request rest c2)- _ -> error "Multiple results!"-}- where retry prefix = eitherFunctor LeftF (RightF . feedList prefix)- feedList b (ParseRequest b' p c) = ParseRequest (b' . b) (feed (b []) p) c+-- | Weaves two complementary 'Request' coroutine suspensions into a coroutine 'yield'ing both requests. If one+-- coroutine terminates before the other, the remaining coroutine is fed the appropriate default value argument.+weaveRequests :: Monad m => x -> y -> WeaveStepper (Request x y) (Request y x) (Yield (x, y)) m r1 r2 (r1, r2)+weaveRequests _ _ weave (Left (Request x f)) (Left (Request y g)) = yield (x, y) >> weave (f y) (g x)+weaveRequests _ y weave (Left s1) (Right r2) = liftM (flip (,) r2) $ mapSuspension (defaultResponse y) (suspend s1)+ where defaultResponse a (Request b f) = Yield (b, a) (f a)+weaveRequests x _ weave (Right r1) (Left s2) = liftM ((,) r1) $ mapSuspension (defaultResponse x) (suspend s2)+ where defaultResponse a (Request b f) = Yield (a, b) (f a)+weaveRequests _ _ weave (Right r1) (Right r2) = return (r1, r2) --- | Feeds a single value to an awaiting coroutine.-feedCoroutine :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r-feedCoroutine x c = bounce (\(Await f)-> f x) c+-- | The consumer coroutine requests input through 'ReadRequest' and gets 'ReadingResult' in response. The producer+-- coroutine receives the unconsumed portion of its last requested chunk as response.+weaveReadWriteRequests :: (Monad m, Monoid x) => WeaveStepper (ReadRequest x) (Request x x) Identity m r1 r2 (r1, r2)+weaveReadWriteRequests _ (Right r1) (Right r2) = return (r1, r2)+weaveReadWriteRequests _ (Left (ReadRequest p eof c)) (Right r2) =+ mapSuspension eofRequest $ liftM (\r1-> (r1, r2)) $ c $ FinalResult eof+ where eofRequest (ReadRequest _ eof c) = Identity (c $ FinalResult eof)+weaveReadWriteRequests _ (Right r1) (Left (Request chunk c)) =+ mapSuspension reflectRequest $ liftM ((,) r1) $ c chunk+ where reflectRequest (Request chunk c) = Identity (c chunk)+weaveReadWriteRequests weave (Left (ReadRequest p _ c1)) (Left (Request xs c2)) =+ case p xs+ of Final s r -> weave (c1 $ FinalResult r) (suspend $ Request s c2)+ Advance p' _ rp -> weave (c1 $ ResultPart rp p') (c2 mempty)+ Deferred p' eof -> weave (suspend $ ReadRequest p' eof c1) (c2 mempty) -prependToParseRequest b (ParseRequest b' p' c') = ParseRequest (b . b') p' c'+-- | Like 'weaveReadWriteRequests' but for nested coroutines.+weaveNestedReadWriteRequests :: (Monad m, Functor s, Monoid x) =>+ NestWeaveStepper s (ReadRequest x) (Request x x) m r1 r2 (r1, r2)+weaveNestedReadWriteRequests _ (Right r1) (Right r2) = return (r1, r2)+weaveNestedReadWriteRequests weave (Left (LeftF s)) cs2 =+ suspend $ fmap (flip weave (Coroutine $ return cs2)) s+weaveNestedReadWriteRequests weave cs1 (Left (LeftF s)) =+ suspend $ fmap (weave (Coroutine $ return cs1)) s+weaveNestedReadWriteRequests _ (Left (RightF (ReadRequest p eof c))) (Right r2) =+ liftM (\r1-> (r1, r2)) $ pogoStickNested eofRequest $ c $ FinalResult eof+ where eofRequest (ReadRequest _ eof c) = c $ FinalResult eof+weaveNestedReadWriteRequests _ (Right r1) (Left (RightF (Request chunk c))) =+ liftM ((,) r1) $ pogoStickNested reflectRequest $ c chunk+ where reflectRequest (Request chunk c) = c chunk+weaveNestedReadWriteRequests weave (Left (RightF (ReadRequest p _ c1))) (Left (RightF (Request xs c2))) =+ case p xs+ of Final s r -> weave (c1 $ FinalResult r) (suspend $ RightF $ Request s c2)+ Advance p' _ rp -> weave (c1 $ ResultPart rp p') (c2 mempty)+ Deferred p' eof -> weave (suspend $ RightF $ ReadRequest p' eof c1) (c2 mempty)
− Data/Functor/Contravariant/Ticker.hs
@@ -1,102 +0,0 @@-{- - 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 Data.Functor.Contravariant.Ticker- (- -- * The Ticker type- Ticker(Ticker), - -- * Using a Ticker- splitTicked, Contravariant(..),- -- * Ticker constructors- tickNone, tickOne, tickCount, tickPrefixOf, tickWhilePrefixOf, tickWhile, tickUntil, tickAll, - -- * Ticker combinators- andThen, and, or- )-where--import Prelude hiding (and, or)-import Control.Monad (liftM2)-import Data.Functor.Contravariant (Contravariant(contramap))---- | This is a contra-functor 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))--instance Contravariant Ticker where- contramap f (Ticker g) = Ticker (fmap (contramap 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 : rest) = Ticker $ \x-> if p x then Just (tickWhilePrefixOf rest) 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 concatenation ticker combinator: when the first argument ticker stops ticking, the second takes over.-andThen :: Ticker x -> Ticker x -> Ticker x-Ticker t1 `andThen` t@(Ticker t2) = Ticker (\x-> maybe (t2 x) (Just . (`andThen` t)) (t1 x))---- | Parallel conjunction ticker combinator: the result keeps ticking as long as both arguments do.-and :: Ticker x -> Ticker x -> Ticker x-Ticker t1 `and` Ticker t2 = Ticker (\x-> liftM2 and (t1 x) (t2 x))---- | Parallel choice ticker combinator: the result keeps ticking as long as any of the arguments does.-or :: Ticker x -> Ticker x -> Ticker x-Ticker t1 `or` Ticker t2 = Ticker (\x-> case (t1 x, t2 x)- of (Nothing, Nothing) -> Nothing- (Nothing, t'@Just{}) -> t'- (t'@Just{}, Nothing) -> t'- (Just t1', Just t2') -> Just (t1' `or` t2'))
Test/BenchmarkCoroutine.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2010 Mario Blazevic+ Copyright 2010-2012 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -16,6 +16,8 @@ -- | The "Control.Monad.Coroutine" tests. +{-# LANGUAGE ScopedTypeVariables #-}+ module Main where import Prelude hiding (sequence)@@ -23,7 +25,7 @@ import Control.Monad (liftM, mapM, when) import Control.Parallel (pseq) import Data.Functor.Compose (Compose(..))-import Data.Functor.Identity (runIdentity)+import Data.Functor.Identity (Identity(Identity), runIdentity) import Data.List (find) import Data.Maybe (fromJust) import System.Environment (getArgs)@@ -42,8 +44,8 @@ fib x n = fib x (n - 2) + fib x (n - 1) factorFibs :: MonadParallel m => [Int] -> m Integer-factorFibs nums = liftM snd $- seesaw bindM2 (SeesawResolver resumeLeft resumeRight resumeBoth)+factorFibs nums = pogoStick runIdentity $+ weave bindM2 weaveSteps (mapM_ (yieldApply (fib 0)) nums) (factorize 0) where factorize :: MonadParallel m => Integer -> Coroutine (Await (Maybe Integer)) m Integer@@ -51,25 +53,30 @@ >>= maybe (return sum) (\n-> factorize (sum + n {-product (factors n)-}))- resumeLeft (Yield _ c) = c- resumeRight (Await c) = c Nothing- resumeBoth c (Yield x c1) (Await c2) = c c1 (c2 (Just x))+ weaveSteps _ (Left s) (Right r) = liftM (const r) $ mapSuspension unYield (suspend s)+ where unYield (Yield _ c) = Identity c+ weaveSteps _ (Right _) (Left s) = mapSuspension unAwait (suspend s)+ where unAwait (Await f) = Identity (f Nothing)+ weaveSteps weave (Left (Yield x c1)) (Left (Await c2)) = weave c1 (c2 (Just x))+ weaveSteps _ (Right _) (Right r) = return r -twoFibs :: MonadParallel m => [Int] -> m Integer-twoFibs nums = pogoStick resume (couple bindM2 (fibs 1) (fibs 2))+twoFibs :: forall m. MonadParallel m => [Int] -> m Integer+twoFibs nums = pogoStick resume (weave bindM2 stepper (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+ where resume :: Yield Integer c -> c+ resume (Yield n c) = c+ stepper :: WeaveStepper (Yield Integer) (Yield Integer) (Yield Integer) m Integer Integer (Integer, Integer)+ stepper _ (Right n1) (Right n2) = return (n1, n2)+ stepper weave (Left (Yield n1 c1)) (Left (Yield n2 c2)) =+ assert (n1 == n2) (yield n1 >> weave c1 c2) fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums) twoFibsSeesaw :: MonadParallel m => [Int] -> m Integer-twoFibsSeesaw nums = liftM (uncurry (+)) $- seesaw bindM2 resolver (fibs 1) (fibs 2)- where resolver = SeesawResolver{- resumeLeft= undefined,- resumeRight= undefined,- resumeBoth= \cont (Yield left c1) (Yield right c2)-> assert (left == right) $ cont c1 c2- }+twoFibsSeesaw nums = pogoStick (\(Yield _ c)-> c) $+ weave bindM2 weaveYields (fibs 1) (fibs 2)+ where weaveYields weave (Left (Yield left c1)) (Left (Yield right c2)) =+ assert (left == right) $ yield left >> weave c1 c2+ weaveYields _ (Right r1) (Right r2) = assert (r1 == r2) $ return r1 fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums) fibs :: MonadParallel m => Int -> [Int] -> m Integer
monad-coroutine.cabal view
@@ -1,6 +1,6 @@ Name: monad-coroutine-Version: 0.7.1-Cabal-Version: >= 1.2+Version: 0.8+Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Coroutine monad transformer for suspending and resuming monadic computations Category: Concurrency, Control, Monads@@ -12,18 +12,18 @@ License: GPL License-file: LICENSE.txt-Copyright: (c) 2010-2011 Mario Blazevic+Copyright: (c) 2010-2012 Mario Blazevic Author: Mario Blazevic Maintainer: blamario@yahoo.com Homepage: http://trac.haskell.org/SCC/wiki/monad-coroutine Extra-source-files: Test/BenchmarkCoroutine.hs--- Source-repository head--- type: darcs--- location: http://code.haskell.org/SCC/+Source-repository head+ type: darcs+ location: http://code.haskell.org/SCC/ Library- Exposed-Modules: Data.Functor.Contravariant.Ticker,- Control.Monad.Coroutine, Control.Monad.Coroutine.SuspensionFunctors, Control.Monad.Coroutine.Nested- Build-Depends: base < 5, transformers >= 0.2 && < 0.3, contravariant >= 0.1 && < 0.2,- monad-parallel, incremental-parser < 1.0+ Exposed-Modules: Control.Monad.Coroutine, Control.Monad.Coroutine.SuspensionFunctors, Control.Monad.Coroutine.Nested+ Build-Depends: base < 5, transformers >= 0.2 && < 0.4, monad-parallel GHC-prof-options: -auto-all+ if impl(ghc >= 7.0.0)+ default-language: Haskell2010