simple-conduit 0.5.0 → 0.5.1
raw patch · 5 files changed
+223/−250 lines, 5 filesdep +CC-delcontdep +QuickCheckdep +conduitdep ~basedep ~lifted-basedep ~monad-control
Dependencies added: CC-delcont, QuickCheck, conduit, conduit-combinators, conduit-extra, criterion, foldl, hspec, simple-conduit, void
Dependency ranges changed: base, lifted-base, monad-control, transformers, transformers-base
Files
- Conduit/Simple.hs +43/−139
- Conduit/Simple/Compat.hs +12/−14
- Conduit/Simple/Core.hs +3/−48
- simple-conduit.cabal +44/−49
- test/bench.hs +121/−0
Conduit/Simple.hs view
@@ -66,7 +66,6 @@ , sinkLazy , sinkList , sinkVector- , sinkVectorN , sinkBuilder , sinkLazyBuilder , sinkNull@@ -152,7 +151,7 @@ , whileMC , zipSinks - , ($=), (=$), ($$)+ , ($=), (=$), (=$=), ($$) , sequenceSources ) where @@ -166,8 +165,8 @@ import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow) import Control.Monad.Cont-import Control.Monad.Primitive (PrimMonad(PrimState))-import Control.Monad.Trans.Control (MonadBaseControl(StM))+import Control.Monad.Primitive+import Control.Monad.Trans.Control import Control.Monad.Trans.Either (EitherT(..), left) import Data.Builder (Builder(builderToLazy), ToBuilder(..)) import Data.ByteString (ByteString)@@ -180,7 +179,7 @@ import Data.NonNull as NonNull (NonNull, fromNullable) import Data.Semigroup (Any(..), All(..), Monoid(..), Semigroup((<>))) import Data.Sequences as Seq (OrdSequence, EqSequence(elem, notElem),- SemiSequence(Index), singleton,+ SemiSequence(..), singleton, IsSequence(break, drop, dropWhile, fromList, splitAt)) import Data.Sequences.Lazy (LazySequence(fromChunks, toChunks))@@ -189,6 +188,7 @@ import Data.Textual.Encoding (Utf8(encodeUtf8)) import Data.Traversable (Traversable) import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as VM import Data.Word (Word8) import System.FilePath ((</>)) import System.IO (stdout, stdin, stderr, openFile, hClose,@@ -198,35 +198,27 @@ yieldMany :: (Monad m, MonoFoldable mono) => mono -> Source m (Element mono) yieldMany xs = source $ \z yield -> ofoldlM yield z xs-{-# INLINE yieldMany #-} sourceList :: Monad m => [a] -> Source m a 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 = (sourceList .) . Data.List.unfoldr-{-# INLINE unfoldC #-} enumFromToC :: forall m a. (Monad m, Enum a, Eq a) => a -> a -> Source m a enumFromToC = (sourceList .) . enumFromTo-{-# INLINE enumFromToC #-} iterateC :: forall m a. Monad m => (a -> a) -> a -> Source m a iterateC = (sourceList .) . iterate-{-# INLINE iterateC #-} repeatC :: forall m a. Monad m => a -> Source m a repeatC = sourceList . Prelude.repeat-{-# INLINE repeatC #-} replicateC :: forall m a. Monad m => Int -> a -> Source m a replicateC = (sourceList .) . Prelude.replicate-{-# INLINE replicateC #-} sourceLazy :: (Monad m, LazySequence lazy strict) => lazy -> Source m strict sourceLazy = sourceList . toChunks-{-# INLINE sourceLazy #-} repeatMC :: forall m a. Monad m => m a -> Source m a repeatMC x = source go@@ -268,73 +260,67 @@ if onull x then return y else loop =<< yield y x+{-# SPECIALIZE sourceHandle :: IOData a => Handle -> Source IO a #-} sourceFile :: (MonadBaseControl IO m, MonadIO m, IOData a) => FilePath -> Source m a sourceFile path = source $ \z yield ->- bracket (liftIO $ openFile path ReadMode) (liftIO . hClose)+ liftBaseOp (bracket (openFile path ReadMode) hClose) (\h -> runSource (sourceHandle h) z yield)-{-# INLINE sourceFile #-}+{-# SPECIALIZE sourceFile :: IOData a => FilePath -> Source IO a #-} sourceIOHandle :: (MonadBaseControl IO m, MonadIO m, IOData a) => IO Handle -> Source m a sourceIOHandle f = source $ \z yield ->- bracket (liftIO f) (liftIO . hClose)- (\h -> runSource (sourceHandle h) z yield)-{-# INLINE sourceIOHandle #-}+ liftBaseOp (bracket f hClose) $ \h ->+ runSource (sourceHandle h) z yield+{-# SPECIALIZE sourceIOHandle :: IOData a => IO Handle -> Source IO a #-} stdinC :: (MonadBaseControl IO m, MonadIO m, IOData a) => Source m a stdinC = sourceHandle stdin-{-# INLINE stdinC #-}+{-# SPECIALIZE stdinC :: IOData a => Source IO a #-} initRepeat :: Monad m => m seed -> (seed -> m a) -> Source m a 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 -> lift mseed >>= \seed -> runSource (replicateMC n (f seed)) z yield-{-# INLINE initReplicate #-} sourceRandom :: (Variate a, MonadIO m) => Source m a sourceRandom = initRepeat (liftIO MWC.createSystemRandom) (liftIO . MWC.uniform)-{-# INLINE sourceRandom #-} sourceRandomN :: (Variate a, MonadIO m) => Int -> Source m a sourceRandomN = initReplicate (liftIO MWC.createSystemRandom) (liftIO . MWC.uniform)-{-# INLINE sourceRandomN #-} sourceRandomGen :: (Variate a, MonadBase base m, PrimMonad base) => Gen (PrimState base) -> Source m a sourceRandomGen gen = initRepeat (return gen) (liftBase . MWC.uniform)-{-# INLINE sourceRandomGen #-} sourceRandomNGen :: (Variate a, MonadBase base m, PrimMonad base) => Gen (PrimState base) -> Int -> Source m a sourceRandomNGen gen = initReplicate (return gen) (liftBase . MWC.uniform)-{-# INLINE sourceRandomNGen #-} -sourceDirectory :: forall m. (MonadBaseControl IO m, MonadIO m)+sourceDirectory :: forall m. MonadBaseControl IO m => FilePath -> Source m FilePath sourceDirectory dir = source $ \z yield ->- bracket- (liftIO (F.openDirStream dir))- (liftIO . F.closeDirStream)+ liftBaseOp (bracket (F.openDirStream dir) F.closeDirStream) (go z yield) where go :: r -> (r -> FilePath -> EitherT r m r) -> F.DirStream -> EitherT r m r go z yield ds = loop z where loop r = do- mfp <- liftIO $ F.readDirStream ds+ mfp <- liftBase $ F.readDirStream ds case mfp of Nothing -> return r Just fp -> loop =<< yield r (dir </> fp)+{-# SPECIALIZE sourceDirectory :: FilePath -> Source IO FilePath #-} -sourceDirectoryDeep :: forall m. (MonadBaseControl IO m, MonadIO m)+sourceDirectoryDeep :: forall m. MonadBaseControl IO m => Bool -> FilePath -> Source m FilePath sourceDirectoryDeep followSymlinks startDir = source go where@@ -343,7 +329,7 @@ where start dir r = runSource (sourceDirectory dir) r entry entry r fp = do- ft <- liftIO $ F.getFileType fp+ ft <- liftBase $ F.getFileType fp case ft of F.FTFile -> yield r fp F.FTFileSym -> yield r fp@@ -352,23 +338,14 @@ | followSymlinks -> start fp r | otherwise -> return r F.FTOther -> return r+{-# SPECIALIZE sourceDirectoryDeep :: Bool -> FilePath -> Source IO FilePath #-} dropC :: Monad m => Int -> Conduit a m a dropC n = conduitWith n go where go (r, n') _ _ | n' > 0 = return (r, n' - 1) 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@@ -399,127 +376,97 @@ foldC :: (Monad m, Monoid a) => Sink a m a foldC = foldMapC id-{-# INLINE foldC #-} foldCE :: (Monad m, MonoFoldable mono, Monoid (Element mono)) => Sink mono m (Element mono) foldCE = foldlC (\acc mono -> acc `mappend` ofoldMap id mono) mempty-{-# INLINE foldCE #-} foldlC :: Monad m => (a -> b -> a) -> a -> Sink b m a foldlC f z = sink z ((return .) . f)-{-# INLINE foldlC #-} foldlCE :: (Monad m, MonoFoldable mono) => (a -> Element mono -> a) -> a -> Sink mono m a foldlCE f = foldlC (ofoldl' f)-{-# INLINE foldlCE #-} foldMapC :: (Monad m, Monoid b) => (a -> b) -> Sink a m b foldMapC f = foldlC (\acc x -> acc `mappend` f x) mempty-{-# INLINE foldMapC #-} foldMapCE :: (Monad m, MonoFoldable mono, Monoid w) => (Element mono -> w) -> Sink mono m w foldMapCE = foldMapC . ofoldMap-{-# INLINE foldMapCE #-} allC :: Monad m => (a -> Bool) -> Sink a m Bool allC f = liftM getAll `liftM` foldMapC (All . f)-{-# INLINE allC #-} allCE :: (Monad m, MonoFoldable mono) => (Element mono -> Bool) -> Sink mono m Bool allCE = allC . oall-{-# INLINE allCE #-} anyC :: Monad m => (a -> Bool) -> Sink a m Bool anyC f = liftM getAny `liftM` foldMapC (Any . f)-{-# INLINE anyC #-} anyCE :: (Monad m, MonoFoldable mono) => (Element mono -> Bool) -> Sink mono m Bool anyCE = anyC . oany-{-# INLINE anyCE #-} andC :: Monad m => Sink Bool m Bool andC = allC id-{-# INLINE andC #-} andCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) => Sink mono m Bool andCE = allCE id-{-# INLINE andCE #-} orC :: Monad m => Sink Bool m Bool orC = anyC id-{-# INLINE orC #-} orCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) => Sink mono m Bool orCE = anyCE id-{-# INLINE orCE #-} elemC :: (Monad m, Eq a) => a -> Sink a m Bool elemC x = anyC (== x)-{-# INLINE elemC #-} elemCE :: (Monad m, EqSequence seq) => Element seq -> Sink seq m Bool elemCE = anyC . Seq.elem-{-# INLINE elemCE #-} notElemC :: (Monad m, Eq a) => a -> Sink a m Bool notElemC x = allC (/= x)-{-# INLINE notElemC #-} notElemCE :: (Monad m, EqSequence seq) => Element seq -> Sink seq m Bool notElemCE = allC . Seq.notElem-{-# INLINE notElemCE #-} produceList :: Monad m => ([a] -> b) -> Sink a m b produceList f = liftM (f . ($ [])) . sink id (\front x -> return (front . (x:)))-{-# INLINE produceList #-} sinkLazy :: (Monad m, LazySequence lazy strict) => Sink strict m lazy sinkLazy = produceList fromChunks--- {-# INLINE sinkLazy #-} sinkList :: Monad m => Sink a m [a] sinkList = produceList id-{-# INLINE sinkList #-} sinkVector :: (MonadBase base m, V.Vector v a, PrimMonad base) => Sink a m (v a) sinkVector = undefined -sinkVectorN :: (MonadBase base m, V.Vector v a, PrimMonad base)- => Int -> Sink a m (v a)-sinkVectorN = undefined- sinkBuilder :: (Monad m, Monoid builder, ToBuilder a builder) => Sink a m builder sinkBuilder = foldMapC toBuilder-{-# INLINE sinkBuilder #-} sinkLazyBuilder :: (Monad m, Monoid builder, ToBuilder a builder, Builder builder lazy) => Sink a m lazy sinkLazyBuilder = liftM builderToLazy . foldMapC toBuilder-{-# INLINE sinkLazyBuilder #-} sinkNull :: Monad m => Sink a m () sinkNull _ = return ()-{-# INLINE sinkNull #-} awaitNonNull :: (Monad m, MonoFoldable a) => Conduit a m (Maybe (NonNull a)) awaitNonNull = conduit $ \r yield x -> maybe (return r) (yield r . Just) (NonNull.fromNullable x)-{-# INLINE awaitNonNull #-} headCE :: (Monad m, IsSequence seq) => Sink seq m (Maybe (Element seq)) headCE = undefined-{-# INLINE headCE #-} -- jww (2014-06-07): These two cannot be implemented without leftover support. -- peekC :: Monad m => Sink a m (Maybe a)@@ -530,44 +477,34 @@ lastC :: Monad m => Sink a m (Maybe a) lastC = sink Nothing (const (return . Just))-{-# INLINE lastC #-} lastCE :: (Monad m, IsSequence seq) => Sink seq m (Maybe (Element seq)) lastCE = undefined-{-# INLINE lastCE #-} lengthC :: (Monad m, Num len) => Sink a m len lengthC = foldlC (\x _ -> x + 1) 0-{-# INLINE lengthC #-} lengthCE :: (Monad m, Num len, MonoFoldable mono) => Sink mono m len lengthCE = foldlC (\x y -> x + fromIntegral (olength y)) 0-{-# INLINE lengthCE #-} lengthIfC :: (Monad m, Num len) => (a -> Bool) -> Sink a m len lengthIfC f = foldlC (\cnt a -> if f a then cnt + 1 else cnt) 0-{-# INLINE lengthIfC #-} lengthIfCE :: (Monad m, Num len, MonoFoldable mono) => (Element mono -> Bool) -> Sink mono m len lengthIfCE f = foldlCE (\cnt a -> if f a then cnt + 1 else cnt) 0-{-# INLINE lengthIfCE #-} maximumC :: (Monad m, Ord a) => Sink a m (Maybe a) maximumC = sink Nothing $ \r y -> return $ Just $ maybe y (max y) r-{-# INLINE maximumC #-} maximumCE :: (Monad m, OrdSequence seq) => Sink seq m (Maybe (Element seq)) maximumCE = undefined-{-# INLINE maximumCE #-} minimumC :: (Monad m, Ord a) => Sink a m (Maybe a) minimumC = sink Nothing $ \r y -> return $ Just $ maybe y (min y) r-{-# INLINE minimumC #-} minimumCE :: (Monad m, OrdSequence seq) => Sink seq m (Maybe (Element seq)) minimumCE = undefined-{-# INLINE minimumCE #-} -- jww (2014-06-07): These two cannot be implemented without leftover support. -- nullC :: Monad m => Sink a m Bool@@ -578,102 +515,79 @@ sumC :: (Monad m, Num a) => Sink a m a sumC = foldlC (+) 0-{-# INLINE sumC #-} sumCE :: (Monad m, MonoFoldable mono, Num (Element mono)) => Sink mono m (Element mono) sumCE = undefined-{-# INLINE sumCE #-} productC :: (Monad m, Num a) => Sink a m a productC = foldlC (*) 1-{-# INLINE productC #-} productCE :: (Monad m, MonoFoldable mono, Num (Element mono)) => Sink mono m (Element mono) productCE = undefined-{-# INLINE productCE #-} findC :: Monad m => (a -> Bool) -> Sink a m (Maybe a) findC f = sink Nothing $ \r x -> if f x then left (Just x) else return r-{-# INLINE findC #-} mapM_C :: Monad m => (a -> m ()) -> Sink a m () mapM_C f = sink () (const $ lift . f)-{-# INLINE mapM_C #-} mapM_CE :: (Monad m, MonoFoldable mono) => (Element mono -> m ()) -> Sink mono m () mapM_CE = undefined-{-# INLINE mapM_CE #-} foldMC :: Monad m => (a -> b -> m a) -> a -> Sink b m a foldMC f = flip sink ((lift .) . f)-{-# INLINE foldMC #-} foldMCE :: (Monad m, MonoFoldable mono) => (a -> Element mono -> m a) -> a -> Sink mono m a foldMCE = undefined-{-# INLINE foldMCE #-} foldMapMC :: (Monad m, Monoid w) => (a -> m w) -> Sink a m w foldMapMC f = foldMC (\acc x -> (acc `mappend`) `liftM` f x) mempty-{-# INLINE foldMapMC #-} foldMapMCE :: (Monad m, MonoFoldable mono, Monoid w) => (Element mono -> m w) -> Sink mono m w foldMapMCE = undefined-{-# INLINE foldMapMCE #-} sinkFile :: (MonadBaseControl IO m, MonadIO m, IOData a) => FilePath -> Sink a m () sinkFile fp = sinkIOHandle (liftIO $ openFile fp WriteMode)-{-# INLINE sinkFile #-} sinkHandle :: (MonadIO m, IOData a) => Handle -> Sink a m () sinkHandle = mapM_C . hPut-{-# INLINE sinkHandle #-} sinkIOHandle :: (MonadBaseControl IO m, MonadIO m, IOData a) => IO Handle -> Sink a m ()-sinkIOHandle alloc =- bracket (liftIO alloc) (liftIO . hClose) . flip sinkHandle-{-# INLINE sinkIOHandle #-}+sinkIOHandle alloc = liftBaseOp (bracket alloc hClose) . flip sinkHandle printC :: (Show a, MonadIO m) => Sink a m () printC = mapM_C (liftIO . print)-{-# INLINE printC #-} stdoutC :: (MonadIO m, IOData a) => Sink a m () stdoutC = sinkHandle stdout-{-# INLINE stdoutC #-} stderrC :: (MonadIO m, IOData a) => Sink a m () stderrC = sinkHandle stderr-{-# INLINE stderrC #-} mapC :: Monad m => (a -> b) -> Conduit a m b mapC = fmap-{-# INLINE mapC #-} mapCE :: (Monad m, Functor f) => (a -> b) -> Conduit (f a) m (f b) mapCE = undefined-{-# INLINE mapCE #-} omapCE :: (Monad m, MonoFunctor mono) => (Element mono -> Element mono) -> Conduit mono m mono omapCE = undefined-{-# INLINE omapCE #-} concatMapC :: (Monad m, MonoFoldable mono) => (a -> mono) -> Conduit a m (Element mono) concatMapC f = conduit $ \r yield -> ofoldlM yield r . f-{-# INLINE concatMapC #-} concatMapCE :: (Monad m, MonoFoldable mono, Monoid w) => (Element mono -> w) -> Conduit mono m w concatMapCE = undefined-{-# INLINE concatMapCE #-} takeC :: Monad m => Int -> Conduit a m a takeC n = conduitWith n go@@ -685,20 +599,6 @@ 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 @@ -724,24 +624,41 @@ takeExactlyCE = undefined concatC :: (Monad m, MonoFoldable mono) => Conduit mono m (Element mono)-concatC = undefined+concatC = awaitForever yieldMany filterC :: Monad m => (a -> Bool) -> Conduit a m a filterC f = awaitForever $ \x -> if f x then return x else skip-{-# INLINE filterC #-} filterCE :: (IsSequence seq, Monad m) => (Element seq -> Bool) -> Conduit seq m seq filterCE = undefined-{-# INLINE filterCE #-} mapWhileC :: Monad m => (a -> Maybe b) -> Conduit a m b mapWhileC f = awaitForever $ \x -> case f x of Just y -> return y; _ -> close-{-# INLINE mapWhileC #-} +-- | Collect elements into a vector until the size @maxSize@ is reached, then+-- yield that vector downstream. conduitVector :: (MonadBase base m, V.Vector v a, PrimMonad base) => Int -> Conduit a m (v a)-conduitVector = undefined+conduitVector maxSize src = source $ \z yield -> do+ mv <- liftBase $ VM.new maxSize+ EitherT $ do+ eres <- runEitherT $ runSource src (z, 0) $ \(r, i :: Int) x -> EitherT $+ if i >= maxSize+ then do+ v <- liftBase $ V.unsafeFreeze mv+ runEitherT $ rewrap (, 0) $ yield r v+ else do+ liftBase $ VM.write mv i x+ return $ Right (r, i + 1)+ case eres of+ Left (z', _) -> return $ Left z'+ Right (z', i)+ | i > 0 -> do+ v <- V.slice 0 i <$> liftBase (V.unsafeFreeze mv)+ runEitherT $ yield z' v+ | otherwise -> return $ Right z'+{-# SPECIALIZE conduitVector :: (V.Vector v a) => Int -> Conduit a IO (v a) #-} scanlC :: Monad m => (a -> b -> a) -> a -> Conduit b m a scanlC = undefined@@ -782,11 +699,9 @@ mapMC :: Monad m => (a -> m b) -> Conduit a m b mapMC f = (>>= lift . f)-{-# INLINE mapMC #-} mapMCE :: (Monad m, Traversable f) => (a -> m b) -> Conduit (f a) m (f b) mapMCE = undefined-{-# INLINE mapMCE #-} omapMCE :: (Monad m, MonoTraversable mono) => (Element mono -> m (Element mono)) -> Conduit mono m mono@@ -802,7 +717,6 @@ if res then return x else skip-{-# INLINE filterMC #-} filterMCE :: (Monad m, IsSequence seq) => (Element seq -> m Bool) -> Conduit seq m seq@@ -820,7 +734,6 @@ encodeUtf8C :: (Monad m, Utf8 text binary) => Conduit text m binary encodeUtf8C = mapC encodeUtf8-{-# INLINE encodeUtf8C #-} decodeUtf8C :: MonadThrow m => Conduit ByteString m Text decodeUtf8C = undefined@@ -836,12 +749,10 @@ unlinesC :: (Monad m, IsSequence seq, Element seq ~ Char) => Conduit seq m seq unlinesC = concatMapC (: [Seq.singleton '\n'])-{-# INLINE unlinesC #-} unlinesAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8) => Conduit seq m seq unlinesAsciiC = concatMapC (: [Seq.singleton 10])-{-# INLINE unlinesAsciiC #-} linesUnboundedC_ :: forall m seq. (Monad m, IsSequence seq, Eq (Element seq)) => Element seq -> Conduit seq m seq@@ -870,22 +781,18 @@ linesUnboundedC :: (Monad m, IsSequence seq, Element seq ~ Char) => Conduit seq m seq linesUnboundedC = linesUnboundedC_ '\n'-{-# INLINE linesUnboundedC #-} linesUnboundedAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8) => Conduit seq m seq linesUnboundedAsciiC = linesUnboundedC_ 10-{-# INLINE linesUnboundedAsciiC #-} 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@@ -916,7 +823,6 @@ asyncC :: (MonadBaseControl IO m, Monad m) => (a -> m b) -> Conduit a m (Async (StM m b)) asyncC f = awaitForever $ lift . async . f-{-# INLINE asyncC #-} sourceSTM :: forall container a. (container a -> STM a) -> (container a -> STM Bool)@@ -938,15 +844,12 @@ -- | A Source for exhausting a TChan, but blocks if it is initially empty. sourceTChan :: forall a. TChan a -> Source STM a sourceTChan = sourceSTM readTChan isEmptyTChan-{-# INLINE sourceTChan #-} sourceTQueue :: forall a. TQueue a -> Source STM a sourceTQueue = sourceSTM readTQueue isEmptyTQueue-{-# INLINE sourceTQueue #-} sourceTBQueue :: forall a. TBQueue a -> Source STM a sourceTBQueue = sourceSTM readTBQueue isEmptyTBQueue-{-# INLINE sourceTBQueue #-} untilMC :: forall m a. Monad m => m a -> m Bool -> Source m a untilMC m f = source go@@ -985,3 +888,4 @@ liftIO $ putMVar x Nothing liftIO $ putMVar y Nothing waitBoth a b+{-# SPECIALIZE zipSinks :: Sink a IO r -> Sink a IO r' -> Sink a IO (r, r') #-}
Conduit/Simple/Compat.hs view
@@ -3,15 +3,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Conduit.Simple.Compat- ( ($=), (=$), ($$)+ ( ($=), (=$), (=$=), ($$) , sequenceSources+ -- , toFoldM, fromFoldM -- , adaptFrom, adaptTo ) where import Conduit.Simple.Core -- import Control.Category (Category) -- import Control.Exception.Lifted (finally)--- import Control.Foldl (PrimMonad, Vector, FoldM(..))+-- import Control.Foldl (FoldM(..)) -- import Control.Monad (liftM) -- import Control.Monad.CC hiding (control) -- import Control.Monad.Cont@@ -36,22 +37,24 @@ 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 two 'Conduit'. This is also just function composition.+infixr 2 =$=+(=$=) :: (a -> b) -> (b -> c) -> a -> c+(=$=) = flip (.)+ -- | 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. --@@ -59,7 +62,6 @@ -- [[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.@@ -69,9 +71,8 @@ -- >>> 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 #-}+fromFoldM (FoldM step start done) src =+ start >>= (\r -> sink r ((lift .) . step) src) >>= done -- | Convert a Sink into a 'Control.Foldl.FoldM', passing it as a continuation -- over the elements.@@ -79,11 +80,8 @@ -- >>> 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 #-}+toFoldM s f = s $ source $ \z yield ->+ lift $ f $ FoldM ((unwrap .) . yield) (return z) return -- | Turns any conduit 'Producer' into a simple-conduit 'Source'. -- Finalization is taken care of, as is processing of leftovers, provided
Conduit/Simple/Core.hs view
@@ -84,122 +84,89 @@ 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 (<*>) #-}+ f <*> x = source $ \z yield ->+ runSource f z (\r f' -> runSource x r (\s x' -> yield s (f' x'))) 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):@@ -210,7 +177,6 @@ -- 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)@@ -218,30 +184,24 @@ 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@@ -256,20 +216,15 @@ 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 #-}+awaitForever = (=<<)
simple-conduit.cabal view
@@ -1,5 +1,5 @@ Name: simple-conduit-Version: 0.5.0+Version: 0.5.1 Synopsis: A simple streaming I/O library based on monadic folds Description: @simple-conduit@ follows a similar UI to the more capable @conduit@ library,@@ -18,6 +18,7 @@ Homepage: http://github.com/jwiegley/simple-conduit Library+ ghc-options: -Wall -O2 -funbox-strict-fields Exposed-modules: Conduit.Simple Conduit.Simple.Compat@@ -26,18 +27,14 @@ 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@@ -51,51 +48,49 @@ , 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: .--- 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+benchmark bench+ hs-source-dirs: .+ ghc-options: -O2 -funbox-strict-fields+ other-modules: Conduit.Simple.Compat+ main-is: test/bench.hs+ type: exitcode-stdio-1.0+ cpp-options: -DTEST+ build-depends:+ simple-conduit+ , base+ , vector+ , 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 source-repository head type: git
+ test/bench.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Conduit as C+import Conduit.Simple+import Conduit.Simple.Compat+import Control.Arrow+import Control.Monad+import Control.Monad.IO.Class+import Criterion.Main (defaultMain, bench, nf)+import Data.Functor.Identity+import Data.Monoid+import qualified Data.Vector as V+import qualified Data.Text as T+import Data.Text.Encoding+import System.IO.Unsafe (unsafePerformIO)++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+ $ (proc x -> do y <- mapC (+1) -< x+ g <- takeC 1 -< y+ returnA -< g)+ $ yieldMany ([1..10] :: [Int])+ print (vs :: [Int])++ 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])+ -- ,+ bench "rechunk1" $ nf (unsafePerformIO . rechunk1)+ (replicate 10 [1..10000])+ , bench "rechunk1IO" $ nf (unsafePerformIO . rechunk1IO)+ (replicate 10 [1..10000])+ , bench "C.rechunk1" $ nf (unsafePerformIO . conduitRechunk1)+ (replicate 10 [1..10000])+ , bench "C.rechunk3" $ nf (unsafePerformIO . conduitRechunk3)+ (replicate 10 [1..10000])+ ]+ 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++rechunk1 :: [[Int]] -> IO [V.Vector Int]+rechunk1 xs = sourceList xs+ $= concatC+ =$= concatMapC (\x -> [x, x])+ =$= conduitVector 512+ $$ sinkList++rechunk1IO :: [[Int]] -> IO [V.Vector Int]+rechunk1IO xs = sourceList xs+ $= concatC+ =$= concatMapC (\x -> [x, x])+ =$= conduitVector 512+ $$ sinkList++-- rechunk2 =+-- mapC (concatMap $ replicate 2) =$= loop+-- where+-- loop = do+-- x <- takeCE 512 $= foldC+-- unless (null x) $ yield x >> loop++conduitRechunk1 :: [[Int]] -> IO [V.Vector Int]+conduitRechunk1 xs = C.yieldMany xs+ C.$= C.concatC+ C.=$= C.concatMapC (\x -> [x, x])+ C.=$= C.conduitVector 512+ C.$$ C.sinkList++-- conduitRechunk2 :: [[Int]] -> IO [V.Vector Int]+-- conduitRechunk2 xs = C.yieldMany xs+-- C.$= C.mapC (concatMap $ replicate 2)+-- C.=$= loop+-- C.$$ C.sinkList+-- where+-- loop = do+-- x <- C.takeCE 512 C.=$= C.foldC+-- unless (null x) $ C.yield x >> loop++conduitRechunk3 :: [[Int]] -> IO [V.Vector Int]+conduitRechunk3 xs = C.yieldMany xs+ C.$= C.vectorBuilderC 512 (\yield' -> C.mapM_CE (\x -> yield' x >> yield' x))+ 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 #-}