monad-coroutine 0.6.1 → 0.7
raw patch · 7 files changed
+354/−226 lines, 7 filesdep +contravariantdep +incremental-parser
Dependencies added: contravariant, incremental-parser
Files
- Control/Cofunctor/Ticker.hs +0/−85
- Control/Monad/Coroutine.hs +21/−4
- Control/Monad/Coroutine/SuspensionFunctors.hs +104/−11
- Data/Functor/Contravariant/Ticker.hs +102/−0
- Test/BenchmarkCoroutine.hs +121/−0
- TestCoroutine.hs +0/−121
- monad-coroutine.cabal +6/−5
− Control/Cofunctor/Ticker.hs
@@ -1,85 +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 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 : 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 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))
Control/Monad/Coroutine.hs view
@@ -59,7 +59,7 @@ -- * Coroutine definition Coroutine(Coroutine, resume), CoroutineStepResult, suspend, -- * Coroutine operations- mapMonad, mapSuspension, + mapMonad, mapSuspension, mapFirstSuspension, -- * Running Coroutine computations Naught, runCoroutine, bounce, pogoStick, foldRun, seesaw, SeesawResolver(..), seesawSteps, -- * Coupled Coroutine computations@@ -68,13 +68,14 @@ ) where -import Control.Monad (liftM)+import Control.Applicative (Applicative(..), (<$>), liftA2)+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+import Control.Monad.Parallel (MonadParallel(..)) -- | Suspending, resumable monadic computations. newtype Coroutine s m r = Coroutine {@@ -85,6 +86,15 @@ type CoroutineStepResult s m r = Either (s (Coroutine s m r)) r +instance (Functor s, Functor m) => Functor (Coroutine s m) where+ fmap f t = Coroutine (fmap (apply f) (resume t))+ where apply fc (Right x) = Right (fc x)+ apply fc (Left s) = Left (fmap (fmap fc) s)++instance (Functor s, Functor m, Monad m) => Applicative (Coroutine s m) where+ pure = return+ (<*>) = ap+ instance (Functor s, Monad m) => Monad (Coroutine s m) where return x = Coroutine (return (Right x)) t >>= f = Coroutine (resume t >>= apply f)@@ -132,10 +142,17 @@ map' (Left s) = Left (fmap (mapMonad f) s) -- | Change the suspension functor of a 'Coroutine'.-mapSuspension :: forall s s' m x. (Functor s, Monad m) => (forall y. s y -> s' y) -> Coroutine s m x -> Coroutine s' m x+mapSuspension :: (Functor s, Monad m) => (forall y. s y -> s' y) -> Coroutine s m x -> Coroutine s' m x mapSuspension f cort = Coroutine {resume= liftM map' (resume cort)} where map' (Right r) = Right r map' (Left s) = Left (f $ fmap (mapSuspension f) s)++-- | Modify the first upcoming suspension of a 'Coroutine'.+mapFirstSuspension :: forall s 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+ map' (Left s) = Left (f s) -- | Convert a non-suspending 'Coroutine' to the base monad. runCoroutine :: Monad m => Coroutine Naught m x -> m x
Control/Monad/Coroutine/SuspensionFunctors.hs view
@@ -1,5 +1,5 @@ {- - Copyright 2010 Mario Blazevic+ Copyright 2010-2011 Mario Blazevic This file is part of the Streaming Component Combinators (SCC) project. @@ -17,28 +17,33 @@ -- | This module defines some common suspension functors for use with the "Control.Monad.Coroutine" module. -- -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE Rank2Types, ExistentialQuantification #-} module Control.Monad.Coroutine.SuspensionFunctors ( -- * Suspension functors- Yield(Yield), Await(Await), Request(Request), EitherFunctor(LeftF, RightF),- yield, await, request,+ Yield(Yield), Await(Await), Request(Request), ParseRequest, EitherFunctor(LeftF, RightF), eitherFunctor,+ yield, await, request, requestParse, -- * Utility functions concatYields, concatAwaits, -- * Resolvers for running pairs of coroutines awaitYieldResolver, awaitMaybeYieldResolver, awaitYieldChunkResolver, requestsResolver, - tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver,+ tickerYieldResolver, tickerRequestResolver, lazyTickerRequestResolver, + parserRequestResolver, lazyParserRequestResolver, liftedTickerYieldResolver, liftedTickerRequestResolver, liftedLazyTickerRequestResolver,+ liftedParserRequestResolver, nestedLazyParserRequestResolver, ) where import Prelude hiding (foldl, foldr) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Foldable (Foldable, foldl, foldr)+import Data.Monoid (Monoid, mempty)+import Data.Monoid.Null (MonoidNull, mnull)+import Text.ParserCombinators.Incremental (Parser, feed, feedEof, results, (><)) import Control.Monad.Coroutine-import Control.Cofunctor.Ticker (Ticker, splitTicked)+import Data.Functor.Contravariant.Ticker (Ticker, splitTicked) -- | The 'Yield' functor instance is equivalent to (,) but more descriptive. data Yield x y = Yield x y@@ -55,12 +60,22 @@ instance Functor (Request x f) where fmap f (Request x g) = Request x (f . g) +data ParseRequest x z = forall y. MonoidNull y => + ParseRequest ([x] -> [x]) (Parser [x] y) ((y, Maybe (Parser [x] y)) -> z)+instance Functor (ParseRequest x) where+ fmap f (ParseRequest b p g) = ParseRequest b p (f . g)+ -- | 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+ -- | Suspend the current coroutine yielding a value. yield :: Monad m => x -> Coroutine (Yield x) m () yield x = suspend (Yield x (return ()))@@ -73,6 +88,10 @@ 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 [x] y -> Coroutine (ParseRequest x) m (y, Maybe (Parser [x] y))+requestParse p = suspend (ParseRequest id p 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}@@ -85,6 +104,8 @@ concatAwaits c = lift (resume c) >>= either concatenate return where concatenate s = do chunk <- await 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.@@ -190,10 +211,82 @@ 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 [x] y) y) (Request [x] [x])+ (Request (Parser [x] y) y) (Request [x] [x])+parserRequestResolver = liftedParserRequestResolver id id++-- | A generic version of 'parserRequestResolver', allowing coroutines with 'Request' functors embedded in other+-- functors.+liftedParserRequestResolver :: (Functor s1, Functor s2, Monoid y) =>+ (forall a. Request (Parser [x] y) y a -> s1 a) -> (forall a. Request [x] [x] a -> s2 a)+ -> SeesawResolver (Request (Parser [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!"+}++-- | 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!"+}++-- | 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+ -- | 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+feedCoroutine :: Monad m => x -> Coroutine (Await x) m r -> Coroutine (Await x) m r+feedCoroutine 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+prependToParseRequest b (ParseRequest b' p' c') = ParseRequest (b . b') p' c'
+ Data/Functor/Contravariant/Ticker.hs view
@@ -0,0 +1,102 @@+{- + 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
@@ -0,0 +1,121 @@+{- + 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/>.+-}++-- | The "Control.Monad.Coroutine" tests.++module Main where++import Prelude hiding (sequence)+import Control.Exception (assert)+import Control.Monad (liftM, mapM, when)+import Control.Parallel (pseq)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (runIdentity)+import Data.List (find)+import Data.Maybe (fromJust)+import System.Environment (getArgs)++import Control.Monad.Coroutine+import Control.Monad.Coroutine.SuspensionFunctors+import Control.Monad.Coroutine.Nested+import Control.Monad.Parallel (MonadParallel, bindM2, liftM2, sequence)++import Criterion.Main++factors n = maybe [n] (\k-> (k : factors (n `div` k))) (find (\k-> n `mod` k == 0) [2 .. n - 1])++fib x 0 | x >= 0 = 1+fib _ 1 = 1+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)+ (mapM_ (yieldApply (fib 0)) nums)+ (factorize 0)+ where factorize :: MonadParallel m => Integer -> Coroutine (Await (Maybe Integer)) m Integer+ factorize sum = await+ >>= 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))++twoFibs :: MonadParallel m => [Int] -> m Integer+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 >> 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+ }+ fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums)++fibs :: MonadParallel m => Int -> [Int] -> m Integer+fibs coroutineCount nums = liftM sum $+ pogoStick+ resume+ (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 >> 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]++nested :: (Monad m, Functor p) =>+ Int -> (Integer -> Coroutine p m ()) -> Coroutine (EitherFunctor p (Yield Integer)) m ()+nested level suspendParent = do mapSuspension RightF (yield 1)+ liftAncestor (suspendParent 2)+ when (level > 0) (pogoStickNested cont $+ nested (pred level) (liftAncestor . suspendParent))+ where cont (Yield x c) = c++runNested size = liftM fst $ foldRun add 0 (nested size yield)+ where add s (LeftF (Yield n c)) = (s + n, c)+ add s (RightF (Yield n c)) = (s + 10 * n, c)+++main = defaultMain ([bgroup "Identity" [bench name (nf (runIdentity . task name) size) | (name, size) <- tasks],+ bgroup "Maybe" [bench name (nf (fromJust . task name) size) | (name, size) <- tasks],+ bgroup "List" [bench name (nf (head . task name) size) | (name, size) <- tasks],+ bgroup "IO" [bench name (task name size :: IO Integer) | (name, size) <- tasks]])++tasks = [("fib-factor", 32), ("2fibs", 30), ("2fibsSeesaw", 30), ("nested", 250),+ ("1*fibs", 33), ("2*fibs", 33), ("3*fibs", 33), ("4*fibs", 33)]++task :: MonadParallel m => String -> Int -> m Integer+task taskName size = + case taskName + of "fib-factor" -> factorFibs [1 .. size]+ "2fibs" -> twoFibs [1 .. size]+ "2fibsSeesaw" -> twoFibsSeesaw [1 .. size]+ "nested" -> runNested size+ coroutineCount : "*fibs" -> fibs (read [coroutineCount]) [1 .. size]+ _ -> error "Bad task."
− TestCoroutine.hs
@@ -1,121 +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/>.--}---- | The "Control.Monad.Coroutine" tests.--module Main where--import Prelude hiding (sequence)-import Control.Exception (assert)-import Control.Monad (liftM, mapM, when)-import Control.Parallel (pseq)-import Data.Functor.Compose (Compose(..))-import Data.Functor.Identity (runIdentity)-import Data.List (find)-import Data.Maybe (fromJust)-import System.Environment (getArgs)--import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors-import Control.Monad.Coroutine.Nested-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])--fib x 0 | x >= 0 = 1-fib _ 1 = 1-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)- (mapM_ (yieldApply (fib 0)) nums)- (factorize 0)- where factorize :: MonadParallel m => Integer -> Coroutine (Await (Maybe Integer)) m Integer- factorize sum = await- >>= 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))--twoFibs :: MonadParallel m => [Int] -> m Integer-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 >> 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- }- fibs ix = mapM_ (yieldApply (fib ix)) nums >> applyM (fib ix) (last nums)--fibs :: MonadParallel m => Int -> [Int] -> m Integer-fibs coroutineCount nums = liftM sum $- pogoStick- resume- (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 >> 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]--nested :: (Monad m, Functor p) =>- Int -> (Integer -> Coroutine p m ()) -> Coroutine (EitherFunctor p (Yield Integer)) m ()-nested level suspendParent = do mapSuspension RightF (yield 1)- liftAncestor (suspendParent 2)- when (level > 0) (pogoStickNested cont $ nested (pred level) (liftAncestor . suspendParent))- where cont (Yield x c) = c--main = do args <- getArgs- if length args /= 4- then putStr help- else do let [taskName, monad, size, coroutineCount] = args- task :: MonadParallel m => m Integer- task = case taskName of "fib-factor" -> factorFibs [1 .. read size]- "2fibs" -> twoFibs [1 .. read size]- "2fibsSeesaw" -> twoFibsSeesaw [1 .. read size]- "fibs" -> fibs (read coroutineCount) [1 .. read size]- "nested" -> liftM fst $ foldRun add 0 (nested (read size) yield)- where add s (LeftF (Yield n c)) = (s + n, c)- add s (RightF (Yield n c)) = (s + 10 * n, c)- _ -> error (help ++ "Bad task.")- result <- case monad of "Maybe" -> return $ fromJust task- "[]" -> return $ head task- "Identity" -> return $ runIdentity task- "IO" -> task- _ -> error (help ++ "Bad monad.")- print result--help = "Usage: test-coroutine <task> <monad> <size> <coroutines>?\n"- ++ " where <task> is 'fib-factor' or 'fibs',\n"- ++ " <monad> is 'Identity', 'Maybe', '[]', or 'IO',\n"- ++ " <size> is the size of the task,\n"- ++ " and <coroutines> is the number of coroutines to employ.\n"
monad-coroutine.cabal view
@@ -1,5 +1,5 @@ Name: monad-coroutine-Version: 0.6.1+Version: 0.7 Cabal-Version: >= 1.2 Build-Type: Simple Synopsis: Coroutine monad transformer for suspending and resuming monadic computations@@ -12,17 +12,18 @@ License: GPL License-file: LICENSE.txt-Copyright: (c) 2010 Mario Blazevic+Copyright: (c) 2010-2011 Mario Blazevic Author: Mario Blazevic Maintainer: blamario@yahoo.com Homepage: http://trac.haskell.org/SCC/wiki/monad-coroutine-Extra-source-files: TestCoroutine.hs+Extra-source-files: Test/BenchmarkCoroutine.hs -- Source-repository head -- type: darcs -- location: http://code.haskell.org/SCC/ Library- Exposed-Modules: Control.Cofunctor.Ticker,+ Exposed-Modules: Data.Functor.Contravariant.Ticker, Control.Monad.Coroutine, Control.Monad.Coroutine.SuspensionFunctors, Control.Monad.Coroutine.Nested- Build-Depends: base < 5, monad-parallel, transformers >= 0.2 && < 0.3+ Build-Depends: base < 5, transformers >= 0.2 && < 0.3, contravariant >= 0.1 && < 0.2,+ monad-parallel, incremental-parser < 1.0 GHC-prof-options: -auto-all