simple-conduit 0.4.0 → 0.5.0
raw patch · 5 files changed
+632/−511 lines, 5 filesdep +freedep −QuickCheckdep −conduitdep −conduit-combinatorsdep ~basedep ~transformers
Dependencies added: free
Dependencies removed: QuickCheck, conduit, conduit-combinators, conduit-extra, criterion, foldl, hspec, simple-conduit, void
Dependency ranges changed: base, transformers
Files
- Conduit/Simple.hs +104/−399
- Conduit/Simple/Compat.hs +169/−0
- Conduit/Simple/Core.hs +275/−0
- simple-conduit.cabal +84/−49
- test/bench.hs +0/−63
Conduit/Simple.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Please see the project README for more details:@@ -17,11 +17,8 @@ module Conduit.Simple ( Source(..), Conduit, Sink- , sequenceSources- , ZipSink(..), sequenceSinks- , source, conduit, conduitWith, sink- , ($=), (=$), ($$)- , returnC, abort, skip, awaitForever+ , runSource, lowerSource, source, conduit, conduitWith, sink+ , returnC, close, skip, awaitForever , yieldMany, sourceList , unfoldC , enumFromToC@@ -143,47 +140,37 @@ , unlinesC , unlinesAsciiC , linesUnboundedC_- , linesUnboundedC- , linesUnboundedAsciiC- , zipSinks+ , linesUnboundedC, linesC+ , linesUnboundedAsciiC, linesAsciiC , sourceMaybeMVar , sourceMaybeTMVar , asyncC- , fromFoldM- , toFoldM , sourceTChan , sourceTQueue , sourceTBQueue , untilMC , whileMC+ , zipSinks++ , ($=), (=$), ($$)+ , sequenceSources ) where -import Control.Applicative (Alternative((<|>), empty),- Applicative((<*>), pure), (<$>))-import Control.Concurrent (MVar, takeMVar, putMVar, newEmptyMVar)-import Control.Concurrent.Async.Lifted (Async, withAsync, waitBoth,- async)+import Conduit.Simple.Compat+import Conduit.Simple.Core+import Control.Applicative ((<$>))+import Control.Concurrent.Async.Lifted+import Control.Concurrent.Lifted hiding (yield) import Control.Concurrent.STM import Control.Exception.Lifted (bracket)-import Control.Foldl (PrimMonad, Vector, FoldM(..))-import Control.Monad (liftM, MonadPlus(..), ap, (<=<)) import Control.Monad.Base (MonadBase(..))-import Control.Monad.Catch (MonadThrow(..), MonadMask, MonadCatch)-import qualified Control.Monad.Catch as Catch-import Control.Monad.Error.Class (MonadError(..))-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Morph (MonadTrans(..), MMonad(..), MFunctor(..))+import Control.Monad.Catch (MonadThrow)+import Control.Monad.Cont import Control.Monad.Primitive (PrimMonad(PrimState))-import Control.Monad.Reader.Class (MonadReader(..))-import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Control (MonadBaseControl(StM)) import Control.Monad.Trans.Either (EitherT(..), left)-import Control.Monad.Writer.Class (MonadWriter(..))-import Data.Bifunctor (Bifunctor(bimap)) import Data.Builder (Builder(builderToLazy), ToBuilder(..)) import Data.ByteString (ByteString)-import Data.Foldable (Foldable(foldMap))-import Data.Functor.Identity (Identity(runIdentity)) import Data.IOData (IOData(hGetChunk, hPut)) import Data.List (unfoldr) import Data.MonoTraversable (MonoTraversable, MonoFunctor, Element,@@ -200,7 +187,8 @@ import qualified Data.Streaming.Filesystem as F import Data.Text (Text) import Data.Textual.Encoding (Utf8(encodeUtf8))-import Data.Traversable (Traversable(sequenceA))+import Data.Traversable (Traversable)+import qualified Data.Vector.Generic as V import Data.Word (Word8) import System.FilePath ((</>)) import System.IO (stdout, stdin, stderr, openFile, hClose,@@ -208,301 +196,40 @@ import System.Random.MWC as MWC (Gen, Variate(uniform), createSystemRandom) --- | The type of Source should recall 'foldM':------ @--- Monad m => (a -> b -> m a) -> a -> [b] -> m a--- @------ 'EitherT' is used to signal short-circuiting of the pipeline. And if it--- weren't for conduits like 'takeC', we wouldn't even need that most of the--- time.------ Sources form a Monad that behaves a lot like 'ListT'; for example:------ @--- do line <- sourceFile "foo.txt"--- liftIO $ putStrLn $ "line: " ++ show line--- x <- yieldMany [1..10]--- return (x, line)--- @------ The above Source yields a series of pairs, proving ten copies of each line--- from the file plus an index number.------ To skip to the next value in a Source, use the function 'skip' or 'mempty';--- to abort the whole pipeline, use 'abort' or 'mzero'. For example:------ @--- do x <- yieldMany [1..10]--- if x == 2 || x == 9--- then return x--- else if x < 5--- then skip--- else abort--- @------ This outputs the list @[2]@.------ One difference from conduit is that monadic chaining of sources with '>>'--- results in the values from the first source being used to determine how--- many values are generated by the next source, just like 'ListT':------ >>> sinkList $ yieldMany [1..3] >> yieldMany [4..6]--- [4,5,6,4,5,6,4,5,6]------ To achieve the same behavior as conduit, use the Monoid instance for--- Sources:------ >>> sinkList $ yieldMany [1..3] <> yieldMany [4..6]--- [1,2,3,4,5,6]-newtype Source m a = Source- { runSource :: forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r }--type Conduit a m b = Source m a -> Source m b-type Sink a m r = Source m a -> m r--instance Monad m => Semigroup (Source m a) where- x <> y = Source $ \r f -> lift $ do- r' <- sink r f x- sink r' f y- {-# INLINE (<>) #-}--instance Monad m => Monoid (Source m a) where- mempty = skip- {-# INLINE mempty #-}- mappend = (<>)- {-# INLINE mappend #-}--instance Monad m => Alternative (Source m) where- empty = skip- {-# INLINE empty #-}- (<|>) = (<>)- {-# INLINE (<|>) #-}--instance Functor (Source m) where- fmap f = conduit $ \r yield -> yield r . f- {-# INLINE fmap #-}--instance Applicative (Source m) where- pure = return- {-# INLINE pure #-}- (<*>) = ap- {-# INLINE (<*>) #-}--instance Monad m => MonadPlus (Source m) where- mzero = abort- {-# INLINE mzero #-}- mplus = (<|>)- {-# INLINE mplus #-}--instance Monad (Source m) where- return x = Source $ \z yield -> yield z x- {-# INLINE return #-}- Source await >>= f = Source $ \z yield ->- await z $ \r x -> runSource (f x) r yield- {-# INLINE (>>=) #-}--instance MFunctor Source where- hoist nat m = Source $ \z yield -> runSource (hoist nat m) z yield- {-# INLINE hoist #-}--instance MMonad Source where- embed f m = Source $ \z yield -> runSource (embed f m) z yield- {-# INLINE embed #-}--instance MonadIO m => MonadIO (Source m) where- liftIO m = Source $ \z yield -> yield z =<< liftIO m- {-# INLINE liftIO #-}--instance MonadTrans Source where- lift m = Source $ \z yield -> yield z =<< lift m- {-# INLINE lift #-}--instance MonadReader r m => MonadReader r (Source m) where- ask = lift ask- {-# INLINE ask #-}- local f = conduit $ \r yield -> local f . yield r- {-# INLINE local #-}- reader = lift . reader- {-# INLINE reader #-}--instance MonadState s m => MonadState s (Source m) where- get = lift get- {-# INLINE get #-}- put = lift . put- {-# INLINE put #-}- state = lift . state- {-# INLINE state #-}--instance MonadWriter w m => MonadWriter w (Source m) where- writer = lift . writer- {-# INLINE writer #-}- tell = lift . tell- {-# INLINE tell #-}- listen = conduit $ \r yield x -> do- ((), w) <- listen $ return ()- yield r (x, w)- {-# INLINE listen #-}- pass = conduit $ \r yield (x, f) -> do- pass $ return ((), f)- yield r x- {-# INLINE pass #-}--instance MonadError e m => MonadError e (Source m) where- throwError = lift . throwError- {-# INLINE throwError #-}- catchError src f = Source $ \z yield -> EitherT $- runEitherT (runSource src z yield)- `catchError` \e -> runEitherT (runSource (f e) z yield)- {-# INLINE catchError #-}--instance MonadThrow m => MonadThrow (Source m) where- throwM e = lift $ throwM e- {-# INLINE throwM #-}--instance MonadCatch m => MonadCatch (Source m) where- catch src f = Source $ \z yield -> EitherT $- runEitherT (runSource src z yield)- `Catch.catch` \e -> runEitherT (runSource (f e) z yield)- {-# INLINE catch #-}--instance MonadMask m => MonadMask (Source m) where- mask a = Source $ \z yield -> EitherT $ Catch.mask $ \u ->- runEitherT $ runSource (a $ \b -> Source $ \r yield' ->- EitherT $ liftM Right $ u $ sink r yield' b) z yield- {-# INLINE mask #-}- uninterruptibleMask a =- Source $ \z yield -> EitherT $ Catch.uninterruptibleMask $ \u ->- runEitherT $ runSource (a $ \b -> Source $ \r yield' ->- EitherT $ liftM Right $ u $ sink r yield' b) z yield- {-# INLINE uninterruptibleMask #-}--instance Foldable (Source Identity) where- foldMap f = runIdentity . sink mempty (\r x -> return $ r `mappend` f x)- {-# INLINE foldMap #-}---- | Sequence a collection of sources.------ >>> sinkList $ sequenceSources [yieldOne 1, yieldOne 2, yieldOne 3]--- [[1,2,3]]-sequenceSources :: (Traversable f, Monad m) => f (Source m a) -> Source m (f a)-sequenceSources = sequenceA-{-# INLINE sequenceSources #-}---- | Compose a 'Source' and a 'Conduit' into a new 'Source'. Note that this--- is just flipped function application, so ($) can be used to achieve the--- same thing.-infixl 1 $=-($=) :: a -> (a -> b) -> b-($=) = flip ($)-{-# INLINE ($=) #-}---- | Compose a 'Conduit' and a 'Sink' into a new 'Sink'. Note that this is--- just function composition, so (.) can be used to achieve the same thing.-infixr 2 =$-(=$) :: (a -> b) -> (b -> c) -> a -> c-(=$) = flip (.)-{-# INLINE (=$) #-}---- | Compose a 'Source' and a 'Sink' and compute the result. Note that this--- is just flipped function application, so ($) can be used to achieve the--- same thing.-infixr 0 $$-($$) :: a -> (a -> b) -> b-($$) = flip ($)-{-# INLINE ($$) #-}--awaitForever :: (a -> Source m b) -> Conduit a m b-awaitForever = flip (>>=)-{-# INLINE awaitForever #-}---- | Promote any sink to a source. This can be used as if it were a source--- transformer (aka, a conduit):------ >>> sinkList $ returnC $ sumC $ mapC (+1) $ yieldMany [1..10]--- [65]------ Note that 'returnC' is a synonym for 'Control.Monad.Trans.Class.lift'.-returnC :: Monad m => m a -> Source m a-returnC = lift--abort :: Monad m => Source m a-abort = Source $ const . left-{-# INLINE abort #-}--skip :: Monad m => Source m a-skip = Source $ const . return-{-# INLINE skip #-}--conduit :: (forall r. r -> (r -> b -> EitherT r m r) -> a -> EitherT r m r)- -> Conduit a m b-conduit f (Source await) = Source $ \z -> await z . flip f-{-# INLINE conduit #-}--sink :: forall m a r. Monad m => r -> (r -> a -> EitherT r m r) -> Sink a m r-sink z f (Source await) = either id id `liftM` runEitherT (await z f)-{-# INLINE sink #-}---- | Most of the time conduit will pass through the fold variable unmolested,--- but sometimes you need to ignore that variable and use your own within--- that stage of the pipeline. This is done by wrapping the fold variable--- in a tuple and then unwrapping it when the conduit is done.--- 'conduitWith' makes this transparent.-conduitWith :: Monad m- => s- -> (forall r. (r, s) -> (r -> b -> EitherT (r, s) m (r, s)) -> a- -> EitherT (r, s) m (r, s))- -> Conduit a m b-conduitWith s f (Source await) = Source $ \z yield ->- rewrap fst $ await (z, s) $ \(r, t) ->- f (r, t) (\r' -> rewrap (, t) . yield r')-{-# INLINE conduitWith #-}--rewrap :: Monad m => (a -> b) -> EitherT a m a -> EitherT b m b-rewrap f k = EitherT $ bimap f f `liftM` runEitherT k-{-# INLINE rewrap #-}--source :: Monad m- => (forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r)- -> Source m a-source = Source-{-# INLINE source #-}- yieldMany :: (Monad m, MonoFoldable mono) => mono -> Source m (Element mono)-yieldMany xs = Source $ \z yield -> ofoldlM yield z xs+yieldMany xs = source $ \z yield -> ofoldlM yield z xs {-# INLINE yieldMany #-} sourceList :: Monad m => [a] -> Source m a-sourceList = yieldMany+sourceList xs = source $ \z yield -> foldM yield z xs {-# INLINE sourceList #-} unfoldC :: forall m a b. Monad m => (b -> Maybe (a, b)) -> b -> Source m a-unfoldC = (yieldMany .) . Data.List.unfoldr+unfoldC = (sourceList .) . Data.List.unfoldr {-# INLINE unfoldC #-} enumFromToC :: forall m a. (Monad m, Enum a, Eq a) => a -> a -> Source m a-enumFromToC = (yieldMany .) . enumFromTo+enumFromToC = (sourceList .) . enumFromTo {-# INLINE enumFromToC #-} iterateC :: forall m a. Monad m => (a -> a) -> a -> Source m a-iterateC = (yieldMany .) . iterate+iterateC = (sourceList .) . iterate {-# INLINE iterateC #-} repeatC :: forall m a. Monad m => a -> Source m a-repeatC = yieldMany . Prelude.repeat+repeatC = sourceList . Prelude.repeat {-# INLINE repeatC #-} replicateC :: forall m a. Monad m => Int -> a -> Source m a-replicateC = (yieldMany .) . Prelude.replicate+replicateC = (sourceList .) . Prelude.replicate {-# INLINE replicateC #-} sourceLazy :: (Monad m, LazySequence lazy strict) => lazy -> Source m strict-sourceLazy = yieldMany . toChunks+sourceLazy = sourceList . toChunks {-# INLINE sourceLazy #-} repeatMC :: forall m a. Monad m => m a -> Source m a-repeatMC x = Source go+repeatMC x = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z@@ -510,7 +237,7 @@ loop r = loop =<< yield r =<< lift x repeatWhileMC :: forall m a. Monad m => m a -> (a -> Bool) -> Source m a-repeatWhileMC m f = Source go+repeatWhileMC m f = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z@@ -522,7 +249,7 @@ else return r replicateMC :: forall m a. Monad m => Int -> m a -> Source m a-replicateMC n m = Source $ go n+replicateMC n m = source $ go n where go :: Int -> r -> (r -> a -> EitherT r m r) -> EitherT r m r go i z yield = loop i z@@ -531,7 +258,7 @@ loop _ r = return r sourceHandle :: forall m a. (MonadIO m, IOData a) => Handle -> Source m a-sourceHandle h = Source go+sourceHandle h = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z@@ -544,14 +271,14 @@ sourceFile :: (MonadBaseControl IO m, MonadIO m, IOData a) => FilePath -> Source m a-sourceFile path = Source $ \z yield ->+sourceFile path = source $ \z yield -> bracket (liftIO $ openFile path ReadMode) (liftIO . hClose) (\h -> runSource (sourceHandle h) z yield) {-# INLINE sourceFile #-} sourceIOHandle :: (MonadBaseControl IO m, MonadIO m, IOData a) => IO Handle -> Source m a-sourceIOHandle f = Source $ \z yield ->+sourceIOHandle f = source $ \z yield -> bracket (liftIO f) (liftIO . hClose) (\h -> runSource (sourceHandle h) z yield) {-# INLINE sourceIOHandle #-}@@ -561,12 +288,12 @@ {-# INLINE stdinC #-} initRepeat :: Monad m => m seed -> (seed -> m a) -> Source m a-initRepeat mseed f = Source $ \z yield ->+initRepeat mseed f = source $ \z yield -> lift mseed >>= \seed -> runSource (repeatMC (f seed)) z yield {-# INLINE initRepeat #-} initReplicate :: Monad m => m seed -> (seed -> m a) -> Int -> Source m a-initReplicate mseed f n = Source $ \z yield ->+initReplicate mseed f n = source $ \z yield -> lift mseed >>= \seed -> runSource (replicateMC n (f seed)) z yield {-# INLINE initReplicate #-} @@ -592,7 +319,7 @@ sourceDirectory :: forall m. (MonadBaseControl IO m, MonadIO m) => FilePath -> Source m FilePath-sourceDirectory dir = Source $ \z yield ->+sourceDirectory dir = source $ \z yield -> bracket (liftIO (F.openDirStream dir)) (liftIO . F.closeDirStream)@@ -609,7 +336,7 @@ sourceDirectoryDeep :: forall m. (MonadBaseControl IO m, MonadIO m) => Bool -> FilePath -> Source m FilePath-sourceDirectoryDeep followSymlinks startDir = Source go+sourceDirectoryDeep followSymlinks startDir = source go where go :: r -> (r -> FilePath -> EitherT r m r) -> EitherT r m r go z yield = start startDir z@@ -633,6 +360,15 @@ go (r, _) yield x = yield r x {-# INLINE dropC #-} +{-+dropCGen :: Monad m => Int -> FoldT (r, Int) m a -> FoldT r m a+dropCGen n = foldWith n go+ where+ go (r, n') _ _ | n' > 0 = return (r, n' - 1)+ go (r, _) yield x = yield r x+{-# INLINE dropCGen #-}+-}+ dropCE :: (Monad m, IsSequence seq) => Index seq -> Conduit seq m seq dropCE n = conduitWith n go where@@ -742,7 +478,7 @@ produceList :: Monad m => ([a] -> b) -> Sink a m b produceList f =- liftM (liftM (f . ($ []))) $ sink id (\front x -> return (front . (x:)))+ liftM (f . ($ [])) . sink id (\front x -> return (front . (x:))) {-# INLINE produceList #-} sinkLazy :: (Monad m, LazySequence lazy strict) => Sink strict m lazy@@ -753,11 +489,11 @@ sinkList = produceList id {-# INLINE sinkList #-} -sinkVector :: (MonadBase base m, Vector v a, PrimMonad base)+sinkVector :: (MonadBase base m, V.Vector v a, PrimMonad base) => Sink a m (v a) sinkVector = undefined -sinkVectorN :: (MonadBase base m, Vector v a, PrimMonad base)+sinkVectorN :: (MonadBase base m, V.Vector v a, PrimMonad base) => Int -> Sink a m (v a) sinkVectorN = undefined @@ -949,6 +685,20 @@ where next = fmap pred <$> yield z' x +{-+takeCGen :: Monad m+ => Int -> FoldT (r, Int) (EitherT (r, Int) m) a+ -> FoldT r (EitherT r m) a+takeCGen n = foldWith' n go+ where+ go (z', n') yield x+ | n' > 1 = next+ | n' > 0 = left =<< next+ | otherwise = left (z', 0)+ where+ next = fmap pred <$> yield z' x+-}+ takeCE :: (Monad m, IsSequence seq) => Index seq -> Conduit seq m seq takeCE = undefined @@ -986,10 +736,10 @@ {-# INLINE filterCE #-} mapWhileC :: Monad m => (a -> Maybe b) -> Conduit a m b-mapWhileC f = awaitForever $ \x -> case f x of Just y -> return y; _ -> abort+mapWhileC f = awaitForever $ \x -> case f x of Just y -> return y; _ -> close {-# INLINE mapWhileC #-} -conduitVector :: (MonadBase base m, Vector v a, PrimMonad base)+conduitVector :: (MonadBase base m, V.Vector v a, PrimMonad base) => Int -> Conduit a m (v a) conduitVector = undefined @@ -1000,8 +750,8 @@ concatMapAccumC = undefined intersperseC :: Monad m => a -> Source m a -> Source m a-intersperseC s (Source await) = Source $ \z yield -> EitherT $ do- eres <- runEitherT $ await (Nothing, z) $ \(my, r) x ->+intersperseC s src = source $ \z yield -> EitherT $ do+ eres <- runEitherT $ runSource src (Nothing, z) $ \(my, r) x -> case my of Nothing -> return (Just x, r) Just y -> do@@ -1031,7 +781,7 @@ decodeBase16C = undefined mapMC :: Monad m => (a -> m b) -> Conduit a m b-mapMC f src = src >>= lift . f+mapMC f = (>>= lift . f) {-# INLINE mapMC #-} mapMCE :: (Monad m, Traversable f) => (a -> m b) -> Conduit (f a) m (f b)@@ -1095,8 +845,8 @@ linesUnboundedC_ :: forall m seq. (Monad m, IsSequence seq, Eq (Element seq)) => Element seq -> Conduit seq m seq-linesUnboundedC_ sep (Source await) = Source $ \z yield -> EitherT $ do- eres <- runEitherT $ await (z, n) (go yield)+linesUnboundedC_ sep src = source $ \z yield -> EitherT $ do+ eres <- runEitherT $ runSource src (z, n) (go yield) case eres of Left (r, _) -> return $ Left r Right (r, t)@@ -1127,37 +877,19 @@ linesUnboundedAsciiC = linesUnboundedC_ 10 {-# INLINE linesUnboundedAsciiC #-} --- | Zip sinks together. This function may be used multiple times:------ >>> let mySink s = sink () $ \() x -> liftIO $ print $ s <> show x--- >>> zipSinks sinkList (zipSinks (mySink "foo") (mySink "bar")) $ yieldMany [1,2,3]--- "foo: 1"--- "bar: 1"--- "foo: 2"--- "bar: 2"--- "foo: 3"--- "bar: 3"--- ([1,2,3],((),()))------ Note that the two sinks are run concurrently, so watch out for possible--- race conditions if they try to interact with the same resources.-zipSinks :: forall a m r r'. (MonadBaseControl IO m, MonadIO m)- => Sink a m r -> Sink a m r' -> Sink a m (r, r')-zipSinks sink1 sink2 (Source await) = do- x <- liftIO newEmptyMVar- y <- liftIO newEmptyMVar- withAsync (sink1 $ sourceMaybeMVar x) $ \a ->- withAsync (sink2 $ sourceMaybeMVar y) $ \b -> do- _ <- runEitherT $ await () $ \() val -> do- liftIO $ putMVar x (Just val)- liftIO $ putMVar y (Just val)- liftIO $ putMVar x Nothing- liftIO $ putMVar y Nothing- waitBoth a b+linesC :: (Monad m, IsSequence seq, Element seq ~ Char)+ => Conduit seq m seq+linesC = linesUnboundedC+{-# INLINE linesC #-} +linesAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8)+ => Conduit seq m seq+linesAsciiC = linesUnboundedAsciiC+{-# INLINE linesAsciiC #-}+ -- | Keep taking from an @MVar (Maybe a)@ until it yields 'Nothing'. sourceMaybeMVar :: forall m a. MonadIO m => MVar (Maybe a) -> Source m a-sourceMaybeMVar var = Source go+sourceMaybeMVar var = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z@@ -1170,7 +902,7 @@ -- | Keep taking from an @TMVar (Maybe a)@ until it yields 'Nothing'. sourceMaybeTMVar :: forall a. TMVar (Maybe a) -> Source STM a-sourceMaybeTMVar var = Source go+sourceMaybeTMVar var = source go where go :: r -> (r -> a -> EitherT r STM r) -> EitherT r STM r go z yield = loop z@@ -1181,55 +913,16 @@ Nothing -> return r Just x -> loop =<< yield r x -newtype ZipSink a m r = ZipSink { getZipSink :: Source m a -> m r }--instance Monad m => Functor (ZipSink a m) where- fmap f (ZipSink k) = ZipSink $ liftM f . k--instance Monad m => Applicative (ZipSink a m) where- pure x = ZipSink $ \_ -> return x- ZipSink f <*> ZipSink x = ZipSink $ \await -> f await `ap` x await---- | Send incoming values to all of the @Sink@ providing, and ultimately--- coalesce together all return values.------ Implemented on top of @ZipSink@, see that data type for more details.-sequenceSinks :: (Traversable f, Monad m) => f (Sink a m r) -> Sink a m (f r)-sequenceSinks = getZipSink . sequenceA . fmap ZipSink-{-# INLINE sequenceSinks #-}- asyncC :: (MonadBaseControl IO m, Monad m) => (a -> m b) -> Conduit a m (Async (StM m b)) asyncC f = awaitForever $ lift . async . f {-# INLINE asyncC #-} --- | Convert a 'Control.Foldl.FoldM' fold abstraction into a Sink.------ NOTE: This requires ImpredicativeTypes in the code that uses it.------ >>> fromFoldM (FoldM ((return .) . (+)) (return 0) return) $ yieldMany [1..10]--- 55-fromFoldM :: Monad m => FoldM m a b -> Source m a -> m b-fromFoldM (FoldM step initial final) src = do- r <- initial- final =<< sink r ((lift .) . step) src-{-# INLINE fromFoldM #-}---- | Convert a Sink into a 'Control.Foldl.FoldM', passing it into a--- continuation.------ >>> toFoldM sumC (\f -> Control.Foldl.foldM f [1..10])--- 55-toFoldM :: Monad m- => Sink a m r -> (forall s. FoldM (EitherT s m) a s -> EitherT s m s) -> m r-toFoldM s f = s $ source $ \k yield -> f $ FoldM yield (return k) return-{-# INLINE toFoldM #-}- sourceSTM :: forall container a. (container a -> STM a) -> (container a -> STM Bool) -> container a -> Source STM a-sourceSTM getter tester chan = Source go+sourceSTM getter tester chan = source go where go :: r -> (r -> a -> EitherT r STM r) -> EitherT r STM r go z yield = loop z@@ -1256,27 +949,39 @@ {-# INLINE sourceTBQueue #-} untilMC :: forall m a. Monad m => m a -> m Bool -> Source m a-untilMC m f = Source go+untilMC m f = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z where loop r = do- x <- lift m+ x <- lift m r' <- yield r x- cont <- lift f- if cont- then loop r'- else return r'+ c <- lift f+ if c then loop r' else return r' whileMC :: forall m a. Monad m => m Bool -> m a -> Source m a-whileMC f m = Source go+whileMC f m = source go where go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r go z yield = loop z where loop r = do- cont <- lift f- if cont+ c <- lift f+ if c then lift m >>= yield r >>= loop else return r++zipSinks :: forall a m r r'. (MonadBaseControl IO m, MonadIO m)+ => Sink a m r -> Sink a m r' -> Sink a m (r, r')+zipSinks sink1 sink2 src = do+ x <- liftIO newEmptyMVar+ y <- liftIO newEmptyMVar+ withAsync (sink1 $ sourceMaybeMVar x) $ \a ->+ withAsync (sink2 $ sourceMaybeMVar y) $ \b -> do+ _ <- runEitherT $ runSource src () $ \() val -> do+ liftIO $ putMVar x (Just val)+ liftIO $ putMVar y (Just val)+ liftIO $ putMVar x Nothing+ liftIO $ putMVar y Nothing+ waitBoth a b
+ Conduit/Simple/Compat.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Conduit.Simple.Compat+ ( ($=), (=$), ($$)+ , sequenceSources+ -- , adaptFrom, adaptTo+ ) where++import Conduit.Simple.Core+-- import Control.Category (Category)+-- import Control.Exception.Lifted (finally)+-- import Control.Foldl (PrimMonad, Vector, FoldM(..))+-- import Control.Monad (liftM)+-- import Control.Monad.CC hiding (control)+-- import Control.Monad.Cont+-- import Control.Monad.Logic+-- import Control.Monad.Trans.Class (lift)+-- import Control.Monad.Trans.Control+-- import Control.Monad.Trans.Either (EitherT(..))+-- import Control.Monad.Trans.Maybe+-- import Crypto.Hash+-- import qualified Data.ByteString as B+-- import Data.Foldable+-- import Data.Functor.Identity+-- import qualified Data.Machine as M+import Data.Traversable++-- import qualified Data.Conduit.Internal as C (Source, Producer,+-- ConduitM(..), Pipe(..))++-- | Compose a 'Source' and a 'Conduit' into a new 'Source'. Note that this+-- is just flipped function application, so ($) can be used to achieve the+-- same thing.+infixl 1 $=+($=) :: a -> (a -> b) -> b+($=) = flip ($)+{-# INLINE ($=) #-}++-- | Compose a 'Conduit' and a 'Sink' into a new 'Sink'. Note that this is+-- just function composition, so (.) can be used to achieve the same thing.+infixr 2 =$+(=$) :: (a -> b) -> (b -> c) -> a -> c+(=$) = flip (.)+{-# INLINE (=$) #-}++-- | Compose a 'Source' and a 'Sink' and compute the result. Note that this+-- is just flipped function application, so ($) can be used to achieve the+-- same thing.+infixr 0 $$+($$) :: a -> (a -> b) -> b+($$) = flip ($)+{-# INLINE ($$) #-}++-- | Sequence a collection of sources.+--+-- >>> sinkList $ sequenceSources [yieldOne 1, yieldOne 2, yieldOne 3]+-- [[1,2,3]]+sequenceSources :: (Traversable f, Monad m) => f (Source m a) -> Source m (f a)+sequenceSources = sequenceA+{-# INLINE sequenceSources #-}++{-+-- | Convert a 'Control.Foldl.FoldM' fold abstraction into a Sink.+--+-- NOTE: This requires ImpredicativeTypes in the code that uses it.+--+-- >>> fromFoldM (FoldM ((return .) . (+)) (return 0) return) $ yieldMany [1..10]+-- 55+fromFoldM :: Monad m => FoldM m a b -> Sink a m b+fromFoldM (FoldM step initial final) src =+ initial >>= (\r -> sink r ((lift .) . step) src) >>= final+{-# INLINE fromFoldM #-}++-- | Convert a Sink into a 'Control.Foldl.FoldM', passing it as a continuation+-- over the elements.+--+-- >>> toFoldM sumC (\f -> Control.Foldl.foldM f [1..10])+-- 55+toFoldM :: Monad m => Sink a m b -> (forall r. FoldM m a r -> m r) -> m b+toFoldM s f = s $ source $ \k yield ->+ EitherT $ liftM Right $ f $+ FoldM (\r x -> either id id `liftM` runEitherT (yield r x))+ (return k) return+{-# INLINE toFoldM #-}++-- | Turns any conduit 'Producer' into a simple-conduit 'Source'.+-- Finalization is taken care of, as is processing of leftovers, provided+-- the base monad implements @MonadBaseControl IO@.+adaptFrom :: forall m a. MonadBaseControl IO m => C.Producer m a -> Source m a+adaptFrom (C.ConduitM m) = source go+ where+ go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r+ go z yield = f z m+ where+ f r (C.HaveOutput p c o) = yield r o >>= \r' -> f r' p `finally` lift c+ f r (C.NeedInput _ u) = f r (u ())+ f r (C.Done ()) = return r+ f r (C.PipeM mp) = lift mp >>= f r+ f r (C.Leftover p l) = yield r l >>= flip f p++-- | Turn a non-resource dependent simple-conduit into a conduit 'Source'.+--+-- Finalization data would be lost in this transfer, and so is denied by+-- lack of an instance for @MonadBaseControl IO@. Further, the resulting+-- pipeline must be run under 'Control.Monad.CC.runCCT', so really this is+-- more a curiosity than anything else.+adaptTo :: MonadDelimitedCont p s m => Source m a -> C.Source m a+adaptTo src = C.ConduitM $ C.PipeM $ reset $ \p ->+ liftM C.Done $ unwrap $ runSource src () $ \() x ->+ lift $ shift p $ \k ->+ return $ C.HaveOutput (C.PipeM $ k (return ())) (return ()) x++fromLogicT :: Monad m => LogicT m a -> Source m a+fromLogicT (LogicT await) = source $ \z yield ->+ lift $ await (go yield) (return z)+ where+ go yield x mr = do+ r <- mr+ eres <- runEitherT $ yield r x+ case eres of+ Left e -> return e -- no short-circuiting here!+ Right r -> return r++-- toLogicT :: forall m a. Monad m => Source m a -> LogicT m a+-- toLogicT (Source (ContT await)) = LogicT $ \yield mz -> do+-- z <- mz+-- liftM (either id id) . runEitherT $+-- runIdentity (await (\x -> Identity $ liftM lift $ yield x . return)) z++fromMachine :: forall m k a. Monad m => M.MachineT m k a -> Source m a+fromMachine mach = source go+ where+ go :: forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r+ go z yield = loop mach z+ where+ loop :: M.MachineT m k a -> r -> EitherT r m r+ loop (M.MachineT m) r = do+ step <- lift m+ case step of+ M.Stop -> return r+ M.Yield x k -> loop k r >>= flip yield x+ M.Await _ _ e -> loop e r++-- toMachine :: forall m k s a. (Category k, Monad m)+-- => Source m a -> s -> M.MachineT m (k a) s+-- toMachine (Source (ContT await)) seed =+-- M.construct $ M.PlanT+-- (\r -> )+-- (\a mr -> )+-- (\f kz mr -> )+-- (return seed)+-- liftM (either id id) . runEitherT $+-- runIdentity (await go) seed+-- where+-- go :: a -> Identity (s -> EitherT s (M.PlanT (k a) a m) ())+-- go x = Identity $ liftM lift $ \r -> M.yield x++-- | A 'Sink' that hashes a stream of 'B.ByteString'@s@ and creates a digest+-- @d@.+sinkHash :: (Monad m, HashAlgorithm hash) => Sink B.ByteString m (Digest hash)+sinkHash = liftM hashFinalize . sink hashInit ((return .) . hashUpdate)++-- | Hashes the whole contents of the given file in constant memory. This+-- function is just a convenient wrapper around 'sinkHash'.+hashFile :: (MonadIO m, HashAlgorithm hash) => FilePath -> m (Digest hash)+hashFile = liftIO . sinkHash . sourceFile+-}
+ Conduit/Simple/Core.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Please see the project README for more details:+--+-- https://github.com/jwiegley/simple-conduit/blob/master/README.md+--+-- Also see this blog article:+--+-- https://www.newartisans.com/2014/06/simpler-conduit-library++module Conduit.Simple.Core where++import Control.Applicative (Alternative((<|>), empty),+ Applicative((<*>), pure))+import Control.Arrow (first)+import Control.Monad.Catch (MonadThrow(..), MonadMask, MonadCatch)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Cont+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Free+import Control.Monad.Morph (MMonad(..), MFunctor(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Either (EitherT(..), left)+import Control.Monad.Writer.Class (MonadWriter(..))+import Data.Bifunctor (Bifunctor(bimap))+import Data.Foldable (Foldable(foldMap))+import Data.Functor.Identity+import Data.Semigroup (Monoid(..), Semigroup((<>)))++-- | A Source is a short-circuiting monadic fold.+--+-- 'Source' forms a Monad that behaves as 'ListT'; for example:+--+-- @+-- do x <- yieldMany [1..3]+-- line <- sourceFile "foo.txt"+-- return (x, line)+-- @+--+-- This yields the cross-product of [3] and the lines in the files, but only+-- reading chunks from the file as needed by the sink.+--+-- To skip to the next value in a Source, use the function 'skip' or 'mempty';+-- to close the source, use 'close'. For example:+--+-- @+-- do x <- yieldMany [1..10]+-- if x == 2 || x == 9+-- then return x+-- else if x < 5+-- then skip+-- else close+-- @+--+-- This outputs the list @[2]@.+--+-- A key difference from the @conduit@ library is that monadic chaining of+-- sources with '>>' follows 'ListT', and not concatenation as in conduit. To+-- achieve conduit-style behavior, use the Monoid instance:+--+-- >>> sinkList $ yieldMany [1..3] <> yieldMany [4..6]+-- [1,2,3,4,5,6]+newtype Source m a = Source { getSource :: forall r. Cont (r -> EitherT r m r) a }+ deriving Functor++-- | A 'Conduit' is a "Source homomorphism", or simple a mapping between+-- sources. There is no need for it to be a type synonym, except to save+-- repetition across type signatures.+type Conduit a m b = Source m a -> Source m b++-- | A 'Sink' folds a 'Source' down to its result value. It is simply a+-- convenient type synonym for functions mapping a 'Source' to some result+-- type.+type Sink a m r = Source m a -> m r++instance Monad m => Semigroup (Source m a) where+ x <> y = source $ \r c -> runSource x r c >>= \r' -> runSource y r' c+ {-# INLINE (<>) #-}++instance Monad m => Monoid (Source m a) where+ mempty = skip+ {-# INLINE mempty #-}+ mappend = (<>)+ {-# INLINE mappend #-}++instance Monad m => Alternative (Source m) where+ empty = skip+ {-# INLINE empty #-}+ (<|>) = (<>)+ {-# INLINE (<|>) #-}++instance Monad m => MonadPlus (Source m) where+ mzero = skip+ {-# INLINE mzero #-}+ mplus = (<|>)+ {-# INLINE mplus #-}++instance Applicative (Source m) where+ pure = return+ {-# INLINE pure #-}+ (<*>) = ap+ {-# INLINE (<*>) #-}++instance Monad (Source m) where+ return x = Source $ return x+ {-# INLINE return #-}+ Source m >>= f = Source $ join (liftM (getSource . f) m)+ {-# INLINE (>>=) #-}++instance MFunctor Source where+ hoist nat m = source $ runSource (hoist nat m)+ {-# INLINE hoist #-}++instance MMonad Source where+ embed f m = source $ runSource (embed f m)+ {-# INLINE embed #-}++instance MonadIO m => MonadIO (Source m) where+ liftIO m = source $ \r yield -> liftIO m >>= yield r+ {-# INLINE liftIO #-}++instance MonadTrans Source where+ lift m = source $ \r yield -> lift m >>= yield r+ {-# INLINE lift #-}++instance (Functor f, MonadFree f m) => MonadFree f (Source m) where+ wrap t = source $ \r h -> wrap $ fmap (\p -> runSource p r h) t+ {-# INLINE wrap #-}++-- jww (2014-06-15): If it weren't for the universally quantified r...+-- instance MonadCont (Source m) where+-- callCC f = source $ \z c -> runSource (f (\x -> source $ \r _ -> c r x)) z c+-- {-# INLINE callCC #-}++instance MonadReader r m => MonadReader r (Source m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = conduit $ \r yield -> local f . yield r+ {-# INLINE local #-}+ reader = lift . reader+ {-# INLINE reader #-}++instance MonadState s m => MonadState s (Source m) where+ get = lift get+ {-# INLINE get #-}+ put = lift . put+ {-# INLINE put #-}+ state = lift . state+ {-# INLINE state #-}++instance MonadWriter w m => MonadWriter w (Source m) where+ writer = lift . writer+ {-# INLINE writer #-}+ tell = lift . tell+ {-# INLINE tell #-}+ listen = conduit $ \r yield x ->+ listen (return ()) >>= yield r . first (const x)+ {-# INLINE listen #-}+ pass = conduit $ \r yield (x, f) -> pass (return ((), f)) >> yield r x+ {-# INLINE pass #-}++instance MonadError e m => MonadError e (Source m) where+ throwError = lift . throwError+ {-# INLINE throwError #-}+ catchError src f = source $ \z yield -> EitherT $+ runEitherT (runSource src z yield)+ `catchError` \e -> runEitherT (runSource (f e) z yield)+ {-# INLINE catchError #-}++instance MonadThrow m => MonadThrow (Source m) where+ throwM = lift . throwM+ {-# INLINE throwM #-}++instance MonadCatch m => MonadCatch (Source m) where+ catch src f = source $ \z yield -> EitherT $+ runEitherT (runSource src z yield)+ `Catch.catch` \e -> runEitherT (runSource (f e) z yield)+ {-# INLINE catch #-}++instance MonadMask m => MonadMask (Source m) where+ mask a = source $ \z yield -> EitherT $ Catch.mask $ \u ->+ runEitherT $ runSource (a $ \b -> source $ \r yield' ->+ EitherT $ liftM Right $ u $ sink r yield' b) z yield+ {-# INLINE mask #-}+ uninterruptibleMask a =+ source $ \z yield -> EitherT $ Catch.uninterruptibleMask $ \u ->+ runEitherT $ runSource (a $ \b -> source $ \r yield' ->+ EitherT $ liftM Right $ u $ sink r yield' b) z yield+ {-# INLINE uninterruptibleMask #-}++instance Foldable (Source Identity) where+ foldMap f = runIdentity . sink mempty (\r x -> return $ r `mappend` f x)+ {-# INLINE foldMap #-}++-- | Promote any sink to a source. This can be used as if it were a source+-- transformer (aka, a conduit):+--+-- >>> sinkList $ returnC $ sumC $ mapC (+1) $ yieldMany [1..10]+-- [65]+--+-- Note that 'returnC' is a synonym for 'Control.Monad.Trans.Class.lift'.+returnC :: Monad m => m a -> Source m a+returnC = lift+{-# INLINE returnC #-}++prod :: Source m (Cont (r -> EitherT r m r) (Source m a))+ -> Cont (r -> EitherT r m r) (Source m a)+prod (Source (ContT src)) = ContT $ \yield -> src $ \(ContT x) -> x yield++close :: Monad m => Source m a+close = source $ const . left+{-# INLINE close #-}++skip :: Monad m => Source m a+skip = source $ const . return+{-# INLINE skip #-}++runSource :: Source m a -> r -> (r -> a -> EitherT r m r) -> EitherT r m r+runSource (Source (ContT src)) z yield =+ runIdentity (src (\x -> Identity $ \r -> yield r x)) z+{-# INLINE runSource #-}++lowerSource :: (Monad m, Monoid a) => Source m a -> m a+lowerSource src = unwrap $ runSource src mempty ((return .) . mappend)+{-# INLINE lowerSource #-}++source :: (forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r) -> Source m a+source await = Source $ ContT $ \yield -> Identity $ \z ->+ await z (\r x -> runIdentity (yield x) r)+{-# INLINE source #-}++conduit :: (forall r. r -> (r -> b -> EitherT r m r) -> a -> EitherT r m r)+ -> Conduit a m b+conduit f src = source $ \z c -> runSource src z (`f` c)+{-# INLINE conduit #-}++-- | Most of the time conduits pass the fold variable through unmolested, but+-- sometimes you need to ignore that variable and use your own within a+-- stage of the pipeline. This is done by wrapping the fold variable in a+-- tuple and then unwrapping it when the conduit is done. 'conduitWith'+-- makes this transparent.+conduitWith :: Monad m+ => s+ -> (forall r. (r, s) -> (r -> b -> EitherT (r, s) m (r, s)) -> a+ -> EitherT (r, s) m (r, s))+ -> Conduit a m b+conduitWith s f src = source $ \z yield ->+ rewrap fst $ runSource src (z, s) $ \(r, t) ->+ f (r, t) (\r' -> rewrap (, t) . yield r')+{-# INLINE conduitWith #-}++unwrap :: Monad m => EitherT a m a -> m a+unwrap k = either id id `liftM` runEitherT k+{-# INLINE unwrap #-}++rewrap :: Monad m => (a -> b) -> EitherT a m a -> EitherT b m b+rewrap f k = EitherT $ bimap f f `liftM` runEitherT k+{-# INLINE rewrap #-}++sink :: forall m a r. Monad m => r -> (r -> a -> EitherT r m r) -> Sink a m r+sink z f src = either id id `liftM` runEitherT (runSource src z f)+{-# INLINE sink #-}++awaitForever :: (a -> Source m b) -> Conduit a m b+awaitForever = flip (>>=)+{-# INLINE awaitForever #-}
simple-conduit.cabal view
@@ -1,8 +1,13 @@ Name: simple-conduit-Version: 0.4.0-Synopsis: A simple streaming library based on composing monadic folds.+Version: 0.5.0+Synopsis: A simple streaming I/O library based on monadic folds Description:- @simple-conduit@ follows a similar UI to the more capable @conduit@ library, but reduces the scope of what it can solve donw to what can be expressed by chaining monadic folds that allow for early termination. This allows for more predictable resource management behavior, at the cost of not allowing scenarios that @conduit@ is better designed.+ @simple-conduit@ follows a similar UI to the more capable @conduit@ library,+ but reduces the scope of what it can solve down to what can be expressed by+ chaining monadic folds that allow for early termination. This allows for+ more predictable resource management behavior, at the cost of not allowing+ scenarios that @conduit@ is better designed.+ License: BSD3 License-file: LICENSE Author: John Wiegley@@ -13,54 +18,84 @@ Homepage: http://github.com/jwiegley/simple-conduit Library- Exposed-modules: Conduit.Simple- Build-depends: base >= 4.3 && < 5- , bifunctors- , bytestring- , chunked-data- , containers- , either- , exceptions- , filepath- , foldl- , lifted-async- , lifted-base >= 0.1- , mmorph- , monad-control >= 0.3.1 && < 0.4- , mono-traversable- , mtl- , mwc-random- , primitive- , semigroups- , stm- , streaming-commons- , text- , transformers >= 0.2.2 && < 0.5- , transformers-base >= 0.4.1 && < 0.5- , vector- , void >= 0.5.5+ Exposed-modules:+ Conduit.Simple+ Conduit.Simple.Compat+ Conduit.Simple.Core+ Build-depends:+ base >= 4.3 && < 5+ , bifunctors+ , bytestring+ -- , CC-delcont+ , chunked-data+ , containers+ -- , contravariant+ , either+ , exceptions+ , filepath+ -- , foldl+ , free+ , lifted-async+ , lifted-base >= 0.1+ -- , machines+ , mmorph+ , monad-control >= 0.3.1 && < 0.4+ , mono-traversable+ , mtl+ , mwc-random+ , primitive+ , semigroups+ , stm+ , streaming-commons+ , text+ , transformers >= 0.2.2 && < 0.5+ , transformers-base >= 0.4.1 && < 0.5+ , vector+ -- , void >= 0.5.5 ghc-options: -Wall -benchmark bench- hs-source-dirs: test- main-is: bench.hs- type: exitcode-stdio-1.0- ghc-options: -O2- cpp-options: -DTEST- build-depends: simple-conduit- , base- , hspec >= 1.3- , QuickCheck- , transformers- , mtl- , void- , containers- , text- , criterion- , conduit- , conduit-extra- , conduit-combinators- ghc-options: -Wall+-- benchmark bench+-- hs-source-dirs: .+-- other-modules: Conduit.Simple.Compat+-- main-is: test/bench.hs+-- type: exitcode-stdio-1.0+-- ghc-options: -O2+-- cpp-options: -DTEST+-- build-depends:+-- simple-conduit+-- -- , base+-- -- , hspec >= 1.3+-- -- , QuickCheck+-- -- , transformers+-- -- , lifted-async+-- -- , stm+-- -- , foldl+-- -- , transformers-base+-- -- , primitive+-- -- , chunked-data+-- -- , CC-delcont+-- -- , bytestring+-- -- , mono-traversable+-- -- , streaming-commons+-- -- , filepath+-- -- , mwc-random+-- -- , lifted-base+-- -- , monad-control+-- -- , either+-- -- , exceptions+-- -- , free+-- -- , mmorph+-- -- , bifunctors+-- -- , semigroups+-- -- , mtl+-- -- , void+-- -- , containers+-- -- , text+-- -- , criterion+-- -- , conduit+-- -- , conduit-extra+-- -- , conduit-combinators+-- ghc-options: -Wall source-repository head type: git
− test/bench.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import qualified Conduit as C-import Conduit.Simple-import Control.Monad-import Control.Monad.IO.Class-import Criterion.Main (defaultMain, bench, nf)-import Data.Functor.Identity-import Data.Monoid-import Data.Text as T-import Data.Text.Encoding--main :: IO ()-main = do- xs <- yieldMany [1..10] $= mapC (+2) $$ sinkList- print (xs :: [Int])-- ys <- yieldMany [1..10] $$ mapC (+2) =$ sinkList- print (ys :: [Int])-- zs <- yieldMany [1..10] $= dropC 5 $= mapC (+2) $$ sinkList- print (zs :: [Int])-- ws <- yieldMany [1..10] $= takeC 5 $= mapC (+2) $$ sinkList- print (ws :: [Int])-- us <- (sourceFile "simple-conduit.cabal" <> sourceFile "README.md")- $= takeC 1- $$ sinkList- print (T.unpack (decodeUtf8 (Prelude.head us)))-- vs <- sinkList- $ mapC (<> "Hello")- $ takeC 1- $ sourceFile "simple-conduit.cabal" <> sourceFile "README.md"- print (T.unpack (decodeUtf8 (Prelude.head vs)))-- x <- sinkList $ returnC $ sumC $ mapC (+1) $ yieldMany ([1..10] :: [Int])- print x-- yieldMany ([1..10] :: [Int]) $$ mapM_C (liftIO . print)-- defaultMain [- bench "centipede1" $ nf (runIdentity . useThis) ([1..1000000] :: [Int])- , bench "conduit1" $ nf (runIdentity . useThat) ([1..1000000] :: [Int])- , bench "centipede2" $ nf (runIdentity . useThis) ([1..1000000] :: [Int])- , bench "centipede3" $ nf (runIdentity . useThis2) ([1..1000000] :: [Int])- , bench "conduit2" $ nf (runIdentity . useThat) ([1..1000000] :: [Int])- ]- where- useThis xs = yieldMany xs $= mapC (+2) $$ sinkList- useThis2 xs = yieldMany2 xs $= mapC (+2) $$ sinkList2- useThat xs = C.yieldMany xs C.$= C.mapC (+2) C.$$ C.sinkList--yieldMany2 :: Monad m => [a] -> Source m a-yieldMany2 xs = Source $ \z yield -> foldM yield z xs-{-# INLINE yieldMany2 #-}--sinkList2 :: Monad m => Sink a m [a]-sinkList2 = liftM (liftM ($ [])) $ sink id $ \r x -> return (r . (x:))-{-# INLINE sinkList2 #-}