diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,81 @@ -## 1.2.13.1 +# ChangeLog for conduit -* Remove the `Safe` language pragma [#353](https://github.com/snoyberg/conduit/issues/353) +## 1.3.6.1 + +* Forward compatibility with `-Wnoncanonical-monad-instances` becoming an error + +## 1.3.6 + +* Avoid dropping upstream items in `mergeSource` [#513](https://github.com/snoyberg/conduit/pull/513) + +## 1.3.5 + +* Add `groupOn` + +## 1.3.4.3 + +* Fix space leak in `*>` [#496](https://github.com/snoyberg/conduit/issues/496) [#497](https://github.com/snoyberg/conduit/pull/497) + +## 1.3.4.2 + +* Fix GHC 9.2 build [#473](https://github.com/snoyberg/conduit/pull/473) + +## 1.3.4.1 + +* Library and tests compile and run with GHC 9.0.1 [#455](https://github.com/snoyberg/conduit/pull/455) + +## 1.3.4 + +* Add `foldWhile` [#453](https://github.com/snoyberg/conduit/issues/453) [#456](https://github.com/snoyberg/conduit/pull/456). + +## 1.3.3 + +* Add `uncons`, `unconsM`, `unconsEither`, `unconsEitherM`. + +## 1.3.2.1 + +* Fix isChunksForExactlyE [#445](https://github.com/snoyberg/conduit/issues/445) [#446](https://github.com/snoyberg/conduit/pull/446) + +## 1.3.2 + +* Add `mapInputM` [#435](https://github.com/snoyberg/conduit/pull/435) + +## 1.3.1.2 + +* More eagerly emit groups in `chunksOf` [#427](https://github.com/snoyberg/conduit/pull/427) + +## 1.3.1.1 + +* Use lower-case imports (better for cross-compilation) [#408](https://github.com/snoyberg/conduit/pull/408) + +## 1.3.1 + +* Add `MonadFail` instance for `ConduitT`. + +## 1.3.0.3 + +* Improve fusion framework rewrite rules + +## 1.3.0.2 + +* Replace `ReadMode` with `WriteMode` in `withSinkFile` + +## 1.3.0.1 + +* Test suite compatibility with GHC 8.4.1 [#358](https://github.com/snoyberg/conduit/issues/358) + +## 1.3.0 + +* Drop monad-control and exceptions in favor of unliftio +* Drop mmorph dependency +* Deprecate old type synonyms and operators +* Drop finalizers from the library entirely + * Much simpler + * Less guarantees about prompt finalization + * No more `yieldOr`, `addCleanup` + * Replace the `Resumable` types with `SealedConduitT` +* Add the `Conduit` and `Data.Conduit.Combinators` modules, stolen from + `conduit-combinators` ## 1.2.13 diff --git a/Data/Conduit.hs b/Data/Conduit.hs deleted file mode 100644 --- a/Data/Conduit.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} --- | If this is your first time with conduit, you should probably start with --- the tutorial: --- . -module Data.Conduit - ( -- * Core interface - -- ** Types - Source - , Conduit - , Sink - , ConduitM - -- ** Connect/fuse operators - , (.|) - , ($$) - , ($=) - , (=$) - , (=$=) - , connect - , fuse - - -- *** Fuse with upstream results - , fuseBoth - , fuseBothMaybe - , fuseUpstream - - -- ** Primitives - , await - , yield - , yieldM - , leftover - , runConduit - , runConduitPure - , runConduitRes - - -- ** Finalization - , bracketP - , addCleanup - , yieldOr - - -- ** Exception handling - , catchC - , handleC - , tryC - - -- * Generalized conduit types - , Producer - , Consumer - , toProducer - , toConsumer - - -- * Utility functions - , awaitForever - , transPipe - , mapOutput - , mapOutputMaybe - , mapInput - , mergeSource - , passthroughSink - , sourceToList - - -- * Connect-and-resume - , ResumableSource - , newResumableSource - , ($$+) - , ($$++) - , ($$+-) - , ($=+) - , unwrapResumable - , closeResumableSource - - -- ** For @Conduit@s - , ResumableConduit - , newResumableConduit - , (=$$+) - , (=$$++) - , (=$$+-) - , unwrapResumableConduit - - -- * Fusion with leftovers - , fuseLeftovers - , fuseReturnLeftovers - - -- * Flushing - , Flush (..) - - -- * Newtype wrappers - -- ** ZipSource - , ZipSource (..) - , sequenceSources - - -- ** ZipSink - , ZipSink (..) - , sequenceSinks - - -- ** ZipConduit - , ZipConduit (..) - , sequenceConduits - ) where - -import Data.Conduit.Internal.Conduit -import Data.Void (Void) -import Data.Functor.Identity (Identity, runIdentity) -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Control.Monad.Trans.Control (MonadBaseControl) - --- | Named function synonym for '$$'. --- --- Since 1.2.3 -connect :: Monad m => Source m a -> Sink a m b -> m b -connect = ($$) - --- | Named function synonym for '=$='. --- --- Since 1.2.3 -fuse :: Monad m => Conduit a m b -> ConduitM b c m r -> ConduitM a c m r -fuse = (=$=) - -infixr 2 .| --- | Combine two @Conduit@s together into a new @Conduit@ (aka 'fuse'). --- --- Output from the upstream (left) conduit will be fed into the --- downstream (right) conduit. Processing will terminate when --- downstream (right) returns. Leftover data returned from the right --- @Conduit@ will be discarded. --- --- @since 1.2.8 -(.|) :: Monad m - => ConduitM a b m () -- ^ upstream - -> ConduitM b c m r -- ^ downstream - -> ConduitM a c m r -(.|) = fuse -{-# INLINE (.|) #-} - --- | Run a pure pipeline until processing completes, i.e. a pipeline --- with @Identity@ as the base monad. This is equivalient to --- @runIdentity . runConduit@. --- --- @since 1.2.8 -runConduitPure :: ConduitM () Void Identity r -> r -runConduitPure = runIdentity . runConduit -{-# INLINE runConduitPure #-} - --- | Run a pipeline which acquires resources with @ResourceT@, and --- then run the @ResourceT@ transformer. This is equivalent to --- @runResourceT . runConduit@. --- --- @since 1.2.8 -runConduitRes :: MonadBaseControl IO m - => ConduitM () Void (ResourceT m) r - -> m r -runConduitRes = runResourceT . runConduit -{-# INLINE runConduitRes #-} diff --git a/Data/Conduit/Internal.hs b/Data/Conduit/Internal.hs deleted file mode 100644 --- a/Data/Conduit/Internal.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -module Data.Conduit.Internal - ( -- * Pipe - module Data.Conduit.Internal.Pipe - -- * Conduit - , module Data.Conduit.Internal.Conduit - -- * Fusion (highly experimental!!!) - , module Data.Conduit.Internal.Fusion - ) where - -import Data.Conduit.Internal.Conduit hiding (addCleanup, await, - awaitForever, bracketP, - leftover, mapInput, mapOutput, - mapOutputMaybe, transPipe, - yield, yieldM, yieldOr) -import Data.Conduit.Internal.Pipe -import Data.Conduit.Internal.Fusion diff --git a/Data/Conduit/Internal/Conduit.hs b/Data/Conduit/Internal/Conduit.hs deleted file mode 100644 --- a/Data/Conduit/Internal/Conduit.hs +++ /dev/null @@ -1,1325 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Conduit.Internal.Conduit - ( -- ** Types - ConduitM (..) - , Source - , Producer - , Sink - , Consumer - , Conduit - , ResumableSource (..) - , ResumableConduit (..) - , Flush (..) - -- *** Newtype wrappers - , ZipSource (..) - , ZipSink (..) - , ZipConduit (..) - -- ** Primitives - , await - , awaitForever - , yield - , yieldM - , yieldOr - , leftover - , runConduit - -- ** Composition - , connectResume - , connectResumeConduit - , fuseLeftovers - , fuseReturnLeftovers - , ($$+) - , ($$++) - , ($$+-) - , ($=+) - , (=$$+) - , (=$$++) - , (=$$+-) - , ($$) - , ($=) - , (=$) - , (=$=) - -- ** Generalizing - , sourceToPipe - , sinkToPipe - , conduitToPipe - , toProducer - , toConsumer - -- ** Cleanup - , bracketP - , addCleanup - -- ** Exceptions - , catchC - , handleC - , tryC - -- ** Utilities - , Data.Conduit.Internal.Conduit.transPipe - , Data.Conduit.Internal.Conduit.mapOutput - , Data.Conduit.Internal.Conduit.mapOutputMaybe - , Data.Conduit.Internal.Conduit.mapInput - , Data.Conduit.Internal.Conduit.closeResumableSource - , unwrapResumable - , unwrapResumableConduit - , newResumableSource - , newResumableConduit - , zipSinks - , zipSources - , zipSourcesApp - , zipConduitApp - , mergeSource - , passthroughSink - , sourceToList - , fuseBoth - , fuseBothMaybe - , fuseUpstream - , sequenceSources - , sequenceSinks - , sequenceConduits - ) where - -import Prelude hiding (catch) -import Control.Applicative (Applicative (..)) -import Control.Exception.Lifted as E (Exception) -import qualified Control.Exception.Lifted as E (catch) -import Control.Monad (liftM, when, liftM2, ap) -import Control.Monad.Error.Class(MonadError(..)) -import Control.Monad.Reader.Class(MonadReader(..)) -import Control.Monad.RWS.Class(MonadRWS()) -import Control.Monad.Writer.Class(MonadWriter(..), censor) -import Control.Monad.State.Class(MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Base (MonadBase (liftBase)) -import Control.Monad.Primitive (PrimMonad, PrimState, primitive) -import Data.Void (Void, absurd) -import Data.Monoid (Monoid (mappend, mempty)) -import Data.Semigroup (Semigroup ((<>))) -import Control.Monad.Trans.Resource -import qualified Data.IORef as I -import Control.Monad.Morph (MFunctor (..)) -import Data.Conduit.Internal.Pipe hiding (yield, mapOutput, leftover, yieldM, yieldOr, await, awaitForever, addCleanup, bracketP) -import qualified Data.Conduit.Internal.Pipe as CI -import Control.Monad (forever) -import Data.Traversable (Traversable (..)) -import Control.Monad.Catch (MonadCatch, catch) - --- | Core datatype of the conduit package. This type represents a general --- component which can consume a stream of input values @i@, produce a stream --- of output values @o@, perform actions in the @m@ monad, and produce a final --- result @r@. The type synonyms provided here are simply wrappers around this --- type. --- --- Since 1.0.0 -newtype ConduitM i o m r = ConduitM - { unConduitM :: forall b. - (r -> Pipe i i o () m b) -> Pipe i i o () m b - } - -instance Functor (ConduitM i o m) where - fmap f (ConduitM c) = ConduitM $ \rest -> c (rest . f) - -instance Applicative (ConduitM i o m) where - pure x = ConduitM ($ x) - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance Monad (ConduitM i o m) where - return = pure - ConduitM f >>= g = ConduitM $ \h -> f $ \a -> unConduitM (g a) h - -instance MonadThrow m => MonadThrow (ConduitM i o m) where - throwM = lift . throwM - -instance MFunctor (ConduitM i o) where - hoist f (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput p c o) = HaveOutput (go p) (f c) o - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = rest r - go (PipeM mp) = - PipeM (f $ liftM go $ collapse mp) - where - -- Combine a series of monadic actions into a single action. Since we - -- throw away side effects between different actions, an arbitrary break - -- between actions will lead to a violation of the monad transformer laws. - -- Example available at: - -- - -- http://hpaste.org/75520 - collapse mpipe = do - pipe' <- mpipe - case pipe' of - PipeM mpipe' -> collapse mpipe' - _ -> return pipe' - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - -instance MonadCatch m => MonadCatch (ConduitM i o m) where - catch (ConduitM p0) onErr = ConduitM $ \rest -> let - go (Done r) = rest r - go (PipeM mp) = PipeM $ catch (liftM go mp) (return . flip unConduitM rest . onErr) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o - in go (p0 Done) - -instance MonadIO m => MonadIO (ConduitM i o m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -instance MonadReader r m => MonadReader r (ConduitM i o m) where - ask = lift ask - {-# INLINE ask #-} - - local f (ConduitM c0) = ConduitM $ \rest -> - let go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput p c) = NeedInput (\i -> go (p i)) (\u -> go (c u)) - go (Done x) = rest x - go (PipeM mp) = PipeM (liftM go $ local f mp) - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x, y, z) 0 -#endif - -instance MonadWriter w m => MonadWriter w (ConduitM i o m) where -#if MIN_VERSION_mtl(2, 1, 0) - writer = lift . writer -#endif - tell = lift . tell - - listen (ConduitM c0) = ConduitM $ \rest -> - let go front (HaveOutput p c o) = HaveOutput (go front p) c o - go front (NeedInput p c) = NeedInput (\i -> go front (p i)) (\u -> go front (c u)) - go front (Done x) = rest (x, front) - go front (PipeM mp) = PipeM $ do - (p,w) <- listen mp - return $ go (front `mappend` w) p - go front (Leftover p i) = Leftover (go front p) i - in go mempty (c0 Done) - - pass (ConduitM c0) = ConduitM $ \rest -> - let go front (HaveOutput p c o) = HaveOutput (go front p) c o - go front (NeedInput p c) = NeedInput (\i -> go front (p i)) (\u -> go front (c u)) - go front (PipeM mp) = PipeM $ do - (p,w) <- censor (const mempty) (listen mp) - return $ go (front `mappend` w) p - go front (Done (x,f)) = PipeM $ do - tell (f front) - return $ rest x - go front (Leftover p i) = Leftover (go front p) i - in go mempty (c0 Done) - -instance MonadState s m => MonadState s (ConduitM i o m) where - get = lift get - put = lift . put -#if MIN_VERSION_mtl(2, 1, 0) - state = lift . state -#endif - -instance MonadRWS r w s m => MonadRWS r w s (ConduitM i o m) - -instance MonadError e m => MonadError e (ConduitM i o m) where - throwError = lift . throwError - catchError (ConduitM c0) f = ConduitM $ \rest -> - let go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput p c) = NeedInput (\i -> go (p i)) (\u -> go (c u)) - go (Done x) = rest x - go (PipeM mp) = - PipeM $ catchError (liftM go mp) $ \e -> do - return $ unConduitM (f e) rest - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - -instance MonadBase base m => MonadBase base (ConduitM i o m) where - liftBase = lift . liftBase - {-# INLINE liftBase #-} - -instance MonadTrans (ConduitM i o) where - lift mr = ConduitM $ \rest -> PipeM (liftM rest mr) - {-# INLINE [1] lift #-} - -instance MonadResource m => MonadResource (ConduitM i o m) where - liftResourceT = lift . liftResourceT - {-# INLINE liftResourceT #-} - -instance Monad m => Semigroup (ConduitM i o m ()) where - (<>) = (>>) - {-# INLINE (<>) #-} - -instance Monad m => Monoid (ConduitM i o m ()) where - mempty = return () - {-# INLINE mempty #-} -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) - {-# INLINE mappend #-} -#endif - -instance PrimMonad m => PrimMonad (ConduitM i o m) where - type PrimState (ConduitM i o m) = PrimState m - primitive = lift . primitive - --- | Provides a stream of output values, without consuming any input or --- producing a final result. --- --- Since 0.5.0 -type Source m o = ConduitM () o m () - --- | A component which produces a stream of output values, regardless of the --- input stream. A @Producer@ is a generalization of a @Source@, and can be --- used as either a @Source@ or a @Conduit@. --- --- Since 1.0.0 -type Producer m o = forall i. ConduitM i o m () - --- | Consumes a stream of input values and produces a final result, without --- producing any output. --- --- > type Sink i m r = ConduitM i Void m r --- --- Since 0.5.0 -type Sink i = ConduitM i Void - --- | A component which consumes a stream of input values and produces a final --- result, regardless of the output stream. A @Consumer@ is a generalization of --- a @Sink@, and can be used as either a @Sink@ or a @Conduit@. --- --- Since 1.0.0 -type Consumer i m r = forall o. ConduitM i o m r - --- | Consumes a stream of input values and produces a stream of output values, --- without producing a final result. --- --- Since 0.5.0 -type Conduit i m o = ConduitM i o m () - --- | A @Source@ which has been started, but has not yet completed. --- --- This type contains both the current state of the @Source@, and the finalizer --- to be run to close it. --- --- Since 0.5.0 -data ResumableSource m o = ResumableSource (Pipe () () o () m ()) (m ()) - --- | Since 1.0.13 -instance MFunctor ResumableSource where - hoist nat (ResumableSource src m) = ResumableSource (hoist nat src) (nat m) - --- | Connect a @Source@ to a @Sink@ until the latter closes. Returns both the --- most recent state of the @Source@ and the result of the @Sink@. --- --- We use a @ResumableSource@ to keep track of the most recent finalizer --- provided by the @Source@. --- --- Since 0.5.0 -connectResume :: Monad m - => ResumableSource m o - -> Sink o m r - -> m (ResumableSource m o, r) -connectResume (ResumableSource left0 leftFinal0) (ConduitM right0) = - goRight leftFinal0 left0 (right0 Done) - where - goRight leftFinal left right = - case right of - HaveOutput _ _ o -> absurd o - NeedInput rp rc -> goLeft rp rc leftFinal left - Done r2 -> return (ResumableSource left leftFinal, r2) - PipeM mp -> mp >>= goRight leftFinal left - Leftover p i -> goRight leftFinal (HaveOutput left leftFinal i) p - - goLeft rp rc leftFinal left = - case left of - HaveOutput left' leftFinal' o -> goRight leftFinal' left' (rp o) - NeedInput _ lc -> recurse (lc ()) - Done () -> goRight (return ()) (Done ()) (rc ()) - PipeM mp -> mp >>= recurse - Leftover p () -> recurse p - where - recurse = goLeft rp rc leftFinal - -sourceToPipe :: Monad m => Source m o -> Pipe l i o u m () -sourceToPipe = - go . flip unConduitM Done - where - go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput _ c) = go $ c () - go (Done ()) = Done () - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover p ()) = go p - -sinkToPipe :: Monad m => Sink i m r -> Pipe l i o u m r -sinkToPipe = - go . injectLeftovers . flip unConduitM Done - where - go (HaveOutput _ _ o) = absurd o - go (NeedInput p c) = NeedInput (go . p) (const $ go $ c ()) - go (Done r) = Done r - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover _ l) = absurd l - -conduitToPipe :: Monad m => Conduit i m o -> Pipe l i o u m () -conduitToPipe = - go . injectLeftovers . flip unConduitM Done - where - go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput p c) = NeedInput (go . p) (const $ go $ c ()) - go (Done ()) = Done () - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover _ l) = absurd l - --- | Unwraps a @ResumableSource@ into a @Source@ and a finalizer. --- --- A @ResumableSource@ represents a @Source@ which has already been run, and --- therefore has a finalizer registered. As a result, if we want to turn it --- into a regular @Source@, we need to ensure that the finalizer will be run --- appropriately. By appropriately, I mean: --- --- * If a new finalizer is registered, the old one should not be called. --- --- * If the old one is called, it should not be called again. --- --- This function returns both a @Source@ and a finalizer which ensures that the --- above two conditions hold. Once you call that finalizer, the @Source@ is --- invalidated and cannot be used. --- --- Since 0.5.2 -unwrapResumable :: MonadIO m => ResumableSource m o -> m (Source m o, m ()) -unwrapResumable (ResumableSource src final) = do - ref <- liftIO $ I.newIORef True - let final' = do - x <- liftIO $ I.readIORef ref - when x final - return (liftIO (I.writeIORef ref False) >> (ConduitM (src >>=)), final') - --- | Turn a @Source@ into a @ResumableSource@ with no attached finalizer. --- --- Since 1.1.4 -newResumableSource :: Monad m => Source m o -> ResumableSource m o -newResumableSource (ConduitM s) = ResumableSource (s Done) (return ()) - --- | Generalize a 'Source' to a 'Producer'. --- --- Since 1.0.0 -toProducer :: Monad m => Source m a -> Producer m a -toProducer (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput _ c) = go (c ()) - go (Done r) = rest r - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover p ()) = go p - in go (c0 Done) - --- | Generalize a 'Sink' to a 'Consumer'. --- --- Since 1.0.0 -toConsumer :: Monad m => Sink a m b -> Consumer a m b -toConsumer (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput _ _ o) = absurd o - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = rest r - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover p l) = Leftover (go p) l - in go (c0 Done) - --- | Catch all exceptions thrown by the current component of the pipeline. --- --- Note: this will /not/ catch exceptions thrown by other components! For --- example, if an exception is thrown in a @Source@ feeding to a @Sink@, and --- the @Sink@ uses @catchC@, the exception will /not/ be caught. --- --- Due to this behavior (as well as lack of async exception safety), you --- should not try to implement combinators such as @onException@ in terms of this --- primitive function. --- --- Note also that the exception handling will /not/ be applied to any --- finalizers generated by this conduit. --- --- Since 1.0.11 -catchC :: (MonadBaseControl IO m, Exception e) - => ConduitM i o m r - -> (e -> ConduitM i o m r) - -> ConduitM i o m r -catchC (ConduitM p0) onErr = ConduitM $ \rest -> let - go (Done r) = rest r - go (PipeM mp) = PipeM $ E.catch (liftM go mp) - (return . flip unConduitM rest . onErr) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o - in go (p0 Done) -{-# INLINE catchC #-} - --- | The same as @flip catchC@. --- --- Since 1.0.11 -handleC :: (MonadBaseControl IO m, Exception e) - => (e -> ConduitM i o m r) - -> ConduitM i o m r - -> ConduitM i o m r -handleC = flip catchC -{-# INLINE handleC #-} - --- | A version of @try@ for use within a pipeline. See the comments in @catchC@ --- for more details. --- --- Since 1.0.11 -tryC :: (MonadBaseControl IO m, Exception e) - => ConduitM i o m r - -> ConduitM i o m (Either e r) -tryC (ConduitM c0) = ConduitM $ \rest -> let - go (Done r) = rest (Right r) - go (PipeM mp) = PipeM $ E.catch (liftM go mp) (return . rest . Left) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o - in go (c0 Done) -{-# INLINE tryC #-} - --- | Combines two sinks. The new sink will complete when both input sinks have --- completed. --- --- Any leftovers are discarded. --- --- Since 0.4.1 -zipSinks :: Monad m => Sink i m r -> Sink i m r' -> Sink i m (r, r') -zipSinks (ConduitM x0) (ConduitM y0) = ConduitM $ \rest -> let - Leftover _ i >< _ = absurd i - _ >< Leftover _ i = absurd i - HaveOutput _ _ o >< _ = absurd o - _ >< HaveOutput _ _ o = absurd o - - PipeM mx >< y = PipeM (liftM (>< y) mx) - x >< PipeM my = PipeM (liftM (x ><) my) - Done x >< Done y = rest (x, y) - NeedInput px cx >< NeedInput py cy = NeedInput (\i -> px i >< py i) (\() -> cx () >< cy ()) - NeedInput px cx >< y@Done{} = NeedInput (\i -> px i >< y) (\u -> cx u >< y) - x@Done{} >< NeedInput py cy = NeedInput (\i -> x >< py i) (\u -> x >< cy u) - in injectLeftovers (x0 Done) >< injectLeftovers (y0 Done) - --- | Combines two sources. The new source will stop producing once either --- source has been exhausted. --- --- Since 1.0.13 -zipSources :: Monad m => Source m a -> Source m b -> Source m (a, b) -zipSources (ConduitM left0) (ConduitM right0) = ConduitM $ \rest -> let - go (Leftover left ()) right = go left right - go left (Leftover right ()) = go left right - go (Done ()) (Done ()) = rest () - go (Done ()) (HaveOutput _ close _) = PipeM (close >> return (rest ())) - go (HaveOutput _ close _) (Done ()) = PipeM (close >> return (rest ())) - go (Done ()) (PipeM _) = rest () - go (PipeM _) (Done ()) = rest () - go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) - go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) - go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) - go (HaveOutput srcx closex x) (HaveOutput srcy closey y) = HaveOutput (go srcx srcy) (closex >> closey) (x, y) - go (NeedInput _ c) right = go (c ()) right - go left (NeedInput _ c) = go left (c ()) - in go (left0 Done) (right0 Done) - --- | Combines two sources. The new source will stop producing once either --- source has been exhausted. --- --- Since 1.0.13 -zipSourcesApp :: Monad m => Source m (a -> b) -> Source m a -> Source m b -zipSourcesApp (ConduitM left0) (ConduitM right0) = ConduitM $ \rest -> let - go (Leftover left ()) right = go left right - go left (Leftover right ()) = go left right - go (Done ()) (Done ()) = rest () - go (Done ()) (HaveOutput _ close _) = PipeM (close >> return (rest ())) - go (HaveOutput _ close _) (Done ()) = PipeM (close >> return (rest ())) - go (Done ()) (PipeM _) = rest () - go (PipeM _) (Done ()) = rest () - go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) - go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) - go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) - go (HaveOutput srcx closex x) (HaveOutput srcy closey y) = HaveOutput (go srcx srcy) (closex >> closey) (x y) - go (NeedInput _ c) right = go (c ()) right - go left (NeedInput _ c) = go left (c ()) - in go (left0 Done) (right0 Done) - --- | --- --- Since 1.0.17 -zipConduitApp - :: Monad m - => ConduitM i o m (x -> y) - -> ConduitM i o m x - -> ConduitM i o m y -zipConduitApp (ConduitM left0) (ConduitM right0) = ConduitM $ \rest -> let - go _ _ (Done f) (Done x) = rest (f x) - go finalX finalY (PipeM mx) y = PipeM (flip (go finalX finalY) y `liftM` mx) - go finalX finalY x (PipeM my) = PipeM (go finalX finalY x `liftM` my) - go _ finalY (HaveOutput x finalX o) y = HaveOutput - (go finalX finalY x y) - (finalX >> finalY) - o - go finalX _ x (HaveOutput y finalY o) = HaveOutput - (go finalX finalY x y) - (finalX >> finalY) - o - go _ _ (Leftover _ i) _ = absurd i - go _ _ _ (Leftover _ i) = absurd i - go finalX finalY (NeedInput px cx) (NeedInput py cy) = NeedInput - (\i -> go finalX finalY (px i) (py i)) - (\u -> go finalX finalY (cx u) (cy u)) - go finalX finalY (NeedInput px cx) (Done y) = NeedInput - (\i -> go finalX finalY (px i) (Done y)) - (\u -> go finalX finalY (cx u) (Done y)) - go finalX finalY (Done x) (NeedInput py cy) = NeedInput - (\i -> go finalX finalY (Done x) (py i)) - (\u -> go finalX finalY (Done x) (cy u)) - in go (return ()) (return ()) (injectLeftovers $ left0 Done) (injectLeftovers $ right0 Done) - --- | Same as normal fusion (e.g. @=$=@), except instead of discarding leftovers --- from the downstream component, return them. --- --- Since 1.0.17 -fuseReturnLeftovers :: Monad m - => ConduitM a b m () - -> ConduitM b c m r - -> ConduitM a c m (r, [b]) -fuseReturnLeftovers (ConduitM left0) (ConduitM right0) = ConduitM $ \rest -> let - goRight final bs left right = - case right of - HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o - NeedInput rp rc -> - case bs of - [] -> goLeft rp rc final left - b:bs' -> goRight final bs' left (rp b) - Done r2 -> PipeM (final >> return (rest (r2, bs))) - PipeM mp -> PipeM (liftM recurse mp) - Leftover p b -> goRight final (b:bs) left p - where - recurse = goRight final bs left - - goLeft rp rc final left = - case left of - HaveOutput left' final' o -> goRight final' [] left' (rp o) - NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) - Done r1 -> goRight (return ()) [] (Done r1) (rc r1) - PipeM mp -> PipeM (liftM recurse mp) - Leftover left' i -> Leftover (recurse left') i - where - recurse = goLeft rp rc final - in goRight (return ()) [] (left0 Done) (right0 Done) - --- | Similar to @fuseReturnLeftovers@, but use the provided function to convert --- downstream leftovers to upstream leftovers. --- --- Since 1.0.17 -fuseLeftovers - :: Monad m - => ([b] -> [a]) - -> ConduitM a b m () - -> ConduitM b c m r - -> ConduitM a c m r -fuseLeftovers f left right = do - (r, bs) <- fuseReturnLeftovers left right - mapM_ leftover $ reverse $ f bs - return r - --- | A generalization of 'ResumableSource'. Allows to resume an arbitrary --- conduit, keeping its state and using it later (or finalizing it). --- --- Since 1.0.17 -data ResumableConduit i m o = - ResumableConduit (Pipe i i o () m ()) (m ()) - --- | Connect a 'ResumableConduit' to a sink and return the output of the sink --- together with a new 'ResumableConduit'. --- --- Since 1.0.17 -connectResumeConduit - :: Monad m - => ResumableConduit i m o - -> Sink o m r - -> Sink i m (ResumableConduit i m o, r) -connectResumeConduit (ResumableConduit left0 leftFinal0) (ConduitM right0) = ConduitM $ \rest -> let - goRight leftFinal left right = - case right of - HaveOutput _ _ o -> absurd o - NeedInput rp rc -> goLeft rp rc leftFinal left - Done r2 -> rest (ResumableConduit left leftFinal, r2) - PipeM mp -> PipeM (liftM (goRight leftFinal left) mp) - Leftover p i -> goRight leftFinal (HaveOutput left leftFinal i) p - - goLeft rp rc leftFinal left = - case left of - HaveOutput left' leftFinal' o -> goRight leftFinal' left' (rp o) - NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) - Done () -> goRight (return ()) (Done ()) (rc ()) - PipeM mp -> PipeM (liftM recurse mp) - Leftover left' i -> Leftover (recurse left') i -- recurse p - where - recurse = goLeft rp rc leftFinal - in goRight leftFinal0 left0 (right0 Done) - --- | Unwraps a @ResumableConduit@ into a @Conduit@ and a finalizer. --- --- Since 'unwrapResumable' for more information. --- --- Since 1.0.17 -unwrapResumableConduit :: MonadIO m => ResumableConduit i m o -> m (Conduit i m o, m ()) -unwrapResumableConduit (ResumableConduit src final) = do - ref <- liftIO $ I.newIORef True - let final' = do - x <- liftIO $ I.readIORef ref - when x final - return (ConduitM ((liftIO (I.writeIORef ref False) >> src) >>=), final') - --- | Turn a @Conduit@ into a @ResumableConduit@ with no attached finalizer. --- --- Since 1.1.4 -newResumableConduit :: Monad m => Conduit i m o -> ResumableConduit i m o -newResumableConduit (ConduitM c) = ResumableConduit (c Done) (return ()) - - --- | Merge a @Source@ into a @Conduit@. --- The new conduit will stop processing once either source or upstream have been exhausted. -mergeSource - :: Monad m - => Source m i - -> Conduit a m (i, a) -mergeSource = loop . newResumableSource - where - loop :: Monad m => ResumableSource m i -> Conduit a m (i, a) - loop src0 = await >>= maybe (lift $ closeResumableSource src0) go - where - go a = do - (src1, mi) <- lift $ src0 $$++ await - case mi of - Nothing -> lift $ closeResumableSource src1 - Just i -> yield (i, a) >> loop src1 - - --- | Turn a @Sink@ into a @Conduit@ in the following way: --- --- * All input passed to the @Sink@ is yielded downstream. --- --- * When the @Sink@ finishes processing, the result is passed to the provided to the finalizer function. --- --- Note that the @Sink@ will stop receiving input as soon as the downstream it --- is connected to shuts down. --- --- An example usage would be to write the result of a @Sink@ to some mutable --- variable while allowing other processing to continue. --- --- Since 1.1.0 -passthroughSink :: Monad m - => Sink i m r - -> (r -> m ()) -- ^ finalizer - -> Conduit i m i -passthroughSink (ConduitM sink0) final = ConduitM $ \rest -> let - -- A bit of explanation is in order, this function is - -- non-obvious. The purpose of go is to keep track of the sink - -- we're passing values to, and then yield values downstream. The - -- third argument to go is the current state of that sink. That's - -- relatively straightforward. - -- - -- The second value is the leftover buffer. These are values that - -- the sink itself has called leftover on, and must be provided - -- back to the sink the next time it awaits. _However_, these - -- values should _not_ be reyielded downstream: we have already - -- yielded them downstream ourself, and it is the responsibility - -- of the functions wrapping around passthroughSink to handle the - -- leftovers from downstream. - -- - -- The trickiest bit is the first argument, which is a solution to - -- bug https://github.com/snoyberg/conduit/issues/304. The issue - -- is that, once we get a value, we need to provide it to both the - -- inner sink _and_ yield it downstream. The obvious thing to do - -- is yield first and then recursively call go. Unfortunately, - -- this doesn't work in all cases: if the downstream component - -- never calls await again, our yield call will never return, and - -- our sink will not get the last value. This results is confusing - -- behavior where the sink and downstream component receive a - -- different number of values. - -- - -- Solution: keep a buffer of the next value to yield downstream, - -- and only yield it downstream in one of two cases: our sink is - -- asking for another value, or our sink is done. This way, we - -- ensure that, in all cases, we pass exactly the same number of - -- values to the inner sink as to downstream. - - go mbuf _ (Done r) = do - maybe (return ()) CI.yield mbuf - lift $ final r - unConduitM (awaitForever yield) rest - go mbuf is (Leftover sink i) = go mbuf (i:is) sink - go _ _ (HaveOutput _ _ o) = absurd o - go mbuf is (PipeM mx) = do - x <- lift mx - go mbuf is x - go mbuf (i:is) (NeedInput next _) = go mbuf is (next i) - go mbuf [] (NeedInput next done) = do - maybe (return ()) CI.yield mbuf - mx <- CI.await - case mx of - Nothing -> go Nothing [] (done ()) - Just x -> go (Just x) [] (next x) - in go Nothing [] (sink0 Done) - --- | Convert a @Source@ into a list. The basic functionality can be explained as: --- --- > sourceToList src = src $$ Data.Conduit.List.consume --- --- However, @sourceToList@ is able to produce its results lazily, which cannot --- be done when running a conduit pipeline in general. Unlike the --- @Data.Conduit.Lazy@ module (in conduit-extra), this function performs no --- unsafe I\/O operations, and therefore can only be as lazily as the --- underlying monad. --- --- Since 1.2.6 -sourceToList :: Monad m => Source m a -> m [a] -sourceToList = - go . flip unConduitM Done - where - go (Done _) = return [] - go (HaveOutput src _ x) = liftM (x:) (go src) - go (PipeM msrc) = msrc >>= go - go (NeedInput _ c) = go (c ()) - go (Leftover p _) = go p - --- Define fixity of all our operators -infixr 0 $$ -infixl 1 $= -infixr 2 =$ -infixr 2 =$= -infixr 0 $$+ -infixr 0 $$++ -infixr 0 $$+- -infixl 1 $=+ - --- | The connect operator, which pulls data from a source and pushes to a sink. --- If you would like to keep the @Source@ open to be used for other --- operations, use the connect-and-resume operator '$$+'. --- --- Since 0.4.0 -($$) :: Monad m => Source m a -> Sink a m b -> m b -src $$ sink = do - (rsrc, res) <- src $$+ sink - rsrc $$+- return () - return res -{-# INLINE [1] ($$) #-} - --- | A synonym for '=$=' for backwards compatibility. --- --- Since 0.4.0 -($=) :: Monad m => Conduit a m b -> ConduitM b c m r -> ConduitM a c m r -($=) = (=$=) -{-# INLINE [0] ($=) #-} -{-# RULES "conduit: $= is =$=" ($=) = (=$=) #-} - --- | A synonym for '=$=' for backwards compatibility. --- --- Since 0.4.0 -(=$) :: Monad m => Conduit a m b -> ConduitM b c m r -> ConduitM a c m r -(=$) = (=$=) -{-# INLINE [0] (=$) #-} -{-# RULES "conduit: =$ is =$=" (=$) = (=$=) #-} - --- | Fusion operator, combining two @Conduit@s together into a new @Conduit@. --- --- Both @Conduit@s will be closed when the newly-created @Conduit@ is closed. --- --- Leftover data returned from the right @Conduit@ will be discarded. --- --- Since 0.4.0 -(=$=) :: Monad m => Conduit a m b -> ConduitM b c m r -> ConduitM a c m r -ConduitM left0 =$= ConduitM right0 = ConduitM $ \rest -> - let goRight final left right = - case right of - HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o - NeedInput rp rc -> goLeft rp rc final left - Done r2 -> PipeM (final >> return (rest r2)) - PipeM mp -> PipeM (liftM recurse mp) - Leftover right' i -> goRight final (HaveOutput left final i) right' - where - recurse = goRight final left - - goLeft rp rc final left = - case left of - HaveOutput left' final' o -> goRight final' left' (rp o) - NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) - Done r1 -> goRight (return ()) (Done r1) (rc r1) - PipeM mp -> PipeM (liftM recurse mp) - Leftover left' i -> Leftover (recurse left') i - where - recurse = goLeft rp rc final - in goRight (return ()) (left0 Done) (right0 Done) - where -{-# INLINE [1] (=$=) #-} - --- | Wait for a single input value from upstream. If no data is available, --- returns @Nothing@. Once @await@ returns @Nothing@, subsequent calls will --- also return @Nothing@. --- --- Since 0.5.0 -await :: Monad m => Consumer i m (Maybe i) -await = ConduitM $ \f -> NeedInput (f . Just) (const $ f Nothing) -{-# INLINE [0] await #-} - -await' :: Monad m - => ConduitM i o m r - -> (i -> ConduitM i o m r) - -> ConduitM i o m r -await' f g = ConduitM $ \rest -> NeedInput - (\i -> unConduitM (g i) rest) - (const $ unConduitM f rest) -{-# INLINE await' #-} -{-# RULES "conduit: await >>= maybe" forall x y. await >>= maybe x y = await' x y #-} - --- | Send a value downstream to the next component to consume. If the --- downstream component terminates, this call will never return control. If you --- would like to register a cleanup function, please use 'yieldOr' instead. --- --- Since 0.5.0 -yield :: Monad m - => o -- ^ output value - -> ConduitM i o m () -yield o = yieldOr o (return ()) -{-# INLINE yield #-} - --- | Send a monadic value downstream for the next component to consume. --- --- @since 1.2.7 -yieldM :: Monad m => m o -> ConduitM i o m () -yieldM mo = lift mo >>= yield -{-# INLINE yieldM #-} - - -- FIXME rule won't fire, see FIXME in .Pipe; "mapM_ yield" mapM_ yield = ConduitM . sourceList - --- | Provide a single piece of leftover input to be consumed by the next --- component in the current monadic binding. --- --- /Note/: it is highly encouraged to only return leftover values from input --- already consumed from upstream. --- --- @since 0.5.0 -leftover :: i -> ConduitM i o m () -leftover i = ConduitM $ \rest -> Leftover (rest ()) i -{-# INLINE leftover #-} - --- | Run a pipeline until processing completes. --- --- Since 1.2.1 -runConduit :: Monad m => ConduitM () Void m r -> m r -runConduit (ConduitM p) = runPipe $ injectLeftovers $ p Done -{-# INLINE [0] runConduit #-} - --- | Bracket a conduit computation between allocation and release of a --- resource. Two guarantees are given about resource finalization: --- --- 1. It will be /prompt/. The finalization will be run as early as possible. --- --- 2. It is exception safe. Due to usage of @resourcet@, the finalization will --- be run in the event of any exceptions. --- --- Since 0.5.0 -bracketP :: MonadResource m - - => IO a - -- ^ computation to run first (\"acquire resource\") - -> (a -> IO ()) - -- ^ computation to run last (\"release resource\") - -> (a -> ConduitM i o m r) - -- ^ computation to run in-between - -> ConduitM i o m r - -- returns the value from the in-between computation -bracketP alloc free inside = ConduitM $ \rest -> PipeM $ do - (key, seed) <- allocate alloc free - return $ unConduitM (addCleanup (const $ release key) (inside seed)) rest - --- | Add some code to be run when the given component cleans up. --- --- The supplied cleanup function will be given a @True@ if the component ran to --- completion, or @False@ if it terminated early due to a downstream component --- terminating. --- --- Note that this function is not exception safe. For that, please use --- 'bracketP'. --- --- Since 0.4.1 -addCleanup :: Monad m - => (Bool -> m ()) - -> ConduitM i o m r - -> ConduitM i o m r -addCleanup cleanup (ConduitM c0) = ConduitM $ \rest -> let - go (Done r) = PipeM (cleanup True >> return (rest r)) - go (HaveOutput src close x) = HaveOutput - (go src) - (cleanup False >> close) - x - go (PipeM msrc) = PipeM (liftM (go) msrc) - go (NeedInput p c) = NeedInput - (go . p) - (go . c) - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - --- | Similar to 'yield', but additionally takes a finalizer to be run if the --- downstream component terminates. --- --- Since 0.5.0 -yieldOr :: Monad m - => o - -> m () -- ^ finalizer - -> ConduitM i o m () -yieldOr o m = ConduitM $ \rest -> HaveOutput (rest ()) m o -{-# INLINE yieldOr #-} - --- | Wait for input forever, calling the given inner component for each piece of --- new input. --- --- This function is provided as a convenience for the common pattern of --- @await@ing input, checking if it's @Just@ and then looping. --- --- Since 0.5.0 -awaitForever :: Monad m => (i -> ConduitM i o m r) -> ConduitM i o m () -awaitForever f = ConduitM $ \rest -> - let go = NeedInput (\i -> unConduitM (f i) (const go)) rest - in go - --- | Transform the monad that a @ConduitM@ lives in. --- --- Note that the monad transforming function will be run multiple times, --- resulting in unintuitive behavior in some cases. For a fuller treatment, --- please see: --- --- --- --- This function is just a synonym for 'hoist'. --- --- Since 0.4.0 -transPipe :: Monad m => (forall a. m a -> n a) -> ConduitM i o m r -> ConduitM i o n r -transPipe = hoist - --- | Apply a function to all the output values of a @ConduitM@. --- --- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 --- days. It can also be simulated by fusing with the @map@ conduit from --- "Data.Conduit.List". --- --- Since 0.4.1 -mapOutput :: Monad m => (o1 -> o2) -> ConduitM i o1 m r -> ConduitM i o2 m r -mapOutput f (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput p c o) = HaveOutput (go p) c (f o) - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = rest r - go (PipeM mp) = PipeM (liftM (go) mp) - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - --- | Same as 'mapOutput', but use a function that returns @Maybe@ values. --- --- Since 0.5.0 -mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> ConduitM i o1 m r -> ConduitM i o2 m r -mapOutputMaybe f (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput p c o) = maybe id (\o' p' -> HaveOutput p' c o') (f o) (go p) - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = rest r - go (PipeM mp) = PipeM (liftM (go) mp) - go (Leftover p i) = Leftover (go p) i - in go (c0 Done) - --- | Apply a function to all the input values of a @ConduitM@. --- --- Since 0.5.0 -mapInput :: Monad m - => (i1 -> i2) -- ^ map initial input to new input - -> (i2 -> Maybe i1) -- ^ map new leftovers to initial leftovers - -> ConduitM i2 o m r - -> ConduitM i1 o m r -mapInput f f' (ConduitM c0) = ConduitM $ \rest -> let - go (HaveOutput p c o) = HaveOutput (go p) c o - go (NeedInput p c) = NeedInput (go . p . f) (go . c) - go (Done r) = rest r - go (PipeM mp) = PipeM $ liftM go mp - go (Leftover p i) = maybe id (flip Leftover) (f' i) (go p) - in go (c0 Done) - --- | The connect-and-resume operator. This does not close the @Source@, but --- instead returns it to be used again. This allows a @Source@ to be used --- incrementally in a large program, without forcing the entire program to live --- in the @Sink@ monad. --- --- Mnemonic: connect + do more. --- --- Since 0.5.0 -($$+) :: Monad m => Source m a -> Sink a m b -> m (ResumableSource m a, b) -ConduitM src $$+ sink = - connectResume (ResumableSource (src Done) (return ())) sink -{-# INLINE ($$+) #-} - --- | Continue processing after usage of @$$+@. --- --- Since 0.5.0 -($$++) :: Monad m => ResumableSource m a -> Sink a m b -> m (ResumableSource m a, b) -($$++) = connectResume -{-# INLINE ($$++) #-} - --- | Complete processing of a @ResumableSource@. This will run the finalizer --- associated with the @ResumableSource@. In order to guarantee process resource --- finalization, you /must/ use this operator after using @$$+@ and @$$++@. --- --- Since 0.5.0 -($$+-) :: Monad m => ResumableSource m a -> Sink a m b -> m b -rsrc $$+- sink = do - (ResumableSource _ final, res) <- connectResume rsrc sink - final - return res -{-# INLINE ($$+-) #-} - --- | Left fusion for a resumable source. --- --- Since 1.0.16 -($=+) :: Monad m => ResumableSource m a -> Conduit a m b -> ResumableSource m b -ResumableSource src final $=+ ConduitM sink = - ResumableSource (src `pipeL` sink Done) final - --- | Execute the finalizer associated with a @ResumableSource@, rendering the --- @ResumableSource@ invalid for further use. --- --- This is just a more explicit version of @$$+- return ()@. --- --- Since 1.1.3 -closeResumableSource :: Monad m => ResumableSource m a -> m () -closeResumableSource = ($$+- return ()) - --- | Provide for a stream of data that can be flushed. --- --- A number of @Conduit@s (e.g., zlib compression) need the ability to flush --- the stream at some point. This provides a single wrapper datatype to be used --- in all such circumstances. --- --- Since 0.3.0 -data Flush a = Chunk a | Flush - deriving (Show, Eq, Ord) -instance Functor Flush where - fmap _ Flush = Flush - fmap f (Chunk a) = Chunk (f a) - --- | A wrapper for defining an 'Applicative' instance for 'Source's which allows --- to combine sources together, generalizing 'zipSources'. A combined source --- will take input yielded from each of its @Source@s until any of them stop --- producing output. --- --- Since 1.0.13 -newtype ZipSource m o = ZipSource { getZipSource :: Source m o } - -instance Monad m => Functor (ZipSource m) where - fmap f = ZipSource . mapOutput f . getZipSource -instance Monad m => Applicative (ZipSource m) where - pure = ZipSource . forever . yield - (ZipSource f) <*> (ZipSource x) = ZipSource $ zipSourcesApp f x - --- | Coalesce all values yielded by all of the @Source@s. --- --- Implemented on top of @ZipSource@ and as such, it exhibits the same --- short-circuiting behavior as @ZipSource@. See that data type for more --- details. If you want to create a source that yields *all* values from --- multiple sources, use `sequence_`. --- --- Since 1.0.13 -sequenceSources :: (Traversable f, Monad m) => f (Source m o) -> Source m (f o) -sequenceSources = getZipSource . sequenceA . fmap ZipSource - --- | A wrapper for defining an 'Applicative' instance for 'Sink's which allows --- to combine sinks together, generalizing 'zipSinks'. A combined sink --- distributes the input to all its participants and when all finish, produces --- the result. This allows to define functions like --- --- @ --- sequenceSinks :: (Monad m) --- => [Sink i m r] -> Sink i m [r] --- sequenceSinks = getZipSink . sequenceA . fmap ZipSink --- @ --- --- Note that the standard 'Applicative' instance for conduits works --- differently. It feeds one sink with input until it finishes, then switches --- to another, etc., and at the end combines their results. --- --- This newtype is in fact a type constrained version of 'ZipConduit', and has --- the same behavior. It's presented as a separate type since (1) it --- historically predates @ZipConduit@, and (2) the type constraining can make --- your code clearer (and thereby make your error messages more easily --- understood). --- --- Since 1.0.13 -newtype ZipSink i m r = ZipSink { getZipSink :: Sink i m r } - -instance Monad m => Functor (ZipSink i m) where - fmap f (ZipSink x) = ZipSink (liftM f x) -instance Monad m => Applicative (ZipSink i m) where - pure = ZipSink . return - (ZipSink f) <*> (ZipSink x) = - ZipSink $ liftM (uncurry ($)) $ zipSinks f x - --- | 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. --- --- Since 1.0.13 -sequenceSinks :: (Traversable f, Monad m) => f (Sink i m r) -> Sink i m (f r) -sequenceSinks = getZipSink . sequenceA . fmap ZipSink - --- | The connect-and-resume operator. This does not close the @Conduit@, but --- instead returns it to be used again. This allows a @Conduit@ to be used --- incrementally in a large program, without forcing the entire program to live --- in the @Sink@ monad. --- --- Leftover data returned from the @Sink@ will be discarded. --- --- Mnemonic: connect + do more. --- --- Since 1.0.17 -(=$$+) :: Monad m => Conduit a m b -> Sink b m r -> Sink a m (ResumableConduit a m b, r) -(=$$+) (ConduitM conduit) = connectResumeConduit (ResumableConduit (conduit Done) (return ())) -{-# INLINE (=$$+) #-} - --- | Continue processing after usage of '=$$+'. Connect a 'ResumableConduit' to --- a sink and return the output of the sink together with a new --- 'ResumableConduit'. --- --- Since 1.0.17 -(=$$++) :: Monad m => ResumableConduit i m o -> Sink o m r -> Sink i m (ResumableConduit i m o, r) -(=$$++) = connectResumeConduit -{-# INLINE (=$$++) #-} - --- | Complete processing of a 'ResumableConduit'. This will run the finalizer --- associated with the @ResumableConduit@. In order to guarantee process --- resource finalization, you /must/ use this operator after using '=$$+' and --- '=$$++'. --- --- Since 1.0.17 -(=$$+-) :: Monad m => ResumableConduit i m o -> Sink o m r -> Sink i m r -rsrc =$$+- sink = do - (ResumableConduit _ final, res) <- connectResumeConduit rsrc sink - lift final - return res -{-# INLINE (=$$+-) #-} - - -infixr 0 =$$+ -infixr 0 =$$++ -infixr 0 =$$+- - --- | Provides an alternative @Applicative@ instance for @ConduitM@. In this instance, --- every incoming value is provided to all @ConduitM@s, and output is coalesced together. --- Leftovers from individual @ConduitM@s will be used within that component, and then discarded --- at the end of their computation. Output and finalizers will both be handled in a left-biased manner. --- --- As an example, take the following program: --- --- @ --- main :: IO () --- main = do --- let src = mapM_ yield [1..3 :: Int] --- conduit1 = CL.map (+1) --- conduit2 = CL.concatMap (replicate 2) --- conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 --- sink = CL.mapM_ print --- src $$ conduit =$ sink --- @ --- --- It will produce the output: 2, 1, 1, 3, 2, 2, 4, 3, 3 --- --- Since 1.0.17 -newtype ZipConduit i o m r = ZipConduit { getZipConduit :: ConduitM i o m r } - deriving Functor -instance Monad m => Applicative (ZipConduit i o m) where - pure = ZipConduit . pure - ZipConduit left <*> ZipConduit right = ZipConduit (zipConduitApp left right) - --- | Provide identical input to all of the @Conduit@s and combine their outputs --- into a single stream. --- --- Implemented on top of @ZipConduit@, see that data type for more details. --- --- Since 1.0.17 -sequenceConduits :: (Traversable f, Monad m) => f (ConduitM i o m r) -> ConduitM i o m (f r) -sequenceConduits = getZipConduit . sequenceA . fmap ZipConduit - --- | Fuse two @ConduitM@s together, and provide the return value of both. Note --- that this will force the entire upstream @ConduitM@ to be run to produce the --- result value, even if the downstream terminates early. --- --- Since 1.1.5 -fuseBoth :: Monad m => ConduitM a b m r1 -> ConduitM b c m r2 -> ConduitM a c m (r1, r2) -fuseBoth (ConduitM up) (ConduitM down) = - ConduitM (pipeL (up Done) (withUpstream $ generalizeUpstream $ down Done) >>=) -{-# INLINE fuseBoth #-} - --- | Like 'fuseBoth', but does not force consumption of the @Producer@. --- In the case that the @Producer@ terminates, the result value is --- provided as a @Just@ value. If it does not terminate, then a --- @Nothing@ value is returned. --- --- One thing to note here is that "termination" here only occurs if the --- @Producer@ actually yields a @Nothing@ value. For example, with the --- @Producer@ @mapM_ yield [1..5]@, if five values are requested, the --- @Producer@ has not yet terminated. Termination only occurs when the --- sixth value is awaited for and the @Producer@ signals termination. --- --- Since 1.2.4 -fuseBothMaybe - :: Monad m - => ConduitM a b m r1 - -> ConduitM b c m r2 - -> ConduitM a c m (Maybe r1, r2) -fuseBothMaybe (ConduitM up) (ConduitM down) = - ConduitM (pipeL (up Done) (go Nothing $ down Done) >>=) - where - go mup (Done r) = Done (mup, r) - go mup (PipeM mp) = PipeM $ liftM (go mup) mp - go mup (HaveOutput p c o) = HaveOutput (go mup p) c o - go _ (NeedInput p c) = NeedInput - (\i -> go Nothing (p i)) - (\u -> go (Just u) (c ())) - go mup (Leftover p i) = Leftover (go mup p) i -{-# INLINABLE fuseBothMaybe #-} - --- | Same as @fuseBoth@, but ignore the return value from the downstream --- @Conduit@. Same caveats of forced consumption apply. --- --- Since 1.1.5 -fuseUpstream :: Monad m => ConduitM a b m r -> Conduit b m c -> ConduitM a c m r -fuseUpstream up down = fmap fst (fuseBoth up down) -{-# INLINE fuseUpstream #-} - --- Rewrite rules - -{- FIXME -{-# RULES "conduit: ConduitM: lift x >>= f" forall m f. lift m >>= f = ConduitM (PipeM (liftM (unConduitM . f) m)) #-} -{-# RULES "conduit: ConduitM: lift x >> f" forall m f. lift m >> f = ConduitM (PipeM (liftM (\_ -> unConduitM f) m)) #-} - -{-# RULES "conduit: ConduitM: liftIO x >>= f" forall m (f :: MonadIO m => a -> ConduitM i o m r). liftIO m >>= f = ConduitM (PipeM (liftM (unConduitM . f) (liftIO m))) #-} -{-# RULES "conduit: ConduitM: liftIO x >> f" forall m (f :: MonadIO m => ConduitM i o m r). liftIO m >> f = ConduitM (PipeM (liftM (\_ -> unConduitM f) (liftIO m))) #-} - -{-# RULES "conduit: ConduitM: liftBase x >>= f" forall m (f :: MonadBase b m => a -> ConduitM i o m r). liftBase m >>= f = ConduitM (PipeM (liftM (unConduitM . f) (liftBase m))) #-} -{-# RULES "conduit: ConduitM: liftBase x >> f" forall m (f :: MonadBase b m => ConduitM i o m r). liftBase m >> f = ConduitM (PipeM (liftM (\_ -> unConduitM f) (liftBase m))) #-} - -{-# RULES - "yield o >> p" forall o (p :: ConduitM i o m r). yield o >> p = ConduitM (HaveOutput (unConduitM p) (return ()) o) - ; "yieldOr o c >> p" forall o c (p :: ConduitM i o m r). yieldOr o c >> p = - ConduitM (HaveOutput (unConduitM p) c o) - ; "when yield next" forall b o p. when b (yield o) >> p = - if b then ConduitM (HaveOutput (unConduitM p) (return ()) o) else p - ; "unless yield next" forall b o p. unless b (yield o) >> p = - if b then p else ConduitM (HaveOutput (unConduitM p) (return ()) o) - ; "lift m >>= yield" forall m. lift m >>= yield = yieldM m - #-} -{-# RULES "conduit: leftover l >> p" forall l (p :: ConduitM i o m r). leftover l >> p = - ConduitM (Leftover (unConduitM p) l) #-} - -} diff --git a/Data/Conduit/Internal/Fusion.hs b/Data/Conduit/Internal/Fusion.hs deleted file mode 100644 --- a/Data/Conduit/Internal/Fusion.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE Trustworthy #-} -module Data.Conduit.Internal.Fusion - ( -- ** Types - Step (..) - , Stream (..) - , ConduitWithStream - , StreamConduitM - , StreamConduit - , StreamSource - , StreamProducer - , StreamSink - , StreamConsumer - -- ** Functions - , streamConduit - , streamSource - , streamSourcePure - , unstream - ) where - -import Data.Conduit.Internal.Conduit -import Data.Conduit.Internal.Pipe (Pipe (..)) -import Data.Functor.Identity (Identity (runIdentity)) -import Data.Void (Void, absurd) - --- | This is the same as stream fusion\'s Step. Constructors are renamed to --- avoid confusion with conduit names. -data Step s o r - = Emit s o - | Skip s - | Stop r - deriving Functor - -data Stream m o r = forall s. Stream - (s -> m (Step s o r)) - (m s) - -data ConduitWithStream i o m r = ConduitWithStream - (ConduitM i o m r) - (StreamConduitM i o m r) - -type StreamConduitM i o m r = Stream m i () -> Stream m o r - -type StreamConduit i m o = StreamConduitM i o m () - -type StreamSource m o = StreamConduitM () o m () - -type StreamProducer m o = forall i. StreamConduitM i o m () - -type StreamSink i m r = StreamConduitM i Void m r - -type StreamConsumer i m r = forall o. StreamConduitM i o m r - -unstream :: ConduitWithStream i o m r -> ConduitM i o m r -unstream (ConduitWithStream c _) = c -{-# INLINE [0] unstream #-} - -fuseStream :: Monad m - => ConduitWithStream a b m () - -> ConduitWithStream b c m r - -> ConduitWithStream a c m r -fuseStream (ConduitWithStream a x) (ConduitWithStream b y) = ConduitWithStream (a =$= b) (y . x) -{-# INLINE fuseStream #-} - -{-# RULES "conduit: fuseStream" forall left right. - unstream left =$= unstream right = unstream (fuseStream left right) - #-} - -runStream :: Monad m - => ConduitWithStream () Void m r - -> m r -runStream (ConduitWithStream _ f) = - run $ f $ Stream emptyStep (return ()) - where - emptyStep _ = return $ Stop () - run (Stream step ms0) = - ms0 >>= loop - where - loop s = do - res <- step s - case res of - Stop r -> return r - Skip s' -> loop s' - Emit _ o -> absurd o -{-# INLINE runStream #-} - -{-# RULES "conduit: runStream" forall stream. - runConduit (unstream stream) = runStream stream - #-} - -connectStream :: Monad m - => ConduitWithStream () i m () - -> ConduitWithStream i Void m r - -> m r -connectStream (ConduitWithStream _ stream) (ConduitWithStream _ f) = - run $ f $ stream $ Stream emptyStep (return ()) - where - emptyStep _ = return $ Stop () - run (Stream step ms0) = - ms0 >>= loop - where - loop s = do - res <- step s - case res of - Stop r -> return r - Skip s' -> loop s' - Emit _ o -> absurd o -{-# INLINE connectStream #-} - -{-# RULES "conduit: connectStream" forall left right. - unstream left $$ unstream right = connectStream left right - #-} - -connectStream1 :: Monad m - => ConduitWithStream () i m () - -> ConduitM i Void m r - -> m r -connectStream1 (ConduitWithStream _ fstream) (ConduitM sink0) = - case fstream $ Stream (const $ return $ Stop ()) (return ()) of - Stream step ms0 -> - let loop _ (Done r) _ = return r - loop ls (PipeM mp) s = mp >>= flip (loop ls) s - loop ls (Leftover p l) s = loop (l:ls) p s - loop _ (HaveOutput _ _ o) _ = absurd o - loop (l:ls) (NeedInput p _) s = loop ls (p l) s - loop [] (NeedInput p c) s = do - res <- step s - case res of - Stop () -> loop [] (c ()) s - Skip s' -> loop [] (NeedInput p c) s' - Emit s' i -> loop [] (p i) s' - in ms0 >>= loop [] (sink0 Done) -{-# INLINE connectStream1 #-} - -{-# RULES "conduit: connectStream1" forall left right. - unstream left $$ right = connectStream1 left right - #-} - -{- - -Not only will this rule not fire reliably, but due to finalizers, it can change -behavior unless implemented very carefully. Odds are that the careful -implementation won't be any faster, so leaving this commented out for now. - -connectStream2 :: Monad m - => ConduitM () i m () - -> ConduitWithStream i Void m r - -> m r -connectStream2 (ConduitM src0) (ConduitWithStream _ fstream) = - run $ fstream $ Stream step' $ return (return (), src0 Done) - where - step' (_, Done ()) = return $ Stop () - {-# INLINE step' #-} - - run (Stream step ms0) = - ms0 >>= loop - where - loop s = do - res <- step s - case res of - Stop r -> return r - Emit _ o -> absurd o - Skip s' -> loop s' -{-# INLINE connectStream2 #-} - -{-# RULES "conduit: connectStream2" forall left right. - left $$ unstream right = connectStream2 left right - #-} --} - -streamConduit :: ConduitM i o m r - -> (Stream m i () -> Stream m o r) - -> ConduitWithStream i o m r -streamConduit = ConduitWithStream -{-# INLINE CONLIKE streamConduit #-} - -streamSource - :: Monad m - => Stream m o () - -> ConduitWithStream i o m () -streamSource str@(Stream step ms0) = - ConduitWithStream con (const str) - where - con = ConduitM $ \rest -> PipeM $ do - s0 <- ms0 - let loop s = do - res <- step s - case res of - Stop () -> return $ rest () - Emit s' o -> return $ HaveOutput (PipeM $ loop s') (return ()) o - Skip s' -> loop s' - loop s0 -{-# INLINE streamSource #-} - -streamSourcePure - :: Monad m - => Stream Identity o () - -> ConduitWithStream i o m () -streamSourcePure (Stream step ms0) = - ConduitWithStream con (const $ Stream (return . runIdentity . step) (return s0)) - where - s0 = runIdentity ms0 - con = ConduitM $ \rest -> - let loop s = - case runIdentity $ step s of - Stop () -> rest () - Emit s' o -> HaveOutput (loop s') (return ()) o - Skip s' -> loop s' - in loop s0 -{-# INLINE streamSourcePure #-} diff --git a/Data/Conduit/Internal/List/Stream.hs b/Data/Conduit/Internal/List/Stream.hs deleted file mode 100644 --- a/Data/Conduit/Internal/List/Stream.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -module Data.Conduit.Internal.List.Stream where - -import Control.Monad (liftM) -import Data.Conduit.Internal.Fusion -import qualified Data.Foldable as F - ---FIXME: Should streamSource / streamSourcePure be used for sources? - -unfoldS :: Monad m - => (b -> Maybe (a, b)) - -> b - -> StreamProducer m a -unfoldS f s0 _ = - Stream step (return s0) - where - step s = return $ - case f s of - Nothing -> Stop () - Just (x, s') -> Emit s' x -{-# INLINE unfoldS #-} - -unfoldEitherS :: Monad m - => (b -> Either r (a, b)) - -> b - -> StreamConduitM i a m r -unfoldEitherS f s0 _ = - Stream step (return s0) - where - step s = return $ - case f s of - Left r -> Stop r - Right (x, s') -> Emit s' x -{-# INLINE unfoldEitherS #-} - -unfoldMS :: Monad m - => (b -> m (Maybe (a, b))) - -> b - -> StreamProducer m a -unfoldMS f s0 _ = - Stream step (return s0) - where - step s = do - ms' <- f s - return $ case ms' of - Nothing -> Stop () - Just (x, s') -> Emit s' x -{-# INLINE unfoldMS #-} - -unfoldEitherMS :: Monad m - => (b -> m (Either r (a, b))) - -> b - -> StreamConduitM i a m r -unfoldEitherMS f s0 _ = - Stream step (return s0) - where - step s = do - ms' <- f s - return $ case ms' of - Left r -> Stop r - Right (x, s') -> Emit s' x -{-# INLINE unfoldEitherMS #-} -sourceListS :: Monad m => [a] -> StreamProducer m a -sourceListS xs0 _ = - Stream (return . step) (return xs0) - where - step [] = Stop () - step (x:xs) = Emit xs x -{-# INLINE sourceListS #-} - -enumFromToS :: (Enum a, Prelude.Ord a, Monad m) - => a - -> a - -> StreamProducer m a -enumFromToS x0 y _ = - Stream step (return x0) - where - step x = return $ if x Prelude.> y - then Stop () - else Emit (Prelude.succ x) x -{-# INLINE [0] enumFromToS #-} - -enumFromToS_int :: (Prelude.Integral a, Monad m) - => a - -> a - -> StreamProducer m a -enumFromToS_int x0 y _ = x0 `seq` y `seq` Stream step (return x0) - where - step x | x <= y = return $ Emit (x Prelude.+ 1) x - | otherwise = return $ Stop () -{-# INLINE enumFromToS_int #-} - -{-# RULES "conduit: enumFromTo" forall f t. - enumFromToS f t = enumFromToS_int f t :: Monad m => StreamProducer m Int - #-} - -iterateS :: Monad m => (a -> a) -> a -> StreamProducer m a -iterateS f x0 _ = - Stream (return . step) (return x0) - where - step x = Emit x' x - where - x' = f x -{-# INLINE iterateS #-} - -replicateS :: Monad m => Int -> a -> StreamProducer m a -replicateS cnt0 a _ = - Stream step (return cnt0) - where - step cnt - | cnt <= 0 = return $ Stop () - | otherwise = return $ Emit (cnt - 1) a -{-# INLINE replicateS #-} - -replicateMS :: Monad m => Int -> m a -> StreamProducer m a -replicateMS cnt0 ma _ = - Stream step (return cnt0) - where - step cnt - | cnt <= 0 = return $ Stop () - | otherwise = Emit (cnt - 1) `liftM` ma -{-# INLINE replicateMS #-} - -foldS :: Monad m => (b -> a -> b) -> b -> StreamConsumer a m b -foldS f b0 (Stream step ms0) = - Stream step' (liftM (b0, ) ms0) - where - step' (!b, s) = do - res <- step s - return $ case res of - Stop () -> Stop b - Skip s' -> Skip (b, s') - Emit s' a -> Skip (f b a, s') -{-# INLINE foldS #-} - -foldMS :: Monad m => (b -> a -> m b) -> b -> StreamConsumer a m b -foldMS f b0 (Stream step ms0) = - Stream step' (liftM (b0, ) ms0) - where - step' (!b, s) = do - res <- step s - case res of - Stop () -> return $ Stop b - Skip s' -> return $ Skip (b, s') - Emit s' a -> do - b' <- f b a - return $ Skip (b', s') -{-# INLINE foldMS #-} - -mapM_S :: Monad m - => (a -> m ()) - -> StreamConsumer a m () -mapM_S f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip s' - Emit s' x -> f x >> return (Skip s') -{-# INLINE [1] mapM_S #-} - -dropS :: Monad m - => Int - -> StreamConsumer a m () -dropS n0 (Stream step ms0) = - Stream step' (liftM (, n0) ms0) - where - step' (_, n) | n <= 0 = return $ Stop () - step' (s, n) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip (s', n) - Emit s' _ -> Skip (s', n - 1) -{-# INLINE dropS #-} - -takeS :: Monad m - => Int - -> StreamConsumer a m [a] -takeS n0 (Stream step s0) = - Stream step' (liftM (id, n0,) s0) - where - step' (output, n, _) | n <= 0 = return $ Stop (output []) - step' (output, n, s) = do - res <- step s - return $ case res of - Stop () -> Stop (output []) - Skip s' -> Skip (output, n, s') - Emit s' x -> Skip (output . (x:), n - 1, s') -{-# INLINE takeS #-} - -headS :: Monad m => StreamConsumer a m (Maybe a) -headS (Stream step s0) = - Stream step' s0 - where - step' s = do - res <- step s - return $ case res of - Stop () -> Stop Nothing - Skip s' -> Skip s' - Emit _ x -> Stop (Just x) -{-# INLINE headS #-} - -mapS :: Monad m => (a -> b) -> StreamConduit a m b -mapS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - return $ case res of - Stop r -> Stop r - Emit s' a -> Emit s' (f a) - Skip s' -> Skip s' -{-# INLINE mapS #-} - -mapMS :: Monad m => (a -> m b) -> StreamConduit a m b -mapMS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - case res of - Stop r -> return $ Stop r - Emit s' a -> Emit s' `liftM` f a - Skip s' -> return $ Skip s' -{-# INLINE mapMS #-} - -iterMS :: Monad m => (a -> m ()) -> StreamConduit a m a -iterMS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip s' - Emit s' x -> f x >> return (Emit s' x) -{-# INLINE iterMS #-} - -mapMaybeS :: Monad m => (a -> Maybe b) -> StreamConduit a m b -mapMaybeS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip s' - Emit s' x -> - case f x of - Just y -> Emit s' y - Nothing -> Skip s' -{-# INLINE mapMaybeS #-} - -mapMaybeMS :: Monad m => (a -> m (Maybe b)) -> StreamConduit a m b -mapMaybeMS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip s' - Emit s' x -> do - my <- f x - case my of - Just y -> return $ Emit s' y - Nothing -> return $ Skip s' -{-# INLINE mapMaybeMS #-} - -catMaybesS :: Monad m => StreamConduit (Maybe a) m a -catMaybesS (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip s' - Emit s' Nothing -> Skip s' - Emit s' (Just x) -> Emit s' x -{-# INLINE catMaybesS #-} - -concatS :: (Monad m, F.Foldable f) => StreamConduit (f a) m a -concatS (Stream step ms0) = - Stream step' (liftM ([], ) ms0) - where - step' ([], s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip ([], s') - Emit s' x -> Skip (F.toList x, s') - step' ((x:xs), s) = return (Emit (xs, s) x) -{-# INLINE concatS #-} - -concatMapS :: Monad m => (a -> [b]) -> StreamConduit a m b -concatMapS f (Stream step ms0) = - Stream step' (liftM ([], ) ms0) - where - step' ([], s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip ([], s') - Emit s' x -> Skip (f x, s') - step' ((x:xs), s) = return (Emit (xs, s) x) -{-# INLINE concatMapS #-} - -concatMapMS :: Monad m => (a -> m [b]) -> StreamConduit a m b -concatMapMS f (Stream step ms0) = - Stream step' (liftM ([], ) ms0) - where - step' ([], s) = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip ([], s') - Emit s' x -> do - xs <- f x - return $ Skip (xs, s') - step' ((x:xs), s) = return (Emit (xs, s) x) -{-# INLINE concatMapMS #-} - -concatMapAccumS :: Monad m => (a -> accum -> (accum, [b])) -> accum -> StreamConduit a m b -concatMapAccumS f initial (Stream step ms0) = - Stream step' (liftM (initial, [], ) ms0) - where - step' (accum, [], s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip (accum, [], s') - Emit s' x -> - let (accum', xs) = f x accum - in Skip (accum', xs, s') - step' (accum, (x:xs), s) = return (Emit (accum, xs, s) x) -{-# INLINE concatMapAccumS #-} - -mapAccumS :: Monad m => (a -> s -> (s, b)) -> s -> StreamConduitM a b m s -mapAccumS f initial (Stream step ms0) = - Stream step' (liftM (initial, ) ms0) - where - step' (accum, s) = do - res <- step s - return $ case res of - Stop () -> Stop accum - Skip s' -> Skip (accum, s') - Emit s' x -> - let (accum', r) = f x accum - in Emit (accum', s') r -{-# INLINE mapAccumS #-} - -mapAccumMS :: Monad m => (a -> s -> m (s, b)) -> s -> StreamConduitM a b m s -mapAccumMS f initial (Stream step ms0) = - Stream step' (liftM (initial, ) ms0) - where - step' (accum, s) = do - res <- step s - case res of - Stop () -> return $ Stop accum - Skip s' -> return $ Skip (accum, s') - Emit s' x -> do - (accum', r) <- f x accum - return $ Emit (accum', s') r -{-# INLINE mapAccumMS #-} - -concatMapAccumMS :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> StreamConduit a m b -concatMapAccumMS f initial (Stream step ms0) = - Stream step' (liftM (initial, [], ) ms0) - where - step' (accum, [], s) = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip (accum, [], s') - Emit s' x -> do - (accum', xs) <- f x accum - return $ Skip (accum', xs, s') - step' (accum, (x:xs), s) = return (Emit (accum, xs, s) x) -{-# INLINE concatMapAccumMS #-} - -mapFoldableS :: (Monad m, F.Foldable f) => (a -> f b) -> StreamConduit a m b -mapFoldableS f (Stream step ms0) = - Stream step' (liftM ([], ) ms0) - where - step' ([], s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip ([], s') - Emit s' x -> Skip (F.toList (f x), s') - step' ((x:xs), s) = return (Emit (xs, s) x) -{-# INLINE mapFoldableS #-} - -mapFoldableMS :: (Monad m, F.Foldable f) => (a -> m (f b)) -> StreamConduit a m b -mapFoldableMS f (Stream step ms0) = - Stream step' (liftM ([], ) ms0) - where - step' ([], s) = do - res <- step s - case res of - Stop () -> return $ Stop () - Skip s' -> return $ Skip ([], s') - Emit s' x -> do - y <- f x - return $ Skip (F.toList y, s') - step' ((x:xs), s) = return (Emit (xs, s) x) -{-# INLINE mapFoldableMS #-} - -consumeS :: Monad m => StreamConsumer a m [a] -consumeS (Stream step ms0) = - Stream step' (liftM (id,) ms0) - where - step' (front, s) = do - res <- step s - return $ case res of - Stop () -> Stop (front []) - Skip s' -> Skip (front, s') - Emit s' a -> Skip (front . (a:), s') -{-# INLINE consumeS #-} - -groupByS :: Monad m => (a -> a -> Bool) -> StreamConduit a m [a] -groupByS f = mapS (Prelude.uncurry (:)) . groupBy1S id f -{-# INLINE groupByS #-} - -groupOn1S :: (Monad m, Eq b) => (a -> b) -> StreamConduit a m (a, [a]) -groupOn1S f = groupBy1S f (==) -{-# INLINE groupOn1S #-} - -data GroupByState a b s - = GBStart s - | GBLoop ([a] -> [a]) a b s - | GBDone - -groupBy1S :: Monad m => (a -> b) -> (b -> b -> Bool) -> StreamConduit a m (a, [a]) -groupBy1S f eq (Stream step ms0) = - Stream step' (liftM GBStart ms0) - where - step' (GBStart s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip (GBStart s') - Emit s' x0 -> Skip (GBLoop id x0 (f x0) s') - step' (GBLoop rest x0 fx0 s) = do - res <- step s - return $ case res of - Stop () -> Emit GBDone (x0, rest []) - Skip s' -> Skip (GBLoop rest x0 fx0 s') - Emit s' x - | fx0 `eq` f x -> Skip (GBLoop (rest . (x:)) x0 fx0 s') - | otherwise -> Emit (GBLoop id x (f x) s') (x0, rest []) - step' GBDone = return $ Stop () -{-# INLINE groupBy1S #-} - -isolateS :: Monad m => Int -> StreamConduit a m a -isolateS count (Stream step ms0) = - Stream step' (liftM (count,) ms0) - where - step' (n, _) | n <= 0 = return $ Stop () - step' (n, s) = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip (n, s') - Emit s' x -> Emit (n - 1, s') x -{-# INLINE isolateS #-} - -filterS :: Monad m => (a -> Bool) -> StreamConduit a m a -filterS f (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip s' - Emit s' x - | f x -> Emit s' x - | otherwise -> Skip s' - -sinkNullS :: Monad m => StreamConsumer a m () -sinkNullS (Stream step ms0) = - Stream step' ms0 - where - step' s = do - res <- step s - return $ case res of - Stop () -> Stop () - Skip s' -> Skip s' - Emit s' _ -> Skip s' -{-# INLINE sinkNullS #-} - -sourceNullS :: Monad m => StreamProducer m a -sourceNullS _ = Stream (\_ -> return (Stop ())) (return ()) -{-# INLINE sourceNullS #-} diff --git a/Data/Conduit/Internal/Pipe.hs b/Data/Conduit/Internal/Pipe.hs deleted file mode 100644 --- a/Data/Conduit/Internal/Pipe.hs +++ /dev/null @@ -1,648 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Conduit.Internal.Pipe - ( -- ** Types - Pipe (..) - -- ** Primitives - , await - , awaitE - , awaitForever - , yield - , yieldM - , yieldOr - , leftover - -- ** Finalization - , bracketP - , addCleanup - -- ** Composition - , idP - , pipe - , pipeL - , runPipe - , injectLeftovers - , (>+>) - , (<+<) - -- ** Exceptions - , catchP - , handleP - , tryP - -- ** Utilities - , transPipe - , mapOutput - , mapOutputMaybe - , mapInput - , sourceList - , withUpstream - , Data.Conduit.Internal.Pipe.enumFromTo - , generalizeUpstream - ) where - -import Control.Applicative (Applicative (..)) -import Control.Exception.Lifted as E (Exception, catch) -import Control.Monad ((>=>), liftM, ap) -import Control.Monad.Error.Class(MonadError(..)) -import Control.Monad.Reader.Class(MonadReader(..)) -import Control.Monad.RWS.Class(MonadRWS()) -import Control.Monad.Writer.Class(MonadWriter(..)) -import Control.Monad.State.Class(MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans (lift)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Base (MonadBase (liftBase)) -import Control.Monad.Primitive (PrimMonad, PrimState, primitive) -import Data.Void (Void, absurd) -import Data.Monoid (Monoid (mappend, mempty)) -import Data.Semigroup (Semigroup ((<>))) -import Control.Monad.Trans.Resource -import qualified GHC.Exts -import Control.Monad.Morph (MFunctor (..)) -import qualified Control.Monad.Catch as Catch - --- | The underlying datatype for all the types in this package. In has six --- type parameters: --- --- * /l/ is the type of values that may be left over from this @Pipe@. A @Pipe@ --- with no leftovers would use @Void@ here, and one with leftovers would use --- the same type as the /i/ parameter. Leftovers are automatically provided to --- the next @Pipe@ in the monadic chain. --- --- * /i/ is the type of values for this @Pipe@'s input stream. --- --- * /o/ is the type of values for this @Pipe@'s output stream. --- --- * /u/ is the result type from the upstream @Pipe@. --- --- * /m/ is the underlying monad. --- --- * /r/ is the result type. --- --- A basic intuition is that every @Pipe@ produces a stream of output values --- (/o/), and eventually indicates that this stream is terminated by sending a --- result (/r/). On the receiving end of a @Pipe@, these become the /i/ and /u/ --- parameters. --- --- Since 0.5.0 -data Pipe l i o u m r = - -- | Provide new output to be sent downstream. This constructor has three - -- fields: the next @Pipe@ to be used, a finalization function, and the - -- output value. - HaveOutput (Pipe l i o u m r) (m ()) o - -- | Request more input from upstream. The first field takes a new input - -- value and provides a new @Pipe@. The second takes an upstream result - -- value, which indicates that upstream is producing no more results. - | NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r) - -- | Processing with this @Pipe@ is complete, providing the final result. - | Done r - -- | Require running of a monadic action to get the next @Pipe@. - | PipeM (m (Pipe l i o u m r)) - -- | Return leftover input, which should be provided to future operations. - | Leftover (Pipe l i o u m r) l - -instance Monad m => Functor (Pipe l i o u m) where - fmap = liftM - {-# INLINE fmap #-} - -instance Monad m => Applicative (Pipe l i o u m) where - pure = Done - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance Monad m => Monad (Pipe l i o u m) where - return = pure - {-# INLINE return #-} - - HaveOutput p c o >>= fp = HaveOutput (p >>= fp) c o - NeedInput p c >>= fp = NeedInput (p >=> fp) (c >=> fp) - Done x >>= fp = fp x - PipeM mp >>= fp = PipeM ((>>= fp) `liftM` mp) - Leftover p i >>= fp = Leftover (p >>= fp) i - -instance MonadBase base m => MonadBase base (Pipe l i o u m) where - liftBase = lift . liftBase - {-# INLINE liftBase #-} - -instance MonadTrans (Pipe l i o u) where - lift mr = PipeM (Done `liftM` mr) - {-# INLINE [1] lift #-} - -instance MonadIO m => MonadIO (Pipe l i o u m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -instance MonadThrow m => MonadThrow (Pipe l i o u m) where - throwM = lift . throwM - {-# INLINE throwM #-} - -instance Catch.MonadCatch m => Catch.MonadCatch (Pipe l i o u m) where - catch p0 onErr = - go p0 - where - go (Done r) = Done r - go (PipeM mp) = PipeM $ Catch.catch (liftM go mp) (return . onErr) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o - {-# INLINE catch #-} - -instance Monad m => Semigroup (Pipe l i o u m ()) where - (<>) = (>>) - {-# INLINE (<>) #-} - -instance Monad m => Monoid (Pipe l i o u m ()) where - mempty = return () - {-# INLINE mempty #-} -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) - {-# INLINE mappend #-} -#endif - -instance PrimMonad m => PrimMonad (Pipe l i o u m) where - type PrimState (Pipe l i o u m) = PrimState m - primitive = lift . primitive - -instance MonadResource m => MonadResource (Pipe l i o u m) where - liftResourceT = lift . liftResourceT - {-# INLINE liftResourceT #-} - -instance MonadReader r m => MonadReader r (Pipe l i o u m) where - ask = lift ask - {-# INLINE ask #-} - local f (HaveOutput p c o) = HaveOutput (local f p) c o - local f (NeedInput p c) = NeedInput (\i -> local f (p i)) (\u -> local f (c u)) - local _ (Done x) = Done x - local f (PipeM mp) = PipeM (liftM (local f) $ local f mp) - local f (Leftover p i) = Leftover (local f p) i - --- Provided for doctest -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x, y, z) 0 -#endif - -instance MonadWriter w m => MonadWriter w (Pipe l i o u m) where -#if MIN_VERSION_mtl(2, 1, 0) - writer = lift . writer -#endif - - tell = lift . tell - - listen (HaveOutput p c o) = HaveOutput (listen p) c o - listen (NeedInput p c) = NeedInput (\i -> listen (p i)) (\u -> listen (c u)) - listen (Done x) = Done (x,mempty) - listen (PipeM mp) = - PipeM $ - do (p,w) <- listen mp - return $ do (x,w') <- listen p - return (x, w `mappend` w') - listen (Leftover p i) = Leftover (listen p) i - - pass (HaveOutput p c o) = HaveOutput (pass p) c o - pass (NeedInput p c) = NeedInput (\i -> pass (p i)) (\u -> pass (c u)) - pass (PipeM mp) = PipeM $ mp >>= (return . pass) - pass (Done (x,_)) = Done x - pass (Leftover p i) = Leftover (pass p) i - -instance MonadState s m => MonadState s (Pipe l i o u m) where - get = lift get - put = lift . put -#if MIN_VERSION_mtl(2, 1, 0) - state = lift . state -#endif - -instance MonadRWS r w s m => MonadRWS r w s (Pipe l i o u m) - -instance MonadError e m => MonadError e (Pipe l i o u m) where - throwError = lift . throwError - catchError (HaveOutput p c o) f = HaveOutput (catchError p f) c o - catchError (NeedInput p c) f = NeedInput (\i -> catchError (p i) f) (\u -> catchError (c u) f) - catchError (Done x) _ = Done x - catchError (PipeM mp) f = - PipeM $ catchError (liftM (flip catchError f) mp) (\e -> return (f e)) - catchError (Leftover p i) f = Leftover (catchError p f) i - --- | Wait for a single input value from upstream. --- --- Since 0.5.0 -await :: Pipe l i o u m (Maybe i) -await = NeedInput (Done . Just) (\_ -> Done Nothing) -{-# RULES "conduit: CI.await >>= maybe" forall x y. await >>= maybe x y = NeedInput y (const x) #-} -{-# INLINE [1] await #-} - --- | This is similar to @await@, but will return the upstream result value as --- @Left@ if available. --- --- Since 0.5.0 -awaitE :: Pipe l i o u m (Either u i) -awaitE = NeedInput (Done . Right) (Done . Left) -{-# RULES "conduit: awaitE >>= either" forall x y. awaitE >>= either x y = NeedInput y x #-} -{-# INLINE [1] awaitE #-} - --- | Wait for input forever, calling the given inner @Pipe@ for each piece of --- new input. Returns the upstream result type. --- --- Since 0.5.0 -awaitForever :: Monad m => (i -> Pipe l i o r m r') -> Pipe l i o r m r -awaitForever inner = - self - where - self = awaitE >>= either return (\i -> inner i >> self) -{-# INLINE [1] awaitForever #-} - --- | Send a single output value downstream. If the downstream @Pipe@ --- terminates, this @Pipe@ will terminate as well. --- --- Since 0.5.0 -yield :: Monad m - => o -- ^ output value - -> Pipe l i o u m () -yield = HaveOutput (Done ()) (return ()) -{-# INLINE [1] yield #-} - -yieldM :: Monad m => m o -> Pipe l i o u m () -yieldM = PipeM . liftM (HaveOutput (Done ()) (return ())) -{-# INLINE [1] yieldM #-} - --- | Similar to @yield@, but additionally takes a finalizer to be run if the --- downstream @Pipe@ terminates. --- --- Since 0.5.0 -yieldOr :: Monad m - => o - -> m () -- ^ finalizer - -> Pipe l i o u m () -yieldOr o f = HaveOutput (Done ()) f o -{-# INLINE [1] yieldOr #-} - -{-# RULES - "CI.yield o >> p" forall o (p :: Pipe l i o u m r). yield o >> p = HaveOutput p (return ()) o - ; "CI.yieldOr o c >> p" forall o c (p :: Pipe l i o u m r). yieldOr o c >> p = HaveOutput p c o - ; "lift m >>= CI.yield" forall m. lift m >>= yield = yieldM m - #-} - -- FIXME: Too much inlining on mapM_, can't enforce; "mapM_ CI.yield" mapM_ yield = sourceList - -- Maybe we can get a rewrite rule on foldr instead? Need a benchmark to back this up. - --- | Provide a single piece of leftover input to be consumed by the next pipe --- in the current monadic binding. --- --- /Note/: it is highly encouraged to only return leftover values from input --- already consumed from upstream. --- --- Since 0.5.0 -leftover :: l -> Pipe l i o u m () -leftover = Leftover (Done ()) -{-# INLINE [1] leftover #-} -{-# RULES "conduit: leftover l >> p" forall l (p :: Pipe l i o u m r). leftover l >> p = Leftover p l #-} - --- | Bracket a pipe computation between allocation and release of a --- resource. Two guarantees are given about resource finalization: --- --- 1. It will be /prompt/. The finalization will be run as early as possible. --- --- 2. It is exception safe. Due to usage of @resourcet@, the finalization will --- be run in the event of any exceptions. --- --- Since 0.5.0 -bracketP :: MonadResource m - => IO a - -- ^ computation to run first (\"acquire resource\") - -> (a -> IO ()) - -- ^ computation to run last (\"release resource\") - -> (a -> Pipe l i o u m r) - -- ^ computation to run in-between - -> Pipe l i o u m r - -- returns the value from the in-between computation -bracketP alloc free inside = - PipeM start - where - start = do - (key, seed) <- allocate alloc free - return $ addCleanup (const $ release key) (inside seed) - --- | Add some code to be run when the given @Pipe@ cleans up. --- --- Since 0.4.1 -addCleanup :: Monad m - => (Bool -> m ()) -- ^ @True@ if @Pipe@ ran to completion, @False@ for early termination. - -> Pipe l i o u m r - -> Pipe l i o u m r -addCleanup cleanup (Done r) = PipeM (cleanup True >> return (Done r)) -addCleanup cleanup (HaveOutput src close x) = HaveOutput - (addCleanup cleanup src) - (cleanup False >> close) - x -addCleanup cleanup (PipeM msrc) = PipeM (liftM (addCleanup cleanup) msrc) -addCleanup cleanup (NeedInput p c) = NeedInput - (addCleanup cleanup . p) - (addCleanup cleanup . c) -addCleanup cleanup (Leftover p i) = Leftover (addCleanup cleanup p) i - --- | The identity @Pipe@. --- --- Since 0.5.0 -idP :: Monad m => Pipe l a a r m r -idP = NeedInput (HaveOutput idP (return ())) Done - --- | Compose a left and right pipe together into a complete pipe. The left pipe --- will be automatically closed when the right pipe finishes. --- --- Since 0.5.0 -pipe :: Monad m => Pipe l a b r0 m r1 -> Pipe Void b c r1 m r2 -> Pipe l a c r0 m r2 -pipe = - goRight (return ()) - where - goRight final left right = - case right of - HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o - NeedInput rp rc -> goLeft rp rc final left - Done r2 -> PipeM (final >> return (Done r2)) - PipeM mp -> PipeM (liftM recurse mp) - Leftover _ i -> absurd i - where - recurse = goRight final left - - goLeft rp rc final left = - case left of - HaveOutput left' final' o -> goRight final' left' (rp o) - NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) - Done r1 -> goRight (return ()) (Done r1) (rc r1) - PipeM mp -> PipeM (liftM recurse mp) - Leftover left' i -> Leftover (recurse left') i - where - recurse = goLeft rp rc final - --- | Same as 'pipe', but automatically applies 'injectLeftovers' to the right @Pipe@. --- --- Since 0.5.0 -pipeL :: Monad m => Pipe l a b r0 m r1 -> Pipe b b c r1 m r2 -> Pipe l a c r0 m r2 --- Note: The following should be equivalent to the simpler: --- --- pipeL l r = l `pipe` injectLeftovers r --- --- However, this version tested as being significantly more efficient. -pipeL = - goRight (return ()) - where - goRight final left right = - case right of - HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o - NeedInput rp rc -> goLeft rp rc final left - Done r2 -> PipeM (final >> return (Done r2)) - PipeM mp -> PipeM (liftM recurse mp) - Leftover right' i -> goRight final (HaveOutput left final i) right' - where - recurse = goRight final left - - goLeft rp rc final left = - case left of - HaveOutput left' final' o -> goRight final' left' (rp o) - NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) - Done r1 -> goRight (return ()) (Done r1) (rc r1) - PipeM mp -> PipeM (liftM recurse mp) - Leftover left' i -> Leftover (recurse left') i - where - recurse = goLeft rp rc final - --- | Run a pipeline until processing completes. --- --- Since 0.5.0 -runPipe :: Monad m => Pipe Void () Void () m r -> m r -runPipe (HaveOutput _ _ o) = absurd o -runPipe (NeedInput _ c) = runPipe (c ()) -runPipe (Done r) = return r -runPipe (PipeM mp) = mp >>= runPipe -runPipe (Leftover _ i) = absurd i - --- | Transforms a @Pipe@ that provides leftovers to one which does not, --- allowing it to be composed. --- --- This function will provide any leftover values within this @Pipe@ to any --- calls to @await@. If there are more leftover values than are demanded, the --- remainder are discarded. --- --- Since 0.5.0 -injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r -injectLeftovers = - go [] - where - go ls (HaveOutput p c o) = HaveOutput (go ls p) c o - go (l:ls) (NeedInput p _) = go ls $ p l - go [] (NeedInput p c) = NeedInput (go [] . p) (go [] . c) - go _ (Done r) = Done r - go ls (PipeM mp) = PipeM (liftM (go ls) mp) - go ls (Leftover p l) = go (l:ls) p - --- | Transform the monad that a @Pipe@ lives in. --- --- Note that the monad transforming function will be run multiple times, --- resulting in unintuitive behavior in some cases. For a fuller treatment, --- please see: --- --- --- --- This function is just a synonym for 'hoist'. --- --- Since 0.4.0 -transPipe :: Monad m => (forall a. m a -> n a) -> Pipe l i o u m r -> Pipe l i o u n r -transPipe f (HaveOutput p c o) = HaveOutput (transPipe f p) (f c) o -transPipe f (NeedInput p c) = NeedInput (transPipe f . p) (transPipe f . c) -transPipe _ (Done r) = Done r -transPipe f (PipeM mp) = - PipeM (f $ liftM (transPipe f) $ collapse mp) - where - -- Combine a series of monadic actions into a single action. Since we - -- throw away side effects between different actions, an arbitrary break - -- between actions will lead to a violation of the monad transformer laws. - -- Example available at: - -- - -- http://hpaste.org/75520 - collapse mpipe = do - pipe' <- mpipe - case pipe' of - PipeM mpipe' -> collapse mpipe' - _ -> return pipe' -transPipe f (Leftover p i) = Leftover (transPipe f p) i - --- | Apply a function to all the output values of a @Pipe@. --- --- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 --- days. --- --- Since 0.4.1 -mapOutput :: Monad m => (o1 -> o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r -mapOutput f = - go - where - go (HaveOutput p c o) = HaveOutput (go p) c (f o) - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = Done r - go (PipeM mp) = PipeM (liftM (go) mp) - go (Leftover p i) = Leftover (go p) i -{-# INLINE mapOutput #-} - --- | Same as 'mapOutput', but use a function that returns @Maybe@ values. --- --- Since 0.5.0 -mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r -mapOutputMaybe f = - go - where - go (HaveOutput p c o) = maybe id (\o' p' -> HaveOutput p' c o') (f o) (go p) - go (NeedInput p c) = NeedInput (go . p) (go . c) - go (Done r) = Done r - go (PipeM mp) = PipeM (liftM (go) mp) - go (Leftover p i) = Leftover (go p) i -{-# INLINE mapOutputMaybe #-} - --- | Apply a function to all the input values of a @Pipe@. --- --- Since 0.5.0 -mapInput :: Monad m - => (i1 -> i2) -- ^ map initial input to new input - -> (l2 -> Maybe l1) -- ^ map new leftovers to initial leftovers - -> Pipe l2 i2 o u m r - -> Pipe l1 i1 o u m r -mapInput f f' (HaveOutput p c o) = HaveOutput (mapInput f f' p) c o -mapInput f f' (NeedInput p c) = NeedInput (mapInput f f' . p . f) (mapInput f f' . c) -mapInput _ _ (Done r) = Done r -mapInput f f' (PipeM mp) = PipeM (liftM (mapInput f f') mp) -mapInput f f' (Leftover p i) = maybe id (flip Leftover) (f' i) $ mapInput f f' p - -enumFromTo :: (Enum o, Eq o, Monad m) - => o - -> o - -> Pipe l i o u m () -enumFromTo start stop = - loop start - where - loop i - | i == stop = HaveOutput (Done ()) (return ()) i - | otherwise = HaveOutput (loop (succ i)) (return ()) i -{-# INLINE enumFromTo #-} - --- | Convert a list into a source. --- --- Since 0.3.0 -sourceList :: Monad m => [a] -> Pipe l i a u m () -sourceList = - go - where - go [] = Done () - go (o:os) = HaveOutput (go os) (return ()) o -{-# INLINE [1] sourceList #-} - --- | The equivalent of @GHC.Exts.build@ for @Pipe@. --- --- Since 0.4.2 -build :: Monad m => (forall b. (o -> b -> b) -> b -> b) -> Pipe l i o u m () -build g = g (\o p -> HaveOutput p (return ()) o) (return ()) - -{-# RULES - "sourceList/build" forall (f :: (forall b. (a -> b -> b) -> b -> b)). sourceList (GHC.Exts.build f) = build f #-} - --- | Returns a tuple of the upstream and downstream results. Note that this --- will force consumption of the entire input stream. --- --- Since 0.5.0 -withUpstream :: Monad m - => Pipe l i o u m r - -> Pipe l i o u m (u, r) -withUpstream down = - down >>= go - where - go r = - loop - where - loop = awaitE >>= either (\u -> return (u, r)) (\_ -> loop) - -infixr 9 <+< -infixl 9 >+> - --- | Fuse together two @Pipe@s, connecting the output from the left to the --- input of the right. --- --- Notice that the /leftover/ parameter for the @Pipe@s must be @Void@. This --- ensures that there is no accidental data loss of leftovers during fusion. If --- you have a @Pipe@ with leftovers, you must first call 'injectLeftovers'. --- --- Since 0.5.0 -(>+>) :: Monad m => Pipe l a b r0 m r1 -> Pipe Void b c r1 m r2 -> Pipe l a c r0 m r2 -(>+>) = pipe -{-# INLINE (>+>) #-} - --- | Same as '>+>', but reverse the order of the arguments. --- --- Since 0.5.0 -(<+<) :: Monad m => Pipe Void b c r1 m r2 -> Pipe l a b r0 m r1 -> Pipe l a c r0 m r2 -(<+<) = flip pipe -{-# INLINE (<+<) #-} - --- | Since 1.0.4 -instance MFunctor (Pipe l i o u) where - hoist = transPipe - --- | See 'catchC' for more details. --- --- Since 1.0.11 -catchP :: (MonadBaseControl IO m, Exception e) - => Pipe l i o u m r - -> (e -> Pipe l i o u m r) - -> Pipe l i o u m r -catchP p0 onErr = - go p0 - where - go (Done r) = Done r - go (PipeM mp) = PipeM $ E.catch (liftM go mp) (return . onErr) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o -{-# INLINABLE catchP #-} - --- | The same as @flip catchP@. --- --- Since 1.0.11 -handleP :: (MonadBaseControl IO m, Exception e) - => (e -> Pipe l i o u m r) - -> Pipe l i o u m r - -> Pipe l i o u m r -handleP = flip catchP -{-# INLINE handleP #-} - --- | See 'tryC' for more details. --- --- Since 1.0.11 -tryP :: (MonadBaseControl IO m, Exception e) - => Pipe l i o u m r - -> Pipe l i o u m (Either e r) -tryP = - go - where - go (Done r) = Done (Right r) - go (PipeM mp) = PipeM $ E.catch (liftM go mp) (return . Done . Left) - go (Leftover p i) = Leftover (go p) i - go (NeedInput x y) = NeedInput (go . x) (go . y) - go (HaveOutput p c o) = HaveOutput (go p) c o -{-# INLINABLE tryP #-} - --- | Generalize the upstream return value for a @Pipe@ from unit to any type. --- --- Since 1.1.5 -generalizeUpstream :: Monad m => Pipe l i o () m r -> Pipe l i o u m r -generalizeUpstream = - go - where - go (HaveOutput p f o) = HaveOutput (go p) f o - go (NeedInput x y) = NeedInput (go . x) (\_ -> go (y ())) - go (Done r) = Done r - go (PipeM mp) = PipeM (liftM go mp) - go (Leftover p l) = Leftover (go p) l -{-# INLINE generalizeUpstream #-} - -{-# RULES "conduit: Pipe: lift x >>= f" forall m f. lift m >>= f = PipeM (liftM f m) #-} -{-# RULES "conduit: Pipe: lift x >> f" forall m f. lift m >> f = PipeM (liftM (\_ -> f) m) #-} diff --git a/Data/Conduit/Lift.hs b/Data/Conduit/Lift.hs deleted file mode 100644 --- a/Data/Conduit/Lift.hs +++ /dev/null @@ -1,630 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | Allow monad transformers to be run\/eval\/exec in a section of conduit --- rather then needing to run across the whole conduit. The circumvents many --- of the problems with breaking the monad transformer laws. For more --- information, see the announcement blog post: --- --- --- This module was added in conduit 1.0.11. -module Data.Conduit.Lift ( - -- * ExceptT - exceptC, - runExceptC, - catchExceptC, - - -- * ErrorT - errorC, - runErrorC, - catchErrorC, --- liftCatchError, - - -- * CatchT - runCatchC, - catchCatchC, - - -- * MaybeT - maybeC, - runMaybeC, - - -- * ReaderT - readerC, - runReaderC, - - -- * StateT, lazy - stateLC, - runStateLC, - evalStateLC, - execStateLC, - - -- ** Strict - stateC, - runStateC, - evalStateC, - execStateC, - - -- * WriterT, lazy - writerLC, - runWriterLC, - execWriterLC, - - -- ** Strict - writerC, - runWriterC, - execWriterC, - - -- * RWST, lazy - rwsLC, - runRWSLC, - evalRWSLC, - execRWSLC, - - -- ** Strict - rwsC, - runRWSC, - evalRWSC, - execRWSC, - - -- * Utilities - - distribute - ) where - -import Data.Conduit -import Data.Conduit.Internal (ConduitM (..), Pipe (..)) - -import Control.Monad.Morph (hoist, lift, MFunctor(..), ) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Exception (SomeException) - -import Data.Monoid (Monoid(..)) - - -import qualified Control.Monad.Trans.Except as Ex -import qualified Control.Monad.Trans.Error as E -import qualified Control.Monad.Trans.Maybe as M -import qualified Control.Monad.Trans.Reader as R - -import qualified Control.Monad.Trans.State.Strict as SS -import qualified Control.Monad.Trans.Writer.Strict as WS -import qualified Control.Monad.Trans.RWS.Strict as RWSS - -import qualified Control.Monad.Trans.State.Lazy as SL -import qualified Control.Monad.Trans.Writer.Lazy as WL -import qualified Control.Monad.Trans.RWS.Lazy as RWSL -import Control.Monad.Catch.Pure (CatchT (runCatchT)) - - -catAwaitLifted - :: (Monad (t (ConduitM o1 o m)), Monad m, MonadTrans t) => - ConduitM i o1 (t (ConduitM o1 o m)) () -catAwaitLifted = go - where - go = do - x <- lift . lift $ await - case x of - Nothing -> return () - Just x2 -> do - yield x2 - go - -catYieldLifted - :: (Monad (t (ConduitM i o1 m)), Monad m, MonadTrans t) => - ConduitM o1 o (t (ConduitM i o1 m)) () -catYieldLifted = go - where - go = do - x <- await - case x of - Nothing -> return () - Just x2 -> do - lift . lift $ yield x2 - go - - -distribute - :: (Monad (t (ConduitM b o m)), Monad m, Monad (t m), MonadTrans t, - MFunctor t) => - ConduitM b o (t m) () -> t (ConduitM b o m) () -distribute p = catAwaitLifted =$= hoist (hoist lift) p $$ catYieldLifted - --- | Wrap the base monad in 'Ex.ExceptT' --- --- Since 1.2.12 -exceptC - :: (Monad m, Monad (t (Ex.ExceptT e m)), MonadTrans t, MFunctor t) => - t m (Either e b) -> t (Ex.ExceptT e m) b -exceptC p = do - x <- hoist lift p - lift $ Ex.ExceptT (return x) - --- | Run 'Ex.ExceptT' in the base monad --- --- Since 1.2.12 -runExceptC - :: Monad m => - ConduitM i o (Ex.ExceptT e m) r -> ConduitM i o m (Either e r) -runExceptC (ConduitM c0) = - ConduitM $ \rest -> - let go (Done r) = rest (Right r) - go (PipeM mp) = PipeM $ do - eres <- Ex.runExceptT mp - return $ case eres of - Left e -> rest $ Left e - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) (Ex.runExceptT f >> return ()) o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go (c0 Done) -{-# INLINABLE runExceptC #-} - --- | Catch an error in the base monad --- --- Since 1.2.12 -catchExceptC - :: Monad m => - ConduitM i o (Ex.ExceptT e m) r - -> (e -> ConduitM i o (Ex.ExceptT e m) r) - -> ConduitM i o (Ex.ExceptT e m) r -catchExceptC c0 h = - ConduitM $ \rest -> - let go (Done r) = rest r - go (PipeM mp) = PipeM $ do - eres <- lift $ Ex.runExceptT mp - return $ case eres of - Left e -> unConduitM (h e) rest - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) f o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go $ unConduitM c0 Done - where -{-# INLINABLE catchExceptC #-} - --- | Wrap the base monad in 'E.ErrorT' --- --- Since 1.0.11 -errorC - :: (Monad m, Monad (t (E.ErrorT e m)), MonadTrans t, E.Error e, - MFunctor t) => - t m (Either e b) -> t (E.ErrorT e m) b -errorC p = do - x <- hoist lift p - lift $ E.ErrorT (return x) - --- | Run 'E.ErrorT' in the base monad --- --- Since 1.0.11 -runErrorC - :: (Monad m, E.Error e) => - ConduitM i o (E.ErrorT e m) r -> ConduitM i o m (Either e r) -runErrorC (ConduitM c0) = - ConduitM $ \rest -> - let go (Done r) = rest (Right r) - go (PipeM mp) = PipeM $ do - eres <- E.runErrorT mp - return $ case eres of - Left e -> rest $ Left e - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) (E.runErrorT f >> return ()) o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go (c0 Done) -{-# INLINABLE runErrorC #-} - --- | Catch an error in the base monad --- --- Since 1.0.11 -catchErrorC - :: (Monad m, E.Error e) => - ConduitM i o (E.ErrorT e m) r - -> (e -> ConduitM i o (E.ErrorT e m) r) - -> ConduitM i o (E.ErrorT e m) r -catchErrorC c0 h = - ConduitM $ \rest -> - let go (Done r) = rest r - go (PipeM mp) = PipeM $ do - eres <- lift $ E.runErrorT mp - return $ case eres of - Left e -> unConduitM (h e) rest - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) f o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go $ unConduitM c0 Done - where -{-# INLINABLE catchErrorC #-} - --- | Run 'CatchT' in the base monad --- --- Since 1.1.0 -runCatchC - :: Monad m => - ConduitM i o (CatchT m) r -> ConduitM i o m (Either SomeException r) -runCatchC c0 = - ConduitM $ \rest -> - let go (Done r) = rest (Right r) - go (PipeM mp) = PipeM $ do - eres <- runCatchT mp - return $ case eres of - Left e -> rest $ Left e - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) (runCatchT f >> return ()) o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go $ unConduitM c0 Done -{-# INLINABLE runCatchC #-} - --- | Catch an exception in the base monad --- --- Since 1.1.0 -catchCatchC - :: Monad m => - ConduitM i o (CatchT m) r - -> (SomeException -> ConduitM i o (CatchT m) r) - -> ConduitM i o (CatchT m) r -catchCatchC (ConduitM c0) h = - ConduitM $ \rest -> - let go (Done r) = rest r - go (PipeM mp) = PipeM $ do - eres <- lift $ runCatchT mp - return $ case eres of - Left e -> unConduitM (h e) rest - Right p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p f o) = HaveOutput (go p) f o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go (c0 Done) -{-# INLINABLE catchCatchC #-} - --- | Wrap the base monad in 'M.MaybeT' --- --- Since 1.0.11 -maybeC - :: (Monad m, Monad (t (M.MaybeT m)), - MonadTrans t, - MFunctor t) => - t m (Maybe b) -> t (M.MaybeT m) b -maybeC p = do - x <- hoist lift p - lift $ M.MaybeT (return x) -{-# INLINABLE maybeC #-} - --- | Run 'M.MaybeT' in the base monad --- --- Since 1.0.11 -runMaybeC - :: Monad m => - ConduitM i o (M.MaybeT m) r -> ConduitM i o m (Maybe r) -runMaybeC (ConduitM c0) = - ConduitM $ \rest -> - let go (Done r) = rest (Just r) - go (PipeM mp) = PipeM $ do - mres <- M.runMaybeT mp - return $ case mres of - Nothing -> rest Nothing - Just p -> go p - go (Leftover p i) = Leftover (go p) i - go (HaveOutput p c o) = HaveOutput (go p) (M.runMaybeT c >> return ()) o - go (NeedInput x y) = NeedInput (go . x) (go . y) - in go (c0 Done) -{-# INLINABLE runMaybeC #-} - --- | Wrap the base monad in 'R.ReaderT' --- --- Since 1.0.11 -readerC - :: (Monad m, Monad (t1 (R.ReaderT t m)), - MonadTrans t1, - MFunctor t1) => - (t -> t1 m b) -> t1 (R.ReaderT t m) b -readerC k = do - i <- lift R.ask - hoist lift (k i) -{-# INLINABLE readerC #-} - --- | Run 'R.ReaderT' in the base monad --- --- Since 1.0.11 -runReaderC - :: Monad m => - r -> ConduitM i o (R.ReaderT r m) res -> ConduitM i o m res -runReaderC r = hoist (`R.runReaderT` r) -{-# INLINABLE runReaderC #-} - - --- | Wrap the base monad in 'SL.StateT' --- --- Since 1.0.11 -stateLC - :: (Monad m, Monad (t1 (SL.StateT t m)), - MonadTrans t1, - MFunctor t1) => - (t -> t1 m (b, t)) -> t1 (SL.StateT t m) b -stateLC k = do - s <- lift SL.get - (r, s') <- hoist lift (k s) - lift (SL.put s') - return r -{-# INLINABLE stateLC #-} - -thread :: Monad m - => (r -> s -> res) - -> (forall a. t m a -> s -> m (a, s)) - -> s - -> ConduitM i o (t m) r - -> ConduitM i o m res -thread toRes runM s0 (ConduitM c0) = - ConduitM $ \rest -> - let go s (Done r) = rest (toRes r s) - go s (PipeM mp) = PipeM $ do - (p, s') <- runM mp s - return $ go s' p - go s (Leftover p i) = Leftover (go s p) i - go s (NeedInput x y) = NeedInput (go s . x) (go s . y) - go s (HaveOutput p f o) = HaveOutput (go s p) (runM f s >> return ()) o - in go s0 (c0 Done) -{-# INLINABLE thread #-} - --- | Run 'SL.StateT' in the base monad --- --- Since 1.0.11 -runStateLC - :: Monad m => - s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m (r, s) -runStateLC = thread (,) SL.runStateT -{-# INLINABLE runStateLC #-} - --- | Evaluate 'SL.StateT' in the base monad --- --- Since 1.0.11 -evalStateLC - :: Monad m => - s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m r -evalStateLC s p = fmap fst $ runStateLC s p -{-# INLINABLE evalStateLC #-} - --- | Execute 'SL.StateT' in the base monad --- --- Since 1.0.11 -execStateLC - :: Monad m => - s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m s -execStateLC s p = fmap snd $ runStateLC s p -{-# INLINABLE execStateLC #-} - - --- | Wrap the base monad in 'SS.StateT' --- --- Since 1.0.11 -stateC - :: (Monad m, Monad (t1 (SS.StateT t m)), - MonadTrans t1, - MFunctor t1) => - (t -> t1 m (b, t)) -> t1 (SS.StateT t m) b -stateC k = do - s <- lift SS.get - (r, s') <- hoist lift (k s) - lift (SS.put s') - return r -{-# INLINABLE stateC #-} - --- | Run 'SS.StateT' in the base monad --- --- Since 1.0.11 -runStateC - :: Monad m => - s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m (r, s) -runStateC = thread (,) SS.runStateT -{-# INLINABLE runStateC #-} - --- | Evaluate 'SS.StateT' in the base monad --- --- Since 1.0.11 -evalStateC - :: Monad m => - s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m r -evalStateC s p = fmap fst $ runStateC s p -{-# INLINABLE evalStateC #-} - --- | Execute 'SS.StateT' in the base monad --- --- Since 1.0.11 -execStateC - :: Monad m => - s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m s -execStateC s p = fmap snd $ runStateC s p -{-# INLINABLE execStateC #-} - - --- | Wrap the base monad in 'WL.WriterT' --- --- Since 1.0.11 -writerLC - :: (Monad m, Monad (t (WL.WriterT w m)), MonadTrans t, Monoid w, - MFunctor t) => - t m (b, w) -> t (WL.WriterT w m) b -writerLC p = do - (r, w) <- hoist lift p - lift $ WL.tell w - return r -{-# INLINABLE writerLC #-} - --- | Run 'WL.WriterT' in the base monad --- --- Since 1.0.11 -runWriterLC - :: (Monad m, Monoid w) => - ConduitM i o (WL.WriterT w m) r -> ConduitM i o m (r, w) -runWriterLC = thread (,) run mempty - where - run m w = do - (a, w') <- WL.runWriterT m - return (a, w `mappend` w') -{-# INLINABLE runWriterLC #-} - --- | Execute 'WL.WriterT' in the base monad --- --- Since 1.0.11 -execWriterLC - :: (Monad m, Monoid w) => - ConduitM i o (WL.WriterT w m) r -> ConduitM i o m w -execWriterLC p = fmap snd $ runWriterLC p -{-# INLINABLE execWriterLC #-} - - --- | Wrap the base monad in 'WS.WriterT' --- --- Since 1.0.11 -writerC - :: (Monad m, Monad (t (WS.WriterT w m)), MonadTrans t, Monoid w, - MFunctor t) => - t m (b, w) -> t (WS.WriterT w m) b -writerC p = do - (r, w) <- hoist lift p - lift $ WS.tell w - return r -{-# INLINABLE writerC #-} - --- | Run 'WS.WriterT' in the base monad --- --- Since 1.0.11 -runWriterC - :: (Monad m, Monoid w) => - ConduitM i o (WS.WriterT w m) r -> ConduitM i o m (r, w) -runWriterC = thread (,) run mempty - where - run m w = do - (a, w') <- WS.runWriterT m - return (a, w `mappend` w') -{-# INLINABLE runWriterC #-} - --- | Execute 'WS.WriterT' in the base monad --- --- Since 1.0.11 -execWriterC - :: (Monad m, Monoid w) => - ConduitM i o (WS.WriterT w m) r -> ConduitM i o m w -execWriterC p = fmap snd $ runWriterC p -{-# INLINABLE execWriterC #-} - - --- | Wrap the base monad in 'RWSL.RWST' --- --- Since 1.0.11 -rwsLC - :: (Monad m, Monad (t1 (RWSL.RWST t w t2 m)), MonadTrans t1, - Monoid w, MFunctor t1) => - (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSL.RWST t w t2 m) b -rwsLC k = do - i <- lift RWSL.ask - s <- lift RWSL.get - (r, s', w) <- hoist lift (k i s) - lift $ do - RWSL.put s' - RWSL.tell w - return r -{-# INLINABLE rwsLC #-} - --- | Run 'RWSL.RWST' in the base monad --- --- Since 1.0.11 -runRWSLC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSL.RWST r w s m) res - -> ConduitM i o m (res, s, w) -runRWSLC r s0 = thread toRes run (s0, mempty) - where - toRes a (s, w) = (a, s, w) - run m (s, w) = do - (res, s', w') <- RWSL.runRWST m r s - return (res, (s', w `mappend` w')) -{-# INLINABLE runRWSLC #-} - --- | Evaluate 'RWSL.RWST' in the base monad --- --- Since 1.0.11 -evalRWSLC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSL.RWST r w s m) res - -> ConduitM i o m (res, w) -evalRWSLC i s p = fmap f $ runRWSLC i s p - where f x = let (r, _, w) = x in (r, w) -{-# INLINABLE evalRWSLC #-} - --- | Execute 'RWSL.RWST' in the base monad --- --- Since 1.0.11 -execRWSLC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSL.RWST r w s m) res - -> ConduitM i o m (s, w) -execRWSLC i s p = fmap f $ runRWSLC i s p - where f x = let (_, s2, w2) = x in (s2, w2) -{-# INLINABLE execRWSLC #-} - - --- | Wrap the base monad in 'RWSS.RWST' --- --- Since 1.0.11 -rwsC - :: (Monad m, Monad (t1 (RWSS.RWST t w t2 m)), MonadTrans t1, - Monoid w, MFunctor t1) => - (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSS.RWST t w t2 m) b -rwsC k = do - i <- lift RWSS.ask - s <- lift RWSS.get - (r, s', w) <- hoist lift (k i s) - lift $ do - RWSS.put s' - RWSS.tell w - return r -{-# INLINABLE rwsC #-} - --- | Run 'RWSS.RWST' in the base monad --- --- Since 1.0.11 -runRWSC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSS.RWST r w s m) res - -> ConduitM i o m (res, s, w) -runRWSC r s0 = thread toRes run (s0, mempty) - where - toRes a (s, w) = (a, s, w) - run m (s, w) = do - (res, s', w') <- RWSS.runRWST m r s - return (res, (s', w `mappend` w')) -{-# INLINABLE runRWSC #-} - --- | Evaluate 'RWSS.RWST' in the base monad --- --- Since 1.0.11 -evalRWSC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSS.RWST r w s m) res - -> ConduitM i o m (res, w) -evalRWSC i s p = fmap f $ runRWSC i s p - where f x = let (r, _, w) = x in (r, w) -{-# INLINABLE evalRWSC #-} - --- | Execute 'RWSS.RWST' in the base monad --- --- Since 1.0.11 -execRWSC - :: (Monad m, Monoid w) => - r - -> s - -> ConduitM i o (RWSS.RWST r w s m) res - -> ConduitM i o m (s, w) -execRWSC i s p = fmap f $ runRWSC i s p - where f x = let (_, s2, w2) = x in (s2, w2) -{-# INLINABLE execRWSC #-} diff --git a/Data/Conduit/List.hs b/Data/Conduit/List.hs deleted file mode 100644 --- a/Data/Conduit/List.hs +++ /dev/null @@ -1,837 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} --- | Higher-level functions to interact with the elements of a stream. Most of --- these are based on list functions. --- --- For many purposes, it's recommended to use the conduit-combinators library, --- which provides a more complete set of functions. --- --- Note that these functions all deal with individual elements of a stream as a --- sort of \"black box\", where there is no introspection of the contained --- elements. Values such as @ByteString@ and @Text@ will likely need to be --- treated specially to deal with their contents properly (@Word8@ and @Char@, --- respectively). See the "Data.Conduit.Binary" and "Data.Conduit.Text" --- modules. -module Data.Conduit.List - ( -- * Sources - sourceList - , sourceNull - , unfold - , unfoldEither - , unfoldM - , unfoldEitherM - , enumFromTo - , iterate - , replicate - , replicateM - -- * Sinks - -- ** Pure - , fold - , foldMap - , take - , drop - , head - , peek - , consume - , sinkNull - -- ** Monadic - , foldMapM - , foldM - , mapM_ - -- * Conduits - -- ** Pure - , map - , mapMaybe - , mapFoldable - , catMaybes - , concat - , concatMap - , concatMapAccum - , scanl - , scan - , mapAccum - , chunksOf - , groupBy - , groupOn1 - , isolate - , filter - -- ** Monadic - , mapM - , iterM - , scanlM - , scanM - , mapAccumM - , mapMaybeM - , mapFoldableM - , concatMapM - , concatMapAccumM - -- * Misc - , sequence - ) where - -import qualified Prelude -import Prelude - ( ($), return, (==), (-), Int - , (.), id, Maybe (..), Monad - , Either (..) - , Bool (..) - , (>>) - , (>>=) - , seq - , otherwise - , Enum, Eq - , maybe - , (<=) - , (>) - ) -import Data.Monoid (Monoid, mempty, mappend) -import qualified Data.Foldable as F -import Data.Conduit -import Data.Conduit.Internal.Fusion -import Data.Conduit.Internal.List.Stream -import qualified Data.Conduit.Internal as CI -import Control.Monad (when, (<=<), liftM, void) -import Control.Monad.Trans.Class (lift) - --- Defines INLINE_RULE0, INLINE_RULE, STREAMING0, and STREAMING. -#include "fusion-macros.h" - --- | Generate a source from a seed value. --- --- Subject to fusion --- --- Since 0.4.2 -unfold, unfoldC :: Monad m - => (b -> Maybe (a, b)) - -> b - -> Producer m a -unfoldC f = - go - where - go seed = - case f seed of - Just (a, seed') -> yield a >> go seed' - Nothing -> return () -{-# INLINE unfoldC #-} -STREAMING(unfold, unfoldC, unfoldS, f x) - --- | Generate a source from a seed value with a return value. --- --- Subject to fusion --- --- @since 1.2.11 -unfoldEither, unfoldEitherC :: Monad m - => (b -> Either r (a, b)) - -> b - -> ConduitM i a m r -unfoldEitherC f = - go - where - go seed = - case f seed of - Right (a, seed') -> yield a >> go seed' - Left r -> return r -{-# INLINE unfoldEitherC #-} -STREAMING(unfoldEither, unfoldEitherC, unfoldEitherS, f x) - --- | A monadic unfold. --- --- Subject to fusion --- --- Since 1.1.2 -unfoldM, unfoldMC :: Monad m - => (b -> m (Maybe (a, b))) - -> b - -> Producer m a -unfoldMC f = - go - where - go seed = do - mres <- lift $ f seed - case mres of - Just (a, seed') -> yield a >> go seed' - Nothing -> return () -STREAMING(unfoldM, unfoldMC, unfoldMS, f seed) - --- | A monadic unfoldEither. --- --- Subject to fusion --- --- @since 1.2.11 -unfoldEitherM, unfoldEitherMC :: Monad m - => (b -> m (Either r (a, b))) - -> b - -> ConduitM i a m r -unfoldEitherMC f = - go - where - go seed = do - mres <- lift $ f seed - case mres of - Right (a, seed') -> yield a >> go seed' - Left r -> return r -STREAMING(unfoldEitherM, unfoldEitherMC, unfoldEitherMS, f seed) - --- | Yield the values from the list. --- --- Subject to fusion -sourceList, sourceListC :: Monad m => [a] -> Producer m a -sourceListC = Prelude.mapM_ yield -{-# INLINE sourceListC #-} -STREAMING(sourceList, sourceListC, sourceListS, xs) - --- | Enumerate from a value to a final value, inclusive, via 'succ'. --- --- This is generally more efficient than using @Prelude@\'s @enumFromTo@ and --- combining with @sourceList@ since this avoids any intermediate data --- structures. --- --- Subject to fusion --- --- Since 0.4.2 -enumFromTo, enumFromToC :: (Enum a, Prelude.Ord a, Monad m) - => a - -> a - -> Producer m a -enumFromToC x0 y = - loop x0 - where - loop x - | x Prelude.> y = return () - | otherwise = yield x >> loop (Prelude.succ x) -{-# INLINE enumFromToC #-} -STREAMING(enumFromTo, enumFromToC, enumFromToS, x0 y) - --- | Produces an infinite stream of repeated applications of f to x. --- --- Subject to fusion --- -iterate, iterateC :: Monad m => (a -> a) -> a -> Producer m a -iterateC f = - go - where - go a = yield a >> go (f a) -{-# INLINE iterateC #-} -STREAMING(iterate, iterateC, iterateS, f a) - --- | Replicate a single value the given number of times. --- --- Subject to fusion --- --- Since 1.2.0 -replicate, replicateC :: Monad m => Int -> a -> Producer m a -replicateC cnt0 a = - loop cnt0 - where - loop i - | i <= 0 = return () - | otherwise = yield a >> loop (i - 1) -{-# INLINE replicateC #-} -STREAMING(replicate, replicateC, replicateS, cnt0 a) - --- | Replicate a monadic value the given number of times. --- --- Subject to fusion --- --- Since 1.2.0 -replicateM, replicateMC :: Monad m => Int -> m a -> Producer m a -replicateMC cnt0 ma = - loop cnt0 - where - loop i - | i <= 0 = return () - | otherwise = lift ma >>= yield >> loop (i - 1) -{-# INLINE replicateMC #-} -STREAMING(replicateM, replicateMC, replicateMS, cnt0 ma) - --- | A strict left fold. --- --- Subject to fusion --- --- Since 0.3.0 -fold, foldC :: Monad m - => (b -> a -> b) - -> b - -> Consumer a m b -foldC f = - loop - where - loop !accum = await >>= maybe (return accum) (loop . f accum) -{-# INLINE foldC #-} -STREAMING(fold, foldC, foldS, f accum) - --- | A monadic strict left fold. --- --- Subject to fusion --- --- Since 0.3.0 -foldM, foldMC :: Monad m - => (b -> a -> m b) - -> b - -> Consumer a m b -foldMC f = - loop - where - loop accum = do - await >>= maybe (return accum) go - where - go a = do - accum' <- lift $ f accum a - accum' `seq` loop accum' -{-# INLINE foldMC #-} -STREAMING(foldM, foldMC, foldMS, f accum) - ------------------------------------------------------------------ --- These are for cases where- for whatever reason- stream fusion cannot be --- applied. -connectFold :: Monad m => Source m a -> (b -> a -> b) -> b -> m b -connectFold (CI.ConduitM src0) f = - go (src0 CI.Done) - where - go (CI.Done ()) b = return b - go (CI.HaveOutput src _ a) b = go src Prelude.$! f b a - go (CI.NeedInput _ c) b = go (c ()) b - go (CI.Leftover src ()) b = go src b - go (CI.PipeM msrc) b = do - src <- msrc - go src b -{-# INLINE connectFold #-} -{-# RULES "conduit: $$ fold" forall src f b. src $$ fold f b = connectFold src f b #-} - -connectFoldM :: Monad m => Source m a -> (b -> a -> m b) -> b -> m b -connectFoldM (CI.ConduitM src0) f = - go (src0 CI.Done) - where - go (CI.Done ()) b = return b - go (CI.HaveOutput src _ a) b = do - !b' <- f b a - go src b' - go (CI.NeedInput _ c) b = go (c ()) b - go (CI.Leftover src ()) b = go src b - go (CI.PipeM msrc) b = do - src <- msrc - go src b -{-# INLINE connectFoldM #-} -{-# RULES "conduit: $$ foldM" forall src f b. src $$ foldM f b = connectFoldM src f b #-} ------------------------------------------------------------------ - --- | A monoidal strict left fold. --- --- Subject to fusion --- --- Since 0.5.3 -foldMap :: (Monad m, Monoid b) - => (a -> b) - -> Consumer a m b -INLINE_RULE(foldMap, f, let combiner accum = mappend accum . f in fold combiner mempty) - --- | A monoidal strict left fold in a Monad. --- --- Since 1.0.8 -foldMapM :: (Monad m, Monoid b) - => (a -> m b) - -> Consumer a m b -INLINE_RULE(foldMapM, f, let combiner accum = liftM (mappend accum) . f in foldM combiner mempty) - --- | Apply the action to all values in the stream. --- --- Subject to fusion --- --- Since 0.3.0 -mapM_, mapM_C :: Monad m - => (a -> m ()) - -> Consumer a m () -mapM_C f = awaitForever $ lift . f -{-# INLINE mapM_C #-} -STREAMING(mapM_, mapM_C, mapM_S, f) - -srcMapM_ :: Monad m => Source m a -> (a -> m ()) -> m () -srcMapM_ (CI.ConduitM src) f = - go (src CI.Done) - where - go (CI.Done ()) = return () - go (CI.PipeM mp) = mp >>= go - go (CI.Leftover p ()) = go p - go (CI.HaveOutput p _ o) = f o >> go p - go (CI.NeedInput _ c) = go (c ()) -{-# INLINE srcMapM_ #-} -{-# RULES "conduit: connect to mapM_" [2] forall f src. src $$ mapM_ f = srcMapM_ src f #-} - --- | Ignore a certain number of values in the stream. This function is --- semantically equivalent to: --- --- > drop i = take i >> return () --- --- However, @drop@ is more efficient as it does not need to hold values in --- memory. --- --- Subject to fusion --- --- Since 0.3.0 -drop, dropC :: Monad m - => Int - -> Consumer a m () -dropC = - loop - where - loop i | i <= 0 = return () - loop count = await >>= maybe (return ()) (\_ -> loop (count - 1)) -{-# INLINE dropC #-} -STREAMING(drop, dropC, dropS, i) - --- | Take some values from the stream and return as a list. If you want to --- instead create a conduit that pipes data to another sink, see 'isolate'. --- This function is semantically equivalent to: --- --- > take i = isolate i =$ consume --- --- Subject to fusion --- --- Since 0.3.0 -take, takeC :: Monad m - => Int - -> Consumer a m [a] -takeC = - loop id - where - loop front count | count <= 0 = return $ front [] - loop front count = await >>= maybe - (return $ front []) - (\x -> loop (front . (x:)) (count - 1)) -{-# INLINE takeC #-} -STREAMING(take, takeC, takeS, i) - --- | Take a single value from the stream, if available. --- --- Subject to fusion --- --- Since 0.3.0 -head, headC :: Monad m => Consumer a m (Maybe a) -headC = await -{-# INLINE headC #-} -STREAMING0(head, headC, headS) - --- | Look at the next value in the stream, if available. This function will not --- change the state of the stream. --- --- Since 0.3.0 -peek :: Monad m => Consumer a m (Maybe a) -peek = await >>= maybe (return Nothing) (\x -> leftover x >> return (Just x)) - --- | Apply a transformation to all values in a stream. --- --- Subject to fusion --- --- Since 0.3.0 -map, mapC :: Monad m => (a -> b) -> Conduit a m b -mapC f = awaitForever $ yield . f -{-# INLINE mapC #-} -STREAMING(map, mapC, mapS, f) - --- Since a Source never has any leftovers, fusion rules on it are safe. -{- -{-# RULES "conduit: source/map fusion =$=" forall f src. src =$= map f = mapFuseRight src f #-} - -mapFuseRight :: Monad m => Source m a -> (a -> b) -> Source m b -mapFuseRight src f = CIC.mapOutput f src -{-# INLINE mapFuseRight #-} --} - -{- - -It might be nice to include these rewrite rules, but they may have subtle -differences based on leftovers. - -{-# RULES "conduit: map-to-mapOutput pipeL" forall f src. pipeL src (map f) = mapOutput f src #-} -{-# RULES "conduit: map-to-mapOutput $=" forall f src. src $= (map f) = mapOutput f src #-} -{-# RULES "conduit: map-to-mapOutput pipe" forall f src. pipe src (map f) = mapOutput f src #-} -{-# RULES "conduit: map-to-mapOutput >+>" forall f src. src >+> (map f) = mapOutput f src #-} - -{-# RULES "conduit: map-to-mapInput pipeL" forall f sink. pipeL (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} -{-# RULES "conduit: map-to-mapInput =$" forall f sink. map f =$ sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} -{-# RULES "conduit: map-to-mapInput pipe" forall f sink. pipe (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} -{-# RULES "conduit: map-to-mapInput >+>" forall f sink. map f >+> sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} - -{-# RULES "conduit: map-to-mapOutput =$=" forall f con. con =$= map f = mapOutput f con #-} -{-# RULES "conduit: map-to-mapInput =$=" forall f con. map f =$= con = mapInput f (Prelude.const Prelude.Nothing) con #-} - -{-# INLINE [1] map #-} - --} - --- | Apply a monadic transformation to all values in a stream. --- --- If you do not need the transformed values, and instead just want the monadic --- side-effects of running the action, see 'mapM_'. --- --- Subject to fusion --- --- Since 0.3.0 -mapM, mapMC :: Monad m => (a -> m b) -> Conduit a m b -mapMC f = awaitForever $ \a -> lift (f a) >>= yield -{-# INLINE mapMC #-} -STREAMING(mapM, mapMC, mapMS, f) - --- | Apply a monadic action on all values in a stream. --- --- This @Conduit@ can be used to perform a monadic side-effect for every --- value, whilst passing the value through the @Conduit@ as-is. --- --- > iterM f = mapM (\a -> f a >>= \() -> return a) --- --- Subject to fusion --- --- Since 0.5.6 -iterM, iterMC :: Monad m => (a -> m ()) -> Conduit a m a -iterMC f = awaitForever $ \a -> lift (f a) >> yield a -{-# INLINE iterMC #-} -STREAMING(iterM, iterMC, iterMS, f) - --- | Apply a transformation that may fail to all values in a stream, discarding --- the failures. --- --- Subject to fusion --- --- Since 0.5.1 -mapMaybe, mapMaybeC :: Monad m => (a -> Maybe b) -> Conduit a m b -mapMaybeC f = awaitForever $ maybe (return ()) yield . f -{-# INLINE mapMaybeC #-} -STREAMING(mapMaybe, mapMaybeC, mapMaybeS, f) - --- | Apply a monadic transformation that may fail to all values in a stream, --- discarding the failures. --- --- Subject to fusion --- --- Since 0.5.1 -mapMaybeM, mapMaybeMC :: Monad m => (a -> m (Maybe b)) -> Conduit a m b -mapMaybeMC f = awaitForever $ maybe (return ()) yield <=< lift . f -{-# INLINE mapMaybeMC #-} -STREAMING(mapMaybeM, mapMaybeMC, mapMaybeMS, f) - --- | Filter the @Just@ values from a stream, discarding the @Nothing@ values. --- --- Subject to fusion --- --- Since 0.5.1 -catMaybes, catMaybesC :: Monad m => Conduit (Maybe a) m a -catMaybesC = awaitForever $ maybe (return ()) yield -{-# INLINE catMaybesC #-} -STREAMING0(catMaybes, catMaybesC, catMaybesS) - --- | Generalization of 'catMaybes'. It puts all values from --- 'F.Foldable' into stream. --- --- Subject to fusion --- --- Since 1.0.6 -concat, concatC :: (Monad m, F.Foldable f) => Conduit (f a) m a -concatC = awaitForever $ F.mapM_ yield -{-# INLINE concatC #-} -STREAMING0(concat, concatC, concatS) - --- | Apply a transformation to all values in a stream, concatenating the output --- values. --- --- Subject to fusion --- --- Since 0.3.0 -concatMap, concatMapC :: Monad m => (a -> [b]) -> Conduit a m b -concatMapC f = awaitForever $ sourceList . f -{-# INLINE concatMapC #-} -STREAMING(concatMap, concatMapC, concatMapS, f) - --- | Apply a monadic transformation to all values in a stream, concatenating --- the output values. --- --- Subject to fusion --- --- Since 0.3.0 -concatMapM, concatMapMC :: Monad m => (a -> m [b]) -> Conduit a m b -concatMapMC f = awaitForever $ sourceList <=< lift . f -{-# INLINE concatMapMC #-} -STREAMING(concatMapM, concatMapMC, concatMapMS, f) - --- | 'concatMap' with a strict accumulator. --- --- Subject to fusion --- --- Since 0.3.0 -concatMapAccum, concatMapAccumC :: Monad m => (a -> accum -> (accum, [b])) -> accum -> Conduit a m b -concatMapAccumC f x0 = void (mapAccum f x0) =$= concat -{-# INLINE concatMapAccumC #-} -STREAMING(concatMapAccum, concatMapAccumC, concatMapAccumS, f x0) - --- | Deprecated synonym for @mapAccum@ --- --- Since 1.0.6 -scanl :: Monad m => (a -> s -> (s, b)) -> s -> Conduit a m b -scanl f s = void $ mapAccum f s -{-# DEPRECATED scanl "Use mapAccum instead" #-} - --- | Deprecated synonym for @mapAccumM@ --- --- Since 1.0.6 -scanlM :: Monad m => (a -> s -> m (s, b)) -> s -> Conduit a m b -scanlM f s = void $ mapAccumM f s -{-# DEPRECATED scanlM "Use mapAccumM instead" #-} - --- | Analog of @mapAccumL@ for lists. Note that in contrast to @mapAccumL@, the function argument --- takes the accumulator as its second argument, not its first argument, and the accumulated value --- is strict. --- --- Subject to fusion --- --- Since 1.1.1 -mapAccum, mapAccumC :: Monad m => (a -> s -> (s, b)) -> s -> ConduitM a b m s -mapAccumC f = - loop - where - loop !s = await >>= maybe (return s) go - where - go a = case f a s of - (s', b) -> yield b >> loop s' -STREAMING(mapAccum, mapAccumC, mapAccumS, f s) - --- | Monadic `mapAccum`. --- --- Subject to fusion --- --- Since 1.1.1 -mapAccumM, mapAccumMC :: Monad m => (a -> s -> m (s, b)) -> s -> ConduitM a b m s -mapAccumMC f = - loop - where - loop !s = await >>= maybe (return s) go - where - go a = do (s', b) <- lift $ f a s - yield b - loop s' -{-# INLINE mapAccumMC #-} -STREAMING(mapAccumM, mapAccumMC, mapAccumMS, f s) - --- | Analog of 'Prelude.scanl' for lists. --- --- Subject to fusion --- --- Since 1.1.1 -scan :: Monad m => (a -> b -> b) -> b -> ConduitM a b m b -INLINE_RULE(scan, f, mapAccum (\a b -> let r = f a b in (r, r))) - --- | Monadic @scanl@. --- --- Subject to fusion --- --- Since 1.1.1 -scanM :: Monad m => (a -> b -> m b) -> b -> ConduitM a b m b -INLINE_RULE(scanM, f, mapAccumM (\a b -> f a b >>= \r -> return (r, r))) - --- | 'concatMapM' with a strict accumulator. --- --- Subject to fusion --- --- Since 0.3.0 -concatMapAccumM, concatMapAccumMC :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> Conduit a m b -concatMapAccumMC f x0 = void (mapAccumM f x0) =$= concat -{-# INLINE concatMapAccumMC #-} -STREAMING(concatMapAccumM, concatMapAccumMC, concatMapAccumMS, f x0) - --- | Generalization of 'mapMaybe' and 'concatMap'. It applies function --- to all values in a stream and send values inside resulting --- 'Foldable' downstream. --- --- Subject to fusion --- --- Since 1.0.6 -mapFoldable, mapFoldableC :: (Monad m, F.Foldable f) => (a -> f b) -> Conduit a m b -mapFoldableC f = awaitForever $ F.mapM_ yield . f -{-# INLINE mapFoldableC #-} -STREAMING(mapFoldable, mapFoldableC, mapFoldableS, f) - --- | Monadic variant of 'mapFoldable'. --- --- Subject to fusion --- --- Since 1.0.6 -mapFoldableM, mapFoldableMC :: (Monad m, F.Foldable f) => (a -> m (f b)) -> Conduit a m b -mapFoldableMC f = awaitForever $ F.mapM_ yield <=< lift . f -{-# INLINE mapFoldableMC #-} -STREAMING(mapFoldableM, mapFoldableMC, mapFoldableMS, f) - --- | Consume all values from the stream and return as a list. Note that this --- will pull all values into memory. --- --- Subject to fusion --- --- Since 0.3.0 -consume, consumeC :: Monad m => Consumer a m [a] -consumeC = - loop id - where - loop front = await >>= maybe (return $ front []) (\x -> loop $ front . (x:)) -{-# INLINE consumeC #-} -STREAMING0(consume, consumeC, consumeS) - --- | Group a stream into chunks of a given size. The last chunk may contain --- fewer than n elements. --- --- Subject to fusion --- --- Since 1.2.9 -chunksOf :: Monad m => Int -> Conduit a m [a] -chunksOf n = - start - where - start = await >>= maybe (return ()) (\x -> loop n (x:)) - - loop !count rest = - await >>= maybe (yield (rest [])) go - where - go y - | count > 1 = loop (count - 1) (rest . (y:)) - | otherwise = yield (rest []) >> loop n (y:) - --- | Grouping input according to an equality function. --- --- Subject to fusion --- --- Since 0.3.0 -groupBy, groupByC :: Monad m => (a -> a -> Bool) -> Conduit a m [a] -groupByC f = - start - where - start = await >>= maybe (return ()) (loop id) - - loop rest x = - await >>= maybe (yield (x : rest [])) go - where - go y - | f x y = loop (rest . (y:)) x - | otherwise = yield (x : rest []) >> loop id y -STREAMING(groupBy, groupByC, groupByS, f) - --- | 'groupOn1' is similar to @groupBy id@ --- --- returns a pair, indicating there are always 1 or more items in the grouping. --- This is designed to be converted into a NonEmpty structure --- but it avoids a dependency on another package --- --- > import Data.List.NonEmpty --- > --- > groupOn1 :: (Monad m, Eq b) => (a -> b) -> Conduit a m (NonEmpty a) --- > groupOn1 f = CL.groupOn1 f =$= CL.map (uncurry (:|)) --- --- Subject to fusion --- --- Since 1.1.7 -groupOn1, groupOn1C :: (Monad m, Eq b) - => (a -> b) - -> Conduit a m (a, [a]) -groupOn1C f = - start - where - start = await >>= maybe (return ()) (loop id) - - loop rest x = - await >>= maybe (yield (x, rest [])) go - where - go y - | f x == f y = loop (rest . (y:)) x - | otherwise = yield (x, rest []) >> loop id y -STREAMING(groupOn1, groupOn1C, groupOn1S, f) - --- | Ensure that the inner sink consumes no more than the given number of --- values. Note this this does /not/ ensure that the sink consumes all of those --- values. To get the latter behavior, combine with 'sinkNull', e.g.: --- --- > src $$ do --- > x <- isolate count =$ do --- > x <- someSink --- > sinkNull --- > return x --- > someOtherSink --- > ... --- --- Subject to fusion --- --- Since 0.3.0 -isolate, isolateC :: Monad m => Int -> Conduit a m a -isolateC = - loop - where - loop count | count <= 0 = return () - loop count = await >>= maybe (return ()) (\x -> yield x >> loop (count - 1)) -STREAMING(isolate, isolateC, isolateS, count) - --- | Keep only values in the stream passing a given predicate. --- --- Subject to fusion --- --- Since 0.3.0 -filter, filterC :: Monad m => (a -> Bool) -> Conduit a m a -filterC f = awaitForever $ \i -> when (f i) (yield i) -STREAMING(filter, filterC, filterS, f) - -filterFuseRight :: Monad m => Source m a -> (a -> Bool) -> Source m a -filterFuseRight (CI.ConduitM src) f = CI.ConduitM $ \rest -> let - go (CI.Done ()) = rest () - go (CI.PipeM mp) = CI.PipeM (liftM go mp) - go (CI.Leftover p i) = CI.Leftover (go p) i - go (CI.HaveOutput p c o) - | f o = CI.HaveOutput (go p) c o - | otherwise = go p - go (CI.NeedInput p c) = CI.NeedInput (go . p) (go . c) - in go (src CI.Done) --- Intermediate finalizers are dropped, but this is acceptable: the next --- yielded value would be demanded by downstream in any event, and that new --- finalizer will always override the existing finalizer. -{-# RULES "conduit: source/filter fusion =$=" forall f src. src =$= filter f = filterFuseRight src f #-} -{-# INLINE filterFuseRight #-} - --- | Ignore the remainder of values in the source. Particularly useful when --- combined with 'isolate'. --- --- Subject to fusion --- --- Since 0.3.0 -sinkNull, sinkNullC :: Monad m => Consumer a m () -sinkNullC = awaitForever $ \_ -> return () -{-# INLINE sinkNullC #-} -STREAMING0(sinkNull, sinkNullC, sinkNullS) - -srcSinkNull :: Monad m => Source m a -> m () -srcSinkNull (CI.ConduitM src) = - go (src CI.Done) - where - go (CI.Done ()) = return () - go (CI.PipeM mp) = mp >>= go - go (CI.Leftover p ()) = go p - go (CI.HaveOutput p _ _) = go p - go (CI.NeedInput _ c) = go (c ()) -{-# INLINE srcSinkNull #-} -{-# RULES "conduit: connect to sinkNull" forall src. src $$ sinkNull = srcSinkNull src #-} - --- | A source that outputs no values. Note that this is just a type-restricted --- synonym for 'mempty'. --- --- Subject to fusion --- --- Since 0.3.0 -sourceNull, sourceNullC :: Monad m => Producer m a -sourceNullC = return () -{-# INLINE sourceNullC #-} -STREAMING0(sourceNull, sourceNullC, sourceNullS) - --- | Run a @Pipe@ repeatedly, and output its result value downstream. Stops --- when no more input is available from upstream. --- --- Since 0.5.0 -sequence :: Monad m - => Consumer i m o -- ^ @Pipe@ to run repeatedly - -> Conduit i m o -sequence sink = - self - where - self = awaitForever $ \i -> leftover i >> sink >>= yield diff --git a/benchmarks/optimize-201408.hs b/benchmarks/optimize-201408.hs --- a/benchmarks/optimize-201408.hs +++ b/benchmarks/optimize-201408.hs @@ -9,16 +9,12 @@ import Control.DeepSeq import Control.Monad (foldM) import Control.Monad (when, liftM) -import Control.Monad.Codensity (lowerCodensity) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) -import Criterion.Main +import Control.Monad.IO.Class (liftIO) +import Gauge.Main import Data.Conduit -import Data.Conduit.Internal (ConduitM (..), Pipe (..)) import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.List as CL import qualified Data.Foldable as F -import Data.Functor.Identity (runIdentity) import Data.IORef import Data.List (foldl') import Data.Monoid (mempty) @@ -96,15 +92,15 @@ , TBPure "unboxed vectors" upper0 expected $ \upper -> VU.foldl' (+) 0 (VU.enumFromTo 1 upper) , TBPure "conduit, pure, fold" upper0 expected - $ \upper -> runIdentity $ CL.enumFromTo 1 upper $$ CL.fold (+) 0 + $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.fold (+) 0 , TBPure "conduit, pure, foldM" upper0 expected - $ \upper -> runIdentity $ CL.enumFromTo 1 upper $$ CL.foldM plusM 0 + $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.foldM plusM 0 , TBIO "conduit, IO, fold" expected $ do upper <- readIORef upperRef - CL.enumFromTo 1 upper $$ CL.fold (+) 0 + runConduit $ CL.enumFromTo 1 upper .| CL.fold (+) 0 , TBIO "conduit, IO, foldM" expected $ do upper <- readIORef upperRef - CL.enumFromTo 1 upper $$ CL.foldM plusM 0 + runConduit $ CL.enumFromTo 1 upper .| CL.foldM plusM 0 ] where upper0 = 10000 :: Int @@ -126,26 +122,11 @@ $ VU.map (+ 1) $ VU.map (* 2) $ VU.enumFromTo 1 upper - , TBPure "conduit, connect1" upper0 expected $ \upper -> runIdentity - $ CL.enumFromTo 1 upper - $$ CL.map (* 2) - =$= CL.map (+ 1) - =$= CL.fold (+) 0 - , TBPure "conduit, connect2" upper0 expected $ \upper -> runIdentity - $ CL.enumFromTo 1 upper - =$= CL.map (* 2) - $$ CL.map (+ 1) - =$= CL.fold (+) 0 - , TBPure "conduit, connect3" upper0 expected $ \upper -> runIdentity - $ CL.enumFromTo 1 upper - =$= CL.map (* 2) - =$= CL.map (+ 1) - $$ CL.fold (+) 0 - , TBPure "conduit, inner fuse" upper0 expected $ \upper -> runIdentity + , TBPure "conduit, connect1" upper0 expected $ \upper -> runConduitPure $ CL.enumFromTo 1 upper - =$= (CL.map (* 2) - =$= CL.map (+ 1)) - $$ CL.fold (+) 0 + .| CL.map (* 2) + .| CL.map (+ 1) + .| CL.fold (+) 0 ] where upper0 = 10000 :: Int @@ -157,8 +138,9 @@ monteCarloTB = return $ TBGroup "monte carlo" [ TBIOTest "conduit" closeEnough $ do gen <- MWC.createSystemRandom - successes <- CL.replicateM count (MWC.uniform gen) - $$ CL.fold (\t (x, y) -> + successes <- runConduit + $ CL.replicateM count (MWC.uniform gen) + .| CL.fold (\t (x, y) -> if (x*x + y*(y :: Double) < 1) then t + 1 else t) @@ -290,9 +272,10 @@ swConduitSeq window upperRef t0 f final = do upper <- readIORef upperRef - t <- CL.enumFromTo 1 upper - $= slidingWindowC window - $$ CL.fold f t0 + t <- runConduit + $ CL.enumFromTo 1 upper + .| slidingWindowC window + .| CL.fold f t0 return $! final t swConduitVector :: V.Vector v Int @@ -305,19 +288,20 @@ swConduitVector window upperRef t0 f final = do upper <- readIORef upperRef - t <- CL.enumFromTo 1 upper - $= slidingVectorC window - $$ CL.fold f t0 + t <- runConduit + $ CL.enumFromTo 1 upper + .| slidingVectorC window + .| CL.fold f t0 return $! final t -slidingWindowC :: Monad m => Int -> Conduit a m (Seq.Seq a) +slidingWindowC :: Monad m => Int -> ConduitT a (Seq.Seq a) m () slidingWindowC = slidingWindowCC {-# INLINE [0] slidingWindowC #-} {-# RULES "unstream slidingWindowC" forall i. slidingWindowC i = CI.unstream (CI.streamConduit (slidingWindowCC i) (slidingWindowS i)) #-} -slidingWindowCC :: Monad m => Int -> Conduit a m (Seq.Seq a) +slidingWindowCC :: Monad m => Int -> ConduitT a (Seq.Seq a) m () slidingWindowCC sz = go sz mempty where @@ -356,14 +340,14 @@ in CI.Emit (Right (s', st')) st' {-# INLINE slidingWindowS #-} -slidingVectorC :: V.Vector v a => Int -> Conduit a IO (v a) +slidingVectorC :: V.Vector v a => Int -> ConduitT a (v a) IO () slidingVectorC = slidingVectorCC {-# INLINE [0] slidingVectorC #-} {-# RULES "unstream slidingVectorC" forall i. slidingVectorC i = CI.unstream (CI.streamConduit (slidingVectorCC i) (slidingVectorS i)) #-} -slidingVectorCC :: V.Vector v a => Int -> Conduit a IO (v a) +slidingVectorCC :: V.Vector v a => Int -> ConduitT a (v a) IO () slidingVectorCC sz = do mv <- newBuf mv2 <- newBuf diff --git a/benchmarks/unfused.hs b/benchmarks/unfused.hs --- a/benchmarks/unfused.hs +++ b/benchmarks/unfused.hs @@ -2,12 +2,10 @@ -- Compare low-level, fused, unfused, and partially fused import Data.Conduit import qualified Data.Conduit.List as CL -import Data.Conduit.Internal (Step (..), Stream (..), unstream, StreamConduit (..)) -import Criterion.Main -import Data.Functor.Identity (runIdentity) +import Gauge.Main -- | unfused -enumFromToC :: (Eq a, Monad m, Enum a) => a -> a -> Producer m a +enumFromToC :: (Eq a, Monad m, Enum a) => a -> a -> ConduitT i a m () enumFromToC x0 y = loop x0 where @@ -17,12 +15,12 @@ {-# INLINE enumFromToC #-} -- | unfused -mapC :: Monad m => (a -> b) -> Conduit a m b +mapC :: Monad m => (a -> b) -> ConduitT a b m () mapC f = awaitForever $ yield . f {-# INLINE mapC #-} -- | unfused -foldC :: Monad m => (b -> a -> b) -> b -> Consumer a m b +foldC :: Monad m => (b -> a -> b) -> b -> ConduitT a o m b foldC f = loop where @@ -37,44 +35,43 @@ | otherwise = loop (x + 1) (t + ((x * 2) + 1)) in loop 1 0 , bench "completely fused" $ flip whnf upper0 $ \upper -> - runIdentity + runConduitPure $ CL.enumFromTo 1 upper - $$ CL.map (* 2) - =$ CL.map (+ 1) - =$ CL.fold (+) 0 + .| CL.map (* 2) + .| CL.map (+ 1) + .| CL.fold (+) 0 , bench "runConduit, completely fused" $ flip whnf upper0 $ \upper -> - runIdentity - $ runConduit - $ CL.enumFromTo 1 upper - =$= CL.map (* 2) - =$= CL.map (+ 1) - =$= CL.fold (+) 0 + runConduitPure + $ CL.enumFromTo 1 upper + .| CL.map (* 2) + .| CL.map (+ 1) + .| CL.fold (+) 0 , bench "completely unfused" $ flip whnf upper0 $ \upper -> - runIdentity + runConduitPure $ enumFromToC 1 upper - $$ mapC (* 2) - =$ mapC (+ 1) - =$ foldC (+) 0 + .| mapC (* 2) + .| mapC (+ 1) + .| foldC (+) 0 , bench "beginning fusion" $ flip whnf upper0 $ \upper -> - runIdentity - $ (CL.enumFromTo 1 upper $= CL.map (* 2)) - $$ mapC (+ 1) - =$ foldC (+) 0 + runConduitPure + $ (CL.enumFromTo 1 upper .| CL.map (* 2)) + .| mapC (+ 1) + .| foldC (+) 0 , bench "middle fusion" $ flip whnf upper0 $ \upper -> - runIdentity + runConduitPure $ enumFromToC 1 upper - $$ (CL.map (* 2) =$= CL.map (+ 1)) - =$ foldC (+) 0 + .| (CL.map (* 2) .| CL.map (+ 1)) + .| foldC (+) 0 , bench "ending fusion" $ flip whnf upper0 $ \upper -> - runIdentity + runConduitPure $ enumFromToC 1 upper - $= mapC (* 2) - $$ (CL.map (+ 1) =$ CL.fold (+) 0) + .| mapC (* 2) + .| (CL.map (+ 1) .| CL.fold (+) 0) , bench "performance of CL.enumFromTo without fusion" $ flip whnf upper0 $ \upper -> - runIdentity + runConduitPure $ CL.enumFromTo 1 upper - $= mapC (* 2) - $$ (CL.map (+ 1) =$ CL.fold (+) 0) + .| mapC (* 2) + .| (CL.map (+ 1) .| CL.fold (+) 0) ] where upper0 = 100000 :: Int diff --git a/conduit.cabal b/conduit.cabal --- a/conduit.cabal +++ b/conduit.cabal @@ -1,5 +1,5 @@ Name: conduit -Version: 1.2.13.1 +Version: 1.3.6.1 Synopsis: Streaming data processing library. description: `conduit` is a solution to the streaming data problem, allowing for production, @@ -17,45 +17,64 @@ Maintainer: michael@snoyman.com Category: Data, Conduit Build-type: Simple -Cabal-version: >=1.8 +Cabal-version: >=1.10 Homepage: http://github.com/snoyberg/conduit extra-source-files: test/main.hs + , test/doctests.hs + , test/subdir/dummyfile.txt , README.md , ChangeLog.md , fusion-macros.h Library + default-language: Haskell2010 + hs-source-dirs: src Exposed-modules: Data.Conduit + Data.Conduit.Combinators Data.Conduit.List Data.Conduit.Internal Data.Conduit.Lift Data.Conduit.Internal.Fusion Data.Conduit.Internal.List.Stream + Data.Conduit.Combinators.Stream + Conduit other-modules: Data.Conduit.Internal.Pipe Data.Conduit.Internal.Conduit - Build-depends: base >= 4.5 && < 5 - , resourcet >= 1.1 && < 1.2 - , exceptions >= 0.6 - , lifted-base >= 0.1 - , transformers-base >= 0.4.1 && < 0.5 - , transformers >= 0.2.2 - , transformers-compat >= 0.3 + Data.Conduit.Combinators.Unqualified + Data.Streaming.FileRead + Data.Streaming.Filesystem + Build-depends: base >= 4.12 && < 5 + , resourcet >= 1.2 && < 1.4 + , transformers >= 0.4 , mtl - , mmorph - , monad-control , primitive - if !impl(ghc>=7.9) - build-depends: void >= 0.5.5 - if !impl(ghc>=7.11) - build-depends: semigroups >= 0.16 + , unliftio-core + , exceptions + , mono-traversable >= 1.0.7 + , vector + , bytestring + , text + , filepath + , directory + + if os(windows) + build-depends: Win32 + other-modules: System.Win32File + cpp-options: -DWINDOWS + else + build-depends: unix + ghc-options: -Wall include-dirs: . -test-suite test +test-suite conduit-test + default-language: Haskell2010 hs-source-dirs: test main-is: main.hs other-modules: Data.Conduit.Extra.ZipConduitSpec , Data.Conduit.StreamSpec + , Spec + , StreamSpec type: exitcode-stdio-1.0 cpp-options: -DTEST build-depends: conduit @@ -69,12 +88,19 @@ , exceptions >= 0.6 , safe , split >= 0.2.0.0 - if !impl(ghc>=7.9) - build-depends: void - if !impl(ghc>=7.11) - build-depends: semigroups >= 0.16 + , mono-traversable + , text + , vector + , directory + , bytestring + , silently + , filepath + , unliftio >= 0.2.4.0 ghc-options: -Wall + if os(windows) + cpp-options: -DWINDOWS + --test-suite doctests -- hs-source-dirs: test -- main-is: doctests.hs @@ -94,6 +120,7 @@ -- ghc-options: -Wall -O2 -with-rtsopts=-s benchmark optimize-201408 + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks build-depends: base @@ -104,17 +131,17 @@ , transformers , hspec , mwc-random - , criterion - , kan-extensions + , gauge main-is: optimize-201408.hs ghc-options: -Wall -O2 -rtsopts benchmark unfused + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks build-depends: base , conduit - , criterion + , gauge , transformers main-is: unfused.hs ghc-options: -Wall -O2 -rtsopts diff --git a/src/Conduit.hs b/src/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Conduit.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Your intended one-stop-shop for conduit functionality. +-- This re-exports functions from many commonly used modules. +-- When there is a conflict with standard functions, functions +-- in this module are disambiguated by adding a trailing C +-- (or for chunked functions, replacing a trailing E with CE). +-- This means that the Conduit module can be imported unqualified +-- without causing naming conflicts. +-- +-- For more information on the naming scheme and intended usages of the +-- combinators, please see the "Data.Conduit.Combinators" documentation. +module Conduit + ( -- * Core conduit library + module Data.Conduit + , module Data.Conduit.Lift + -- * Commonly used combinators + , module Data.Conduit.Combinators.Unqualified + -- * Monadic lifting + , MonadIO (..) + , MonadTrans (..) + , MonadThrow (..) + , MonadUnliftIO (..) + , PrimMonad (..) + -- * ResourceT + , MonadResource + , ResourceT + , runResourceT + -- * Acquire + , module Data.Acquire + -- * Pure pipelines + , Identity (..) + ) where + +import Data.Conduit +import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Control.Monad.Primitive (PrimMonad (..), PrimState) +import Data.Conduit.Lift +import Data.Conduit.Combinators.Unqualified +import Data.Functor.Identity (Identity (..)) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), runResourceT, ResourceT) +import Data.Acquire hiding (with) diff --git a/src/Data/Conduit.hs b/src/Data/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +-- | If this is your first time with conduit, you should probably start with +-- the tutorial: +-- . +module Data.Conduit + ( -- * Core interface + -- ** Types + ConduitT + -- *** Deprecated + , Source + , Conduit + , Sink + , ConduitM + -- ** Connect/fuse operators + , (.|) + , connect + , fuse + -- *** Deprecated + , ($$) + , ($=) + , (=$) + , (=$=) + + -- *** Fuse with upstream results + , fuseBoth + , fuseBothMaybe + , fuseUpstream + + -- ** Primitives + , await + , yield + , yieldM + , leftover + , runConduit + , runConduitPure + , runConduitRes + + -- ** Finalization + , bracketP + + -- ** Exception handling + , catchC + , handleC + , tryC + + -- * Generalized conduit types + , Producer + , Consumer + , toProducer + , toConsumer + + -- * Utility functions + , awaitForever + , transPipe + , mapOutput + , mapOutputMaybe + , mapInput + , mapInputM + , mergeSource + , passthroughSink + , sourceToList + + -- * Connect-and-resume + , SealedConduitT + , sealConduitT + , unsealConduitT + , ($$+) + , ($$++) + , ($$+-) + , ($=+) + + -- ** For @Conduit@s + , (=$$+) + , (=$$++) + , (=$$+-) + + -- * Fusion with leftovers + , fuseLeftovers + , fuseReturnLeftovers + + -- * Flushing + , Flush (..) + + -- * Newtype wrappers + -- ** ZipSource + , ZipSource (..) + , sequenceSources + + -- ** ZipSink + , ZipSink (..) + , sequenceSinks + + -- ** ZipConduit + , ZipConduit (..) + , sequenceConduits + + -- * Convenience reexports + , Void -- FIXME consider instead relaxing type of runConduit + ) where + +import Data.Conduit.Internal.Conduit +import Data.Void (Void) +import Data.Functor.Identity (Identity, runIdentity) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Control.Monad.IO.Unlift (MonadUnliftIO) diff --git a/src/Data/Conduit/Combinators.hs b/src/Data/Conduit/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Combinators.hs @@ -0,0 +1,2556 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE BangPatterns #-} +-- | This module is meant as a replacement for Data.Conduit.List. +-- That module follows a naming scheme which was originally inspired +-- by its enumerator roots. This module is meant to introduce a naming +-- scheme which encourages conduit best practices. +-- +-- There are two versions of functions in this module. Those with a trailing +-- E work in the individual elements of a chunk of data, e.g., the bytes of +-- a ByteString, the Chars of a Text, or the Ints of a Vector Int. Those +-- without a trailing E work on unchunked streams. +-- +-- FIXME: discuss overall naming, usage of mono-traversable, etc +-- +-- Mention take (Conduit) vs drop (Consumer) +module Data.Conduit.Combinators + ( -- * Producers + -- ** Pure + yieldMany + , unfold + , enumFromTo + , iterate + , repeat + , replicate + , sourceLazy + + -- ** Monadic + , repeatM + , repeatWhileM + , replicateM + + -- ** I\/O + , sourceFile + , sourceFileBS + , sourceHandle + , sourceHandleUnsafe + , sourceIOHandle + , stdin + , withSourceFile + + -- ** Filesystem + , sourceDirectory + , sourceDirectoryDeep + + -- * Consumers + -- ** Pure + , drop + , dropE + , dropWhile + , dropWhileE + , fold + , foldE + , foldl + , foldl1 + , foldlE + , foldMap + , foldMapE + , foldWhile + , all + , allE + , any + , anyE + , and + , andE + , or + , orE + , asum + , elem + , elemE + , notElem + , notElemE + , sinkLazy + , sinkList + , sinkVector + , sinkVectorN + , sinkLazyBuilder + , sinkNull + , awaitNonNull + , head + , headDef + , headE + , peek + , peekE + , last + , lastDef + , lastE + , length + , lengthE + , lengthIf + , lengthIfE + , maximum + , maximumE + , minimum + , minimumE + , null + , nullE + , sum + , sumE + , product + , productE + , find + + -- ** Monadic + , mapM_ + , mapM_E + , foldM + , foldME + , foldMapM + , foldMapME + + -- ** I\/O + , sinkFile + , sinkFileCautious + , sinkTempFile + , sinkSystemTempFile + , sinkFileBS + , sinkHandle + , sinkIOHandle + , print + , stdout + , stderr + , withSinkFile + , withSinkFileBuilder + , withSinkFileCautious + , sinkHandleBuilder + , sinkHandleFlush + + -- * Transformers + -- ** Pure + , map + , mapE + , omapE + , concatMap + , concatMapE + , take + , takeE + , takeWhile + , takeWhileE + , takeExactly + , takeExactlyE + , concat + , filter + , filterE + , mapWhile + , conduitVector + , scanl + , mapAccumWhile + , concatMapAccum + , intersperse + , slidingWindow + , chunksOfE + , chunksOfExactlyE + + -- ** Monadic + , mapM + , mapME + , omapME + , concatMapM + , filterM + , filterME + , iterM + , scanlM + , mapAccumWhileM + , concatMapAccumM + + -- ** Textual + , encodeUtf8 + , decodeUtf8 + , decodeUtf8Lenient + , line + , lineAscii + , unlines + , unlinesAscii + , takeExactlyUntilE + , linesUnbounded + , linesUnboundedAscii + , splitOnUnboundedE + + -- ** Builders + , builderToByteString + , unsafeBuilderToByteString + , builderToByteStringWith + , builderToByteStringFlush + , builderToByteStringWithFlush + , BufferAllocStrategy + , allNewBuffersStrategy + , reuseBufferStrategy + + -- * Special + , vectorBuilder + , mapAccumS + , peekForever + , peekForeverE + ) where + +-- BEGIN IMPORTS + +import Data.ByteString.Builder (Builder, toLazyByteString, hPutBuilder) +import qualified Data.ByteString.Builder.Internal as BB (flush) +import qualified Data.ByteString.Builder.Extra as BB (runBuilder, Next(Done, More, Chunk)) +import qualified Data.NonNull as NonNull +import qualified Data.Traversable +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Control.Applicative (Alternative(..), (<$>)) +import Control.Exception (catch, throwIO, finally, bracket, try, evaluate) +import Control.Category (Category (..)) +import Control.Monad (unless, when, (>=>), liftM, forever) +import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, withRunInIO) +import Control.Monad.Primitive (PrimMonad, PrimState, unsafePrimToPrim) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow, allocate, throwM) +import Data.Conduit +import Data.Conduit.Internal (ConduitT (..), Pipe (..)) +import qualified Data.Conduit.List as CL +import Data.IORef +import Data.Maybe (fromMaybe, isNothing, isJust) +import Data.Monoid (Monoid (..)) +import Data.MonoTraversable +import qualified Data.Sequences as Seq +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as VM +import Data.Void (absurd) +import Prelude (Bool (..), Eq (..), Int, + Maybe (..), Either (..), Monad (..), Num (..), + Ord (..), fromIntegral, maybe, either, + ($), Functor (..), Enum, seq, Show, Char, + otherwise, Either (..), not, + ($!), succ, FilePath, IO, String) +import Data.Word (Word8) +import qualified Prelude +import qualified System.IO as IO +import System.IO.Error (isDoesNotExistError) +import System.IO.Unsafe (unsafePerformIO) +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import Data.Conduit.Combinators.Stream +import Data.Conduit.Internal.Fusion +import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar, + writeMutVar) +import qualified Data.Streaming.FileRead as FR +import qualified Data.Streaming.Filesystem as F +import GHC.ForeignPtr (mallocPlainForeignPtrBytes, unsafeForeignPtrToPtr) +import Foreign.ForeignPtr (touchForeignPtr, ForeignPtr) +import Foreign.Ptr (Ptr, plusPtr, minusPtr) +import Data.ByteString.Internal (ByteString (PS), mallocByteString) +import System.FilePath ((), (<.>), takeDirectory, takeFileName) +import System.Directory (renameFile, getTemporaryDirectory, removeFile) + +import qualified Data.Sequences as DTE +import Data.Sequences (LazySequence (..)) + +-- Defines INLINE_RULE0, INLINE_RULE, STREAMING0, and STREAMING. +#include "fusion-macros.h" + +-- END IMPORTS + +-- TODO: +-- +-- * The functions sourceRandom* are based on, initReplicate and +-- initRepeat have specialized versions for when they're used with +-- ($$). How does this interact with stream fusion? +-- +-- * Is it possible to implement fusion for vectorBuilder? Since it +-- takes a Sink yielding function as an input, the rewrite rule +-- would need to trigger when that parameter looks something like +-- (\x -> unstream (...)). I don't see anything preventing doing +-- this, but it would be quite a bit of code. + +-- NOTE: Fusion isn't possible for the following operations: +-- +-- * Due to a lack of leftovers: +-- - dropE, dropWhile, dropWhileE +-- - headE +-- - peek, peekE +-- - null, nullE +-- - takeE, takeWhile, takeWhileE +-- - mapWhile +-- - codeWith +-- - line +-- - lineAscii +-- +-- * Due to a use of leftover in a dependency: +-- - Due to "codeWith": encodeBase64, decodeBase64, encodeBase64URL, decodeBase64URL, decodeBase16 +-- - due to "CT.decode": decodeUtf8, decodeUtf8Lenient +-- +-- * Due to lack of resource cleanup (e.g. bracketP): +-- - sourceDirectory +-- - sourceDirectoryDeep +-- - sourceFile +-- +-- * takeExactly / takeExactlyE - no monadic bind. Another way to +-- look at this is that subsequent streams drive stream evaluation, +-- so there's no way for the conduit to guarantee a certain amount +-- of demand from the upstream. + +-- | Yield each of the values contained by the given @MonoFoldable@. +-- +-- This will work on many data structures, including lists, @ByteString@s, and @Vector@s. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +yieldMany, yieldManyC :: (Monad m, MonoFoldable mono) + => mono + -> ConduitT i (Element mono) m () +yieldManyC = ofoldMap yield +{-# INLINE yieldManyC #-} +STREAMING(yieldMany, yieldManyC, yieldManyS, x) + +-- | Generate a producer from a seed value. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +unfold :: Monad m + => (b -> Maybe (a, b)) + -> b + -> ConduitT i a m () +INLINE_RULE(unfold, f x, CL.unfold f x) + +-- | Enumerate from a value to a final value, inclusive, via 'succ'. +-- +-- This is generally more efficient than using @Prelude@\'s @enumFromTo@ and +-- combining with @sourceList@ since this avoids any intermediate data +-- structures. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +enumFromTo :: (Monad m, Enum a, Ord a) => a -> a -> ConduitT i a m () +INLINE_RULE(enumFromTo, f t, CL.enumFromTo f t) + +-- | Produces an infinite stream of repeated applications of f to x. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +iterate :: Monad m => (a -> a) -> a -> ConduitT i a m () +INLINE_RULE(iterate, f t, CL.iterate f t) + +-- | Produce an infinite stream consisting entirely of the given value. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +repeat :: Monad m => a -> ConduitT i a m () +INLINE_RULE(repeat, x, iterate id x) + +-- | Produce a finite stream consisting of n copies of the given value. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +replicate :: Monad m + => Int + -> a + -> ConduitT i a m () +INLINE_RULE(replicate, n x, CL.replicate n x) + +-- | Generate a producer by yielding each of the strict chunks in a @LazySequence@. +-- +-- For more information, see 'toChunks'. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sourceLazy :: (Monad m, LazySequence lazy strict) + => lazy + -> ConduitT i strict m () +INLINE_RULE(sourceLazy, x, yieldMany (toChunks x)) + +-- | Repeatedly run the given action and yield all values it produces. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +repeatM, repeatMC :: Monad m + => m a + -> ConduitT i a m () +repeatMC m = forever $ lift m >>= yield +{-# INLINE repeatMC #-} +STREAMING(repeatM, repeatMC, repeatMS, m) + +-- | Repeatedly run the given action and yield all values it produces, until +-- the provided predicate returns @False@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +repeatWhileM, repeatWhileMC :: Monad m + => m a + -> (a -> Bool) + -> ConduitT i a m () +repeatWhileMC m f = + loop + where + loop = do + x <- lift m + when (f x) $ yield x >> loop +STREAMING(repeatWhileM, repeatWhileMC, repeatWhileMS, m f) + +-- | Perform the given action n times, yielding each result. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +replicateM :: Monad m + => Int + -> m a + -> ConduitT i a m () +INLINE_RULE(replicateM, n m, CL.replicateM n m) + +-- | Stream the contents of a file as binary data. +-- +-- @since 1.3.0 +sourceFile :: MonadResource m + => FilePath + -> ConduitT i S.ByteString m () +sourceFile fp = + bracketP + (FR.openFile fp) + FR.closeFile + loop + where + loop h = do + bs <- liftIO $ FR.readChunk h + unless (S.null bs) $ do + yield bs + loop h + +-- | Stream the contents of a 'IO.Handle' as binary data. Note that this +-- function will /not/ automatically close the @Handle@ when processing +-- completes, since it did not acquire the @Handle@ in the first place. +-- +-- @since 1.3.0 +sourceHandle :: MonadIO m + => IO.Handle + -> ConduitT i S.ByteString m () +sourceHandle h = + loop + where + loop = do + bs <- liftIO (S.hGetSome h defaultChunkSize) + if S.null bs + then return () + else yield bs >> loop + +-- | Same as @sourceHandle@, but instead of allocating a new buffer for each +-- incoming chunk of data, reuses the same buffer. Therefore, the @ByteString@s +-- yielded by this function are not referentially transparent between two +-- different @yield@s. +-- +-- This function will be slightly more efficient than @sourceHandle@ by +-- avoiding allocations and reducing garbage collections, but should only be +-- used if you can guarantee that you do not reuse a @ByteString@ (or any slice +-- thereof) between two calls to @await@. +-- +-- @since 1.3.0 +sourceHandleUnsafe :: MonadIO m => IO.Handle -> ConduitT i ByteString m () +sourceHandleUnsafe handle = do + fptr <- liftIO $ mallocPlainForeignPtrBytes defaultChunkSize + let ptr = unsafeForeignPtrToPtr fptr + loop = do + count <- liftIO $ IO.hGetBuf handle ptr defaultChunkSize + when (count > 0) $ do + yield (PS fptr 0 count) + loop + + loop + + liftIO $ touchForeignPtr fptr + +-- | An alternative to 'sourceHandle'. +-- Instead of taking a pre-opened 'IO.Handle', it takes an action that opens +-- a 'IO.Handle' (in read mode), so that it can open it only when needed +-- and close it as soon as possible. +-- +-- @since 1.3.0 +sourceIOHandle :: MonadResource m + => IO IO.Handle + -> ConduitT i S.ByteString m () +sourceIOHandle alloc = bracketP alloc IO.hClose sourceHandle + +-- | Same as 'sourceFile'. The alternate name is a holdover from an older +-- version, when 'sourceFile' was more polymorphic than it is today. +-- +-- @since 1.3.0 +sourceFileBS :: MonadResource m => FilePath -> ConduitT i ByteString m () +sourceFileBS = sourceFile +{-# INLINE sourceFileBS #-} + +-- | @sourceHandle@ applied to @stdin@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +stdin :: MonadIO m => ConduitT i ByteString m () +INLINE_RULE0(stdin, sourceHandle IO.stdin) + +-- | Stream all incoming data to the given file. +-- +-- @since 1.3.0 +sinkFile :: MonadResource m + => FilePath + -> ConduitT S.ByteString o m () +sinkFile fp = sinkIOHandle (IO.openBinaryFile fp IO.WriteMode) + +-- | Cautious version of 'sinkFile'. The idea here is to stream the +-- values to a temporary file in the same directory of the destination +-- file, and only on successfully writing the entire file, moves it +-- atomically to the destination path. +-- +-- In the event of an exception occurring, the temporary file will be +-- deleted and no move will be made. If the application shuts down +-- without running exception handling (such as machine failure or a +-- SIGKILL), the temporary file will remain and the destination file +-- will be untouched. +-- +-- @since 1.3.0 +sinkFileCautious + :: MonadResource m + => FilePath + -> ConduitM S.ByteString o m () +sinkFileCautious fp = + bracketP (cautiousAcquire fp) cautiousCleanup inner + where + inner (tmpFP, h) = do + sinkHandle h + liftIO $ do + IO.hClose h + renameFile tmpFP fp + +-- | Like 'sinkFileCautious', but uses the @with@ pattern instead of +-- @MonadResource@. +-- +-- @since 1.3.0 +withSinkFileCautious + :: (MonadUnliftIO m, MonadIO n) + => FilePath + -> (ConduitM S.ByteString o n () -> m a) + -> m a +withSinkFileCautious fp inner = + withRunInIO $ \run -> bracket + (cautiousAcquire fp) + cautiousCleanup + (\(tmpFP, h) -> do + a <- run $ inner $ sinkHandle h + IO.hClose h + renameFile tmpFP fp + return a) + +-- | Helper function for Cautious functions above, do not export! +cautiousAcquire :: FilePath -> IO (FilePath, IO.Handle) +cautiousAcquire fp = IO.openBinaryTempFile (takeDirectory fp) (takeFileName fp <.> "tmp") + +-- | Helper function for Cautious functions above, do not export! +cautiousCleanup :: (FilePath, IO.Handle) -> IO () +cautiousCleanup (tmpFP, h) = do + IO.hClose h + removeFile tmpFP `Control.Exception.catch` \e -> + if isDoesNotExistError e + then return () + else throwIO e + +-- | Stream data into a temporary file in the given directory with the +-- given filename pattern, and return the temporary filename. The +-- temporary file will be automatically deleted when exiting the +-- active 'ResourceT' block, if it still exists. +-- +-- @since 1.3.0 +sinkTempFile :: MonadResource m + => FilePath -- ^ temp directory + -> String -- ^ filename pattern + -> ConduitM ByteString o m FilePath +sinkTempFile tmpdir pattern = do + (_releaseKey, (fp, h)) <- allocate + (IO.openBinaryTempFile tmpdir pattern) + (\(fp, h) -> IO.hClose h `finally` (removeFile fp `Control.Exception.catch` \e -> + if isDoesNotExistError e + then return () + else throwIO e)) + sinkHandle h + liftIO $ IO.hClose h + return fp + +-- | Same as 'sinkTempFile', but will use the default temp file +-- directory for the system as the first argument. +-- +-- @since 1.3.0 +sinkSystemTempFile + :: MonadResource m + => String -- ^ filename pattern + -> ConduitM ByteString o m FilePath +sinkSystemTempFile pattern = do + dir <- liftIO getTemporaryDirectory + sinkTempFile dir pattern + +-- | Stream all incoming data to the given 'IO.Handle'. Note that this function +-- does /not/ flush and will /not/ close the @Handle@ when processing completes. +-- +-- @since 1.3.0 +sinkHandle :: MonadIO m + => IO.Handle + -> ConduitT S.ByteString o m () +sinkHandle h = awaitForever (liftIO . S.hPut h) + +-- | Stream incoming builders, executing them directly on the buffer of the +-- given 'IO.Handle'. Note that this function does /not/ automatically close the +-- @Handle@ when processing completes. +-- Pass 'Data.ByteString.Builder.Extra.flush' to flush the buffer. +-- +-- @since 1.3.0 +sinkHandleBuilder :: MonadIO m => IO.Handle -> ConduitM Builder o m () +sinkHandleBuilder h = awaitForever (liftIO . hPutBuilder h) + +-- | Stream incoming @Flush@es, executing them on @IO.Handle@ +-- Note that this function does /not/ automatically close the @Handle@ when +-- processing completes +-- +-- @since 1.3.0 +sinkHandleFlush :: MonadIO m + => IO.Handle + -> ConduitM (Flush S.ByteString) o m () +sinkHandleFlush h = + awaitForever $ \mbs -> liftIO $ + case mbs of + Chunk bs -> S.hPut h bs + Flush -> IO.hFlush h + +-- | An alternative to 'sinkHandle'. +-- Instead of taking a pre-opened 'IO.Handle', it takes an action that opens +-- a 'IO.Handle' (in write mode), so that it can open it only when needed +-- and close it as soon as possible. +-- +-- @since 1.3.0 +sinkIOHandle :: MonadResource m + => IO IO.Handle + -> ConduitT S.ByteString o m () +sinkIOHandle alloc = bracketP alloc IO.hClose sinkHandle + +-- | Like 'IO.withBinaryFile', but provides a source to read bytes from. +-- +-- @since 1.3.0 +withSourceFile + :: (MonadUnliftIO m, MonadIO n) + => FilePath + -> (ConduitM i ByteString n () -> m a) + -> m a +withSourceFile fp inner = + withRunInIO $ \run -> + IO.withBinaryFile fp IO.ReadMode $ + run . inner . sourceHandle + +-- | Like 'IO.withBinaryFile', but provides a sink to write bytes to. +-- +-- @since 1.3.0 +withSinkFile + :: (MonadUnliftIO m, MonadIO n) + => FilePath + -> (ConduitM ByteString o n () -> m a) + -> m a +withSinkFile fp inner = + withRunInIO $ \run -> + IO.withBinaryFile fp IO.WriteMode $ + run . inner . sinkHandle + +-- | Same as 'withSinkFile', but lets you use a 'BB.Builder'. +-- +-- @since 1.3.0 +withSinkFileBuilder + :: (MonadUnliftIO m, MonadIO n) + => FilePath + -> (ConduitM Builder o n () -> m a) + -> m a +withSinkFileBuilder fp inner = + withRunInIO $ \run -> + IO.withBinaryFile fp IO.WriteMode $ \h -> + run $ inner $ CL.mapM_ (liftIO . hPutBuilder h) + +-- | Stream the contents of the given directory, without traversing deeply. +-- +-- This function will return /all/ of the contents of the directory, whether +-- they be files, directories, etc. +-- +-- Note that the generated filepaths will be the complete path, not just the +-- filename. In other words, if you have a directory @foo@ containing files +-- @bar@ and @baz@, and you use @sourceDirectory@ on @foo@, the results will be +-- @foo/bar@ and @foo/baz@. +-- +-- @since 1.3.0 +sourceDirectory :: MonadResource m => FilePath -> ConduitT i FilePath m () +sourceDirectory dir = + bracketP (F.openDirStream dir) F.closeDirStream go + where + go ds = + loop + where + loop = do + mfp <- liftIO $ F.readDirStream ds + case mfp of + Nothing -> return () + Just fp -> do + yield $ dir fp + loop + +-- | Deeply stream the contents of the given directory. +-- +-- This works the same as @sourceDirectory@, but will not return directories at +-- all. This function also takes an extra parameter to indicate whether +-- symlinks will be followed. +-- +-- @since 1.3.0 +sourceDirectoryDeep :: MonadResource m + => Bool -- ^ Follow directory symlinks + -> FilePath -- ^ Root directory + -> ConduitT i FilePath m () +sourceDirectoryDeep followSymlinks = + start + where + start :: MonadResource m => FilePath -> ConduitT i FilePath m () + start dir = sourceDirectory dir .| awaitForever go + + go :: MonadResource m => FilePath -> ConduitT i FilePath m () + go fp = do + ft <- liftIO $ F.getFileType fp + case ft of + F.FTFile -> yield fp + F.FTFileSym -> yield fp + F.FTDirectory -> start fp + F.FTDirectorySym + | followSymlinks -> start fp + | otherwise -> return () + F.FTOther -> return () + +-- | Ignore a certain number of values in the stream. +-- +-- Note: since this function doesn't produce anything, you probably want to +-- use it with ('>>') instead of directly plugging it into a pipeline: +-- +-- >>> runConduit $ yieldMany [1..5] .| drop 2 .| sinkList +-- [] +-- >>> runConduit $ yieldMany [1..5] .| (drop 2 >> sinkList) +-- [3,4,5] +-- +-- @since 1.3.0 +drop :: Monad m + => Int + -> ConduitT a o m () +INLINE_RULE(drop, n, CL.drop n) + +-- | Drop a certain number of elements from a chunked stream. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'drop'. +-- +-- @since 1.3.0 +dropE :: (Monad m, Seq.IsSequence seq) + => Seq.Index seq + -> ConduitT seq o m () +dropE = + loop + where + loop i = if i <= 0 + then return () + else await >>= maybe (return ()) (go i) + + go i sq = do + unless (onull y) $ leftover y + loop i' + where + (x, y) = Seq.splitAt i sq + i' = i - fromIntegral (olength x) +{-# INLINEABLE dropE #-} + +-- | Drop all values which match the given predicate. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'drop'. +-- +-- @since 1.3.0 +dropWhile :: Monad m + => (a -> Bool) + -> ConduitT a o m () +dropWhile f = + loop + where + loop = await >>= maybe (return ()) go + go x = if f x then loop else leftover x +{-# INLINE dropWhile #-} + +-- | Drop all elements in the chunked stream which match the given predicate. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'drop'. +-- +-- @since 1.3.0 +dropWhileE :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) + -> ConduitT seq o m () +dropWhileE f = + loop + where + loop = await >>= maybe (return ()) go + + go sq = + if onull x then loop else leftover x + where + x = Seq.dropWhile f sq +{-# INLINE dropWhileE #-} + +-- | Monoidally combine all values in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +fold :: (Monad m, Monoid a) + => ConduitT a o m a +INLINE_RULE0(fold, CL.foldMap id) + +-- | Monoidally combine all elements in the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldE :: (Monad m, MonoFoldable mono, Monoid (Element mono)) + => ConduitT mono o m (Element mono) +INLINE_RULE0(foldE, CL.fold (\accum mono -> accum `mappend` ofoldMap id mono) mempty) + +-- | A strict left fold. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldl :: Monad m => (a -> b -> a) -> a -> ConduitT b o m a +INLINE_RULE(foldl, f x, CL.fold f x) + +-- | A strict left fold on a chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldlE :: (Monad m, MonoFoldable mono) + => (a -> Element mono -> a) + -> a + -> ConduitT mono o m a +INLINE_RULE(foldlE, f x, CL.fold (ofoldlPrime f) x) + +-- Work around CPP not supporting identifiers with primes... +ofoldlPrime :: MonoFoldable mono => (a -> Element mono -> a) -> a -> mono -> a +ofoldlPrime = ofoldl' + +-- | Apply the provided mapping function and monoidal combine all values. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldMap :: (Monad m, Monoid b) + => (a -> b) + -> ConduitT a o m b +INLINE_RULE(foldMap, f, CL.foldMap f) + +-- | Apply the provided mapping function and monoidal combine all elements of the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldMapE :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> w) + -> ConduitT mono o m w +INLINE_RULE(foldMapE, f, CL.foldMap (ofoldMap f)) + +-- | A strict left fold with no starting value. Returns 'Nothing' +-- when the stream is empty. +-- +-- Subject to fusion +foldl1, foldl1C :: Monad m => (a -> a -> a) -> ConduitT a o m (Maybe a) +foldl1C f = + await >>= maybe (return Nothing) loop + where + loop !prev = await >>= maybe (return $ Just prev) (loop . f prev) +STREAMING(foldl1, foldl1C, foldl1S, f) + +-- | A strict left fold on a chunked stream, with no starting value. +-- Returns 'Nothing' when the stream is empty. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldl1E :: (Monad m, MonoFoldable mono, a ~ Element mono) + => (a -> a -> a) + -> ConduitT mono o m (Maybe a) +INLINE_RULE(foldl1E, f, foldl (foldMaybeNull f) Nothing) + +-- Helper for foldl1E +foldMaybeNull :: (MonoFoldable mono, e ~ Element mono) + => (e -> e -> e) + -> Maybe e + -> mono + -> Maybe e +foldMaybeNull f macc mono = + case (macc, NonNull.fromNullable mono) of + (Just acc, Just nn) -> Just $ ofoldl' f acc nn + (Nothing, Just nn) -> Just $ NonNull.ofoldl1' f nn + _ -> macc +{-# INLINE foldMaybeNull #-} + +-- | Check that all values in the stream return True. +-- +-- Subject to shortcut logic: at the first False, consumption of the stream +-- will stop. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +all, allC :: Monad m + => (a -> Bool) + -> ConduitT a o m Bool +allC f = fmap isNothing $ find (Prelude.not . f) +{-# INLINE allC #-} +STREAMING(all, allC, allS, f) + +-- | Check that all elements in the chunked stream return True. +-- +-- Subject to shortcut logic: at the first False, consumption of the stream +-- will stop. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +allE :: (Monad m, MonoFoldable mono) + => (Element mono -> Bool) + -> ConduitT mono o m Bool +INLINE_RULE(allE, f, all (oall f)) + +-- | Check that at least one value in the stream returns True. +-- +-- Subject to shortcut logic: at the first True, consumption of the stream +-- will stop. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +any, anyC :: Monad m + => (a -> Bool) + -> ConduitT a o m Bool +anyC = fmap isJust . find +{-# INLINE anyC #-} +STREAMING(any, anyC, anyS, f) + +-- | Check that at least one element in the chunked stream returns True. +-- +-- Subject to shortcut logic: at the first True, consumption of the stream +-- will stop. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +anyE :: (Monad m, MonoFoldable mono) + => (Element mono -> Bool) + -> ConduitT mono o m Bool +INLINE_RULE(anyE, f, any (oany f)) + +-- | Are all values in the stream True? +-- +-- Consumption stops once the first False is encountered. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +and :: Monad m => ConduitT Bool o m Bool +INLINE_RULE0(and, all id) + +-- | Are all elements in the chunked stream True? +-- +-- Consumption stops once the first False is encountered. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +andE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) + => ConduitT mono o m Bool +INLINE_RULE0(andE, allE id) + +-- | Are any values in the stream True? +-- +-- Consumption stops once the first True is encountered. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +or :: Monad m => ConduitT Bool o m Bool +INLINE_RULE0(or, any id) + +-- | Are any elements in the chunked stream True? +-- +-- Consumption stops once the first True is encountered. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +orE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) + => ConduitT mono o m Bool +INLINE_RULE0(orE, anyE id) + +-- | 'Alternative'ly combine all values in the stream. +-- +-- @since 1.3.0 +asum :: (Monad m, Alternative f) + => ConduitT (f a) o m (f a) +INLINE_RULE0(asum, foldl (<|>) empty) + +-- | Are any values in the stream equal to the given value? +-- +-- Stops consuming as soon as a match is found. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +elem :: (Monad m, Eq a) => a -> ConduitT a o m Bool +INLINE_RULE(elem, x, any (== x)) + +-- | Are any elements in the chunked stream equal to the given element? +-- +-- Stops consuming as soon as a match is found. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +elemE :: (Monad m, Seq.IsSequence seq, Eq (Element seq)) + => Element seq + -> ConduitT seq o m Bool +INLINE_RULE(elemE, f, any (oelem f)) + +-- | Are no values in the stream equal to the given value? +-- +-- Stops consuming as soon as a match is found. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +notElem :: (Monad m, Eq a) => a -> ConduitT a o m Bool +INLINE_RULE(notElem, x, all (/= x)) + +-- | Are no elements in the chunked stream equal to the given element? +-- +-- Stops consuming as soon as a match is found. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +notElemE :: (Monad m, Seq.IsSequence seq, Eq (Element seq)) + => Element seq + -> ConduitT seq o m Bool +INLINE_RULE(notElemE, x, all (onotElem x)) + +-- | Consume all incoming strict chunks into a lazy sequence. +-- Note that the entirety of the sequence will be resident at memory. +-- +-- This can be used to consume a stream of strict ByteStrings into a lazy +-- ByteString, for example. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkLazy, sinkLazyC :: (Monad m, LazySequence lazy strict) + => ConduitT strict o m lazy +sinkLazyC = (fromChunks . ($ [])) <$> CL.fold (\front next -> front . (next:)) id +{-# INLINE sinkLazyC #-} +STREAMING0(sinkLazy, sinkLazyC, sinkLazyS) + +-- | Consume all values from the stream and return as a list. Note that this +-- will pull all values into memory. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkList :: Monad m => ConduitT a o m [a] +INLINE_RULE0(sinkList, CL.consume) + +-- | Sink incoming values into a vector, growing the vector as necessary to fit +-- more elements. +-- +-- Note that using this function is more memory efficient than @sinkList@ and +-- then converting to a @Vector@, as it avoids intermediate list constructors. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkVector, sinkVectorC :: (V.Vector v a, PrimMonad m) + => ConduitT a o m (v a) +sinkVectorC = do + let initSize = 10 + mv0 <- VM.new initSize + let go maxSize i mv | i >= maxSize = do + let newMax = maxSize * 2 + mv' <- VM.grow mv maxSize + go newMax i mv' + go maxSize i mv = do + mx <- await + case mx of + Nothing -> V.slice 0 i <$> V.unsafeFreeze mv + Just x -> do + VM.write mv i x + go maxSize (i + 1) mv + go initSize 0 mv0 +{-# INLINEABLE sinkVectorC #-} +STREAMING0(sinkVector, sinkVectorC, sinkVectorS) + +-- | Sink incoming values into a vector, up until size @maxSize@. Subsequent +-- values will be left in the stream. If there are less than @maxSize@ values +-- present, returns a @Vector@ of smaller size. +-- +-- Note that using this function is more memory efficient than @sinkList@ and +-- then converting to a @Vector@, as it avoids intermediate list constructors. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkVectorN, sinkVectorNC :: (V.Vector v a, PrimMonad m) + => Int -- ^ maximum allowed size + -> ConduitT a o m (v a) +sinkVectorNC maxSize = do + mv <- VM.new maxSize + let go i | i >= maxSize = V.unsafeFreeze mv + go i = do + mx <- await + case mx of + Nothing -> V.slice 0 i <$> V.unsafeFreeze mv + Just x -> do + VM.write mv i x + go (i + 1) + go 0 +{-# INLINEABLE sinkVectorNC #-} +STREAMING(sinkVectorN, sinkVectorNC, sinkVectorNS, maxSize) + +-- | Same as @sinkBuilder@, but afterwards convert the builder to its lazy +-- representation. +-- +-- Alternatively, this could be considered an alternative to @sinkLazy@, with +-- the following differences: +-- +-- * This function will allow multiple input types, not just the strict version +-- of the lazy structure. +-- +-- * Some buffer copying may occur in this version. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkLazyBuilder, sinkLazyBuilderC :: Monad m => ConduitT Builder o m BL.ByteString +sinkLazyBuilderC = fmap toLazyByteString fold +{-# INLINE sinkLazyBuilderC #-} +STREAMING0(sinkLazyBuilder, sinkLazyBuilderC, sinkLazyBuilderS) + +-- | Consume and discard all remaining values in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sinkNull :: Monad m => ConduitT a o m () +INLINE_RULE0(sinkNull, CL.sinkNull) + +-- | Same as @await@, but discards any leading 'onull' values. +-- +-- @since 1.3.0 +awaitNonNull :: (Monad m, MonoFoldable a) => ConduitT a o m (Maybe (NonNull.NonNull a)) +awaitNonNull = + go + where + go = await >>= maybe (return Nothing) go' + + go' = maybe go (return . Just) . NonNull.fromNullable +{-# INLINE awaitNonNull #-} + +-- | Take a single value from the stream, if available. +-- +-- @since 1.3.0 +head :: Monad m => ConduitT a o m (Maybe a) +head = CL.head + +-- | Same as 'head', but returns a default value if none are available from the stream. +-- +-- @since 1.3.0 +headDef :: Monad m => a -> ConduitT a o m a +headDef a = fromMaybe a <$> head + +-- | Get the next element in the chunked stream. +-- +-- @since 1.3.0 +headE :: (Monad m, Seq.IsSequence seq) => ConduitT seq o m (Maybe (Element seq)) +headE = + loop + where + loop = await >>= maybe (return Nothing) go + go x = + case Seq.uncons x of + Nothing -> loop + Just (y, z) -> do + unless (onull z) $ leftover z + return $ Just y +{-# INLINE headE #-} + +-- | View the next value in the stream without consuming it. +-- +-- @since 1.3.0 +peek :: Monad m => ConduitT a o m (Maybe a) +peek = CL.peek +{-# INLINE peek #-} + +-- | View the next element in the chunked stream without consuming it. +-- +-- @since 1.3.0 +peekE :: (Monad m, MonoFoldable mono) => ConduitT mono o m (Maybe (Element mono)) +peekE = + loop + where + loop = await >>= maybe (return Nothing) go + go x = + case headMay x of + Nothing -> loop + Just y -> do + leftover x + return $ Just y +{-# INLINE peekE #-} + +-- | Retrieve the last value in the stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +last, lastC :: Monad m => ConduitT a o m (Maybe a) +lastC = + await >>= maybe (return Nothing) loop + where + loop prev = await >>= maybe (return $ Just prev) loop +STREAMING0(last, lastC, lastS) + +-- | Same as 'last', but returns a default value if none are available from the stream. +-- +-- @since 1.3.0 +lastDef :: Monad m => a -> ConduitT a o m a +lastDef a = fromMaybe a <$> last + +-- | Retrieve the last element in the chunked stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +lastE, lastEC :: (Monad m, Seq.IsSequence seq) => ConduitT seq o m (Maybe (Element seq)) +lastEC = + awaitNonNull >>= maybe (return Nothing) (loop . NonNull.last) + where + loop prev = awaitNonNull >>= maybe (return $ Just prev) (loop . NonNull.last) +STREAMING0(lastE, lastEC, lastES) + +-- | Count how many values are in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +length :: (Monad m, Num len) => ConduitT a o m len +INLINE_RULE0(length, foldl (\x _ -> x + 1) 0) + +-- | Count how many elements are in the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +lengthE :: (Monad m, Num len, MonoFoldable mono) => ConduitT mono o m len +INLINE_RULE0(lengthE, foldl (\x y -> x + fromIntegral (olength y)) 0) + +-- | Count how many values in the stream pass the given predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +lengthIf :: (Monad m, Num len) => (a -> Bool) -> ConduitT a o m len +INLINE_RULE(lengthIf, f, foldl (\cnt a -> if f a then (cnt + 1) else cnt) 0) + +-- | Count how many elements in the chunked stream pass the given predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +lengthIfE :: (Monad m, Num len, MonoFoldable mono) + => (Element mono -> Bool) -> ConduitT mono o m len +INLINE_RULE(lengthIfE, f, foldlE (\cnt a -> if f a then (cnt + 1) else cnt) 0) + +-- | Get the largest value in the stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +maximum :: (Monad m, Ord a) => ConduitT a o m (Maybe a) +INLINE_RULE0(maximum, foldl1 max) + +-- | Get the largest element in the chunked stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +maximumE :: (Monad m, Seq.IsSequence seq, Ord (Element seq)) => ConduitT seq o m (Maybe (Element seq)) +INLINE_RULE0(maximumE, foldl1E max) + +-- | Get the smallest value in the stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +minimum :: (Monad m, Ord a) => ConduitT a o m (Maybe a) +INLINE_RULE0(minimum, foldl1 min) + +-- | Get the smallest element in the chunked stream, if present. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +minimumE :: (Monad m, Seq.IsSequence seq, Ord (Element seq)) => ConduitT seq o m (Maybe (Element seq)) +INLINE_RULE0(minimumE, foldl1E min) + +-- | True if there are no values in the stream. +-- +-- This function does not modify the stream. +-- +-- @since 1.3.0 +null :: Monad m => ConduitT a o m Bool +null = (maybe True (\_ -> False)) `fmap` peek +{-# INLINE null #-} + +-- | True if there are no elements in the chunked stream. +-- +-- This function may remove empty leading chunks from the stream, but otherwise +-- will not modify it. +-- +-- @since 1.3.0 +nullE :: (Monad m, MonoFoldable mono) + => ConduitT mono o m Bool +nullE = + go + where + go = await >>= maybe (return True) go' + go' x = if onull x then go else leftover x >> return False +{-# INLINE nullE #-} + +-- | Get the sum of all values in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sum :: (Monad m, Num a) => ConduitT a o m a +INLINE_RULE0(sum, foldl (+) 0) + +-- | Get the sum of all elements in the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +sumE :: (Monad m, MonoFoldable mono, Num (Element mono)) => ConduitT mono o m (Element mono) +INLINE_RULE0(sumE, foldlE (+) 0) + +-- | Get the product of all values in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +product :: (Monad m, Num a) => ConduitT a o m a +INLINE_RULE0(product, foldl (*) 1) + +-- | Get the product of all elements in the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +productE :: (Monad m, MonoFoldable mono, Num (Element mono)) => ConduitT mono o m (Element mono) +INLINE_RULE0(productE, foldlE (*) 1) + +-- | Find the first matching value. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +find, findC :: Monad m => (a -> Bool) -> ConduitT a o m (Maybe a) +findC f = + loop + where + loop = await >>= maybe (return Nothing) go + go x = if f x then return (Just x) else loop +{-# INLINE findC #-} +STREAMING(find, findC, findS, f) + +-- | Apply the action to all values in the stream. +-- +-- Note: if you want to /pass/ the values instead of /consuming/ them, use +-- 'iterM' instead. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +mapM_ :: Monad m => (a -> m ()) -> ConduitT a o m () +INLINE_RULE(mapM_, f, CL.mapM_ f) + +-- | Apply the action to all elements in the chunked stream. +-- +-- Note: the same caveat as with 'mapM_' applies. If you don't want to +-- consume the values, you can use 'iterM': +-- +-- > iterM (omapM_ f) +-- +-- Subject to fusion +-- +-- @since 1.3.0 +mapM_E :: (Monad m, MonoFoldable mono) => (Element mono -> m ()) -> ConduitT mono o m () +INLINE_RULE(mapM_E, f, CL.mapM_ (omapM_ f)) + +-- | A monadic strict left fold. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldM :: Monad m => (a -> b -> m a) -> a -> ConduitT b o m a +INLINE_RULE(foldM, f x, CL.foldM f x) + +-- | A monadic strict left fold on a chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldME :: (Monad m, MonoFoldable mono) + => (a -> Element mono -> m a) + -> a + -> ConduitT mono o m a +INLINE_RULE(foldME, f x, foldM (ofoldlM f) x) + +-- | Apply the provided monadic mapping function and monoidal combine all values. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldMapM :: (Monad m, Monoid w) => (a -> m w) -> ConduitT a o m w +INLINE_RULE(foldMapM, f, CL.foldMapM f) + +-- | Apply the provided monadic mapping function and monoidal combine all +-- elements in the chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +foldMapME :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> m w) + -> ConduitT mono o m w +INLINE_RULE(foldMapME, f, CL.foldM (ofoldlM (\accum e -> mappend accum `liftM` f e)) mempty) + +-- | 'sinkFile' specialized to 'ByteString' to help with type +-- inference. +-- +-- @since 1.3.0 +sinkFileBS :: MonadResource m => FilePath -> ConduitT ByteString o m () +sinkFileBS = sinkFile +{-# INLINE sinkFileBS #-} + +-- | Print all incoming values to stdout. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +print :: (Show a, MonadIO m) => ConduitT a o m () +INLINE_RULE0(print, mapM_ (liftIO . Prelude.print)) + +-- | @sinkHandle@ applied to @stdout@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +stdout :: MonadIO m => ConduitT ByteString o m () +INLINE_RULE0(stdout, sinkHandle IO.stdout) + +-- | @sinkHandle@ applied to @stderr@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +stderr :: MonadIO m => ConduitT ByteString o m () +INLINE_RULE0(stderr, sinkHandle IO.stderr) + +-- | Apply a transformation to all values in a stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +map :: Monad m => (a -> b) -> ConduitT a b m () +INLINE_RULE(map, f, CL.map f) + +-- | Apply a transformation to all elements in a chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +mapE :: (Monad m, Functor f) => (a -> b) -> ConduitT (f a) (f b) m () +INLINE_RULE(mapE, f, CL.map (fmap f)) + +-- | Apply a monomorphic transformation to all elements in a chunked stream. +-- +-- Unlike @mapE@, this will work on types like @ByteString@ and @Text@ which +-- are @MonoFunctor@ but not @Functor@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +omapE :: (Monad m, MonoFunctor mono) => (Element mono -> Element mono) -> ConduitT mono mono m () +INLINE_RULE(omapE, f, CL.map (omap f)) + +-- | Apply the function to each value in the stream, resulting in a foldable +-- value (e.g., a list). Then yield each of the individual values in that +-- foldable value separately. +-- +-- Generalizes concatMap, mapMaybe, and mapFoldable. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concatMap, concatMapC :: (Monad m, MonoFoldable mono) + => (a -> mono) + -> ConduitT a (Element mono) m () +concatMapC f = awaitForever (yieldMany . f) +{-# INLINE concatMapC #-} +STREAMING(concatMap, concatMapC, concatMapS, f) + +-- | Apply the function to each element in the chunked stream, resulting in a +-- foldable value (e.g., a list). Then yield each of the individual values in +-- that foldable value separately. +-- +-- Generalizes concatMap, mapMaybe, and mapFoldable. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concatMapE :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> w) + -> ConduitT mono w m () +INLINE_RULE(concatMapE, f, CL.map (ofoldMap f)) + +-- | Stream up to n number of values downstream. +-- +-- Note that, if downstream terminates early, not all values will be consumed. +-- If you want to force /exactly/ the given number of values to be consumed, +-- see 'takeExactly'. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +take :: Monad m => Int -> ConduitT a a m () +INLINE_RULE(take, n, CL.isolate n) + +-- | Stream up to n number of elements downstream in a chunked stream. +-- +-- Note that, if downstream terminates early, not all values will be consumed. +-- If you want to force /exactly/ the given number of values to be consumed, +-- see 'takeExactlyE'. +-- +-- @since 1.3.0 +takeE :: (Monad m, Seq.IsSequence seq) + => Seq.Index seq + -> ConduitT seq seq m () +takeE = + loop + where + loop i = if i <= 0 + then return () + else await >>= maybe (return ()) (go i) + + go i sq = do + unless (onull x) $ yield x + unless (onull y) $ leftover y + loop i' + where + (x, y) = Seq.splitAt i sq + i' = i - fromIntegral (olength x) +{-# INLINEABLE takeE #-} + +-- | Stream all values downstream that match the given predicate. +-- +-- Same caveats regarding downstream termination apply as with 'take'. +-- +-- @since 1.3.0 +takeWhile :: Monad m + => (a -> Bool) + -> ConduitT a a m () +takeWhile f = + loop + where + loop = await >>= maybe (return ()) go + go x = if f x + then yield x >> loop + else leftover x +{-# INLINE takeWhile #-} + +-- | Stream all elements downstream that match the given predicate in a chunked stream. +-- +-- Same caveats regarding downstream termination apply as with 'takeE'. +-- +-- @since 1.3.0 +takeWhileE :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) + -> ConduitT seq seq m () +takeWhileE f = + loop + where + loop = await >>= maybe (return ()) go + + go sq = do + unless (onull x) $ yield x + if onull y + then loop + else leftover y + where + (x, y) = Seq.span f sq +{-# INLINE takeWhileE #-} + +-- | Consume precisely the given number of values and feed them downstream. +-- +-- This function is in contrast to 'take', which will only consume up to the +-- given number of values, and will terminate early if downstream terminates +-- early. This function will discard any additional values in the stream if +-- they are unconsumed. +-- +-- Note that this function takes a downstream @ConduitT@ as a parameter, as +-- opposed to working with normal fusion. For more information, see +-- , the section +-- titled \"pipes and conduit: isolate\". +-- +-- @since 1.3.0 +takeExactly :: Monad m + => Int + -> ConduitT a b m r + -> ConduitT a b m r +takeExactly count inner = take count .| do + r <- inner + CL.sinkNull + return r + +-- | Same as 'takeExactly', but for chunked streams. +-- +-- @since 1.3.0 +takeExactlyE :: (Monad m, Seq.IsSequence a) + => Seq.Index a + -> ConduitT a b m r + -> ConduitT a b m r +takeExactlyE count inner = takeE count .| do + r <- inner + CL.sinkNull + return r +{-# INLINE takeExactlyE #-} + +-- | Flatten out a stream by yielding the values contained in an incoming +-- @MonoFoldable@ as individually yielded values. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concat, concatC :: (Monad m, MonoFoldable mono) + => ConduitT mono (Element mono) m () +concatC = awaitForever yieldMany +STREAMING0(concat, concatC, concatS) + +-- | Keep only values in the stream passing a given predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +filter :: Monad m => (a -> Bool) -> ConduitT a a m () +INLINE_RULE(filter, f, CL.filter f) + +-- | Keep only elements in the chunked stream passing a given predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +filterE :: (Seq.IsSequence seq, Monad m) => (Element seq -> Bool) -> ConduitT seq seq m () +INLINE_RULE(filterE, f, CL.map (Seq.filter f)) + +-- | Map values as long as the result is @Just@. +-- +-- @since 1.3.0 +mapWhile :: Monad m => (a -> Maybe b) -> ConduitT a b m () +mapWhile f = + loop + where + loop = await >>= maybe (return ()) go + go x = + case f x of + Just y -> yield y >> loop + Nothing -> leftover x +{-# INLINE mapWhile #-} + +-- | Break up a stream of values into vectors of size n. The final vector may +-- be smaller than n if the total number of values is not a strict multiple of +-- n. No empty vectors will be yielded. +-- +-- @since 1.3.0 +conduitVector :: (V.Vector v a, PrimMonad m) + => Int -- ^ maximum allowed size + -> ConduitT a (v a) m () +conduitVector size = + loop + where + loop = do + v <- sinkVectorN size + unless (V.null v) $ do + yield v + loop +{-# INLINE conduitVector #-} + +-- | Analog of 'Prelude.scanl' for lists. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +scanl, scanlC :: Monad m => (a -> b -> a) -> a -> ConduitT b a m () +scanlC f = + loop + where + loop seed = + await >>= maybe (yield seed) go + where + go b = do + let seed' = f seed b + seed' `seq` yield seed + loop seed' +STREAMING(scanl, scanlC, scanlS, f x) + +-- | 'mapWhile' with a break condition dependent on a strict accumulator. +-- Equivalently, 'CL.mapAccum' as long as the result is @Right@. Instead of +-- producing a leftover, the breaking input determines the resulting +-- accumulator via @Left@. +-- +-- Subject to fusion +mapAccumWhile, mapAccumWhileC :: Monad m => (a -> s -> Either s (s, b)) -> s -> ConduitT a b m s +mapAccumWhileC f = + loop + where + loop !s = await >>= maybe (return s) go + where + go a = either (return $!) (\(s', b) -> yield b >> loop s') $ f a s +{-# INLINE mapAccumWhileC #-} +STREAMING(mapAccumWhile, mapAccumWhileC, mapAccumWhileS, f s) + + +-- | Specialized version of 'mapAccumWhile' that does not provide values downstream. +-- +-- @since 1.3.4 +foldWhile :: Monad m => (a -> s -> Either e s) -> s -> ConduitT a o m (Either e s) +foldWhile f = loop + where + loop !s = await >>= maybe (return $ Right s) go + where + go a = either (return . Left $!) loop $ f a s +{-# INLINE foldWhile #-} + + +-- | 'concatMap' with an accumulator. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concatMapAccum :: Monad m => (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m () +INLINE_RULE0(concatMapAccum, CL.concatMapAccum) + +-- | Insert the given value between each two values in the stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +intersperse, intersperseC :: Monad m => a -> ConduitT a a m () +intersperseC x = + await >>= omapM_ go + where + go y = yield y >> concatMap (\z -> [x, z]) +STREAMING(intersperse, intersperseC, intersperseS, x) + +-- | Sliding window of values +-- 1,2,3,4,5 with window size 2 gives +-- [1,2],[2,3],[3,4],[4,5] +-- +-- Best used with structures that support O(1) snoc. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +slidingWindow, slidingWindowC :: (Monad m, Seq.IsSequence seq, Element seq ~ a) => Int -> ConduitT a seq m () +slidingWindowC sz = go (max 1 sz) mempty + where goContinue st = await >>= + maybe (return ()) + (\x -> do + let st' = Seq.snoc st x + yield st' >> goContinue (Seq.unsafeTail st') + ) + go 0 st = yield st >> goContinue (Seq.unsafeTail st) + go !n st = CL.head >>= \m -> + case m of + Nothing -> yield st + Just x -> go (n-1) (Seq.snoc st x) +STREAMING(slidingWindow, slidingWindowC, slidingWindowS, sz) + + +-- | Split input into chunk of size 'chunkSize' +-- +-- The last element may be smaller than the 'chunkSize' (see also +-- 'chunksOfExactlyE' which will not yield this last element) +-- +-- @since 1.3.0 +chunksOfE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> ConduitT seq seq m () +chunksOfE chunkSize = chunksOfExactlyE chunkSize >> (await >>= maybe (return ()) yield) + +-- | Split input into chunk of size 'chunkSize' +-- +-- If the input does not split into chunks exactly, the remainder will be +-- leftover (see also 'chunksOfE') +-- +-- @since 1.3.0 +chunksOfExactlyE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> ConduitT seq seq m () +chunksOfExactlyE chunkSize = await >>= maybe (return ()) start + where + start b + | onull b = chunksOfExactlyE chunkSize + | Seq.lengthIndex b < chunkSize = continue (Seq.lengthIndex b) [b] + | otherwise = let (first,rest) = Seq.splitAt chunkSize b in + yield first >> start rest + continue !sofar bs = do + next <- await + case next of + Nothing -> leftover (mconcat $ Prelude.reverse bs) + Just next' -> + let !sofar' = Seq.lengthIndex next' + sofar + bs' = next':bs + in if sofar' < chunkSize + then continue sofar' bs' + else start (mconcat (Prelude.reverse bs')) + +-- | Apply a monadic transformation to all values in a stream. +-- +-- If you do not need the transformed values, and instead just want the monadic +-- side-effects of running the action, see 'mapM_'. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +mapM :: Monad m => (a -> m b) -> ConduitT a b m () +INLINE_RULE(mapM, f, CL.mapM f) + +-- | Apply a monadic transformation to all elements in a chunked stream. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +mapME :: (Monad m, Data.Traversable.Traversable f) => (a -> m b) -> ConduitT (f a) (f b) m () +INLINE_RULE(mapME, f, CL.mapM (Data.Traversable.mapM f)) + +-- | Apply a monadic monomorphic transformation to all elements in a chunked stream. +-- +-- Unlike @mapME@, this will work on types like @ByteString@ and @Text@ which +-- are @MonoFunctor@ but not @Functor@. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +omapME :: (Monad m, MonoTraversable mono) + => (Element mono -> m (Element mono)) + -> ConduitT mono mono m () +INLINE_RULE(omapME, f, CL.mapM (omapM f)) + +-- | Apply the monadic function to each value in the stream, resulting in a +-- foldable value (e.g., a list). Then yield each of the individual values in +-- that foldable value separately. +-- +-- Generalizes concatMapM, mapMaybeM, and mapFoldableM. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concatMapM, concatMapMC :: (Monad m, MonoFoldable mono) + => (a -> m mono) + -> ConduitT a (Element mono) m () +concatMapMC f = awaitForever (lift . f >=> yieldMany) +STREAMING(concatMapM, concatMapMC, concatMapMS, f) + +-- | Keep only values in the stream passing a given monadic predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +filterM, filterMC :: Monad m + => (a -> m Bool) + -> ConduitT a a m () +filterMC f = + awaitForever go + where + go x = do + b <- lift $ f x + when b $ yield x +STREAMING(filterM, filterMC, filterMS, f) + +-- | Keep only elements in the chunked stream passing a given monadic predicate. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +filterME :: (Monad m, Seq.IsSequence seq) => (Element seq -> m Bool) -> ConduitT seq seq m () +INLINE_RULE(filterME, f, CL.mapM (Seq.filterM f)) + +-- | Apply a monadic action on all values in a stream. +-- +-- This @Conduit@ can be used to perform a monadic side-effect for every +-- value, whilst passing the value through the @Conduit@ as-is. +-- +-- > iterM f = mapM (\a -> f a >>= \() -> return a) +-- +-- Subject to fusion +-- +-- @since 1.3.0 +iterM :: Monad m => (a -> m ()) -> ConduitT a a m () +INLINE_RULE(iterM, f, CL.iterM f) + +-- | Analog of 'Prelude.scanl' for lists, monadic. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +scanlM, scanlMC :: Monad m => (a -> b -> m a) -> a -> ConduitT b a m () +scanlMC f = + loop + where + loop seed = + await >>= maybe (yield seed) go + where + go b = do + seed' <- lift $ f seed b + seed' `seq` yield seed + loop seed' +STREAMING(scanlM, scanlMC, scanlMS, f x) + +-- | Monadic `mapAccumWhile`. +-- +-- Subject to fusion +mapAccumWhileM, mapAccumWhileMC :: Monad m => (a -> s -> m (Either s (s, b))) -> s -> ConduitT a b m s +mapAccumWhileMC f = + loop + where + loop !s = await >>= maybe (return s) go + where + go a = lift (f a s) >>= either (return $!) (\(s', b) -> yield b >> loop s') +{-# INLINE mapAccumWhileMC #-} +STREAMING(mapAccumWhileM, mapAccumWhileMC, mapAccumWhileMS, f s) + +-- | 'concatMapM' with an accumulator. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +concatMapAccumM :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> ConduitT a b m () +INLINE_RULE(concatMapAccumM, f x, CL.concatMapAccumM f x) + +-- | Encode a stream of text as UTF8. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +encodeUtf8 :: (Monad m, DTE.Utf8 text binary) => ConduitT text binary m () +INLINE_RULE0(encodeUtf8, map DTE.encodeUtf8) + +-- | Decode a stream of binary data as UTF8. +-- +-- @since 1.3.0 +decodeUtf8 :: MonadThrow m => ConduitT ByteString Text m () +decodeUtf8 = + loop TE.streamDecodeUtf8 + where + loop parse = + await >>= maybe done go + where + parse' = unsafePerformIO . try . evaluate . parse + done = + case parse' mempty of + Left e -> throwM (e :: TEE.UnicodeException) + Right (TE.Some t bs _) -> do + unless (T.null t) (yield t) + unless (S.null bs) (yield $ T.replicate (S.length bs) (T.singleton '\xFFFD')) + + go bs = do + case parse' bs of + Left e -> do + leftover bs + throwM (e :: TEE.UnicodeException) + Right (TE.Some t _ next) -> do + unless (T.null t) (yield t) + loop next + +-- | Decode a stream of binary data as UTF8, replacing any invalid bytes with +-- the Unicode replacement character. +-- +-- @since 1.3.0 +decodeUtf8Lenient :: Monad m => ConduitT ByteString Text m () +decodeUtf8Lenient = + loop (TE.streamDecodeUtf8With TEE.lenientDecode) + where + loop parse = + await >>= maybe done go + where + done = do + let TE.Some t bs _ = parse mempty + unless (T.null t) (yield t) + unless (S.null bs) (yield $ T.replicate (S.length bs) (T.singleton '\xFFFD')) + + go bs = do + let TE.Some t _ next = parse bs + unless (T.null t) (yield t) + loop next + +-- | Stream in the entirety of a single line. +-- +-- Like @takeExactly@, this will consume the entirety of the line regardless of +-- the behavior of the inner Conduit. +-- +-- @since 1.3.0 +line :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) + => ConduitT seq o m r + -> ConduitT seq o m r +line = takeExactlyUntilE (== '\n') +{-# INLINE line #-} + +-- | Same as 'line', but operates on ASCII/binary data. +-- +-- @since 1.3.0 +lineAscii :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) + => ConduitT seq o m r + -> ConduitT seq o m r +lineAscii = takeExactlyUntilE (== 10) +{-# INLINE lineAscii #-} + +-- | Stream in the chunked input until an element matches a predicate. +-- +-- Like @takeExactly@, this will consume the entirety of the prefix +-- regardless of the behavior of the inner Conduit. +takeExactlyUntilE :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) + -> ConduitT seq o m r + -> ConduitT seq o m r +takeExactlyUntilE f inner = + loop .| do + x <- inner + sinkNull + return x + where + loop = await >>= omapM_ go + go t = + if onull y + then yield x >> loop + else do + unless (onull x) $ yield x + let y' = Seq.drop 1 y + unless (onull y') $ leftover y' + where + (x, y) = Seq.break f t +{-# INLINE takeExactlyUntilE #-} + +-- | Insert a newline character after each incoming chunk of data. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +unlines :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) => ConduitT seq seq m () +INLINE_RULE0(unlines, concatMap (:[Seq.singleton '\n'])) + +-- | Same as 'unlines', but operates on ASCII/binary data. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +unlinesAscii :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) => ConduitT seq seq m () +INLINE_RULE0(unlinesAscii, concatMap (:[Seq.singleton 10])) + +-- | Split a stream of arbitrarily-chunked data, based on a predicate +-- on elements. Elements that satisfy the predicate will cause chunks +-- to be split, and aren't included in these output chunks. Note +-- that, if you have unknown or untrusted input, this function is +-- /unsafe/, since it would allow an attacker to form chunks of +-- massive length and exhaust memory. +splitOnUnboundedE, splitOnUnboundedEC :: (Monad m, Seq.IsSequence seq) => (Element seq -> Bool) -> ConduitT seq seq m () +splitOnUnboundedEC f = + start + where + start = await >>= maybe (return ()) (loop id) + + loop bldr t = + if onull y + then do + mt <- await + case mt of + Nothing -> let finalChunk = mconcat $ bldr [t] + in unless (onull finalChunk) $ yield finalChunk + Just t' -> loop (bldr . (t:)) t' + else yield (mconcat $ bldr [x]) >> loop id (Seq.drop 1 y) + where + (x, y) = Seq.break f t +STREAMING(splitOnUnboundedE, splitOnUnboundedEC, splitOnUnboundedES, f) + +-- | Convert a stream of arbitrarily-chunked textual data into a stream of data +-- where each chunk represents a single line. Note that, if you have +-- unknown or untrusted input, this function is /unsafe/, since it would allow an +-- attacker to form lines of massive length and exhaust memory. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +linesUnbounded :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) + => ConduitT seq seq m () +INLINE_RULE0(linesUnbounded, splitOnUnboundedE (== '\n')) + +-- | Same as 'linesUnbounded', but for ASCII/binary data. +-- +-- Subject to fusion +-- +-- @since 1.3.0 +linesUnboundedAscii :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) + => ConduitT seq seq m () +INLINE_RULE0(linesUnboundedAscii, splitOnUnboundedE (== 10)) + +-- | Incrementally execute builders and pass on the filled chunks as +-- bytestrings. +-- +-- @since 1.3.0 +builderToByteString :: PrimMonad m => ConduitT Builder S.ByteString m () +builderToByteString = builderToByteStringWith defaultStrategy +{-# INLINE builderToByteString #-} + +-- | Same as 'builderToByteString', but input and output are wrapped in +-- 'Flush'. +-- +-- @since 1.3.0 +builderToByteStringFlush :: PrimMonad m + => ConduitT (Flush Builder) (Flush S.ByteString) m () +builderToByteStringFlush = builderToByteStringWithFlush defaultStrategy +{-# INLINE builderToByteStringFlush #-} + +-- | Incrementally execute builders on the given buffer and pass on the filled +-- chunks as bytestrings. Note that, if the given buffer is too small for the +-- execution of a build step, a larger one will be allocated. +-- +-- WARNING: This conduit yields bytestrings that are NOT +-- referentially transparent. Their content will be overwritten as soon +-- as control is returned from the inner sink! +-- +-- @since 1.3.0 +unsafeBuilderToByteString :: PrimMonad m + => ConduitT Builder S.ByteString m () +unsafeBuilderToByteString = + builderToByteStringWith (reuseBufferStrategy (allocBuffer defaultChunkSize)) +{-# INLINE unsafeBuilderToByteString #-} + + +-- | A conduit that incrementally executes builders and passes on the +-- filled chunks as bytestrings to an inner sink. +-- +-- INV: All bytestrings passed to the inner sink are non-empty. +-- +-- @since 1.3.0 +builderToByteStringWith :: PrimMonad m + => BufferAllocStrategy + -> ConduitT Builder S.ByteString m () +builderToByteStringWith = + bbhelper (liftM (fmap Chunk) await) yield' + where + yield' Flush = return () + yield' (Chunk bs) = yield bs +{-# INLINE builderToByteStringWith #-} + +-- | +-- +-- @since 1.3.0 +builderToByteStringWithFlush + :: PrimMonad m + => BufferAllocStrategy + -> ConduitT (Flush Builder) (Flush S.ByteString) m () +builderToByteStringWithFlush = bbhelper await yield +{-# INLINE builderToByteStringWithFlush #-} + +bbhelper + :: PrimMonad m + => m (Maybe (Flush Builder)) + -> (Flush S.ByteString -> m ()) + -> BufferAllocStrategy + -> m () +bbhelper await' yield' strat = do + (recv, finish) <- unsafePrimToPrim $ newByteStringBuilderRecv strat + let loop = await' >>= maybe finish' cont + finish' = do + mbs <- unsafePrimToPrim finish + maybe (return ()) (yield' . Chunk) mbs + cont fbuilder = do + let builder = + case fbuilder of + Flush -> BB.flush + Chunk b -> b + popper <- unsafePrimToPrim $ recv builder + let cont' = do + bs <- unsafePrimToPrim popper + unless (S.null bs) $ do + yield' (Chunk bs) + cont' + cont' + case fbuilder of + Flush -> yield' Flush + Chunk _ -> return () + loop + loop +{-# INLINE bbhelper #-} + +-- | Provides a series of @ByteString@s until empty, at which point it provides +-- an empty @ByteString@. +-- +-- @since 1.3.0 +-- +type BuilderPopper = IO S.ByteString + +type BuilderRecv = Builder -> IO BuilderPopper + +type BuilderFinish = IO (Maybe S.ByteString) + +newByteStringBuilderRecv :: BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish) +newByteStringBuilderRecv (ioBufInit, nextBuf) = do + refBuf <- newIORef ioBufInit + return (push refBuf, finish refBuf) + where + finish refBuf = do + ioBuf <- readIORef refBuf + buf <- ioBuf + return $ unsafeFreezeNonEmptyBuffer buf + + push refBuf builder = do + refWri <- newIORef $ Left $ BB.runBuilder builder + return $ popper refBuf refWri + + popper refBuf refWri = do + ioBuf <- readIORef refBuf + ebWri <- readIORef refWri + case ebWri of + Left bWri -> do + !buf@(Buffer _ _ op ope) <- ioBuf + (bytes, next) <- bWri op (ope `minusPtr` op) + let op' = op `plusPtr` bytes + case next of + BB.Done -> do + writeIORef refBuf $ return $ updateEndOfSlice buf op' + return S.empty + BB.More minSize bWri' -> do + let buf' = updateEndOfSlice buf op' + {-# INLINE cont #-} + cont mbs = do + -- sequencing the computation of the next buffer + -- construction here ensures that the reference to the + -- foreign pointer `fp` is lost as soon as possible. + ioBuf' <- nextBuf minSize buf' + writeIORef refBuf ioBuf' + writeIORef refWri $ Left bWri' + case mbs of + Just bs | not $ S.null bs -> return bs + _ -> popper refBuf refWri + cont $ unsafeFreezeNonEmptyBuffer buf' + BB.Chunk bs bWri' -> do + let buf' = updateEndOfSlice buf op' + let yieldBS = do + nextBuf 1 buf' >>= writeIORef refBuf + writeIORef refWri $ Left bWri' + if S.null bs + then popper refBuf refWri + else return bs + case unsafeFreezeNonEmptyBuffer buf' of + Nothing -> yieldBS + Just bs' -> do + writeIORef refWri $ Right yieldBS + return bs' + Right action -> action + +-- | A buffer @Buffer fpbuf p0 op ope@ describes a buffer with the underlying +-- byte array @fpbuf..ope@, the currently written slice @p0..op@ and the free +-- space @op..ope@. +-- +-- @since 1.3.0 +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice + {-# UNPACK #-} !(Ptr Word8) -- next free byte + {-# UNPACK #-} !(Ptr Word8) -- first byte after buffer + +-- | Convert the buffer to a bytestring. This operation is unsafe in the sense +-- that created bytestring shares the underlying byte array with the buffer. +-- Hence, depending on the later use of this buffer (e.g., if it gets reset and +-- filled again) referential transparency may be lost. +-- +-- @since 1.3.0 +-- +{-# INLINE unsafeFreezeBuffer #-} +unsafeFreezeBuffer :: Buffer -> S.ByteString +unsafeFreezeBuffer (Buffer fpbuf p0 op _) = + PS fpbuf (p0 `minusPtr` unsafeForeignPtrToPtr fpbuf) (op `minusPtr` p0) + +-- | Convert a buffer to a non-empty bytestring. See 'unsafeFreezeBuffer' for +-- the explanation of why this operation may be unsafe. +-- +-- @since 1.3.0 +-- +{-# INLINE unsafeFreezeNonEmptyBuffer #-} +unsafeFreezeNonEmptyBuffer :: Buffer -> Maybe S.ByteString +unsafeFreezeNonEmptyBuffer buf + | sliceSize buf <= 0 = Nothing + | otherwise = Just $ unsafeFreezeBuffer buf + +-- | Update the end of slice pointer. +-- +-- @since 1.3.0 +-- +{-# INLINE updateEndOfSlice #-} +updateEndOfSlice :: Buffer -- Old buffer + -> Ptr Word8 -- New end of slice + -> Buffer -- Updated buffer +updateEndOfSlice (Buffer fpbuf p0 _ ope) op' = Buffer fpbuf p0 op' ope + +-- | The size of the written slice in the buffer. +-- +-- @since 1.3.0 +-- +sliceSize :: Buffer -> Int +sliceSize (Buffer _ p0 op _) = op `minusPtr` p0 + +-- | A buffer allocation strategy @(buf0, nextBuf)@ specifies the initial +-- buffer to use and how to compute a new buffer @nextBuf minSize buf@ with at +-- least size @minSize@ from a filled buffer @buf@. The double nesting of the +-- @IO@ monad helps to ensure that the reference to the filled buffer @buf@ is +-- lost as soon as possible, but the new buffer doesn't have to be allocated +-- too early. +-- +-- @since 1.3.0 +type BufferAllocStrategy = (IO Buffer, Int -> Buffer -> IO (IO Buffer)) + +-- | Safe default: allocate new buffers of default chunk size +-- +-- @since 1.3.0 +defaultStrategy :: BufferAllocStrategy +defaultStrategy = allNewBuffersStrategy defaultChunkSize + +-- | The simplest buffer allocation strategy: whenever a buffer is requested, +-- allocate a new one that is big enough for the next build step to execute. +-- +-- NOTE that this allocation strategy may spill quite some memory upon direct +-- insertion of a bytestring by the builder. Thats no problem for garbage +-- collection, but it may lead to unreasonably high memory consumption in +-- special circumstances. +-- +-- @since 1.3.0 +allNewBuffersStrategy :: Int -- Minimal buffer size. + -> BufferAllocStrategy +allNewBuffersStrategy bufSize = + ( allocBuffer bufSize + , \reqSize _ -> return (allocBuffer (max reqSize bufSize)) ) + +-- | An unsafe, but possibly more efficient buffer allocation strategy: +-- reuse the buffer, if it is big enough for the next build step to execute. +-- +-- @since 1.3.0 +reuseBufferStrategy :: IO Buffer + -> BufferAllocStrategy +reuseBufferStrategy buf0 = + (buf0, tryReuseBuffer) + where + tryReuseBuffer reqSize buf + | bufferSize buf >= reqSize = return $ return (reuseBuffer buf) + | otherwise = return $ allocBuffer reqSize + +-- | The size of the whole byte array underlying the buffer. +-- +-- @since 1.3.0 +-- +bufferSize :: Buffer -> Int +bufferSize (Buffer fpbuf _ _ ope) = + ope `minusPtr` unsafeForeignPtrToPtr fpbuf + +-- | @allocBuffer size@ allocates a new buffer of size @size@. +-- +-- @since 1.3.0 +-- +{-# INLINE allocBuffer #-} +allocBuffer :: Int -> IO Buffer +allocBuffer size = do + fpbuf <- mallocByteString size + let !pbuf = unsafeForeignPtrToPtr fpbuf + return $! Buffer fpbuf pbuf pbuf (pbuf `plusPtr` size) + +-- | Resets the beginning of the next slice and the next free byte such that +-- the whole buffer can be filled again. +-- +-- @since 1.3.0 +-- +{-# INLINE reuseBuffer #-} +reuseBuffer :: Buffer -> Buffer +reuseBuffer (Buffer fpbuf _ _ ope) = Buffer fpbuf p0 p0 ope + where + p0 = unsafeForeignPtrToPtr fpbuf + +-- | Generally speaking, yielding values from inside a Conduit requires +-- some allocation for constructors. This can introduce an overhead, +-- similar to the overhead needed to represent a list of values instead of +-- a vector. This overhead is even more severe when talking about unboxed +-- values. +-- +-- This combinator allows you to overcome this overhead, and efficiently +-- fill up vectors. It takes two parameters. The first is the size of each +-- mutable vector to be allocated. The second is a function. The function +-- takes an argument which will yield the next value into a mutable +-- vector. +-- +-- Under the surface, this function uses a number of tricks to get high +-- performance. For more information on both usage and implementation, +-- please see: +-- +-- +-- @since 1.3.0 +vectorBuilder :: (PrimMonad m, PrimMonad n, V.Vector v e, PrimState m ~ PrimState n) + => Int -- ^ size + -> ((e -> n ()) -> ConduitT i Void m r) + -> ConduitT i (v e) m r +vectorBuilder size inner = do + ref <- do + mv <- VM.new size + newMutVar $! S 0 mv id + res <- onAwait (yieldS ref) (inner (addE ref)) + vs <- do + S idx mv front <- readMutVar ref + end <- + if idx == 0 + then return [] + else do + v <- V.unsafeFreeze mv + return [V.unsafeTake idx v] + return $ front end + Prelude.mapM_ yield vs + return res +{-# INLINE vectorBuilder #-} + +data S s v e = S + {-# UNPACK #-} !Int -- index + !(V.Mutable v s e) + ([v e] -> [v e]) + +onAwait :: Monad m + => ConduitT i o m () + -> ConduitT i Void m r + -> ConduitT i o m r +onAwait (ConduitT callback) (ConduitT sink0) = ConduitT $ \rest -> let + go (Done r) = rest r + go (HaveOutput _ o) = absurd o + go (NeedInput f g) = callback $ \() -> NeedInput (go . f) (go . g) + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover f i) = Leftover (go f) i + in go (sink0 Done) +{-# INLINE onAwait #-} + +yieldS :: PrimMonad m + => MutVar (PrimState m) (S (PrimState m) v e) + -> ConduitT i (v e) m () +yieldS ref = do + S idx mv front <- readMutVar ref + Prelude.mapM_ yield (front []) + writeMutVar ref $! S idx mv id +{-# INLINE yieldS #-} + +addE :: (PrimMonad m, V.Vector v e) + => MutVar (PrimState m) (S (PrimState m) v e) + -> e + -> m () +addE ref e = do + S idx mv front <- readMutVar ref + VM.write mv idx e + let idx' = succ idx + size = VM.length mv + if idx' >= size + then do + v <- V.unsafeFreeze mv + let front' = front . (v:) + mv' <- VM.new size + writeMutVar ref $! S 0 mv' front' + else writeMutVar ref $! S idx' mv front +{-# INLINE addE #-} + +-- | Consume a source with a strict accumulator, in a way piecewise defined by +-- a controlling stream. The latter will be evaluated until it terminates. +-- +-- >>> let f a s = liftM (:s) $ mapC (*a) =$ CL.take a +-- >>> reverse $ runIdentity $ yieldMany [0..3] $$ mapAccumS f [] (yieldMany [1..]) +-- [[],[1],[4,6],[12,15,18]] :: [[Int]] +mapAccumS + :: Monad m + => (a -> s -> ConduitT b Void m s) + -> s + -> ConduitT () b m () + -> ConduitT a Void m s +mapAccumS f s xs = do + (_, u) <- loop (sealConduitT xs, s) + return u + where loop r@(ys, !t) = await >>= maybe (return r) go + where go a = lift (ys $$++ f a t) >>= loop +{-# INLINE mapAccumS #-} + +-- | Run a consuming conduit repeatedly, only stopping when there is no more +-- data available from upstream. +-- +-- @since 1.3.0 +peekForever :: Monad m => ConduitT i o m () -> ConduitT i o m () +peekForever inner = + loop + where + loop = do + mx <- peek + case mx of + Nothing -> return () + Just _ -> inner >> loop + +-- | Run a consuming conduit repeatedly, only stopping when there is no more +-- data available from upstream. +-- +-- In contrast to 'peekForever', this function will ignore empty +-- chunks of data. So for example, if a stream of data contains an +-- empty @ByteString@, it is still treated as empty, and the consuming +-- function is not called. +-- +-- @since 1.3.0 +peekForeverE :: (Monad m, MonoFoldable i) + => ConduitT i o m () + -> ConduitT i o m () +peekForeverE inner = + loop + where + loop = do + mx <- peekE + case mx of + Nothing -> return () + Just _ -> inner >> loop diff --git a/src/Data/Conduit/Combinators/Stream.hs b/src/Data/Conduit/Combinators/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Combinators/Stream.hs @@ -0,0 +1,474 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +-- | These are stream fusion versions of some of the functions in +-- "Data.Conduit.Combinators". Many functions don't have stream +-- versions here because instead they have @RULES@ which inline a +-- definition that fuses. +module Data.Conduit.Combinators.Stream + ( yieldManyS + , repeatMS + , repeatWhileMS + , foldl1S + , allS + , anyS + , sinkLazyS + , sinkVectorS + , sinkVectorNS + , sinkLazyBuilderS + , lastS + , lastES + , findS + , concatMapS + , concatMapMS + , concatS + , scanlS + , scanlMS + , mapAccumWhileS + , mapAccumWhileMS + , intersperseS + , slidingWindowS + , filterMS + , splitOnUnboundedES + , initReplicateS + , initRepeatS + ) + where + +-- BEGIN IMPORTS + +import Control.Monad (liftM) +import Control.Monad.Primitive (PrimMonad) +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Builder (Builder, toLazyByteString) +import Data.Conduit.Internal.Fusion +import Data.Conduit.Internal.List.Stream (foldS) +import Data.Maybe (isNothing, isJust) +import Data.MonoTraversable +#if ! MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid (..)) +#endif +import qualified Data.NonNull as NonNull +import qualified Data.Sequences as Seq +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as VM +import Prelude + +#if MIN_VERSION_mono_traversable(1,0,0) +import Data.Sequences (LazySequence (..)) +#else +import Data.Sequences.Lazy +#endif + +-- END IMPORTS + +yieldManyS :: (Monad m, MonoFoldable mono) + => mono + -> StreamProducer m (Element mono) +yieldManyS mono _ = + Stream (return . step) (return (otoList mono)) + where + step [] = Stop () + step (x:xs) = Emit xs x +{-# INLINE yieldManyS #-} + +repeatMS :: Monad m + => m a + -> StreamProducer m a +repeatMS m _ = + Stream step (return ()) + where + step _ = liftM (Emit ()) m +{-# INLINE repeatMS #-} + +repeatWhileMS :: Monad m + => m a + -> (a -> Bool) + -> StreamProducer m a +repeatWhileMS m f _ = + Stream step (return ()) + where + step _ = do + x <- m + return $ if f x + then Emit () x + else Stop () +{-# INLINE repeatWhileMS #-} + +foldl1S :: Monad m + => (a -> a -> a) + -> StreamConsumer a m (Maybe a) +foldl1S f (Stream step ms0) = + Stream step' (liftM (Nothing, ) ms0) + where + step' (mprev, s) = do + res <- step s + return $ case res of + Stop () -> Stop mprev + Skip s' -> Skip (mprev, s') + Emit s' a -> Skip (Just $ maybe a (`f` a) mprev, s') +{-# INLINE foldl1S #-} + +allS :: Monad m + => (a -> Bool) + -> StreamConsumer a m Bool +allS f = fmapS isNothing (findS (Prelude.not . f)) +{-# INLINE allS #-} + +anyS :: Monad m + => (a -> Bool) + -> StreamConsumer a m Bool +anyS f = fmapS isJust (findS f) +{-# INLINE anyS #-} + +--TODO: use a definition like +-- fmapS (fromChunks . ($ [])) <$> CL.fold (\front next -> front . (next:)) id + +sinkLazyS :: (Monad m, LazySequence lazy strict) + => StreamConsumer strict m lazy +sinkLazyS = fmapS (fromChunks . ($ [])) $ foldS (\front next -> front . (next:)) id +{-# INLINE sinkLazyS #-} + +sinkVectorS :: (V.Vector v a, PrimMonad m) + => StreamConsumer a m (v a) +sinkVectorS (Stream step ms0) = do + Stream step' $ do + s0 <- ms0 + mv0 <- VM.new initSize + return (initSize, 0, mv0, s0) + where + initSize = 10 + step' (maxSize, i, mv, s) = do + res <- step s + case res of + Stop () -> liftM (Stop . V.slice 0 i) $ V.unsafeFreeze mv + Skip s' -> return $ Skip (maxSize, i, mv, s') + Emit s' x -> do + VM.write mv i x + let i' = i + 1 + if i' >= maxSize + then do + let newMax = maxSize * 2 + mv' <- VM.grow mv maxSize + return $ Skip (newMax, i', mv', s') + else return $ Skip (maxSize, i', mv, s') +{-# INLINE sinkVectorS #-} + +sinkVectorNS :: (V.Vector v a, PrimMonad m) + => Int -- ^ maximum allowed size + -> StreamConsumer a m (v a) +sinkVectorNS maxSize (Stream step ms0) = do + Stream step' $ do + s0 <- ms0 + mv0 <- VM.new maxSize + return (0, mv0, s0) + where + step' (i, mv, _) | i >= maxSize = liftM Stop $ V.unsafeFreeze mv + step' (i, mv, s) = do + res <- step s + case res of + Stop () -> liftM (Stop . V.slice 0 i) $ V.unsafeFreeze mv + Skip s' -> return $ Skip (i, mv, s') + Emit s' x -> do + VM.write mv i x + let i' = i + 1 + return $ Skip (i', mv, s') +{-# INLINE sinkVectorNS #-} + +sinkLazyBuilderS :: Monad m => StreamConsumer Builder m BL.ByteString +sinkLazyBuilderS = fmapS toLazyByteString (foldS mappend mempty) +{-# INLINE sinkLazyBuilderS #-} + +lastS :: Monad m + => StreamConsumer a m (Maybe a) +lastS (Stream step ms0) = + Stream step' (liftM (Nothing,) ms0) + where + step' (mlast, s) = do + res <- step s + return $ case res of + Stop () -> Stop mlast + Skip s' -> Skip (mlast, s') + Emit s' x -> Skip (Just x, s') +{-# INLINE lastS #-} + +lastES :: (Monad m, Seq.IsSequence seq) + => StreamConsumer seq m (Maybe (Element seq)) +lastES (Stream step ms0) = + Stream step' (liftM (Nothing, ) ms0) + where + step' (mlast, s) = do + res <- step s + return $ case res of + Stop () -> Stop (fmap NonNull.last mlast) + Skip s' -> Skip (mlast, s') + Emit s' (NonNull.fromNullable -> mlast'@(Just _)) -> Skip (mlast', s') + Emit s' _ -> Skip (mlast, s') +{-# INLINE lastES #-} + +findS :: Monad m + => (a -> Bool) -> StreamConsumer a m (Maybe a) +findS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop Nothing + Skip s' -> Skip s' + Emit s' x -> + if f x + then Stop (Just x) + else Skip s' +{-# INLINE findS #-} + +concatMapS :: (Monad m, MonoFoldable mono) + => (a -> mono) + -> StreamConduit a m (Element mono) +concatMapS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip ([], s') + Emit s' x -> Skip (otoList (f x), s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE concatMapS #-} + +concatMapMS :: (Monad m, MonoFoldable mono) + => (a -> m mono) + -> StreamConduit a m (Element mono) +concatMapMS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip ([], s') + Emit s' x -> do + o <- f x + return $ Skip (otoList o, s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE concatMapMS #-} + +concatS :: (Monad m, MonoFoldable mono) + => StreamConduit mono m (Element mono) +concatS = concatMapS id +{-# INLINE concatS #-} + +data ScanState a s + = ScanEnded + | ScanContinues a s + +scanlS :: Monad m => (a -> b -> a) -> a -> StreamConduit b m a +scanlS f seed0 (Stream step ms0) = + Stream step' (liftM (ScanContinues seed0) ms0) + where + step' ScanEnded = return $ Stop () + step' (ScanContinues seed s) = do + res <- step s + return $ case res of + Stop () -> Emit ScanEnded seed + Skip s' -> Skip (ScanContinues seed s') + Emit s' x -> Emit (ScanContinues seed' s') seed + where + !seed' = f seed x +{-# INLINE scanlS #-} + +scanlMS :: Monad m => (a -> b -> m a) -> a -> StreamConduit b m a +scanlMS f seed0 (Stream step ms0) = + Stream step' (liftM (ScanContinues seed0) ms0) + where + step' ScanEnded = return $ Stop () + step' (ScanContinues seed s) = do + res <- step s + case res of + Stop () -> return $ Emit ScanEnded seed + Skip s' -> return $ Skip (ScanContinues seed s') + Emit s' x -> do + !seed' <- f seed x + return $ Emit (ScanContinues seed' s') seed +{-# INLINE scanlMS #-} + +mapAccumWhileS :: Monad m => + (a -> s -> Either s (s, b)) -> s -> StreamConduitT a b m s +mapAccumWhileS f initial (Stream step ms0) = + Stream step' (liftM (initial, ) ms0) + where + step' (!accum, s) = do + res <- step s + return $ case res of + Stop () -> Stop accum + Skip s' -> Skip (accum, s') + Emit s' x -> case f x accum of + Right (!accum', r) -> Emit (accum', s') r + Left !accum' -> Stop accum' +{-# INLINE mapAccumWhileS #-} + +mapAccumWhileMS :: Monad m => + (a -> s -> m (Either s (s, b))) -> s -> StreamConduitT a b m s +mapAccumWhileMS f initial (Stream step ms0) = + Stream step' (liftM (initial, ) ms0) + where + step' (!accum, s) = do + res <- step s + case res of + Stop () -> return $ Stop accum + Skip s' -> return $ Skip (accum, s') + Emit s' x -> do + lr <- f x accum + return $ case lr of + Right (!accum', r) -> Emit (accum', s') r + Left !accum' -> Stop accum' +{-# INLINE mapAccumWhileMS #-} + +data IntersperseState a s + = IFirstValue s + | IGotValue s a + | IEmitValue s a + +intersperseS :: Monad m => a -> StreamConduit a m a +intersperseS sep (Stream step ms0) = + Stream step' (liftM IFirstValue ms0) + where + step' (IFirstValue s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (IFirstValue s') + Emit s' x -> Emit (IGotValue s' x) x + -- Emit the separator once we know it's not the end of the list. + step' (IGotValue s x) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (IGotValue s' x) + Emit s' x' -> Emit (IEmitValue s' x') sep + -- We emitted a separator, now emit the value that comes after. + step' (IEmitValue s x) = return $ Emit (IGotValue s x) x +{-# INLINE intersperseS #-} + +data SlidingWindowState seq s + = SWInitial Int seq s + | SWSliding seq s + | SWEarlyExit + +slidingWindowS :: (Monad m, Seq.IsSequence seq, Element seq ~ a) => Int -> StreamConduit a m seq +slidingWindowS sz (Stream step ms0) = + Stream step' (liftM (SWInitial (max 1 sz) mempty) ms0) + where + step' (SWInitial n st s) = do + res <- step s + return $ case res of + Stop () -> Emit SWEarlyExit st + Skip s' -> Skip (SWInitial n st s') + Emit s' x -> + if n == 1 + then Emit (SWSliding (Seq.unsafeTail st') s') st' + else Skip (SWInitial (n - 1) st' s') + where + st' = Seq.snoc st x + -- After collecting the initial window, each upstream element + -- causes an additional window to be yielded. + step' (SWSliding st s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (SWSliding st s') + Emit s' x -> Emit (SWSliding (Seq.unsafeTail st') s') st' + where + st' = Seq.snoc st x + step' SWEarlyExit = return $ Stop () + +{-# INLINE slidingWindowS #-} + +filterMS :: Monad m + => (a -> m Bool) + -> StreamConduit a m a +filterMS f (Stream step ms0) = do + Stream step' ms0 + where + step' s = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip s' + Emit s' x -> do + r <- f x + return $ + if r + then Emit s' x + else Skip s' +{-# INLINE filterMS #-} + +data SplitState seq s + = SplitDone + -- When no element of seq passes the predicate. This allows + -- 'splitOnUnboundedES' to not run 'Seq.break' multiple times due + -- to 'Skip's being sent by the upstream. + | SplitNoSep seq s + | SplitState seq s + +splitOnUnboundedES :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) -> StreamConduit seq m seq +splitOnUnboundedES f (Stream step ms0) = + Stream step' (liftM (SplitState mempty) ms0) + where + step' SplitDone = return $ Stop () + step' (SplitNoSep t s) = do + res <- step s + return $ case res of + Stop () | not (onull t) -> Emit SplitDone t + | otherwise -> Stop () + Skip s' -> Skip (SplitNoSep t s') + Emit s' t' -> Skip (SplitState (t `mappend` t') s') + step' (SplitState t s) = do + if onull y + then do + res <- step s + return $ case res of + Stop () | not (onull t) -> Emit SplitDone t + | otherwise -> Stop () + Skip s' -> Skip (SplitNoSep t s') + Emit s' t' -> Skip (SplitState (t `mappend` t') s') + else return $ Emit (SplitState (Seq.drop 1 y) s) x + where + (x, y) = Seq.break f t +{-# INLINE splitOnUnboundedES #-} + +-- | Streaming versions of @Data.Conduit.Combinators.Internal.initReplicate@ +initReplicateS :: Monad m => m seed -> (seed -> m a) -> Int -> StreamProducer m a +initReplicateS mseed f cnt _ = + Stream step (liftM (cnt, ) mseed) + where + step (ix, _) | ix <= 0 = return $ Stop () + step (ix, seed) = do + x <- f seed + return $ Emit (ix - 1, seed) x +{-# INLINE initReplicateS #-} + +-- | Streaming versions of @Data.Conduit.Combinators.Internal.initRepeat@ +initRepeatS :: Monad m => m seed -> (seed -> m a) -> StreamProducer m a +initRepeatS mseed f _ = + Stream step mseed + where + step seed = do + x <- f seed + return $ Emit seed x +{-# INLINE initRepeatS #-} + +-- | Utility function +fmapS :: Monad m + => (a -> b) + -> StreamConduitT i o m a + -> StreamConduitT i o m b +fmapS f s inp = + case s inp of + Stream step ms0 -> Stream (fmap (liftM (fmap f)) step) ms0 +{-# INLINE fmapS #-} diff --git a/src/Data/Conduit/Combinators/Unqualified.hs b/src/Data/Conduit/Combinators/Unqualified.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Combinators/Unqualified.hs @@ -0,0 +1,1206 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +module Data.Conduit.Combinators.Unqualified + ( -- ** Producers + -- *** Pure + CC.yieldMany + , unfoldC + , enumFromToC + , iterateC + , repeatC + , replicateC + , CC.sourceLazy + + -- *** Monadic + , repeatMC + , repeatWhileMC + , replicateMC + + -- *** I\/O + , CC.sourceFile + , CC.sourceFileBS + , CC.sourceHandle + , CC.sourceHandleUnsafe + , CC.sourceIOHandle + , stdinC + , CC.withSourceFile + + -- *** Filesystem + , CC.sourceDirectory + , CC.sourceDirectoryDeep + + -- ** Consumers + -- *** Pure + , dropC + , dropCE + , dropWhileC + , dropWhileCE + , foldC + , foldCE + , foldlC + , foldlCE + , foldMapC + , foldMapCE + , allC + , allCE + , anyC + , anyCE + , andC + , andCE + , orC + , orCE + , asumC + , elemC + , elemCE + , notElemC + , notElemCE + , CC.sinkLazy + , CC.sinkList + , CC.sinkVector + , CC.sinkVectorN + , CC.sinkLazyBuilder + , CC.sinkNull + , CC.awaitNonNull + , headC + , headDefC + , headCE + , peekC + , peekCE + , lastC + , lastDefC + , lastCE + , lengthC + , lengthCE + , lengthIfC + , lengthIfCE + , maximumC + , maximumCE + , minimumC + , minimumCE + , nullC + , nullCE + , sumC + , sumCE + , productC + , productCE + , findC + + -- *** Monadic + , mapM_C + , mapM_CE + , foldMC + , foldMCE + , foldMapMC + , foldMapMCE + + -- *** I\/O + , CC.sinkFile + , CC.sinkFileCautious + , CC.sinkTempFile + , CC.sinkSystemTempFile + , CC.sinkFileBS + , CC.sinkHandle + , CC.sinkIOHandle + , printC + , stdoutC + , stderrC + , CC.withSinkFile + , CC.withSinkFileBuilder + , CC.withSinkFileCautious + , CC.sinkHandleBuilder + , CC.sinkHandleFlush + + -- ** Transformers + -- *** Pure + , mapC + , mapCE + , omapCE + , concatMapC + , concatMapCE + , takeC + , takeCE + , takeWhileC + , takeWhileCE + , takeExactlyC + , takeExactlyCE + , concatC + , filterC + , filterCE + , mapWhileC + , conduitVector + , scanlC + , mapAccumWhileC + , concatMapAccumC + , intersperseC + , slidingWindowC + , chunksOfCE + , chunksOfExactlyCE + + -- *** Monadic + , mapMC + , mapMCE + , omapMCE + , concatMapMC + , filterMC + , filterMCE + , iterMC + , scanlMC + , mapAccumWhileMC + , concatMapAccumMC + + -- *** Textual + , encodeUtf8C + , decodeUtf8C + , decodeUtf8LenientC + , lineC + , lineAsciiC + , unlinesC + , unlinesAsciiC + , linesUnboundedC + , linesUnboundedAsciiC + + -- ** Builders + , CC.builderToByteString + , CC.unsafeBuilderToByteString + , CC.builderToByteStringWith + , CC.builderToByteStringFlush + , CC.builderToByteStringWithFlush + , CC.BufferAllocStrategy + , CC.allNewBuffersStrategy + , CC.reuseBufferStrategy + + -- ** Special + , vectorBuilderC + , CC.mapAccumS + , CC.peekForever + , CC.peekForeverE + ) where + +-- BEGIN IMPORTS + +import qualified Data.Conduit.Combinators as CC +-- BEGIN IMPORTS + +import qualified Data.Traversable +import Control.Applicative (Alternative) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad.Trans.Resource (MonadThrow) +import Data.Conduit +import Data.Monoid (Monoid (..)) +import Data.MonoTraversable +import qualified Data.Sequences as Seq +import qualified Data.Vector.Generic as V +import Prelude (Bool (..), Eq (..), Int, + Maybe (..), Monad (..), Num (..), + Ord (..), Functor (..), Either (..), + Enum, Show, Char) +import Data.Word (Word8) +import Data.ByteString (ByteString) +import Data.Text (Text) + +import qualified Data.Sequences as DTE + + +-- END IMPORTS + +-- | Generate a producer from a seed value. +-- +-- @since 1.3.0 +unfoldC :: Monad m + => (b -> Maybe (a, b)) + -> b + -> ConduitT i a m () +unfoldC = CC.unfold +{-# INLINE unfoldC #-} + +-- | Enumerate from a value to a final value, inclusive, via 'succ'. +-- +-- This is generally more efficient than using @Prelude@\'s @enumFromTo@ and +-- combining with @sourceList@ since this avoids any intermediate data +-- structures. +-- +-- @since 1.3.0 +enumFromToC :: (Monad m, Enum a, Ord a) => a -> a -> ConduitT i a m () +enumFromToC = CC.enumFromTo +{-# INLINE enumFromToC #-} + +-- | Produces an infinite stream of repeated applications of f to x. +-- +-- @since 1.3.0 +iterateC :: Monad m => (a -> a) -> a -> ConduitT i a m () +iterateC = CC.iterate +{-# INLINE iterateC #-} + +-- | Produce an infinite stream consisting entirely of the given value. +-- +-- @since 1.3.0 +repeatC :: Monad m => a -> ConduitT i a m () +repeatC = CC.repeat +{-# INLINE repeatC #-} + +-- | Produce a finite stream consisting of n copies of the given value. +-- +-- @since 1.3.0 +replicateC :: Monad m + => Int + -> a + -> ConduitT i a m () +replicateC = CC.replicate +{-# INLINE replicateC #-} + +-- | Repeatedly run the given action and yield all values it produces. +-- +-- @since 1.3.0 +repeatMC :: Monad m + => m a + -> ConduitT i a m () +repeatMC = CC.repeatM +{-# INLINE repeatMC #-} + +-- | Repeatedly run the given action and yield all values it produces, until +-- the provided predicate returns @False@. +-- +-- @since 1.3.0 +repeatWhileMC :: Monad m + => m a + -> (a -> Bool) + -> ConduitT i a m () +repeatWhileMC = CC.repeatWhileM +{-# INLINE repeatWhileMC #-} + +-- | Perform the given action n times, yielding each result. +-- +-- @since 1.3.0 +replicateMC :: Monad m + => Int + -> m a + -> ConduitT i a m () +replicateMC = CC.replicateM +{-# INLINE replicateMC #-} + +-- | @sourceHandle@ applied to @stdin@. +-- +-- @since 1.3.0 +stdinC :: MonadIO m => ConduitT i ByteString m () +stdinC = CC.stdin +{-# INLINE stdinC #-} + +-- | Ignore a certain number of values in the stream. +-- +-- Note: since this function doesn't produce anything, you probably want to +-- use it with ('>>') instead of directly plugging it into a pipeline: +-- +-- >>> runConduit $ yieldMany [1..5] .| dropC 2 .| sinkList +-- [] +-- >>> runConduit $ yieldMany [1..5] .| (dropC 2 >> sinkList) +-- [3,4,5] +-- +-- @since 1.3.0 +dropC :: Monad m + => Int + -> ConduitT a o m () +dropC = CC.drop +{-# INLINE dropC #-} + +-- | Drop a certain number of elements from a chunked stream. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'dropC'. +-- +-- @since 1.3.0 +dropCE :: (Monad m, Seq.IsSequence seq) + => Seq.Index seq + -> ConduitT seq o m () +dropCE = CC.dropE +{-# INLINE dropCE #-} + +-- | Drop all values which match the given predicate. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'dropC'. +-- +-- @since 1.3.0 +dropWhileC :: Monad m + => (a -> Bool) + -> ConduitT a o m () +dropWhileC = CC.dropWhile +{-# INLINE dropWhileC #-} + +-- | Drop all elements in the chunked stream which match the given predicate. +-- +-- Note: you likely want to use it with monadic composition. See the docs +-- for 'dropC'. +-- +-- @since 1.3.0 +dropWhileCE :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) + -> ConduitT seq o m () +dropWhileCE = CC.dropWhileE +{-# INLINE dropWhileCE #-} + +-- | Monoidally combine all values in the stream. +-- +-- @since 1.3.0 +foldC :: (Monad m, Monoid a) + => ConduitT a o m a +foldC = CC.fold +{-# INLINE foldC #-} + +-- | Monoidally combine all elements in the chunked stream. +-- +-- @since 1.3.0 +foldCE :: (Monad m, MonoFoldable mono, Monoid (Element mono)) + => ConduitT mono o m (Element mono) +foldCE = CC.foldE +{-# INLINE foldCE #-} + +-- | A strict left fold. +-- +-- @since 1.3.0 +foldlC :: Monad m => (a -> b -> a) -> a -> ConduitT b o m a +foldlC = CC.foldl +{-# INLINE foldlC #-} + +-- | A strict left fold on a chunked stream. +-- +-- @since 1.3.0 +foldlCE :: (Monad m, MonoFoldable mono) + => (a -> Element mono -> a) + -> a + -> ConduitT mono o m a +foldlCE = CC.foldlE +{-# INLINE foldlCE #-} + +-- | Apply the provided mapping function and monoidal combine all values. +-- +-- @since 1.3.0 +foldMapC :: (Monad m, Monoid b) + => (a -> b) + -> ConduitT a o m b +foldMapC = CC.foldMap +{-# INLINE foldMapC #-} + +-- | Apply the provided mapping function and monoidal combine all elements of the chunked stream. +-- +-- @since 1.3.0 +foldMapCE :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> w) + -> ConduitT mono o m w +foldMapCE = CC.foldMapE +{-# INLINE foldMapCE #-} + +-- | Check that all values in the stream return True. +-- +-- Subject to shortcut logic: at the first False, consumption of the stream +-- will stop. +-- +-- @since 1.3.0 +allC :: Monad m + => (a -> Bool) + -> ConduitT a o m Bool +allC = CC.all +{-# INLINE allC #-} + +-- | Check that all elements in the chunked stream return True. +-- +-- Subject to shortcut logic: at the first False, consumption of the stream +-- will stop. +-- +-- @since 1.3.0 +allCE :: (Monad m, MonoFoldable mono) + => (Element mono -> Bool) + -> ConduitT mono o m Bool +allCE = CC.allE +{-# INLINE allCE #-} + +-- | Check that at least one value in the stream returns True. +-- +-- Subject to shortcut logic: at the first True, consumption of the stream +-- will stop. +-- +-- @since 1.3.0 +anyC :: Monad m + => (a -> Bool) + -> ConduitT a o m Bool +anyC = CC.any +{-# INLINE anyC #-} + +-- | Check that at least one element in the chunked stream returns True. +-- +-- Subject to shortcut logic: at the first True, consumption of the stream +-- will stop. +-- +-- @since 1.3.0 +anyCE :: (Monad m, MonoFoldable mono) + => (Element mono -> Bool) + -> ConduitT mono o m Bool +anyCE = CC.anyE +{-# INLINE anyCE #-} + +-- | Are all values in the stream True? +-- +-- Consumption stops once the first False is encountered. +-- +-- @since 1.3.0 +andC :: Monad m => ConduitT Bool o m Bool +andC = CC.and +{-# INLINE andC #-} + +-- | Are all elements in the chunked stream True? +-- +-- Consumption stops once the first False is encountered. +-- +-- @since 1.3.0 +andCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) + => ConduitT mono o m Bool +andCE = CC.andE +{-# INLINE andCE #-} + +-- | Are any values in the stream True? +-- +-- Consumption stops once the first True is encountered. +-- +-- @since 1.3.0 +orC :: Monad m => ConduitT Bool o m Bool +orC = CC.or +{-# INLINE orC #-} + +-- | Are any elements in the chunked stream True? +-- +-- Consumption stops once the first True is encountered. +-- +-- @since 1.3.0 +orCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) + => ConduitT mono o m Bool +orCE = CC.orE +{-# INLINE orCE #-} + +-- | 'Alternative'ly combine all values in the stream. +-- +-- @since 1.3.0 +asumC :: (Monad m, Alternative f) => ConduitT (f a) o m (f a) +asumC = CC.asum + +-- | Are any values in the stream equal to the given value? +-- +-- Stops consuming as soon as a match is found. +-- +-- @since 1.3.0 +elemC :: (Monad m, Eq a) => a -> ConduitT a o m Bool +elemC = CC.elem +{-# INLINE elemC #-} + +-- | Are any elements in the chunked stream equal to the given element? +-- +-- Stops consuming as soon as a match is found. +-- +-- @since 1.3.0 +#if MIN_VERSION_mono_traversable(1,0,0) +elemCE :: (Monad m, Seq.IsSequence seq, Eq (Element seq)) +#else +elemCE :: (Monad m, Seq.EqSequence seq) +#endif + => Element seq + -> ConduitT seq o m Bool +elemCE = CC.elemE +{-# INLINE elemCE #-} + +-- | Are no values in the stream equal to the given value? +-- +-- Stops consuming as soon as a match is found. +-- +-- @since 1.3.0 +notElemC :: (Monad m, Eq a) => a -> ConduitT a o m Bool +notElemC = CC.notElem +{-# INLINE notElemC #-} + +-- | Are no elements in the chunked stream equal to the given element? +-- +-- Stops consuming as soon as a match is found. +-- +-- @since 1.3.0 +#if MIN_VERSION_mono_traversable(1,0,0) +notElemCE :: (Monad m, Seq.IsSequence seq, Eq (Element seq)) +#else +notElemCE :: (Monad m, Seq.EqSequence seq) +#endif + => Element seq + -> ConduitT seq o m Bool +notElemCE = CC.notElemE +{-# INLINE notElemCE #-} + +-- | Take a single value from the stream, if available. +-- +-- @since 1.3.0 +headC :: Monad m => ConduitT a o m (Maybe a) +headC = CC.head + +-- | Same as 'headC', but returns a default value if none are available from the stream. +-- +-- @since 1.3.0 +headDefC :: Monad m => a -> ConduitT a o m a +headDefC = CC.headDef + +-- | Get the next element in the chunked stream. +-- +-- @since 1.3.0 +headCE :: (Monad m, Seq.IsSequence seq) => ConduitT seq o m (Maybe (Element seq)) +headCE = CC.headE +{-# INLINE headCE #-} + +-- | View the next value in the stream without consuming it. +-- +-- @since 1.3.0 +peekC :: Monad m => ConduitT a o m (Maybe a) +peekC = CC.peek +{-# INLINE peekC #-} + +-- | View the next element in the chunked stream without consuming it. +-- +-- @since 1.3.0 +peekCE :: (Monad m, MonoFoldable mono) => ConduitT mono o m (Maybe (Element mono)) +peekCE = CC.peekE +{-# INLINE peekCE #-} + +-- | Retrieve the last value in the stream, if present. +-- +-- @since 1.3.0 +lastC :: Monad m => ConduitT a o m (Maybe a) +lastC = CC.last +{-# INLINE lastC #-} + +-- | Same as 'lastC', but returns a default value if none are available from the stream. +-- +-- @since 1.3.0 +lastDefC :: Monad m => a -> ConduitT a o m a +lastDefC = CC.lastDef + +-- | Retrieve the last element in the chunked stream, if present. +-- +-- @since 1.3.0 +lastCE :: (Monad m, Seq.IsSequence seq) => ConduitT seq o m (Maybe (Element seq)) +lastCE = CC.lastE +{-# INLINE lastCE #-} + +-- | Count how many values are in the stream. +-- +-- @since 1.3.0 +lengthC :: (Monad m, Num len) => ConduitT a o m len +lengthC = CC.length +{-# INLINE lengthC #-} + +-- | Count how many elements are in the chunked stream. +-- +-- @since 1.3.0 +lengthCE :: (Monad m, Num len, MonoFoldable mono) => ConduitT mono o m len +lengthCE = CC.lengthE +{-# INLINE lengthCE #-} + +-- | Count how many values in the stream pass the given predicate. +-- +-- @since 1.3.0 +lengthIfC :: (Monad m, Num len) => (a -> Bool) -> ConduitT a o m len +lengthIfC = CC.lengthIf +{-# INLINE lengthIfC #-} + +-- | Count how many elements in the chunked stream pass the given predicate. +-- +-- @since 1.3.0 +lengthIfCE :: (Monad m, Num len, MonoFoldable mono) + => (Element mono -> Bool) -> ConduitT mono o m len +lengthIfCE = CC.lengthIfE +{-# INLINE lengthIfCE #-} + +-- | Get the largest value in the stream, if present. +-- +-- @since 1.3.0 +maximumC :: (Monad m, Ord a) => ConduitT a o m (Maybe a) +maximumC = CC.maximum +{-# INLINE maximumC #-} + +-- | Get the largest element in the chunked stream, if present. +-- +-- @since 1.3.0 +#if MIN_VERSION_mono_traversable(1,0,0) +maximumCE :: (Monad m, Seq.IsSequence seq, Ord (Element seq)) => ConduitT seq o m (Maybe (Element seq)) +#else +maximumCE :: (Monad m, Seq.OrdSequence seq) => ConduitT seq o m (Maybe (Element seq)) +#endif +maximumCE = CC.maximumE +{-# INLINE maximumCE #-} + +-- | Get the smallest value in the stream, if present. +-- +-- @since 1.3.0 +minimumC :: (Monad m, Ord a) => ConduitT a o m (Maybe a) +minimumC = CC.minimum +{-# INLINE minimumC #-} + +-- | Get the smallest element in the chunked stream, if present. +-- +-- @since 1.3.0 +#if MIN_VERSION_mono_traversable(1,0,0) +minimumCE :: (Monad m, Seq.IsSequence seq, Ord (Element seq)) => ConduitT seq o m (Maybe (Element seq)) +#else +minimumCE :: (Monad m, Seq.OrdSequence seq) => ConduitT seq o m (Maybe (Element seq)) +#endif +minimumCE = CC.minimumE +{-# INLINE minimumCE #-} + +-- | True if there are no values in the stream. +-- +-- This function does not modify the stream. +-- +-- @since 1.3.0 +nullC :: Monad m => ConduitT a o m Bool +nullC = CC.null +{-# INLINE nullC #-} + +-- | True if there are no elements in the chunked stream. +-- +-- This function may remove empty leading chunks from the stream, but otherwise +-- will not modify it. +-- +-- @since 1.3.0 +nullCE :: (Monad m, MonoFoldable mono) + => ConduitT mono o m Bool +nullCE = CC.nullE +{-# INLINE nullCE #-} + +-- | Get the sum of all values in the stream. +-- +-- @since 1.3.0 +sumC :: (Monad m, Num a) => ConduitT a o m a +sumC = CC.sum +{-# INLINE sumC #-} + +-- | Get the sum of all elements in the chunked stream. +-- +-- @since 1.3.0 +sumCE :: (Monad m, MonoFoldable mono, Num (Element mono)) => ConduitT mono o m (Element mono) +sumCE = CC.sumE +{-# INLINE sumCE #-} + +-- | Get the product of all values in the stream. +-- +-- @since 1.3.0 +productC :: (Monad m, Num a) => ConduitT a o m a +productC = CC.product +{-# INLINE productC #-} + +-- | Get the product of all elements in the chunked stream. +-- +-- @since 1.3.0 +productCE :: (Monad m, MonoFoldable mono, Num (Element mono)) => ConduitT mono o m (Element mono) +productCE = CC.productE +{-# INLINE productCE #-} + +-- | Find the first matching value. +-- +-- @since 1.3.0 +findC :: Monad m => (a -> Bool) -> ConduitT a o m (Maybe a) +findC = CC.find +{-# INLINE findC #-} + +-- | Apply the action to all values in the stream. +-- +-- Note: if you want to /pass/ the values instead of /consuming/ them, use +-- 'iterM' instead. +-- +-- @since 1.3.0 +mapM_C :: Monad m => (a -> m ()) -> ConduitT a o m () +mapM_C = CC.mapM_ +{-# INLINE mapM_C #-} + +-- | Apply the action to all elements in the chunked stream. +-- +-- Note: the same caveat as with 'mapM_C' applies. If you don't want to +-- consume the values, you can use 'iterM': +-- +-- > iterM (omapM_ f) +-- +-- @since 1.3.0 +mapM_CE :: (Monad m, MonoFoldable mono) => (Element mono -> m ()) -> ConduitT mono o m () +mapM_CE = CC.mapM_E +{-# INLINE mapM_CE #-} + +-- | A monadic strict left fold. +-- +-- @since 1.3.0 +foldMC :: Monad m => (a -> b -> m a) -> a -> ConduitT b o m a +foldMC = CC.foldM +{-# INLINE foldMC #-} + +-- | A monadic strict left fold on a chunked stream. +-- +-- @since 1.3.0 +foldMCE :: (Monad m, MonoFoldable mono) + => (a -> Element mono -> m a) + -> a + -> ConduitT mono o m a +foldMCE = CC.foldME +{-# INLINE foldMCE #-} + +-- | Apply the provided monadic mapping function and monoidal combine all values. +-- +-- @since 1.3.0 +foldMapMC :: (Monad m, Monoid w) => (a -> m w) -> ConduitT a o m w +foldMapMC = CC.foldMapM +{-# INLINE foldMapMC #-} + +-- | Apply the provided monadic mapping function and monoidal combine all +-- elements in the chunked stream. +-- +-- @since 1.3.0 +foldMapMCE :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> m w) + -> ConduitT mono o m w +foldMapMCE = CC.foldMapME +{-# INLINE foldMapMCE #-} + +-- | Print all incoming values to stdout. +-- +-- @since 1.3.0 +printC :: (Show a, MonadIO m) => ConduitT a o m () +printC = CC.print +{-# INLINE printC #-} + +-- | @sinkHandle@ applied to @stdout@. +-- +-- @since 1.3.0 +stdoutC :: MonadIO m => ConduitT ByteString o m () +stdoutC = CC.stdout +{-# INLINE stdoutC #-} + +-- | @sinkHandle@ applied to @stderr@. +-- +-- @since 1.3.0 +stderrC :: MonadIO m => ConduitT ByteString o m () +stderrC = CC.stderr +{-# INLINE stderrC #-} + +-- | Apply a transformation to all values in a stream. +-- +-- @since 1.3.0 +mapC :: Monad m => (a -> b) -> ConduitT a b m () +mapC = CC.map +{-# INLINE mapC #-} + +-- | Apply a transformation to all elements in a chunked stream. +-- +-- @since 1.3.0 +mapCE :: (Monad m, Functor f) => (a -> b) -> ConduitT (f a) (f b) m () +mapCE = CC.mapE +{-# INLINE mapCE #-} + +-- | Apply a monomorphic transformation to all elements in a chunked stream. +-- +-- Unlike @mapE@, this will work on types like @ByteString@ and @Text@ which +-- are @MonoFunctor@ but not @Functor@. +-- +-- @since 1.3.0 +omapCE :: (Monad m, MonoFunctor mono) => (Element mono -> Element mono) -> ConduitT mono mono m () +omapCE = CC.omapE +{-# INLINE omapCE #-} + +-- | Apply the function to each value in the stream, resulting in a foldable +-- value (e.g., a list). Then yield each of the individual values in that +-- foldable value separately. +-- +-- Generalizes concatMap, mapMaybe, and mapFoldable. +-- +-- @since 1.3.0 +concatMapC :: (Monad m, MonoFoldable mono) + => (a -> mono) + -> ConduitT a (Element mono) m () +concatMapC = CC.concatMap +{-# INLINE concatMapC #-} + +-- | Apply the function to each element in the chunked stream, resulting in a +-- foldable value (e.g., a list). Then yield each of the individual values in +-- that foldable value separately. +-- +-- Generalizes concatMap, mapMaybe, and mapFoldable. +-- +-- @since 1.3.0 +concatMapCE :: (Monad m, MonoFoldable mono, Monoid w) + => (Element mono -> w) + -> ConduitT mono w m () +concatMapCE = CC.concatMapE +{-# INLINE concatMapCE #-} + +-- | Stream up to n number of values downstream. +-- +-- Note that, if downstream terminates early, not all values will be consumed. +-- If you want to force /exactly/ the given number of values to be consumed, +-- see 'takeExactly'. +-- +-- @since 1.3.0 +takeC :: Monad m => Int -> ConduitT a a m () +takeC = CC.take +{-# INLINE takeC #-} + +-- | Stream up to n number of elements downstream in a chunked stream. +-- +-- Note that, if downstream terminates early, not all values will be consumed. +-- If you want to force /exactly/ the given number of values to be consumed, +-- see 'takeExactlyE'. +-- +-- @since 1.3.0 +takeCE :: (Monad m, Seq.IsSequence seq) + => Seq.Index seq + -> ConduitT seq seq m () +takeCE = CC.takeE +{-# INLINE takeCE #-} + +-- | Stream all values downstream that match the given predicate. +-- +-- Same caveats regarding downstream termination apply as with 'take'. +-- +-- @since 1.3.0 +takeWhileC :: Monad m + => (a -> Bool) + -> ConduitT a a m () +takeWhileC = CC.takeWhile +{-# INLINE takeWhileC #-} + +-- | Stream all elements downstream that match the given predicate in a chunked stream. +-- +-- Same caveats regarding downstream termination apply as with 'takeE'. +-- +-- @since 1.3.0 +takeWhileCE :: (Monad m, Seq.IsSequence seq) + => (Element seq -> Bool) + -> ConduitT seq seq m () +takeWhileCE = CC.takeWhileE +{-# INLINE takeWhileCE #-} + +-- | Consume precisely the given number of values and feed them downstream. +-- +-- This function is in contrast to 'take', which will only consume up to the +-- given number of values, and will terminate early if downstream terminates +-- early. This function will discard any additional values in the stream if +-- they are unconsumed. +-- +-- Note that this function takes a downstream @ConduitT@ as a parameter, as +-- opposed to working with normal fusion. For more information, see +-- , the section +-- titled \"pipes and conduit: isolate\". +-- +-- @since 1.3.0 +takeExactlyC :: Monad m + => Int + -> ConduitT a b m r + -> ConduitT a b m r +takeExactlyC = CC.takeExactly +{-# INLINE takeExactlyC #-} + +-- | Same as 'takeExactly', but for chunked streams. +-- +-- @since 1.3.0 +takeExactlyCE :: (Monad m, Seq.IsSequence a) + => Seq.Index a + -> ConduitT a b m r + -> ConduitT a b m r +takeExactlyCE = CC.takeExactlyE +{-# INLINE takeExactlyCE #-} + +-- | Flatten out a stream by yielding the values contained in an incoming +-- @MonoFoldable@ as individually yielded values. +-- +-- @since 1.3.0 +concatC :: (Monad m, MonoFoldable mono) + => ConduitT mono (Element mono) m () +concatC = CC.concat +{-# INLINE concatC #-} + +-- | Keep only values in the stream passing a given predicate. +-- +-- @since 1.3.0 +filterC :: Monad m => (a -> Bool) -> ConduitT a a m () +filterC = CC.filter +{-# INLINE filterC #-} + +-- | Keep only elements in the chunked stream passing a given predicate. +-- +-- @since 1.3.0 +filterCE :: (Seq.IsSequence seq, Monad m) => (Element seq -> Bool) -> ConduitT seq seq m () +filterCE = CC.filterE +{-# INLINE filterCE #-} + +-- | Map values as long as the result is @Just@. +-- +-- @since 1.3.0 +mapWhileC :: Monad m => (a -> Maybe b) -> ConduitT a b m () +mapWhileC = CC.mapWhile +{-# INLINE mapWhileC #-} + +-- | Break up a stream of values into vectors of size n. The final vector may +-- be smaller than n if the total number of values is not a strict multiple of +-- n. No empty vectors will be yielded. +-- +-- @since 1.3.0 +conduitVector :: (V.Vector v a, PrimMonad m) + => Int -- ^ maximum allowed size + -> ConduitT a (v a) m () +conduitVector = CC.conduitVector +{-# INLINE conduitVector #-} + +-- | Analog of 'Prelude.scanl' for lists. +-- +-- @since 1.3.0 +scanlC :: Monad m => (a -> b -> a) -> a -> ConduitT b a m () +scanlC = CC.scanl +{-# INLINE scanlC #-} + +-- | 'mapWhileC' with a break condition dependent on a strict accumulator. +-- Equivalently, 'CL.mapAccum' as long as the result is @Right@. Instead of +-- producing a leftover, the breaking input determines the resulting +-- accumulator via @Left@. +mapAccumWhileC :: Monad m => + (a -> s -> Either s (s, b)) -> s -> ConduitT a b m s +mapAccumWhileC = CC.mapAccumWhile +{-# INLINE mapAccumWhileC #-} + +-- | 'concatMap' with an accumulator. +-- +-- @since 1.3.0 +concatMapAccumC :: Monad m => (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m () +concatMapAccumC = CC.concatMapAccum +{-# INLINE concatMapAccumC #-} + +-- | Insert the given value between each two values in the stream. +-- +-- @since 1.3.0 +intersperseC :: Monad m => a -> ConduitT a a m () +intersperseC = CC.intersperse +{-# INLINE intersperseC #-} + +-- | Sliding window of values +-- 1,2,3,4,5 with window size 2 gives +-- [1,2],[2,3],[3,4],[4,5] +-- +-- Best used with structures that support O(1) snoc. +-- +-- @since 1.3.0 +slidingWindowC :: (Monad m, Seq.IsSequence seq, Element seq ~ a) => Int -> ConduitT a seq m () +slidingWindowC = CC.slidingWindow +{-# INLINE slidingWindowC #-} + + +-- | Split input into chunk of size 'chunkSize' +-- +-- The last element may be smaller than the 'chunkSize' (see also +-- 'chunksOfExactlyE' which will not yield this last element) +-- +-- @since 1.3.0 +chunksOfCE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> ConduitT seq seq m () +chunksOfCE = CC.chunksOfE +{-# INLINE chunksOfCE #-} + +-- | Split input into chunk of size 'chunkSize' +-- +-- If the input does not split into chunks exactly, the remainder will be +-- leftover (see also 'chunksOfE') +-- +-- @since 1.3.0 +chunksOfExactlyCE :: (Monad m, Seq.IsSequence seq) => Seq.Index seq -> ConduitT seq seq m () +chunksOfExactlyCE = CC.chunksOfExactlyE +{-# INLINE chunksOfExactlyCE #-} + +-- | Apply a monadic transformation to all values in a stream. +-- +-- If you do not need the transformed values, and instead just want the monadic +-- side-effects of running the action, see 'mapM_'. +-- +-- @since 1.3.0 +mapMC :: Monad m => (a -> m b) -> ConduitT a b m () +mapMC = CC.mapM +{-# INLINE mapMC #-} + +-- | Apply a monadic transformation to all elements in a chunked stream. +-- +-- @since 1.3.0 +mapMCE :: (Monad m, Data.Traversable.Traversable f) => (a -> m b) -> ConduitT (f a) (f b) m () +mapMCE = CC.mapME +{-# INLINE mapMCE #-} + +-- | Apply a monadic monomorphic transformation to all elements in a chunked stream. +-- +-- Unlike @mapME@, this will work on types like @ByteString@ and @Text@ which +-- are @MonoFunctor@ but not @Functor@. +-- +-- @since 1.3.0 +omapMCE :: (Monad m, MonoTraversable mono) + => (Element mono -> m (Element mono)) + -> ConduitT mono mono m () +omapMCE = CC.omapME +{-# INLINE omapMCE #-} + +-- | Apply the monadic function to each value in the stream, resulting in a +-- foldable value (e.g., a list). Then yield each of the individual values in +-- that foldable value separately. +-- +-- Generalizes concatMapM, mapMaybeM, and mapFoldableM. +-- +-- @since 1.3.0 +concatMapMC :: (Monad m, MonoFoldable mono) + => (a -> m mono) + -> ConduitT a (Element mono) m () +concatMapMC = CC.concatMapM +{-# INLINE concatMapMC #-} + +-- | Keep only values in the stream passing a given monadic predicate. +-- +-- @since 1.3.0 +filterMC :: Monad m + => (a -> m Bool) + -> ConduitT a a m () +filterMC = CC.filterM +{-# INLINE filterMC #-} + +-- | Keep only elements in the chunked stream passing a given monadic predicate. +-- +-- @since 1.3.0 +filterMCE :: (Monad m, Seq.IsSequence seq) => (Element seq -> m Bool) -> ConduitT seq seq m () +filterMCE = CC.filterME +{-# INLINE filterMCE #-} + +-- | Apply a monadic action on all values in a stream. +-- +-- This @Conduit@ can be used to perform a monadic side-effect for every +-- value, whilst passing the value through the @Conduit@ as-is. +-- +-- > iterM f = mapM (\a -> f a >>= \() -> return a) +-- +-- @since 1.3.0 +iterMC :: Monad m => (a -> m ()) -> ConduitT a a m () +iterMC = CC.iterM +{-# INLINE iterMC #-} + +-- | Analog of 'Prelude.scanl' for lists, monadic. +-- +-- @since 1.3.0 +scanlMC :: Monad m => (a -> b -> m a) -> a -> ConduitT b a m () +scanlMC = CC.scanlM +{-# INLINE scanlMC #-} + +-- | Monadic `mapAccumWhileC`. +mapAccumWhileMC :: Monad m => (a -> s -> m (Either s (s, b))) -> s -> ConduitT a b m s +mapAccumWhileMC = CC.mapAccumWhileM +{-# INLINE mapAccumWhileMC #-} + +-- | 'concatMapM' with an accumulator. +-- +-- @since 1.3.0 +concatMapAccumMC :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> ConduitT a b m () +concatMapAccumMC = CC.concatMapAccumM +{-# INLINE concatMapAccumMC #-} + +-- | Encode a stream of text as UTF8. +-- +-- @since 1.3.0 +encodeUtf8C :: (Monad m, DTE.Utf8 text binary) => ConduitT text binary m () +encodeUtf8C = CC.encodeUtf8 +{-# INLINE encodeUtf8C #-} + +-- | Decode a stream of binary data as UTF8. +-- +-- @since 1.3.0 +decodeUtf8C :: MonadThrow m => ConduitT ByteString Text m () +decodeUtf8C = CC.decodeUtf8 +{-# INLINE decodeUtf8C #-} + +-- | Decode a stream of binary data as UTF8, replacing any invalid bytes with +-- the Unicode replacement character. +-- +-- @since 1.3.0 +decodeUtf8LenientC :: Monad m => ConduitT ByteString Text m () +decodeUtf8LenientC = CC.decodeUtf8Lenient +{-# INLINE decodeUtf8LenientC #-} + +-- | Stream in the entirety of a single line. +-- +-- Like @takeExactly@, this will consume the entirety of the line regardless of +-- the behavior of the inner Conduit. +-- +-- @since 1.3.0 +lineC :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) + => ConduitT seq o m r + -> ConduitT seq o m r +lineC = CC.line +{-# INLINE lineC #-} + +-- | Same as 'line', but operates on ASCII/binary data. +-- +-- @since 1.3.0 +lineAsciiC :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) + => ConduitT seq o m r + -> ConduitT seq o m r +lineAsciiC = CC.lineAscii +{-# INLINE lineAsciiC #-} + +-- | Insert a newline character after each incoming chunk of data. +-- +-- @since 1.3.0 +unlinesC :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) => ConduitT seq seq m () +unlinesC = CC.unlines +{-# INLINE unlinesC #-} + +-- | Same as 'unlines', but operates on ASCII/binary data. +-- +-- @since 1.3.0 +unlinesAsciiC :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) => ConduitT seq seq m () +unlinesAsciiC = CC.unlinesAscii +{-# INLINE unlinesAsciiC #-} + +-- | Convert a stream of arbitrarily-chunked textual data into a stream of data +-- where each chunk represents a single line. Note that, if you have +-- unknown/untrusted input, this function is /unsafe/, since it would allow an +-- attacker to form lines of massive length and exhaust memory. +-- +-- @since 1.3.0 +linesUnboundedC :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) + => ConduitT seq seq m () +linesUnboundedC = CC.linesUnbounded +{-# INLINE linesUnboundedC #-} + +-- | Same as 'linesUnbounded', but for ASCII/binary data. +-- +-- @since 1.3.0 +linesUnboundedAsciiC :: (Monad m, Seq.IsSequence seq, Element seq ~ Word8) + => ConduitT seq seq m () +linesUnboundedAsciiC = CC.linesUnboundedAscii +{-# INLINE linesUnboundedAsciiC #-} + +-- | Generally speaking, yielding values from inside a Conduit requires +-- some allocation for constructors. This can introduce an overhead, +-- similar to the overhead needed to represent a list of values instead of +-- a vector. This overhead is even more severe when talking about unboxed +-- values. +-- +-- This combinator allows you to overcome this overhead, and efficiently +-- fill up vectors. It takes two parameters. The first is the size of each +-- mutable vector to be allocated. The second is a function. The function +-- takes an argument which will yield the next value into a mutable +-- vector. +-- +-- Under the surface, this function uses a number of tricks to get high +-- performance. For more information on both usage and implementation, +-- please see: +-- +-- +-- @since 1.3.0 +vectorBuilderC :: (PrimMonad m, V.Vector v e, PrimMonad n, PrimState m ~ PrimState n) + => Int -- ^ size + -> ((e -> n ()) -> ConduitT i Void m r) + -> ConduitT i (v e) m r +vectorBuilderC = CC.vectorBuilder +{-# INLINE vectorBuilderC #-} diff --git a/src/Data/Conduit/Internal.hs b/src/Data/Conduit/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Internal.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE Safe #-} +{-# OPTIONS_HADDOCK not-home #-} +module Data.Conduit.Internal + ( -- * Pipe + module Data.Conduit.Internal.Pipe + -- * Conduit + , module Data.Conduit.Internal.Conduit + -- * Fusion (highly experimental!!!) + , module Data.Conduit.Internal.Fusion + ) where + +import Data.Conduit.Internal.Conduit hiding (await, + awaitForever, bracketP, + leftover, mapInput, mapInputM, + mapOutput, mapOutputMaybe, + transPipe, + yield, yieldM, + unconsM, unconsEitherM) +import Data.Conduit.Internal.Pipe +import Data.Conduit.Internal.Fusion diff --git a/src/Data/Conduit/Internal/Conduit.hs b/src/Data/Conduit/Internal/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Internal/Conduit.hs @@ -0,0 +1,1333 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Conduit.Internal.Conduit + ( -- ** Types + ConduitT (..) + , ConduitM + , Source + , Producer + , Sink + , Consumer + , Conduit + , Flush (..) + -- *** Newtype wrappers + , ZipSource (..) + , ZipSink (..) + , ZipConduit (..) + -- ** Sealed + , SealedConduitT (..) + , sealConduitT + , unsealConduitT + -- ** Primitives + , await + , awaitForever + , yield + , yieldM + , leftover + , runConduit + , runConduitPure + , runConduitRes + , fuse + , connect + , unconsM + , unconsEitherM + -- ** Composition + , connectResume + , connectResumeConduit + , fuseLeftovers + , fuseReturnLeftovers + , ($$+) + , ($$++) + , ($$+-) + , ($=+) + , (=$$+) + , (=$$++) + , (=$$+-) + , ($$) + , ($=) + , (=$) + , (=$=) + , (.|) + -- ** Generalizing + , sourceToPipe + , sinkToPipe + , conduitToPipe + , toProducer + , toConsumer + -- ** Cleanup + , bracketP + -- ** Exceptions + , catchC + , handleC + , tryC + -- ** Utilities + , Data.Conduit.Internal.Conduit.transPipe + , Data.Conduit.Internal.Conduit.mapOutput + , Data.Conduit.Internal.Conduit.mapOutputMaybe + , Data.Conduit.Internal.Conduit.mapInput + , Data.Conduit.Internal.Conduit.mapInputM + , zipSinks + , zipSources + , zipSourcesApp + , zipConduitApp + , mergeSource + , passthroughSink + , sourceToList + , fuseBoth + , fuseBothMaybe + , fuseUpstream + , sequenceSources + , sequenceSinks + , sequenceConduits + ) where + +import Control.Applicative (Applicative (..)) +import Control.Exception (Exception) +import qualified Control.Exception as E (catch) +import Control.Monad (liftM, liftM2, ap) +import Control.Monad.Fail(MonadFail(..)) +import Control.Monad.Error.Class(MonadError(..)) +import Control.Monad.Reader.Class(MonadReader(..)) +import Control.Monad.RWS.Class(MonadRWS()) +import Control.Monad.Writer.Class(MonadWriter(..), censor) +import Control.Monad.State.Class(MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.IO.Unlift (MonadIO (liftIO), MonadUnliftIO, withRunInIO) +import Control.Monad.Primitive (PrimMonad, PrimState, primitive) +import Data.Functor.Identity (Identity, runIdentity) +import Data.Void (Void, absurd) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Semigroup (Semigroup ((<>))) +import Control.Monad.Trans.Resource +import Data.Conduit.Internal.Pipe hiding (yield, mapOutput, leftover, yieldM, await, awaitForever, bracketP, unconsM, unconsEitherM) +import qualified Data.Conduit.Internal.Pipe as CI +import Control.Monad (forever) +import Data.Traversable (Traversable (..)) + +-- | Core datatype of the conduit package. This type represents a general +-- component which can consume a stream of input values @i@, produce a stream +-- of output values @o@, perform actions in the @m@ monad, and produce a final +-- result @r@. The type synonyms provided here are simply wrappers around this +-- type. +-- +-- Since 1.3.0 +newtype ConduitT i o m r = ConduitT + { unConduitT :: forall b. + (r -> Pipe i i o () m b) -> Pipe i i o () m b + } + +-- | In order to provide for efficient monadic composition, the +-- @ConduitT@ type is implemented internally using a technique known +-- as the codensity transform. This allows for cheap appending, but +-- makes one case much more expensive: partially running a @ConduitT@ +-- and that capturing the new state. +-- +-- This data type is the same as @ConduitT@, but does not use the +-- codensity transform technique. +-- +-- @since 1.3.0 +newtype SealedConduitT i o m r = SealedConduitT (Pipe i i o () m r) + +-- | Same as 'ConduitT', for backwards compat +type ConduitM = ConduitT + +instance Functor (ConduitT i o m) where + fmap f (ConduitT c) = ConduitT $ \rest -> c (rest . f) + +instance Applicative (ConduitT i o m) where + pure x = ConduitT ($ x) + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + x *> y = x >>= \_ -> y + {-# INLINE (*>) #-} + +instance Monad (ConduitT i o m) where + return = pure + ConduitT f >>= g = ConduitT $ \h -> f $ \a -> unConduitT (g a) h + +-- | @since 1.3.1 +instance MonadFail m => MonadFail (ConduitT i o m) where + fail = lift . Control.Monad.Fail.fail + +instance MonadThrow m => MonadThrow (ConduitT i o m) where + throwM = lift . throwM + +instance MonadIO m => MonadIO (ConduitT i o m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance MonadReader r m => MonadReader r (ConduitT i o m) where + ask = lift ask + {-# INLINE ask #-} + + local f (ConduitT c0) = ConduitT $ \rest -> + let go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (\i -> go (p i)) (\u -> go (c u)) + go (Done x) = rest x + go (PipeM mp) = PipeM (liftM go $ local f mp) + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x, y, z) 0 +#endif + +instance MonadWriter w m => MonadWriter w (ConduitT i o m) where +#if MIN_VERSION_mtl(2, 1, 0) + writer = lift . writer +#endif + tell = lift . tell + + listen (ConduitT c0) = ConduitT $ \rest -> + let go front (HaveOutput p o) = HaveOutput (go front p) o + go front (NeedInput p c) = NeedInput (\i -> go front (p i)) (\u -> go front (c u)) + go front (Done x) = rest (x, front) + go front (PipeM mp) = PipeM $ do + (p,w) <- listen mp + return $ go (front `mappend` w) p + go front (Leftover p i) = Leftover (go front p) i + in go mempty (c0 Done) + + pass (ConduitT c0) = ConduitT $ \rest -> + let go front (HaveOutput p o) = HaveOutput (go front p) o + go front (NeedInput p c) = NeedInput (\i -> go front (p i)) (\u -> go front (c u)) + go front (PipeM mp) = PipeM $ do + (p,w) <- censor (const mempty) (listen mp) + return $ go (front `mappend` w) p + go front (Done (x,f)) = PipeM $ do + tell (f front) + return $ rest x + go front (Leftover p i) = Leftover (go front p) i + in go mempty (c0 Done) + +instance MonadState s m => MonadState s (ConduitT i o m) where + get = lift get + put = lift . put +#if MIN_VERSION_mtl(2, 1, 0) + state = lift . state +#endif + +instance MonadRWS r w s m => MonadRWS r w s (ConduitT i o m) + +instance MonadError e m => MonadError e (ConduitT i o m) where + throwError = lift . throwError + catchError (ConduitT c0) f = ConduitT $ \rest -> + let go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (\i -> go (p i)) (\u -> go (c u)) + go (Done x) = rest x + go (PipeM mp) = + PipeM $ catchError (liftM go mp) $ \e -> do + return $ unConduitT (f e) rest + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + +instance MonadTrans (ConduitT i o) where + lift mr = ConduitT $ \rest -> PipeM (liftM rest mr) + {-# INLINE [1] lift #-} + +instance MonadResource m => MonadResource (ConduitT i o m) where + liftResourceT = lift . liftResourceT + {-# INLINE liftResourceT #-} + +instance Monad m => Semigroup (ConduitT i o m ()) where + (<>) = (>>) + {-# INLINE (<>) #-} + +instance Monad m => Monoid (ConduitT i o m ()) where + mempty = return () + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + {-# INLINE mappend #-} +#endif + +instance PrimMonad m => PrimMonad (ConduitT i o m) where + type PrimState (ConduitT i o m) = PrimState m + primitive = lift . primitive + +-- | Provides a stream of output values, without consuming any input or +-- producing a final result. +-- +-- Since 0.5.0 +type Source m o = ConduitT () o m () +{-# DEPRECATED Source "Use ConduitT directly" #-} + +-- | A component which produces a stream of output values, regardless of the +-- input stream. A @Producer@ is a generalization of a @Source@, and can be +-- used as either a @Source@ or a @Conduit@. +-- +-- Since 1.0.0 +type Producer m o = forall i. ConduitT i o m () +{-# DEPRECATED Producer "Use ConduitT directly" #-} + +-- | Consumes a stream of input values and produces a final result, without +-- producing any output. +-- +-- > type Sink i m r = ConduitT i Void m r +-- +-- Since 0.5.0 +type Sink i = ConduitT i Void +{-# DEPRECATED Sink "Use ConduitT directly" #-} + +-- | A component which consumes a stream of input values and produces a final +-- result, regardless of the output stream. A @Consumer@ is a generalization of +-- a @Sink@, and can be used as either a @Sink@ or a @Conduit@. +-- +-- Since 1.0.0 +type Consumer i m r = forall o. ConduitT i o m r +{-# DEPRECATED Consumer "Use ConduitT directly" #-} + +-- | Consumes a stream of input values and produces a stream of output values, +-- without producing a final result. +-- +-- Since 0.5.0 +type Conduit i m o = ConduitT i o m () +{-# DEPRECATED Conduit "Use ConduitT directly" #-} + +sealConduitT :: ConduitT i o m r -> SealedConduitT i o m r +sealConduitT (ConduitT f) = SealedConduitT (f Done) + +unsealConduitT :: Monad m => SealedConduitT i o m r -> ConduitT i o m r +unsealConduitT (SealedConduitT f) = ConduitT (f >>=) + +-- | Connect a @Source@ to a @Sink@ until the latter closes. Returns both the +-- most recent state of the @Source@ and the result of the @Sink@. +-- +-- Since 0.5.0 +connectResume :: Monad m + => SealedConduitT () a m () + -> ConduitT a Void m r + -> m (SealedConduitT () a m (), r) +connectResume (SealedConduitT left0) (ConduitT right0) = + goRight left0 (right0 Done) + where + goRight left right = + case right of + HaveOutput _ o -> absurd o + NeedInput rp rc -> goLeft rp rc left + Done r2 -> return (SealedConduitT left, r2) + PipeM mp -> mp >>= goRight left + Leftover p i -> goRight (HaveOutput left i) p + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight left' (rp o) + NeedInput _ lc -> recurse (lc ()) + Done () -> goRight (Done ()) (rc ()) + PipeM mp -> mp >>= recurse + Leftover p () -> recurse p + where + recurse = goLeft rp rc + +sourceToPipe :: Monad m => ConduitT () o m () -> Pipe l i o u m () +sourceToPipe (ConduitT k) = + go $ k Done + where + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput _ c) = go $ c () + go (Done ()) = Done () + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover p ()) = go p + +sinkToPipe :: Monad m => ConduitT i Void m r -> Pipe l i o u m r +sinkToPipe (ConduitT k) = + go $ injectLeftovers $ k Done + where + go (HaveOutput _ o) = absurd o + go (NeedInput p c) = NeedInput (go . p) (const $ go $ c ()) + go (Done r) = Done r + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover _ l) = absurd l + +conduitToPipe :: Monad m => ConduitT i o m () -> Pipe l i o u m () +conduitToPipe (ConduitT k) = + go $ injectLeftovers $ k Done + where + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (go . p) (const $ go $ c ()) + go (Done ()) = Done () + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover _ l) = absurd l + +-- | Generalize a 'Source' to a 'Producer'. +-- +-- Since 1.0.0 +toProducer :: Monad m => ConduitT () a m () -> ConduitT i a m () +toProducer (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput _ c) = go (c ()) + go (Done r) = rest r + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover p ()) = go p + in go (c0 Done) + +-- | Generalize a 'Sink' to a 'Consumer'. +-- +-- Since 1.0.0 +toConsumer :: Monad m => ConduitT a Void m b -> ConduitT a o m b +toConsumer (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput _ o) = absurd o + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = rest r + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover p l) = Leftover (go p) l + in go (c0 Done) + +-- | Catch all exceptions thrown by the current component of the pipeline. +-- +-- Note: this will /not/ catch exceptions thrown by other components! For +-- example, if an exception is thrown in a @Source@ feeding to a @Sink@, and +-- the @Sink@ uses @catchC@, the exception will /not/ be caught. +-- +-- Due to this behavior (as well as lack of async exception safety), you +-- should not try to implement combinators such as @onException@ in terms of this +-- primitive function. +-- +-- Note also that the exception handling will /not/ be applied to any +-- finalizers generated by this conduit. +-- +-- Since 1.0.11 +catchC :: (MonadUnliftIO m, Exception e) + => ConduitT i o m r + -> (e -> ConduitT i o m r) + -> ConduitT i o m r +catchC (ConduitT p0) onErr = ConduitT $ \rest -> let + go (Done r) = rest r + go (PipeM mp) = PipeM $ withRunInIO $ \ run -> + run (liftM go mp) `E.catch` \ e -> + return $ onErr e `unConduitT` rest + go (Leftover p i) = Leftover (go p) i + go (NeedInput x y) = NeedInput (go . x) (go . y) + go (HaveOutput p o) = HaveOutput (go p) o + in go (p0 Done) +{-# INLINE catchC #-} + +-- | The same as @flip catchC@. +-- +-- Since 1.0.11 +handleC :: (MonadUnliftIO m, Exception e) + => (e -> ConduitT i o m r) + -> ConduitT i o m r + -> ConduitT i o m r +handleC = flip catchC +{-# INLINE handleC #-} + +-- | A version of @try@ for use within a pipeline. See the comments in @catchC@ +-- for more details. +-- +-- Since 1.0.11 +tryC :: (MonadUnliftIO m, Exception e) + => ConduitT i o m r + -> ConduitT i o m (Either e r) +tryC c = fmap Right c `catchC` (return . Left) +{-# INLINE tryC #-} + +-- | Combines two sinks. The new sink will complete when both input sinks have +-- completed. +-- +-- Any leftovers are discarded. +-- +-- Since 0.4.1 +zipSinks :: Monad m => ConduitT i Void m r -> ConduitT i Void m r' -> ConduitT i Void m (r, r') +zipSinks (ConduitT x0) (ConduitT y0) = ConduitT $ \rest -> let + Leftover _ i >< _ = absurd i + _ >< Leftover _ i = absurd i + HaveOutput _ o >< _ = absurd o + _ >< HaveOutput _ o = absurd o + + PipeM mx >< y = PipeM (liftM (>< y) mx) + x >< PipeM my = PipeM (liftM (x ><) my) + Done x >< Done y = rest (x, y) + NeedInput px cx >< NeedInput py cy = NeedInput (\i -> px i >< py i) (\() -> cx () >< cy ()) + NeedInput px cx >< y@Done{} = NeedInput (\i -> px i >< y) (\u -> cx u >< y) + x@Done{} >< NeedInput py cy = NeedInput (\i -> x >< py i) (\u -> x >< cy u) + in injectLeftovers (x0 Done) >< injectLeftovers (y0 Done) + +-- | Combines two sources. The new source will stop producing once either +-- source has been exhausted. +-- +-- Since 1.0.13 +zipSources :: Monad m => ConduitT () a m () -> ConduitT () b m () -> ConduitT () (a, b) m () +zipSources (ConduitT left0) (ConduitT right0) = ConduitT $ \rest -> let + go (Leftover left ()) right = go left right + go left (Leftover right ()) = go left right + go (Done ()) (Done ()) = rest () + go (Done ()) (HaveOutput _ _) = rest () + go (HaveOutput _ _) (Done ()) = rest () + go (Done ()) (PipeM _) = rest () + go (PipeM _) (Done ()) = rest () + go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) + go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) + go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) + go (HaveOutput srcx x) (HaveOutput srcy y) = HaveOutput (go srcx srcy) (x, y) + go (NeedInput _ c) right = go (c ()) right + go left (NeedInput _ c) = go left (c ()) + in go (left0 Done) (right0 Done) + +-- | Combines two sources. The new source will stop producing once either +-- source has been exhausted. +-- +-- Since 1.0.13 +zipSourcesApp :: Monad m => ConduitT () (a -> b) m () -> ConduitT () a m () -> ConduitT () b m () +zipSourcesApp (ConduitT left0) (ConduitT right0) = ConduitT $ \rest -> let + go (Leftover left ()) right = go left right + go left (Leftover right ()) = go left right + go (Done ()) (Done ()) = rest () + go (Done ()) (HaveOutput _ _) = rest () + go (HaveOutput _ _) (Done ()) = rest () + go (Done ()) (PipeM _) = rest () + go (PipeM _) (Done ()) = rest () + go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) + go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) + go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) + go (HaveOutput srcx x) (HaveOutput srcy y) = HaveOutput (go srcx srcy) (x y) + go (NeedInput _ c) right = go (c ()) right + go left (NeedInput _ c) = go left (c ()) + in go (left0 Done) (right0 Done) + +-- | +-- +-- Since 1.0.17 +zipConduitApp + :: Monad m + => ConduitT i o m (x -> y) + -> ConduitT i o m x + -> ConduitT i o m y +zipConduitApp (ConduitT left0) (ConduitT right0) = ConduitT $ \rest -> let + go (Done f) (Done x) = rest (f x) + go (PipeM mx) y = PipeM (flip go y `liftM` mx) + go x (PipeM my) = PipeM (go x `liftM` my) + go (HaveOutput x o) y = HaveOutput (go x y) o + go x (HaveOutput y o) = HaveOutput (go x y) o + go (Leftover _ i) _ = absurd i + go _ (Leftover _ i) = absurd i + go (NeedInput px cx) (NeedInput py cy) = NeedInput + (\i -> go (px i) (py i)) + (\u -> go (cx u) (cy u)) + go (NeedInput px cx) (Done y) = NeedInput + (\i -> go (px i) (Done y)) + (\u -> go (cx u) (Done y)) + go (Done x) (NeedInput py cy) = NeedInput + (\i -> go (Done x) (py i)) + (\u -> go (Done x) (cy u)) + in go (injectLeftovers $ left0 Done) (injectLeftovers $ right0 Done) + +-- | Same as normal fusion (e.g. @=$=@), except instead of discarding leftovers +-- from the downstream component, return them. +-- +-- Since 1.0.17 +fuseReturnLeftovers :: Monad m + => ConduitT a b m () + -> ConduitT b c m r + -> ConduitT a c m (r, [b]) +fuseReturnLeftovers (ConduitT left0) (ConduitT right0) = ConduitT $ \rest -> let + goRight bs left right = + case right of + HaveOutput p o -> HaveOutput (recurse p) o + NeedInput rp rc -> + case bs of + [] -> goLeft rp rc left + b:bs' -> goRight bs' left (rp b) + Done r2 -> rest (r2, bs) + PipeM mp -> PipeM (liftM recurse mp) + Leftover p b -> goRight (b:bs) left p + where + recurse = goRight bs left + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight [] left' (rp o) + NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) + Done r1 -> goRight [] (Done r1) (rc r1) + PipeM mp -> PipeM (liftM recurse mp) + Leftover left' i -> Leftover (recurse left') i + where + recurse = goLeft rp rc + in goRight [] (left0 Done) (right0 Done) + +-- | Similar to @fuseReturnLeftovers@, but use the provided function to convert +-- downstream leftovers to upstream leftovers. +-- +-- Since 1.0.17 +fuseLeftovers + :: Monad m + => ([b] -> [a]) + -> ConduitT a b m () + -> ConduitT b c m r + -> ConduitT a c m r +fuseLeftovers f left right = do + (r, bs) <- fuseReturnLeftovers left right + mapM_ leftover $ reverse $ f bs + return r + +-- | Connect a 'Conduit' to a sink and return the output of the sink +-- together with a new 'Conduit'. +-- +-- Since 1.0.17 +connectResumeConduit + :: Monad m + => SealedConduitT i o m () + -> ConduitT o Void m r + -> ConduitT i Void m (SealedConduitT i o m (), r) +connectResumeConduit (SealedConduitT left0) (ConduitT right0) = ConduitT $ \rest -> let + goRight left right = + case right of + HaveOutput _ o -> absurd o + NeedInput rp rc -> goLeft rp rc left + Done r2 -> rest (SealedConduitT left, r2) + PipeM mp -> PipeM (liftM (goRight left) mp) + Leftover p i -> goRight (HaveOutput left i) p + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight left' (rp o) + NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) + Done () -> goRight (Done ()) (rc ()) + PipeM mp -> PipeM (liftM recurse mp) + Leftover left' i -> Leftover (recurse left') i -- recurse p + where + recurse = goLeft rp rc + in goRight left0 (right0 Done) + +-- | Merge a @Source@ into a @Conduit@. +-- The new conduit will stop processing once either source or upstream have been exhausted. +mergeSource + :: Monad m + => ConduitT () i m () + -> ConduitT a (i, a) m () +mergeSource = loop . sealConduitT + where + loop :: Monad m => SealedConduitT () i m () -> ConduitT a (i, a) m () + loop src0 = await >>= maybe (return ()) go + where + go a = do + (src1, mi) <- lift $ src0 $$++ await + case mi of + Nothing -> leftover a + Just i -> yield (i, a) >> loop src1 + + +-- | Turn a @Sink@ into a @Conduit@ in the following way: +-- +-- * All input passed to the @Sink@ is yielded downstream. +-- +-- * When the @Sink@ finishes processing, the result is passed to the provided to the finalizer function. +-- +-- Note that the @Sink@ will stop receiving input as soon as the downstream it +-- is connected to shuts down. +-- +-- An example usage would be to write the result of a @Sink@ to some mutable +-- variable while allowing other processing to continue. +-- +-- Since 1.1.0 +passthroughSink :: Monad m + => ConduitT i Void m r + -> (r -> m ()) -- ^ finalizer + -> ConduitT i i m () +passthroughSink (ConduitT sink0) final = ConduitT $ \rest -> let + -- A bit of explanation is in order, this function is + -- non-obvious. The purpose of go is to keep track of the sink + -- we're passing values to, and then yield values downstream. The + -- third argument to go is the current state of that sink. That's + -- relatively straightforward. + -- + -- The second value is the leftover buffer. These are values that + -- the sink itself has called leftover on, and must be provided + -- back to the sink the next time it awaits. _However_, these + -- values should _not_ be reyielded downstream: we have already + -- yielded them downstream ourself, and it is the responsibility + -- of the functions wrapping around passthroughSink to handle the + -- leftovers from downstream. + -- + -- The trickiest bit is the first argument, which is a solution to + -- bug https://github.com/snoyberg/conduit/issues/304. The issue + -- is that, once we get a value, we need to provide it to both the + -- inner sink _and_ yield it downstream. The obvious thing to do + -- is yield first and then recursively call go. Unfortunately, + -- this doesn't work in all cases: if the downstream component + -- never calls await again, our yield call will never return, and + -- our sink will not get the last value. This results is confusing + -- behavior where the sink and downstream component receive a + -- different number of values. + -- + -- Solution: keep a buffer of the next value to yield downstream, + -- and only yield it downstream in one of two cases: our sink is + -- asking for another value, or our sink is done. This way, we + -- ensure that, in all cases, we pass exactly the same number of + -- values to the inner sink as to downstream. + + go mbuf _ (Done r) = do + maybe (return ()) CI.yield mbuf + lift $ final r + unConduitT (awaitForever yield) rest + go mbuf is (Leftover sink i) = go mbuf (i:is) sink + go _ _ (HaveOutput _ o) = absurd o + go mbuf is (PipeM mx) = do + x <- lift mx + go mbuf is x + go mbuf (i:is) (NeedInput next _) = go mbuf is (next i) + go mbuf [] (NeedInput next done) = do + maybe (return ()) CI.yield mbuf + mx <- CI.await + case mx of + Nothing -> go Nothing [] (done ()) + Just x -> go (Just x) [] (next x) + in go Nothing [] (sink0 Done) + +-- | Convert a @Source@ into a list. The basic functionality can be explained as: +-- +-- > sourceToList src = src $$ Data.Conduit.List.consume +-- +-- However, @sourceToList@ is able to produce its results lazily, which cannot +-- be done when running a conduit pipeline in general. Unlike the +-- @Data.Conduit.Lazy@ module (in conduit-extra), this function performs no +-- unsafe I\/O operations, and therefore can only be as lazy as the +-- underlying monad. +-- +-- Since 1.2.6 +sourceToList :: Monad m => ConduitT () a m () -> m [a] +sourceToList (ConduitT k) = + go $ k Done + where + go (Done _) = return [] + go (HaveOutput src x) = liftM (x:) (go src) + go (PipeM msrc) = msrc >>= go + go (NeedInput _ c) = go (c ()) + go (Leftover p _) = go p + +-- Define fixity of all our operators +infixr 0 $$ +infixl 1 $= +infixr 2 =$ +infixr 2 =$= +infixr 0 $$+ +infixr 0 $$++ +infixr 0 $$+- +infixl 1 $=+ +infixr 2 .| + +-- | Equivalent to using 'runConduit' and '.|' together. +-- +-- Since 1.2.3 +connect :: Monad m + => ConduitT () a m () + -> ConduitT a Void m r + -> m r +connect = ($$) + +-- | Split a conduit into head and tail. +-- +-- Note that you have to 'sealConduitT' it first. +-- +-- Since 1.3.3 +unconsM :: Monad m + => SealedConduitT () o m () + -> m (Maybe (o, SealedConduitT () o m ())) +unconsM (SealedConduitT p) = go p + where + -- This function is the same as @Pipe.unconsM@ but it ignores leftovers. + go (HaveOutput p o) = pure $ Just (o, SealedConduitT p) + go (NeedInput _ c) = go $ c () + go (Done ()) = pure Nothing + go (PipeM mp) = mp >>= go + go (Leftover p ()) = go p + +-- | Split a conduit into head and tail or return its result if it is done. +-- +-- Note that you have to 'sealConduitT' it first. +-- +-- Since 1.3.3 +unconsEitherM :: Monad m + => SealedConduitT () o m r + -> m (Either r (o, SealedConduitT () o m r)) +unconsEitherM (SealedConduitT p) = go p + where + -- This function is the same as @Pipe.unconsEitherM@ but it ignores leftovers. + go (HaveOutput p o) = pure $ Right (o, SealedConduitT p) + go (NeedInput _ c) = go $ c () + go (Done r) = pure $ Left r + go (PipeM mp) = mp >>= go + go (Leftover p ()) = go p + +-- | Named function synonym for '.|' +-- +-- Equivalent to '.|' and '=$='. However, the latter is +-- deprecated and will be removed in a future version. +-- +-- Since 1.2.3 +fuse :: Monad m => ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r +fuse = (=$=) + +-- | Combine two @Conduit@s together into a new @Conduit@ (aka 'fuse'). +-- +-- Output from the upstream (left) conduit will be fed into the +-- downstream (right) conduit. Processing will terminate when +-- downstream (right) returns. +-- Leftover data returned from the right @Conduit@ will be discarded. +-- +-- Equivalent to 'fuse' and '=$=', however the latter is deprecated and will +-- be removed in a future version. +-- +-- Note that, while this operator looks like categorical composition +-- (from "Control.Category"), there are a few reasons it's different: +-- +-- * The position of the type parameters to 'ConduitT' do not +-- match. We would need to change @ConduitT i o m r@ to @ConduitT r +-- m i o@, which would preclude a 'Monad' or 'MonadTrans' instance. +-- +-- * The result value from upstream and downstream are allowed to +-- differ between upstream and downstream. In other words, we would +-- need the type signature here to look like @ConduitT a b m r -> +-- ConduitT b c m r -> ConduitT a c m r@. +-- +-- * Due to leftovers, we do not have a left identity in Conduit. This +-- can be achieved with the underlying @Pipe@ datatype, but this is +-- not generally recommended. See . +-- +-- @since 1.2.8 +(.|) :: Monad m + => ConduitT a b m () -- ^ upstream + -> ConduitT b c m r -- ^ downstream + -> ConduitT a c m r +(.|) = fuse +{-# INLINE (.|) #-} + +-- | The connect operator, which pulls data from a source and pushes to a sink. +-- If you would like to keep the @Source@ open to be used for other +-- operations, use the connect-and-resume operator '$$+'. +-- +-- Since 0.4.0 +($$) :: Monad m => Source m a -> Sink a m b -> m b +src $$ sink = do + (rsrc, res) <- src $$+ sink + rsrc $$+- return () + return res +{-# INLINE [1] ($$) #-} +{-# DEPRECATED ($$) "Use runConduit and .|" #-} + +-- | A synonym for '=$=' for backwards compatibility. +-- +-- Since 0.4.0 +($=) :: Monad m => Conduit a m b -> ConduitT b c m r -> ConduitT a c m r +($=) = (=$=) +{-# INLINE [0] ($=) #-} +{-# RULES "conduit: $= is =$=" ($=) = (=$=) #-} +{-# DEPRECATED ($=) "Use .|" #-} + +-- | A synonym for '=$=' for backwards compatibility. +-- +-- Since 0.4.0 +(=$) :: Monad m => Conduit a m b -> ConduitT b c m r -> ConduitT a c m r +(=$) = (=$=) +{-# INLINE [0] (=$) #-} +{-# RULES "conduit: =$ is =$=" (=$) = (=$=) #-} +{-# DEPRECATED (=$) "Use .|" #-} + +-- | Deprecated fusion operator. +-- +-- Since 0.4.0 +(=$=) :: Monad m => Conduit a m b -> ConduitT b c m r -> ConduitT a c m r +ConduitT left0 =$= ConduitT right0 = ConduitT $ \rest -> + let goRight left right = + case right of + HaveOutput p o -> HaveOutput (recurse p) o + NeedInput rp rc -> goLeft rp rc left + Done r2 -> rest r2 + PipeM mp -> PipeM (liftM recurse mp) + Leftover right' i -> goRight (HaveOutput left i) right' + where + recurse = goRight left + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight left' (rp o) + NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) + Done r1 -> goRight (Done r1) (rc r1) + PipeM mp -> PipeM (liftM recurse mp) + Leftover left' i -> Leftover (recurse left') i + where + recurse = goLeft rp rc + in goRight (left0 Done) (right0 Done) +{-# INLINE [1] (=$=) #-} +{-# DEPRECATED (=$=) "Use .|" #-} + +-- | Wait for a single input value from upstream. If no data is available, +-- returns @Nothing@. Once @await@ returns @Nothing@, subsequent calls will +-- also return @Nothing@. +-- +-- Since 0.5.0 +await :: Monad m => ConduitT i o m (Maybe i) +await = ConduitT $ \f -> NeedInput (f . Just) (const $ f Nothing) +{-# INLINE [0] await #-} + +await' :: Monad m + => ConduitT i o m r + -> (i -> ConduitT i o m r) + -> ConduitT i o m r +await' f g = ConduitT $ \rest -> NeedInput + (\i -> unConduitT (g i) rest) + (const $ unConduitT f rest) +{-# INLINE await' #-} +{-# RULES "conduit: await >>= maybe" forall x y. await >>= maybe x y = await' x y #-} + +-- | Send a value downstream to the next component to consume. If the +-- downstream component terminates, this call will never return control. +-- +-- Since 0.5.0 +yield :: Monad m + => o -- ^ output value + -> ConduitT i o m () +yield o = ConduitT $ \rest -> HaveOutput (rest ()) o +{-# INLINE yield #-} + +-- | Send a monadic value downstream for the next component to consume. +-- +-- @since 1.2.7 +yieldM :: Monad m => m o -> ConduitT i o m () +yieldM mo = lift mo >>= yield +{-# INLINE yieldM #-} + + -- FIXME rule won't fire, see FIXME in .Pipe; "mapM_ yield" mapM_ yield = ConduitT . sourceList + +-- | Provide a single piece of leftover input to be consumed by the next +-- component in the current monadic binding. +-- +-- /Note/: it is highly encouraged to only return leftover values from input +-- already consumed from upstream. +-- +-- @since 0.5.0 +leftover :: i -> ConduitT i o m () +leftover i = ConduitT $ \rest -> Leftover (rest ()) i +{-# INLINE leftover #-} + +-- | Run a pipeline until processing completes. +-- +-- Since 1.2.1 +runConduit :: Monad m => ConduitT () Void m r -> m r +runConduit (ConduitT p) = runPipe $ injectLeftovers $ p Done +{-# INLINE [0] runConduit #-} + +-- | Bracket a conduit computation between allocation and release of a +-- resource. Two guarantees are given about resource finalization: +-- +-- 1. It will be /prompt/. The finalization will be run as early as possible. +-- +-- 2. It is exception safe. Due to usage of @resourcet@, the finalization will +-- be run in the event of any exceptions. +-- +-- Since 0.5.0 +bracketP :: MonadResource m + + => IO a + -- ^ computation to run first (\"acquire resource\") + -> (a -> IO ()) + -- ^ computation to run last (\"release resource\") + -> (a -> ConduitT i o m r) + -- ^ computation to run in-between + -> ConduitT i o m r + -- returns the value from the in-between computation +bracketP alloc free inside = ConduitT $ \rest -> do + (key, seed) <- allocate alloc free + unConduitT (inside seed) $ \res -> do + release key + rest res + +-- | Wait for input forever, calling the given inner component for each piece of +-- new input. +-- +-- This function is provided as a convenience for the common pattern of +-- @await@ing input, checking if it's @Just@ and then looping. +-- +-- Since 0.5.0 +awaitForever :: Monad m => (i -> ConduitT i o m r) -> ConduitT i o m () +awaitForever f = ConduitT $ \rest -> + let go = NeedInput (\i -> unConduitT (f i) (const go)) rest + in go + +-- | Transform the monad that a @ConduitT@ lives in. +-- +-- Note that the monad transforming function will be run multiple times, +-- resulting in unintuitive behavior in some cases. For a fuller treatment, +-- please see: +-- +-- +-- +-- Since 0.4.0 +transPipe :: Monad m => (forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r +transPipe f (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = rest r + go (PipeM mp) = + PipeM (f $ liftM go $ collapse mp) + where + -- Combine a series of monadic actions into a single action. Since we + -- throw away side effects between different actions, an arbitrary break + -- between actions will lead to a violation of the monad transformer laws. + -- Example available at: + -- + -- http://hpaste.org/75520 + collapse mpipe = do + pipe' <- mpipe + case pipe' of + PipeM mpipe' -> collapse mpipe' + _ -> return pipe' + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + +-- | Apply a function to all the output values of a @ConduitT@. +-- +-- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 +-- days. It can also be simulated by fusing with the @map@ conduit from +-- "Data.Conduit.List". +-- +-- Since 0.4.1 +mapOutput :: Monad m => (o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r +mapOutput f (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = HaveOutput (go p) (f o) + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = rest r + go (PipeM mp) = PipeM (liftM (go) mp) + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + +-- | Same as 'mapOutput', but use a function that returns @Maybe@ values. +-- +-- Since 0.5.0 +mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> ConduitT i o1 m r -> ConduitT i o2 m r +mapOutputMaybe f (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = maybe id (\o' p' -> HaveOutput p' o') (f o) (go p) + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = rest r + go (PipeM mp) = PipeM (liftM (go) mp) + go (Leftover p i) = Leftover (go p) i + in go (c0 Done) + +-- | Apply a function to all the input values of a @ConduitT@. +-- +-- Since 0.5.0 +mapInput :: Monad m + => (i1 -> i2) -- ^ map initial input to new input + -> (i2 -> Maybe i1) -- ^ map new leftovers to initial leftovers + -> ConduitT i2 o m r + -> ConduitT i1 o m r +mapInput f f' (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (go . p . f) (go . c) + go (Done r) = rest r + go (PipeM mp) = PipeM $ liftM go mp + go (Leftover p i) = maybe id (flip Leftover) (f' i) (go p) + in go (c0 Done) + +-- | Apply a monadic action to all the input values of a @ConduitT@. +-- +-- Since 1.3.2 +mapInputM :: Monad m + => (i1 -> m i2) -- ^ map initial input to new input + -> (i2 -> m (Maybe i1)) -- ^ map new leftovers to initial leftovers + -> ConduitT i2 o m r + -> ConduitT i1 o m r +mapInputM f f' (ConduitT c0) = ConduitT $ \rest -> let + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput p c) = NeedInput (\i -> PipeM $ go . p <$> f i) (go . c) + go (Done r) = rest r + go (PipeM mp) = PipeM $ fmap go mp + go (Leftover p i) = PipeM $ (\x -> maybe id (flip Leftover) x (go p)) <$> f' i + in go (c0 Done) + +-- | The connect-and-resume operator. This does not close the @Source@, but +-- instead returns it to be used again. This allows a @Source@ to be used +-- incrementally in a large program, without forcing the entire program to live +-- in the @Sink@ monad. +-- +-- Mnemonic: connect + do more. +-- +-- Since 0.5.0 +($$+) :: Monad m => ConduitT () a m () -> ConduitT a Void m b -> m (SealedConduitT () a m (), b) +src $$+ sink = connectResume (sealConduitT src) sink +{-# INLINE ($$+) #-} + +-- | Continue processing after usage of @$$+@. +-- +-- Since 0.5.0 +($$++) :: Monad m => SealedConduitT () a m () -> ConduitT a Void m b -> m (SealedConduitT () a m (), b) +($$++) = connectResume +{-# INLINE ($$++) #-} + +-- | Same as @$$++@ and @connectResume@, but doesn't include the +-- updated @SealedConduitT@. +-- +-- /NOTE/ In previous versions, this would cause finalizers to +-- run. Since version 1.3.0, there are no finalizers in conduit. +-- +-- Since 0.5.0 +($$+-) :: Monad m => SealedConduitT () a m () -> ConduitT a Void m b -> m b +rsrc $$+- sink = do + (_, res) <- connectResume rsrc sink + return res +{-# INLINE ($$+-) #-} + +-- | Left fusion for a sealed source. +-- +-- Since 1.0.16 +($=+) :: Monad m => SealedConduitT () a m () -> ConduitT a b m () -> SealedConduitT () b m () +SealedConduitT src $=+ ConduitT sink = SealedConduitT (src `pipeL` sink Done) + +-- | Provide for a stream of data that can be flushed. +-- +-- A number of @Conduit@s (e.g., zlib compression) need the ability to flush +-- the stream at some point. This provides a single wrapper datatype to be used +-- in all such circumstances. +-- +-- Since 0.3.0 +data Flush a = Chunk a | Flush + deriving (Show, Eq, Ord) +instance Functor Flush where + fmap _ Flush = Flush + fmap f (Chunk a) = Chunk (f a) + +-- | A wrapper for defining an 'Applicative' instance for 'Source's which allows +-- to combine sources together, generalizing 'zipSources'. A combined source +-- will take input yielded from each of its @Source@s until any of them stop +-- producing output. +-- +-- Since 1.0.13 +newtype ZipSource m o = ZipSource { getZipSource :: ConduitT () o m () } + +instance Monad m => Functor (ZipSource m) where + fmap f = ZipSource . mapOutput f . getZipSource +instance Monad m => Applicative (ZipSource m) where + pure = ZipSource . forever . yield + (ZipSource f) <*> (ZipSource x) = ZipSource $ zipSourcesApp f x + +-- | Coalesce all values yielded by all of the @Source@s. +-- +-- Implemented on top of @ZipSource@ and as such, it exhibits the same +-- short-circuiting behavior as @ZipSource@. See that data type for more +-- details. If you want to create a source that yields *all* values from +-- multiple sources, use `sequence_`. +-- +-- Since 1.0.13 +sequenceSources :: (Traversable f, Monad m) => f (ConduitT () o m ()) -> ConduitT () (f o) m () +sequenceSources = getZipSource . sequenceA . fmap ZipSource + +-- | A wrapper for defining an 'Applicative' instance for 'Sink's which allows +-- to combine sinks together, generalizing 'zipSinks'. A combined sink +-- distributes the input to all its participants and when all finish, produces +-- the result. This allows to define functions like +-- +-- @ +-- sequenceSinks :: (Monad m) +-- => [ConduitT i Void m r] -> ConduitT i Void m [r] +-- sequenceSinks = getZipSink . sequenceA . fmap ZipSink +-- @ +-- +-- Note that the standard 'Applicative' instance for conduits works +-- differently. It feeds one sink with input until it finishes, then switches +-- to another, etc., and at the end combines their results. +-- +-- This newtype is in fact a type constrained version of 'ZipConduit', and has +-- the same behavior. It's presented as a separate type since (1) it +-- historically predates @ZipConduit@, and (2) the type constraining can make +-- your code clearer (and thereby make your error messages more easily +-- understood). +-- +-- Since 1.0.13 +newtype ZipSink i m r = ZipSink { getZipSink :: ConduitT i Void m r } + +instance Monad m => Functor (ZipSink i m) where + fmap f (ZipSink x) = ZipSink (liftM f x) +instance Monad m => Applicative (ZipSink i m) where + pure = ZipSink . return + (ZipSink f) <*> (ZipSink x) = + ZipSink $ liftM (uncurry ($)) $ zipSinks f x + +-- | 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. +-- +-- Since 1.0.13 +sequenceSinks :: (Traversable f, Monad m) => f (ConduitT i Void m r) -> ConduitT i Void m (f r) +sequenceSinks = getZipSink . sequenceA . fmap ZipSink + +-- | The connect-and-resume operator. This does not close the @Conduit@, but +-- instead returns it to be used again. This allows a @Conduit@ to be used +-- incrementally in a large program, without forcing the entire program to live +-- in the @Sink@ monad. +-- +-- Leftover data returned from the @Sink@ will be discarded. +-- +-- Mnemonic: connect + do more. +-- +-- Since 1.0.17 +(=$$+) :: Monad m + => ConduitT a b m () + -> ConduitT b Void m r + -> ConduitT a Void m (SealedConduitT a b m (), r) +(=$$+) conduit = connectResumeConduit (sealConduitT conduit) +{-# INLINE (=$$+) #-} + +-- | Continue processing after usage of '=$$+'. Connect a 'SealedConduitT' to +-- a sink and return the output of the sink together with a new +-- 'SealedConduitT'. +-- +-- Since 1.0.17 +(=$$++) :: Monad m => SealedConduitT i o m () -> ConduitT o Void m r -> ConduitT i Void m (SealedConduitT i o m (), r) +(=$$++) = connectResumeConduit +{-# INLINE (=$$++) #-} + +-- | Same as @=$$++@, but doesn't include the updated +-- @SealedConduitT@. +-- +-- /NOTE/ In previous versions, this would cause finalizers to +-- run. Since version 1.3.0, there are no finalizers in conduit. +-- +-- Since 1.0.17 +(=$$+-) :: Monad m => SealedConduitT i o m () -> ConduitT o Void m r -> ConduitT i Void m r +rsrc =$$+- sink = do + (_, res) <- connectResumeConduit rsrc sink + return res +{-# INLINE (=$$+-) #-} + + +infixr 0 =$$+ +infixr 0 =$$++ +infixr 0 =$$+- + +-- | Provides an alternative @Applicative@ instance for @ConduitT@. In this instance, +-- every incoming value is provided to all @ConduitT@s, and output is coalesced together. +-- Leftovers from individual @ConduitT@s will be used within that component, and then discarded +-- at the end of their computation. Output and finalizers will both be handled in a left-biased manner. +-- +-- As an example, take the following program: +-- +-- @ +-- main :: IO () +-- main = do +-- let src = mapM_ yield [1..3 :: Int] +-- conduit1 = CL.map (+1) +-- conduit2 = CL.concatMap (replicate 2) +-- conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 +-- sink = CL.mapM_ print +-- src $$ conduit =$ sink +-- @ +-- +-- It will produce the output: 2, 1, 1, 3, 2, 2, 4, 3, 3 +-- +-- Since 1.0.17 +newtype ZipConduit i o m r = ZipConduit { getZipConduit :: ConduitT i o m r } + deriving Functor +instance Monad m => Applicative (ZipConduit i o m) where + pure = ZipConduit . pure + ZipConduit left <*> ZipConduit right = ZipConduit (zipConduitApp left right) + +-- | Provide identical input to all of the @Conduit@s and combine their outputs +-- into a single stream. +-- +-- Implemented on top of @ZipConduit@, see that data type for more details. +-- +-- Since 1.0.17 +sequenceConduits :: (Traversable f, Monad m) => f (ConduitT i o m r) -> ConduitT i o m (f r) +sequenceConduits = getZipConduit . sequenceA . fmap ZipConduit + +-- | Fuse two @ConduitT@s together, and provide the return value of both. Note +-- that this will force the entire upstream @ConduitT@ to be run to produce the +-- result value, even if the downstream terminates early. +-- +-- Since 1.1.5 +fuseBoth :: Monad m => ConduitT a b m r1 -> ConduitT b c m r2 -> ConduitT a c m (r1, r2) +fuseBoth (ConduitT up) (ConduitT down) = + ConduitT (pipeL (up Done) (withUpstream $ generalizeUpstream $ down Done) >>=) +{-# INLINE fuseBoth #-} + +-- | Like 'fuseBoth', but does not force consumption of the @Producer@. +-- In the case that the @Producer@ terminates, the result value is +-- provided as a @Just@ value. If it does not terminate, then a +-- @Nothing@ value is returned. +-- +-- One thing to note here is that "termination" here only occurs if the +-- @Producer@ actually yields a @Nothing@ value. For example, with the +-- @Producer@ @mapM_ yield [1..5]@, if five values are requested, the +-- @Producer@ has not yet terminated. Termination only occurs when the +-- sixth value is awaited for and the @Producer@ signals termination. +-- +-- Since 1.2.4 +fuseBothMaybe + :: Monad m + => ConduitT a b m r1 + -> ConduitT b c m r2 + -> ConduitT a c m (Maybe r1, r2) +fuseBothMaybe (ConduitT up) (ConduitT down) = + ConduitT (pipeL (up Done) (go Nothing $ down Done) >>=) + where + go mup (Done r) = Done (mup, r) + go mup (PipeM mp) = PipeM $ liftM (go mup) mp + go mup (HaveOutput p o) = HaveOutput (go mup p) o + go _ (NeedInput p c) = NeedInput + (\i -> go Nothing (p i)) + (\u -> go (Just u) (c ())) + go mup (Leftover p i) = Leftover (go mup p) i +{-# INLINABLE fuseBothMaybe #-} + +-- | Same as @fuseBoth@, but ignore the return value from the downstream +-- @Conduit@. Same caveats of forced consumption apply. +-- +-- Since 1.1.5 +fuseUpstream :: Monad m => ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r +fuseUpstream up down = fmap fst (fuseBoth up down) +{-# INLINE fuseUpstream #-} + +-- Rewrite rules + +{- FIXME +{-# RULES "conduit: ConduitT: lift x >>= f" forall m f. lift m >>= f = ConduitT (PipeM (liftM (unConduitT . f) m)) #-} +{-# RULES "conduit: ConduitT: lift x >> f" forall m f. lift m >> f = ConduitT (PipeM (liftM (\_ -> unConduitT f) m)) #-} + +{-# RULES "conduit: ConduitT: liftIO x >>= f" forall m (f :: MonadIO m => a -> ConduitT i o m r). liftIO m >>= f = ConduitT (PipeM (liftM (unConduitT . f) (liftIO m))) #-} +{-# RULES "conduit: ConduitT: liftIO x >> f" forall m (f :: MonadIO m => ConduitT i o m r). liftIO m >> f = ConduitT (PipeM (liftM (\_ -> unConduitT f) (liftIO m))) #-} + +{-# RULES "conduit: ConduitT: liftBase x >>= f" forall m (f :: MonadBase b m => a -> ConduitT i o m r). liftBase m >>= f = ConduitT (PipeM (liftM (unConduitT . f) (liftBase m))) #-} +{-# RULES "conduit: ConduitT: liftBase x >> f" forall m (f :: MonadBase b m => ConduitT i o m r). liftBase m >> f = ConduitT (PipeM (liftM (\_ -> unConduitT f) (liftBase m))) #-} + +{-# RULES + "yield o >> p" forall o (p :: ConduitT i o m r). yield o >> p = ConduitT (HaveOutput (unConduitT p) o) + ; "when yield next" forall b o p. when b (yield o) >> p = + if b then ConduitT (HaveOutput (unConduitT p) o) else p + ; "unless yield next" forall b o p. unless b (yield o) >> p = + if b then p else ConduitT (HaveOutput (unConduitT p) o) + ; "lift m >>= yield" forall m. lift m >>= yield = yieldM m + #-} +{-# RULES "conduit: leftover l >> p" forall l (p :: ConduitT i o m r). leftover l >> p = + ConduitT (Leftover (unConduitT p) l) #-} + -} + +-- | Run a pure pipeline until processing completes, i.e. a pipeline +-- with @Identity@ as the base monad. This is equivalient to +-- @runIdentity . runConduit@. +-- +-- @since 1.2.8 +runConduitPure :: ConduitT () Void Identity r -> r +runConduitPure = runIdentity . runConduit +{-# INLINE runConduitPure #-} + +-- | Run a pipeline which acquires resources with @ResourceT@, and +-- then run the @ResourceT@ transformer. This is equivalent to +-- @runResourceT . runConduit@. +-- +-- @since 1.2.8 +runConduitRes :: MonadUnliftIO m + => ConduitT () Void (ResourceT m) r + -> m r +runConduitRes = runResourceT . runConduit +{-# INLINE runConduitRes #-} diff --git a/src/Data/Conduit/Internal/Fusion.hs b/src/Data/Conduit/Internal/Fusion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Internal/Fusion.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Conduit.Internal.Fusion + ( -- ** Types + Step (..) + , Stream (..) + , ConduitWithStream + , StreamConduitT + , StreamConduit + , StreamSource + , StreamProducer + , StreamSink + , StreamConsumer + -- ** Functions + , streamConduit + , streamSource + , streamSourcePure + , unstream + ) where + +import Data.Conduit.Internal.Conduit +import Data.Conduit.Internal.Pipe (Pipe (..)) +import Data.Functor.Identity (Identity (runIdentity)) +import Data.Void (Void, absurd) +import Control.Monad.Trans.Resource (runResourceT) + +-- | This is the same as stream fusion\'s Step. Constructors are renamed to +-- avoid confusion with conduit names. +data Step s o r + = Emit s o + | Skip s + | Stop r + deriving Functor + +data Stream m o r = forall s. Stream + (s -> m (Step s o r)) + (m s) + +data ConduitWithStream i o m r = ConduitWithStream + (ConduitT i o m r) + (StreamConduitT i o m r) + +type StreamConduitT i o m r = Stream m i () -> Stream m o r + +type StreamConduit i m o = StreamConduitT i o m () + +type StreamSource m o = StreamConduitT () o m () + +type StreamProducer m o = forall i. StreamConduitT i o m () + +type StreamSink i m r = StreamConduitT i Void m r + +type StreamConsumer i m r = forall o. StreamConduitT i o m r + +unstream :: ConduitWithStream i o m r -> ConduitT i o m r +unstream (ConduitWithStream c _) = c +{-# INLINE [0] unstream #-} + +fuseStream :: Monad m + => ConduitWithStream a b m () + -> ConduitWithStream b c m r + -> ConduitWithStream a c m r +fuseStream (ConduitWithStream a x) (ConduitWithStream b y) = + ConduitWithStream (a .| b) (y . x) +{-# INLINE fuseStream #-} + +{-# RULES "conduit: fuseStream (.|)" forall left right. + unstream left .| unstream right = unstream (fuseStream left right) + #-} +{-# RULES "conduit: fuseStream (fuse)" forall left right. + fuse (unstream left) (unstream right) = unstream (fuseStream left right) + #-} +{-# RULES "conduit: fuseStream (=$=)" forall left right. + unstream left =$= unstream right = unstream (fuseStream left right) + #-} + +runStream :: Monad m + => ConduitWithStream () Void m r + -> m r +runStream (ConduitWithStream _ f) = + run $ f $ Stream emptyStep (return ()) + where + emptyStep _ = return $ Stop () + run (Stream step ms0) = + ms0 >>= loop + where + loop s = do + res <- step s + case res of + Stop r -> return r + Skip s' -> loop s' + Emit _ o -> absurd o +{-# INLINE runStream #-} + +{-# RULES "conduit: runStream" forall stream. + runConduit (unstream stream) = runStream stream + #-} +{-# RULES "conduit: runStream (pure)" forall stream. + runConduitPure (unstream stream) = runIdentity (runStream stream) + #-} +{-# RULES "conduit: runStream (ResourceT)" forall stream. + runConduitRes (unstream stream) = runResourceT (runStream stream) + #-} + +connectStream :: Monad m + => ConduitWithStream () i m () + -> ConduitWithStream i Void m r + -> m r +connectStream (ConduitWithStream _ stream) (ConduitWithStream _ f) = + run $ f $ stream $ Stream emptyStep (return ()) + where + emptyStep _ = return $ Stop () + run (Stream step ms0) = + ms0 >>= loop + where + loop s = do + res <- step s + case res of + Stop r -> return r + Skip s' -> loop s' + Emit _ o -> absurd o +{-# INLINE connectStream #-} + +{-# RULES "conduit: connectStream ($$)" forall left right. + unstream left $$ unstream right = connectStream left right + #-} + +connectStream1 :: Monad m + => ConduitWithStream () i m () + -> ConduitT i Void m r + -> m r +connectStream1 (ConduitWithStream _ fstream) (ConduitT sink0) = + case fstream $ Stream (const $ return $ Stop ()) (return ()) of + Stream step ms0 -> + let loop _ (Done r) _ = return r + loop ls (PipeM mp) s = mp >>= flip (loop ls) s + loop ls (Leftover p l) s = loop (l:ls) p s + loop _ (HaveOutput _ o) _ = absurd o + loop (l:ls) (NeedInput p _) s = loop ls (p l) s + loop [] (NeedInput p c) s = do + res <- step s + case res of + Stop () -> loop [] (c ()) s + Skip s' -> loop [] (NeedInput p c) s' + Emit s' i -> loop [] (p i) s' + in ms0 >>= loop [] (sink0 Done) +{-# INLINE connectStream1 #-} + +{-# RULES "conduit: connectStream1 ($$)" forall left right. + unstream left $$ right = connectStream1 left right + #-} + +{-# RULES "conduit: connectStream1 (runConduit/.|)" forall left right. + runConduit (unstream left .| right) = connectStream1 left right + #-} +{-# RULES "conduit: connectStream1 (runConduit/=$=)" forall left right. + runConduit (unstream left =$= right) = connectStream1 left right + #-} +{-# RULES "conduit: connectStream1 (runConduit/fuse)" forall left right. + runConduit (fuse (unstream left) right) = connectStream1 left right + #-} + +{-# RULES "conduit: connectStream1 (runConduitPure/.|)" forall left right. + runConduitPure (unstream left .| right) = runIdentity (connectStream1 left right) + #-} +{-# RULES "conduit: connectStream1 (runConduitPure/=$=)" forall left right. + runConduitPure (unstream left =$= right) = runIdentity (connectStream1 left right) + #-} +{-# RULES "conduit: connectStream1 (runConduitPure/fuse)" forall left right. + runConduitPure (fuse (unstream left) right) = runIdentity (connectStream1 left right) + #-} + +{-# RULES "conduit: connectStream1 (runConduitRes/.|)" forall left right. + runConduitRes (unstream left .| right) = runResourceT (connectStream1 left right) + #-} +{-# RULES "conduit: connectStream1 (runConduitRes/=$=)" forall left right. + runConduitRes (unstream left =$= right) = runResourceT (connectStream1 left right) + #-} +{-# RULES "conduit: connectStream1 (runConduitRes/fuse)" forall left right. + runConduitRes (fuse (unstream left) right) = runResourceT (connectStream1 left right) + #-} + +connectStream2 :: forall i m r. Monad m + => ConduitT () i m () + -> ConduitWithStream i Void m r + -> m r +connectStream2 (ConduitT src0) (ConduitWithStream _ fstream) = + run $ fstream $ Stream step' $ return (src0 Done) + where + step' :: Pipe () () i () m () -> m (Step (Pipe () () i () m ()) i ()) + step' (Done ()) = return $ Stop () + step' (HaveOutput pipe o) = return $ Emit pipe o + step' (NeedInput _ c) = return $ Skip $ c () + step' (PipeM mp) = Skip <$> mp + step' (Leftover p ()) = return $ Skip p + {-# INLINE step' #-} + + run (Stream step ms0) = + ms0 >>= loop + where + loop s = do + res <- step s + case res of + Stop r -> return r + Emit _ o -> absurd o + Skip s' -> loop s' +{-# INLINE connectStream2 #-} + +{-# RULES "conduit: connectStream2 ($$)" forall left right. + left $$ unstream right = connectStream2 left right + #-} + +{-# RULES "conduit: connectStream2 (runConduit/.|)" forall left right. + runConduit (left .| unstream right) = connectStream2 left right + #-} +{-# RULES "conduit: connectStream2 (runConduit/fuse)" forall left right. + runConduit (fuse left (unstream right)) = connectStream2 left right + #-} +{-# RULES "conduit: connectStream2 (runConduit/=$=)" forall left right. + runConduit (left =$= unstream right) = connectStream2 left right + #-} + +{-# RULES "conduit: connectStream2 (runConduitPure/.|)" forall left right. + runConduitPure (left .| unstream right) = runIdentity (connectStream2 left right) + #-} +{-# RULES "conduit: connectStream2 (runConduitPure/fuse)" forall left right. + runConduitPure (fuse left (unstream right)) = runIdentity (connectStream2 left right) + #-} +{-# RULES "conduit: connectStream2 (runConduitPure/=$=)" forall left right. + runConduitPure (left =$= unstream right) = runIdentity (connectStream2 left right) + #-} + +{-# RULES "conduit: connectStream2 (runConduitRes/.|)" forall left right. + runConduitRes (left .| unstream right) = runResourceT (connectStream2 left right) + #-} +{-# RULES "conduit: connectStream2 (runConduitRes/fuse)" forall left right. + runConduitRes (fuse left (unstream right)) = runResourceT (connectStream2 left right) + #-} +{-# RULES "conduit: connectStream2 (runConduitRes/=$=)" forall left right. + runConduitRes (left =$= unstream right) = runResourceT (connectStream2 left right) + #-} + +streamConduit :: ConduitT i o m r + -> (Stream m i () -> Stream m o r) + -> ConduitWithStream i o m r +streamConduit = ConduitWithStream +{-# INLINE CONLIKE streamConduit #-} + +streamSource + :: Monad m + => Stream m o () + -> ConduitWithStream i o m () +streamSource str@(Stream step ms0) = + ConduitWithStream con (const str) + where + con = ConduitT $ \rest -> PipeM $ do + s0 <- ms0 + let loop s = do + res <- step s + case res of + Stop () -> return $ rest () + Emit s' o -> return $ HaveOutput (PipeM $ loop s') o + Skip s' -> loop s' + loop s0 +{-# INLINE streamSource #-} + +streamSourcePure + :: Monad m + => Stream Identity o () + -> ConduitWithStream i o m () +streamSourcePure (Stream step ms0) = + ConduitWithStream con (const $ Stream (return . runIdentity . step) (return s0)) + where + s0 = runIdentity ms0 + con = ConduitT $ \rest -> + let loop s = + case runIdentity $ step s of + Stop () -> rest () + Emit s' o -> HaveOutput (loop s') o + Skip s' -> loop s' + in loop s0 +{-# INLINE streamSourcePure #-} diff --git a/src/Data/Conduit/Internal/List/Stream.hs b/src/Data/Conduit/Internal/List/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Internal/List/Stream.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} +module Data.Conduit.Internal.List.Stream where + +import Control.Monad (liftM) +import Data.Conduit.Internal.Fusion +import qualified Data.Foldable as F + +--FIXME: Should streamSource / streamSourcePure be used for sources? + +unfoldS :: Monad m + => (b -> Maybe (a, b)) + -> b + -> StreamProducer m a +unfoldS f s0 _ = + Stream step (return s0) + where + step s = return $ + case f s of + Nothing -> Stop () + Just (x, s') -> Emit s' x +{-# INLINE unfoldS #-} + +unfoldEitherS :: Monad m + => (b -> Either r (a, b)) + -> b + -> StreamConduitT i a m r +unfoldEitherS f s0 _ = + Stream step (return s0) + where + step s = return $ + case f s of + Left r -> Stop r + Right (x, s') -> Emit s' x +{-# INLINE unfoldEitherS #-} + +unfoldMS :: Monad m + => (b -> m (Maybe (a, b))) + -> b + -> StreamProducer m a +unfoldMS f s0 _ = + Stream step (return s0) + where + step s = do + ms' <- f s + return $ case ms' of + Nothing -> Stop () + Just (x, s') -> Emit s' x +{-# INLINE unfoldMS #-} + +unfoldEitherMS :: Monad m + => (b -> m (Either r (a, b))) + -> b + -> StreamConduitT i a m r +unfoldEitherMS f s0 _ = + Stream step (return s0) + where + step s = do + ms' <- f s + return $ case ms' of + Left r -> Stop r + Right (x, s') -> Emit s' x +{-# INLINE unfoldEitherMS #-} +sourceListS :: Monad m => [a] -> StreamProducer m a +sourceListS xs0 _ = + Stream (return . step) (return xs0) + where + step [] = Stop () + step (x:xs) = Emit xs x +{-# INLINE sourceListS #-} + +enumFromToS :: (Enum a, Prelude.Ord a, Monad m) + => a + -> a + -> StreamProducer m a +enumFromToS x0 y _ = + Stream step (return x0) + where + step x = return $ if x Prelude.> y + then Stop () + else Emit (Prelude.succ x) x +{-# INLINE [0] enumFromToS #-} + +enumFromToS_int :: (Prelude.Integral a, Monad m) + => a + -> a + -> StreamProducer m a +enumFromToS_int x0 y _ = x0 `seq` y `seq` Stream step (return x0) + where + step x | x <= y = return $ Emit (x Prelude.+ 1) x + | otherwise = return $ Stop () +{-# INLINE enumFromToS_int #-} + +{-# RULES "conduit: enumFromTo" forall f t. + enumFromToS f t = enumFromToS_int f t :: Monad m => StreamProducer m Int + #-} + +iterateS :: Monad m => (a -> a) -> a -> StreamProducer m a +iterateS f x0 _ = + Stream (return . step) (return x0) + where + step x = Emit x' x + where + x' = f x +{-# INLINE iterateS #-} + +replicateS :: Monad m => Int -> a -> StreamProducer m a +replicateS cnt0 a _ = + Stream step (return cnt0) + where + step cnt + | cnt <= 0 = return $ Stop () + | otherwise = return $ Emit (cnt - 1) a +{-# INLINE replicateS #-} + +replicateMS :: Monad m => Int -> m a -> StreamProducer m a +replicateMS cnt0 ma _ = + Stream step (return cnt0) + where + step cnt + | cnt <= 0 = return $ Stop () + | otherwise = Emit (cnt - 1) `liftM` ma +{-# INLINE replicateMS #-} + +foldS :: Monad m => (b -> a -> b) -> b -> StreamConsumer a m b +foldS f b0 (Stream step ms0) = + Stream step' (liftM (b0, ) ms0) + where + step' (!b, s) = do + res <- step s + return $ case res of + Stop () -> Stop b + Skip s' -> Skip (b, s') + Emit s' a -> Skip (f b a, s') +{-# INLINE foldS #-} + +foldMS :: Monad m => (b -> a -> m b) -> b -> StreamConsumer a m b +foldMS f b0 (Stream step ms0) = + Stream step' (liftM (b0, ) ms0) + where + step' (!b, s) = do + res <- step s + case res of + Stop () -> return $ Stop b + Skip s' -> return $ Skip (b, s') + Emit s' a -> do + b' <- f b a + return $ Skip (b', s') +{-# INLINE foldMS #-} + +mapM_S :: Monad m + => (a -> m ()) + -> StreamConsumer a m () +mapM_S f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip s' + Emit s' x -> f x >> return (Skip s') +{-# INLINE [1] mapM_S #-} + +dropS :: Monad m + => Int + -> StreamConsumer a m () +dropS n0 (Stream step ms0) = + Stream step' (liftM (, n0) ms0) + where + step' (_, n) | n <= 0 = return $ Stop () + step' (s, n) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (s', n) + Emit s' _ -> Skip (s', n - 1) +{-# INLINE dropS #-} + +takeS :: Monad m + => Int + -> StreamConsumer a m [a] +takeS n0 (Stream step s0) = + Stream step' (liftM (id, n0,) s0) + where + step' (output, n, _) | n <= 0 = return $ Stop (output []) + step' (output, n, s) = do + res <- step s + return $ case res of + Stop () -> Stop (output []) + Skip s' -> Skip (output, n, s') + Emit s' x -> Skip (output . (x:), n - 1, s') +{-# INLINE takeS #-} + +headS :: Monad m => StreamConsumer a m (Maybe a) +headS (Stream step s0) = + Stream step' s0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop Nothing + Skip s' -> Skip s' + Emit _ x -> Stop (Just x) +{-# INLINE headS #-} + +mapS :: Monad m => (a -> b) -> StreamConduit a m b +mapS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop r -> Stop r + Emit s' a -> Emit s' (f a) + Skip s' -> Skip s' +{-# INLINE mapS #-} + +mapMS :: Monad m => (a -> m b) -> StreamConduit a m b +mapMS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + case res of + Stop r -> return $ Stop r + Emit s' a -> Emit s' `liftM` f a + Skip s' -> return $ Skip s' +{-# INLINE mapMS #-} + +iterMS :: Monad m => (a -> m ()) -> StreamConduit a m a +iterMS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip s' + Emit s' x -> f x >> return (Emit s' x) +{-# INLINE iterMS #-} + +mapMaybeS :: Monad m => (a -> Maybe b) -> StreamConduit a m b +mapMaybeS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip s' + Emit s' x -> + case f x of + Just y -> Emit s' y + Nothing -> Skip s' +{-# INLINE mapMaybeS #-} + +mapMaybeMS :: Monad m => (a -> m (Maybe b)) -> StreamConduit a m b +mapMaybeMS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip s' + Emit s' x -> do + my <- f x + case my of + Just y -> return $ Emit s' y + Nothing -> return $ Skip s' +{-# INLINE mapMaybeMS #-} + +catMaybesS :: Monad m => StreamConduit (Maybe a) m a +catMaybesS (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip s' + Emit s' Nothing -> Skip s' + Emit s' (Just x) -> Emit s' x +{-# INLINE catMaybesS #-} + +concatS :: (Monad m, F.Foldable f) => StreamConduit (f a) m a +concatS (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip ([], s') + Emit s' x -> Skip (F.toList x, s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE concatS #-} + +concatMapS :: Monad m => (a -> [b]) -> StreamConduit a m b +concatMapS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip ([], s') + Emit s' x -> Skip (f x, s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE concatMapS #-} + +concatMapMS :: Monad m => (a -> m [b]) -> StreamConduit a m b +concatMapMS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip ([], s') + Emit s' x -> do + xs <- f x + return $ Skip (xs, s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE concatMapMS #-} + +concatMapAccumS :: Monad m => (a -> accum -> (accum, [b])) -> accum -> StreamConduit a m b +concatMapAccumS f initial (Stream step ms0) = + Stream step' (liftM (initial, [], ) ms0) + where + step' (accum, [], s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (accum, [], s') + Emit s' x -> + let (accum', xs) = f x accum + in Skip (accum', xs, s') + step' (accum, (x:xs), s) = return (Emit (accum, xs, s) x) +{-# INLINE concatMapAccumS #-} + +mapAccumS :: Monad m => (a -> s -> (s, b)) -> s -> StreamConduitT a b m s +mapAccumS f initial (Stream step ms0) = + Stream step' (liftM (initial, ) ms0) + where + step' (accum, s) = do + res <- step s + return $ case res of + Stop () -> Stop accum + Skip s' -> Skip (accum, s') + Emit s' x -> + let (accum', r) = f x accum + in Emit (accum', s') r +{-# INLINE mapAccumS #-} + +mapAccumMS :: Monad m => (a -> s -> m (s, b)) -> s -> StreamConduitT a b m s +mapAccumMS f initial (Stream step ms0) = + Stream step' (liftM (initial, ) ms0) + where + step' (accum, s) = do + res <- step s + case res of + Stop () -> return $ Stop accum + Skip s' -> return $ Skip (accum, s') + Emit s' x -> do + (accum', r) <- f x accum + return $ Emit (accum', s') r +{-# INLINE mapAccumMS #-} + +concatMapAccumMS :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> StreamConduit a m b +concatMapAccumMS f initial (Stream step ms0) = + Stream step' (liftM (initial, [], ) ms0) + where + step' (accum, [], s) = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip (accum, [], s') + Emit s' x -> do + (accum', xs) <- f x accum + return $ Skip (accum', xs, s') + step' (accum, (x:xs), s) = return (Emit (accum, xs, s) x) +{-# INLINE concatMapAccumMS #-} + +mapFoldableS :: (Monad m, F.Foldable f) => (a -> f b) -> StreamConduit a m b +mapFoldableS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip ([], s') + Emit s' x -> Skip (F.toList (f x), s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE mapFoldableS #-} + +mapFoldableMS :: (Monad m, F.Foldable f) => (a -> m (f b)) -> StreamConduit a m b +mapFoldableMS f (Stream step ms0) = + Stream step' (liftM ([], ) ms0) + where + step' ([], s) = do + res <- step s + case res of + Stop () -> return $ Stop () + Skip s' -> return $ Skip ([], s') + Emit s' x -> do + y <- f x + return $ Skip (F.toList y, s') + step' ((x:xs), s) = return (Emit (xs, s) x) +{-# INLINE mapFoldableMS #-} + +consumeS :: Monad m => StreamConsumer a m [a] +consumeS (Stream step ms0) = + Stream step' (liftM (id,) ms0) + where + step' (front, s) = do + res <- step s + return $ case res of + Stop () -> Stop (front []) + Skip s' -> Skip (front, s') + Emit s' a -> Skip (front . (a:), s') +{-# INLINE consumeS #-} + +groupByS :: Monad m => (a -> a -> Bool) -> StreamConduit a m [a] +groupByS f = mapS (Prelude.uncurry (:)) . groupBy1S id f +{-# INLINE groupByS #-} + +groupOn1S :: (Monad m, Eq b) => (a -> b) -> StreamConduit a m (a, [a]) +groupOn1S f = groupBy1S f (==) +{-# INLINE groupOn1S #-} + +data GroupByState a b s + = GBStart s + | GBLoop ([a] -> [a]) a b s + | GBDone + +groupBy1S :: Monad m => (a -> b) -> (b -> b -> Bool) -> StreamConduit a m (a, [a]) +groupBy1S f eq (Stream step ms0) = + Stream step' (liftM GBStart ms0) + where + step' (GBStart s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (GBStart s') + Emit s' x0 -> Skip (GBLoop id x0 (f x0) s') + step' (GBLoop rest x0 fx0 s) = do + res <- step s + return $ case res of + Stop () -> Emit GBDone (x0, rest []) + Skip s' -> Skip (GBLoop rest x0 fx0 s') + Emit s' x + | fx0 `eq` f x -> Skip (GBLoop (rest . (x:)) x0 fx0 s') + | otherwise -> Emit (GBLoop id x (f x) s') (x0, rest []) + step' GBDone = return $ Stop () +{-# INLINE groupBy1S #-} + +isolateS :: Monad m => Int -> StreamConduit a m a +isolateS count (Stream step ms0) = + Stream step' (liftM (count,) ms0) + where + step' (n, _) | n <= 0 = return $ Stop () + step' (n, s) = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip (n, s') + Emit s' x -> Emit (n - 1, s') x +{-# INLINE isolateS #-} + +filterS :: Monad m => (a -> Bool) -> StreamConduit a m a +filterS f (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip s' + Emit s' x + | f x -> Emit s' x + | otherwise -> Skip s' + +sinkNullS :: Monad m => StreamConsumer a m () +sinkNullS (Stream step ms0) = + Stream step' ms0 + where + step' s = do + res <- step s + return $ case res of + Stop () -> Stop () + Skip s' -> Skip s' + Emit s' _ -> Skip s' +{-# INLINE sinkNullS #-} + +sourceNullS :: Monad m => StreamProducer m a +sourceNullS _ = Stream (\_ -> return (Stop ())) (return ()) +{-# INLINE sourceNullS #-} diff --git a/src/Data/Conduit/Internal/Pipe.hs b/src/Data/Conduit/Internal/Pipe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Internal/Pipe.hs @@ -0,0 +1,619 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Conduit.Internal.Pipe + ( -- ** Types + Pipe (..) + -- ** Primitives + , await + , awaitE + , awaitForever + , yield + , yieldM + , leftover + , unconsM + , unconsEitherM + -- ** Finalization + , bracketP + -- ** Composition + , idP + , pipe + , pipeL + , runPipe + , injectLeftovers + , (>+>) + , (<+<) + -- ** Exceptions + , catchP + , handleP + , tryP + -- ** Utilities + , transPipe + , mapOutput + , mapOutputMaybe + , mapInput + , sourceList + , withUpstream + , Data.Conduit.Internal.Pipe.enumFromTo + , generalizeUpstream + ) where + +import Control.Applicative (Applicative (..)) +import Control.Monad ((>=>), liftM, ap) +import Control.Monad.Error.Class(MonadError(..)) +import Control.Monad.Reader.Class(MonadReader(..)) +import Control.Monad.RWS.Class(MonadRWS()) +import Control.Monad.Writer.Class(MonadWriter(..)) +import Control.Monad.State.Class(MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.IO.Unlift (MonadIO (liftIO), MonadUnliftIO, withRunInIO) +import Control.Monad.Primitive (PrimMonad, PrimState, primitive) +import Data.Void (Void, absurd) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Semigroup (Semigroup ((<>))) +import Control.Monad.Trans.Resource +import qualified GHC.Exts +import qualified Control.Exception as E + +-- | The underlying datatype for all the types in this package. In has six +-- type parameters: +-- +-- * /l/ is the type of values that may be left over from this @Pipe@. A @Pipe@ +-- with no leftovers would use @Void@ here, and one with leftovers would use +-- the same type as the /i/ parameter. Leftovers are automatically provided to +-- the next @Pipe@ in the monadic chain. +-- +-- * /i/ is the type of values for this @Pipe@'s input stream. +-- +-- * /o/ is the type of values for this @Pipe@'s output stream. +-- +-- * /u/ is the result type from the upstream @Pipe@. +-- +-- * /m/ is the underlying monad. +-- +-- * /r/ is the result type. +-- +-- A basic intuition is that every @Pipe@ produces a stream of output values +-- (/o/), and eventually indicates that this stream is terminated by sending a +-- result (/r/). On the receiving end of a @Pipe@, these become the /i/ and /u/ +-- parameters. +-- +-- Since 0.5.0 +data Pipe l i o u m r = + -- | Provide new output to be sent downstream. This constructor has two + -- fields: the next @Pipe@ to be used and the output value. + HaveOutput (Pipe l i o u m r) o + -- | Request more input from upstream. The first field takes a new input + -- value and provides a new @Pipe@. The second takes an upstream result + -- value, which indicates that upstream is producing no more results. + | NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r) + -- | Processing with this @Pipe@ is complete, providing the final result. + | Done r + -- | Require running of a monadic action to get the next @Pipe@. + | PipeM (m (Pipe l i o u m r)) + -- | Return leftover input, which should be provided to future operations. + | Leftover (Pipe l i o u m r) l + +instance Monad m => Functor (Pipe l i o u m) where + fmap = liftM + {-# INLINE fmap #-} + +instance Monad m => Applicative (Pipe l i o u m) where + pure = Done + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (Pipe l i o u m) where + return = pure + {-# INLINE return #-} + + HaveOutput p o >>= fp = HaveOutput (p >>= fp) o + NeedInput p c >>= fp = NeedInput (p >=> fp) (c >=> fp) + Done x >>= fp = fp x + PipeM mp >>= fp = PipeM ((>>= fp) `liftM` mp) + Leftover p i >>= fp = Leftover (p >>= fp) i + +instance MonadTrans (Pipe l i o u) where + lift mr = PipeM (Done `liftM` mr) + {-# INLINE [1] lift #-} + +instance MonadIO m => MonadIO (Pipe l i o u m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance MonadThrow m => MonadThrow (Pipe l i o u m) where + throwM = lift . throwM + {-# INLINE throwM #-} + + +instance Monad m => Semigroup (Pipe l i o u m ()) where + (<>) = (>>) + {-# INLINE (<>) #-} + +instance Monad m => Monoid (Pipe l i o u m ()) where + mempty = return () + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) + {-# INLINE mappend #-} +#endif + +instance PrimMonad m => PrimMonad (Pipe l i o u m) where + type PrimState (Pipe l i o u m) = PrimState m + primitive = lift . primitive + +instance MonadResource m => MonadResource (Pipe l i o u m) where + liftResourceT = lift . liftResourceT + {-# INLINE liftResourceT #-} + +instance MonadReader r m => MonadReader r (Pipe l i o u m) where + ask = lift ask + {-# INLINE ask #-} + local f (HaveOutput p o) = HaveOutput (local f p) o + local f (NeedInput p c) = NeedInput (\i -> local f (p i)) (\u -> local f (c u)) + local _ (Done x) = Done x + local f (PipeM mp) = PipeM (liftM (local f) $ local f mp) + local f (Leftover p i) = Leftover (local f p) i + +-- Provided for doctest +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x, y, z) 0 +#endif + +instance MonadWriter w m => MonadWriter w (Pipe l i o u m) where +#if MIN_VERSION_mtl(2, 1, 0) + writer = lift . writer +#endif + + tell = lift . tell + + listen (HaveOutput p o) = HaveOutput (listen p) o + listen (NeedInput p c) = NeedInput (\i -> listen (p i)) (\u -> listen (c u)) + listen (Done x) = Done (x,mempty) + listen (PipeM mp) = + PipeM $ + do (p,w) <- listen mp + return $ do (x,w') <- listen p + return (x, w `mappend` w') + listen (Leftover p i) = Leftover (listen p) i + + pass (HaveOutput p o) = HaveOutput (pass p) o + pass (NeedInput p c) = NeedInput (\i -> pass (p i)) (\u -> pass (c u)) + pass (PipeM mp) = PipeM $ mp >>= (return . pass) + pass (Done (x,_)) = Done x + pass (Leftover p i) = Leftover (pass p) i + +instance MonadState s m => MonadState s (Pipe l i o u m) where + get = lift get + put = lift . put +#if MIN_VERSION_mtl(2, 1, 0) + state = lift . state +#endif + +instance MonadRWS r w s m => MonadRWS r w s (Pipe l i o u m) + +instance MonadError e m => MonadError e (Pipe l i o u m) where + throwError = lift . throwError + catchError (HaveOutput p o) f = HaveOutput (catchError p f) o + catchError (NeedInput p c) f = NeedInput (\i -> catchError (p i) f) (\u -> catchError (c u) f) + catchError (Done x) _ = Done x + catchError (PipeM mp) f = + PipeM $ catchError (liftM (flip catchError f) mp) (\e -> return (f e)) + catchError (Leftover p i) f = Leftover (catchError p f) i + +-- | Wait for a single input value from upstream. +-- +-- Since 0.5.0 +await :: Pipe l i o u m (Maybe i) +await = NeedInput (Done . Just) (\_ -> Done Nothing) +{-# RULES "conduit: CI.await >>= maybe" forall x y. await >>= maybe x y = NeedInput y (const x) #-} +{-# INLINE [1] await #-} + +-- | This is similar to @await@, but will return the upstream result value as +-- @Left@ if available. +-- +-- Since 0.5.0 +awaitE :: Pipe l i o u m (Either u i) +awaitE = NeedInput (Done . Right) (Done . Left) +{-# RULES "conduit: awaitE >>= either" forall x y. awaitE >>= either x y = NeedInput y x #-} +{-# INLINE [1] awaitE #-} + +-- | Wait for input forever, calling the given inner @Pipe@ for each piece of +-- new input. Returns the upstream result type. +-- +-- Since 0.5.0 +awaitForever :: Monad m => (i -> Pipe l i o r m r') -> Pipe l i o r m r +awaitForever inner = + self + where + self = awaitE >>= either return (\i -> inner i >> self) +{-# INLINE [1] awaitForever #-} + +-- | Send a single output value downstream. If the downstream @Pipe@ +-- terminates, this @Pipe@ will terminate as well. +-- +-- Since 0.5.0 +yield :: Monad m + => o -- ^ output value + -> Pipe l i o u m () +yield = HaveOutput (Done ()) +{-# INLINE [1] yield #-} + +yieldM :: Monad m => m o -> Pipe l i o u m () +yieldM = PipeM . liftM (HaveOutput (Done ())) +{-# INLINE [1] yieldM #-} + +{-# RULES + "CI.yield o >> p" forall o (p :: Pipe l i o u m r). yield o >> p = HaveOutput p o + #-} + + -- Rule does not fire due to inlining of lift + -- ; "lift m >>= CI.yield" forall m. lift m >>= yield = yieldM m + + -- FIXME: Too much inlining on mapM_, can't enforce; "mapM_ CI.yield" mapM_ yield = sourceList + -- Maybe we can get a rewrite rule on foldr instead? Need a benchmark to back this up. + +-- | Provide a single piece of leftover input to be consumed by the next pipe +-- in the current monadic binding. +-- +-- /Note/: it is highly encouraged to only return leftover values from input +-- already consumed from upstream. +-- +-- Since 0.5.0 +leftover :: l -> Pipe l i o u m () +leftover = Leftover (Done ()) +{-# INLINE [1] leftover #-} +{-# RULES "conduit: leftover l >> p" forall l (p :: Pipe l i o u m r). leftover l >> p = Leftover p l #-} + +-- | Split a pipe into head and tail. +-- +-- Since 1.3.3 +unconsM :: Monad m + => Pipe Void () o () m () + -> m (Maybe (o, Pipe Void () o () m ())) +unconsM = go + where + go (HaveOutput p o) = pure $ Just (o, p) + go (NeedInput _ c) = go $ c () + go (Done ()) = pure Nothing + go (PipeM mp) = mp >>= go + go (Leftover _ i) = absurd i + +-- | Split a pipe into head and tail or return its result if it is done. +-- +-- Since 1.3.3 +unconsEitherM :: Monad m + => Pipe Void () o () m r + -> m (Either r (o, Pipe Void () o () m r)) +unconsEitherM = go + where + go (HaveOutput p o) = pure $ Right (o, p) + go (NeedInput _ c) = go $ c () + go (Done r) = pure $ Left r + go (PipeM mp) = mp >>= go + go (Leftover _ i) = absurd i + +-- | Bracket a pipe computation between allocation and release of a resource. +-- We guarantee, via the @MonadResource@ context, that the resource +-- finalization is exception safe. However, it will not necessarily be +-- /prompt/, in that running a finalizer may wait until the @ResourceT@ block +-- exits. +-- +-- Since 0.5.0 +bracketP :: MonadResource m + => IO a + -- ^ computation to run first (\"acquire resource\") + -> (a -> IO ()) + -- ^ computation to run last (\"release resource\") + -> (a -> Pipe l i o u m r) + -- ^ computation to run in-between + -> Pipe l i o u m r + -- returns the value from the in-between computation +bracketP alloc free inside = do + (key, seed) <- allocate alloc free + res <- inside seed + release key + return res + +-- | The identity @Pipe@. +-- +-- Since 0.5.0 +idP :: Monad m => Pipe l a a r m r +idP = NeedInput (HaveOutput idP) Done + +-- | Compose a left and right pipe together into a complete pipe. +-- +-- Since 0.5.0 +pipe :: Monad m => Pipe l a b r0 m r1 -> Pipe Void b c r1 m r2 -> Pipe l a c r0 m r2 +pipe = + goRight + where + goRight left right = + case right of + HaveOutput p o -> HaveOutput (recurse p) o + NeedInput rp rc -> goLeft rp rc left + Done r2 -> Done r2 + PipeM mp -> PipeM (liftM recurse mp) + Leftover _ i -> absurd i + where + recurse = goRight left + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight left' (rp o) + NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) + Done r1 -> goRight (Done r1) (rc r1) + PipeM mp -> PipeM (liftM recurse mp) + Leftover left' i -> Leftover (recurse left') i + where + recurse = goLeft rp rc + +-- | Same as 'pipe', but automatically applies 'injectLeftovers' to the right @Pipe@. +-- +-- Since 0.5.0 +pipeL :: Monad m => Pipe l a b r0 m r1 -> Pipe b b c r1 m r2 -> Pipe l a c r0 m r2 +-- Note: The following should be equivalent to the simpler: +-- +-- pipeL l r = l `pipe` injectLeftovers r +-- +-- However, this version tested as being significantly more efficient. +pipeL = + goRight + where + goRight left right = + case right of + HaveOutput p o -> HaveOutput (recurse p) o + NeedInput rp rc -> goLeft rp rc left + Done r2 -> Done r2 + PipeM mp -> PipeM (liftM recurse mp) + Leftover right' i -> goRight (HaveOutput left i) right' + where + recurse = goRight left + + goLeft rp rc left = + case left of + HaveOutput left' o -> goRight left' (rp o) + NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) + Done r1 -> goRight (Done r1) (rc r1) + PipeM mp -> PipeM (liftM recurse mp) + Leftover left' i -> Leftover (recurse left') i + where + recurse = goLeft rp rc + +-- | Run a pipeline until processing completes. +-- +-- Since 0.5.0 +runPipe :: Monad m => Pipe Void () Void () m r -> m r +runPipe (HaveOutput _ o) = absurd o +runPipe (NeedInput _ c) = runPipe (c ()) +runPipe (Done r) = return r +runPipe (PipeM mp) = mp >>= runPipe +runPipe (Leftover _ i) = absurd i + +-- | Transforms a @Pipe@ that provides leftovers to one which does not, +-- allowing it to be composed. +-- +-- This function will provide any leftover values within this @Pipe@ to any +-- calls to @await@. If there are more leftover values than are demanded, the +-- remainder are discarded. +-- +-- Since 0.5.0 +injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r +injectLeftovers = + go [] + where + go ls (HaveOutput p o) = HaveOutput (go ls p) o + go (l:ls) (NeedInput p _) = go ls $ p l + go [] (NeedInput p c) = NeedInput (go [] . p) (go [] . c) + go _ (Done r) = Done r + go ls (PipeM mp) = PipeM (liftM (go ls) mp) + go ls (Leftover p l) = go (l:ls) p + +-- | Transform the monad that a @Pipe@ lives in. +-- +-- Note that the monad transforming function will be run multiple times, +-- resulting in unintuitive behavior in some cases. For a fuller treatment, +-- please see: +-- +-- +-- +-- This function is just a synonym for 'hoist'. +-- +-- Since 0.4.0 +transPipe :: Monad m => (forall a. m a -> n a) -> Pipe l i o u m r -> Pipe l i o u n r +transPipe f (HaveOutput p o) = HaveOutput (transPipe f p) o +transPipe f (NeedInput p c) = NeedInput (transPipe f . p) (transPipe f . c) +transPipe _ (Done r) = Done r +transPipe f (PipeM mp) = + PipeM (f $ liftM (transPipe f) $ collapse mp) + where + -- Combine a series of monadic actions into a single action. Since we + -- throw away side effects between different actions, an arbitrary break + -- between actions will lead to a violation of the monad transformer laws. + -- Example available at: + -- + -- http://hpaste.org/75520 + collapse mpipe = do + pipe' <- mpipe + case pipe' of + PipeM mpipe' -> collapse mpipe' + _ -> return pipe' +transPipe f (Leftover p i) = Leftover (transPipe f p) i + +-- | Apply a function to all the output values of a @Pipe@. +-- +-- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 +-- days. +-- +-- Since 0.4.1 +mapOutput :: Monad m => (o1 -> o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r +mapOutput f = + go + where + go (HaveOutput p o) = HaveOutput (go p) (f o) + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = Done r + go (PipeM mp) = PipeM (liftM (go) mp) + go (Leftover p i) = Leftover (go p) i +{-# INLINE mapOutput #-} + +-- | Same as 'mapOutput', but use a function that returns @Maybe@ values. +-- +-- Since 0.5.0 +mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r +mapOutputMaybe f = + go + where + go (HaveOutput p o) = maybe id (\o' p' -> HaveOutput p' o') (f o) (go p) + go (NeedInput p c) = NeedInput (go . p) (go . c) + go (Done r) = Done r + go (PipeM mp) = PipeM (liftM (go) mp) + go (Leftover p i) = Leftover (go p) i +{-# INLINE mapOutputMaybe #-} + +-- | Apply a function to all the input values of a @Pipe@. +-- +-- Since 0.5.0 +mapInput :: Monad m + => (i1 -> i2) -- ^ map initial input to new input + -> (l2 -> Maybe l1) -- ^ map new leftovers to initial leftovers + -> Pipe l2 i2 o u m r + -> Pipe l1 i1 o u m r +mapInput f f' (HaveOutput p o) = HaveOutput (mapInput f f' p) o +mapInput f f' (NeedInput p c) = NeedInput (mapInput f f' . p . f) (mapInput f f' . c) +mapInput _ _ (Done r) = Done r +mapInput f f' (PipeM mp) = PipeM (liftM (mapInput f f') mp) +mapInput f f' (Leftover p i) = maybe id (flip Leftover) (f' i) $ mapInput f f' p + +enumFromTo :: (Enum o, Eq o, Monad m) + => o + -> o + -> Pipe l i o u m () +enumFromTo start stop = + loop start + where + loop i + | i == stop = HaveOutput (Done ()) i + | otherwise = HaveOutput (loop (succ i)) i +{-# INLINE enumFromTo #-} + +-- | Convert a list into a source. +-- +-- Since 0.3.0 +sourceList :: Monad m => [a] -> Pipe l i a u m () +sourceList = + go + where + go [] = Done () + go (o:os) = HaveOutput (go os) o +{-# INLINE [1] sourceList #-} + +-- | The equivalent of @GHC.Exts.build@ for @Pipe@. +-- +-- Since 0.4.2 +build :: Monad m => (forall b. (o -> b -> b) -> b -> b) -> Pipe l i o u m () +build g = g (\o p -> HaveOutput p o) (return ()) + +{-# RULES + "sourceList/build" forall (f :: (forall b. (a -> b -> b) -> b -> b)). sourceList (GHC.Exts.build f) = build f #-} + +-- | Returns a tuple of the upstream and downstream results. Note that this +-- will force consumption of the entire input stream. +-- +-- Since 0.5.0 +withUpstream :: Monad m + => Pipe l i o u m r + -> Pipe l i o u m (u, r) +withUpstream down = + down >>= go + where + go r = + loop + where + loop = awaitE >>= either (\u -> return (u, r)) (\_ -> loop) + +infixr 9 <+< +infixl 9 >+> + +-- | Fuse together two @Pipe@s, connecting the output from the left to the +-- input of the right. +-- +-- Notice that the /leftover/ parameter for the @Pipe@s must be @Void@. This +-- ensures that there is no accidental data loss of leftovers during fusion. If +-- you have a @Pipe@ with leftovers, you must first call 'injectLeftovers'. +-- +-- Since 0.5.0 +(>+>) :: Monad m => Pipe l a b r0 m r1 -> Pipe Void b c r1 m r2 -> Pipe l a c r0 m r2 +(>+>) = pipe +{-# INLINE (>+>) #-} + +-- | Same as '>+>', but reverse the order of the arguments. +-- +-- Since 0.5.0 +(<+<) :: Monad m => Pipe Void b c r1 m r2 -> Pipe l a b r0 m r1 -> Pipe l a c r0 m r2 +(<+<) = flip pipe +{-# INLINE (<+<) #-} + +-- | See 'catchC' for more details. +-- +-- Since 1.0.11 +catchP :: (MonadUnliftIO m, E.Exception e) + => Pipe l i o u m r + -> (e -> Pipe l i o u m r) + -> Pipe l i o u m r +catchP p0 onErr = + go p0 + where + go (Done r) = Done r + go (PipeM mp) = PipeM $ withRunInIO $ \run -> + E.catch (run (liftM go mp)) (return . onErr) + go (Leftover p i) = Leftover (go p) i + go (NeedInput x y) = NeedInput (go . x) (go . y) + go (HaveOutput p o) = HaveOutput (go p) o +{-# INLINABLE catchP #-} + +-- | The same as @flip catchP@. +-- +-- Since 1.0.11 +handleP :: (MonadUnliftIO m, E.Exception e) + => (e -> Pipe l i o u m r) + -> Pipe l i o u m r + -> Pipe l i o u m r +handleP = flip catchP +{-# INLINE handleP #-} + +-- | See 'tryC' for more details. +-- +-- Since 1.0.11 +tryP :: (MonadUnliftIO m, E.Exception e) + => Pipe l i o u m r + -> Pipe l i o u m (Either e r) +tryP p = (fmap Right p) `catchP` (return . Left) +{-# INLINABLE tryP #-} + +-- | Generalize the upstream return value for a @Pipe@ from unit to any type. +-- +-- Since 1.1.5 +generalizeUpstream :: Monad m => Pipe l i o () m r -> Pipe l i o u m r +generalizeUpstream = + go + where + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (\_ -> go (y ())) + go (Done r) = Done r + go (PipeM mp) = PipeM (liftM go mp) + go (Leftover p l) = Leftover (go p) l +{-# INLINE generalizeUpstream #-} + +{- Rules don't fire due to inlining of lift +{-# RULES "conduit: Pipe: lift x >>= f" forall m f. lift m >>= f = PipeM (liftM f m) #-} +{-# RULES "conduit: Pipe: lift x >> f" forall m f. lift m >> f = PipeM (liftM (\_ -> f) m) #-} +-} diff --git a/src/Data/Conduit/Lift.hs b/src/Data/Conduit/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Lift.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE RankNTypes #-} +-- | Allow monad transformers to be run\/eval\/exec in a section of conduit +-- rather then needing to run across the whole conduit. The circumvents many +-- of the problems with breaking the monad transformer laws. For more +-- information, see the announcement blog post: +-- +-- +-- This module was added in conduit 1.0.11. +module Data.Conduit.Lift ( + -- * ExceptT + exceptC, + runExceptC, + catchExceptC, + + -- * CatchC + runCatchC, + catchCatchC, + + -- * MaybeT + maybeC, + runMaybeC, + + -- * ReaderT + readerC, + runReaderC, + + -- * StateT, lazy + stateLC, + runStateLC, + evalStateLC, + execStateLC, + + -- ** Strict + stateC, + runStateC, + evalStateC, + execStateC, + + -- * WriterT, lazy + writerLC, + runWriterLC, + execWriterLC, + + -- ** Strict + writerC, + runWriterC, + execWriterC, + + -- * RWST, lazy + rwsLC, + runRWSLC, + evalRWSLC, + execRWSLC, + + -- ** Strict + rwsC, + runRWSC, + evalRWSC, + execRWSC + ) where + +import Data.Conduit +import Data.Conduit.Internal (ConduitT (..), Pipe (..)) + +import Control.Monad.Trans.Class (MonadTrans(..)) + +import Data.Monoid (Monoid(..)) + + +import qualified Control.Monad.Trans.Except as Ex +import qualified Control.Monad.Trans.Maybe as M +import qualified Control.Monad.Trans.Reader as R + +import qualified Control.Monad.Trans.State.Strict as SS +import qualified Control.Monad.Trans.Writer.Strict as WS +import qualified Control.Monad.Trans.RWS.Strict as RWSS + +import qualified Control.Monad.Trans.State.Lazy as SL +import qualified Control.Monad.Trans.Writer.Lazy as WL +import qualified Control.Monad.Trans.RWS.Lazy as RWSL + +import Control.Monad.Catch.Pure (CatchT (runCatchT)) +import Control.Exception (SomeException) + +-- | Wrap the base monad in 'Ex.ExceptT' +-- +-- Since 1.2.12 +exceptC + :: Monad m => + ConduitT i o m (Either e a) -> ConduitT i o (Ex.ExceptT e m) a +exceptC p = do + x <- transPipe lift p + lift $ Ex.ExceptT (return x) + +-- | Run 'Ex.ExceptT' in the base monad +-- +-- Since 1.2.12 +runExceptC + :: Monad m => + ConduitT i o (Ex.ExceptT e m) r -> ConduitT i o m (Either e r) +runExceptC (ConduitT c0) = + ConduitT $ \rest -> + let go (Done r) = rest (Right r) + go (PipeM mp) = PipeM $ do + eres <- Ex.runExceptT mp + return $ case eres of + Left e -> rest $ Left e + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (go . y) + in go (c0 Done) +{-# INLINABLE runExceptC #-} + +-- | Catch an error in the base monad +-- +-- Since 1.2.12 +catchExceptC + :: Monad m => + ConduitT i o (Ex.ExceptT e m) r + -> (e -> ConduitT i o (Ex.ExceptT e m) r) + -> ConduitT i o (Ex.ExceptT e m) r +catchExceptC c0 h = + ConduitT $ \rest -> + let go (Done r) = rest r + go (PipeM mp) = PipeM $ do + eres <- lift $ Ex.runExceptT mp + return $ case eres of + Left e -> unConduitT (h e) rest + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (go . y) + in go $ unConduitT c0 Done + where +{-# INLINABLE catchExceptC #-} + +-- | Run 'CatchT' in the base monad +-- +-- Since 1.1.0 +runCatchC + :: Monad m => + ConduitT i o (CatchT m) r -> ConduitT i o m (Either SomeException r) +runCatchC c0 = + ConduitT $ \rest -> + let go (Done r) = rest (Right r) + go (PipeM mp) = PipeM $ do + eres <- runCatchT mp + return $ case eres of + Left e -> rest $ Left e + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (go . y) + in go $ unConduitT c0 Done +{-# INLINABLE runCatchC #-} + +-- | Catch an exception in the base monad +-- +-- Since 1.1.0 +catchCatchC + :: Monad m + => ConduitT i o (CatchT m) r + -> (SomeException -> ConduitT i o (CatchT m) r) + -> ConduitT i o (CatchT m) r +catchCatchC (ConduitT c0) h = + ConduitT $ \rest -> + let go (Done r) = rest r + go (PipeM mp) = PipeM $ do + eres <- lift $ runCatchT mp + return $ case eres of + Left e -> unConduitT (h e) rest + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (go . y) + in go (c0 Done) +{-# INLINABLE catchCatchC #-} + +-- | Wrap the base monad in 'M.MaybeT' +-- +-- Since 1.0.11 +maybeC + :: Monad m => + ConduitT i o m (Maybe a) -> ConduitT i o (M.MaybeT m) a +maybeC p = do + x <- transPipe lift p + lift $ M.MaybeT (return x) +{-# INLINABLE maybeC #-} + +-- | Run 'M.MaybeT' in the base monad +-- +-- Since 1.0.11 +runMaybeC + :: Monad m => + ConduitT i o (M.MaybeT m) r -> ConduitT i o m (Maybe r) +runMaybeC (ConduitT c0) = + ConduitT $ \rest -> + let go (Done r) = rest (Just r) + go (PipeM mp) = PipeM $ do + mres <- M.runMaybeT mp + return $ case mres of + Nothing -> rest Nothing + Just p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p o) = HaveOutput (go p) o + go (NeedInput x y) = NeedInput (go . x) (go . y) + in go (c0 Done) +{-# INLINABLE runMaybeC #-} + +-- | Wrap the base monad in 'R.ReaderT' +-- +-- Since 1.0.11 +readerC + :: Monad m => + (r -> ConduitT i o m a) -> ConduitT i o (R.ReaderT r m) a +readerC k = do + i <- lift R.ask + transPipe lift (k i) +{-# INLINABLE readerC #-} + +-- | Run 'R.ReaderT' in the base monad +-- +-- Since 1.0.11 +runReaderC + :: Monad m => + r -> ConduitT i o (R.ReaderT r m) res -> ConduitT i o m res +runReaderC r = transPipe (`R.runReaderT` r) +{-# INLINABLE runReaderC #-} + + +-- | Wrap the base monad in 'SL.StateT' +-- +-- Since 1.0.11 +stateLC + :: Monad m => + (s -> ConduitT i o m (a, s)) -> ConduitT i o (SL.StateT s m) a +stateLC k = do + s <- lift SL.get + (r, s') <- transPipe lift (k s) + lift (SL.put s') + return r +{-# INLINABLE stateLC #-} + +thread :: Monad m + => (r -> s -> res) + -> (forall a. t m a -> s -> m (a, s)) + -> s + -> ConduitT i o (t m) r + -> ConduitT i o m res +thread toRes runM s0 (ConduitT c0) = + ConduitT $ \rest -> + let go s (Done r) = rest (toRes r s) + go s (PipeM mp) = PipeM $ do + (p, s') <- runM mp s + return $ go s' p + go s (Leftover p i) = Leftover (go s p) i + go s (NeedInput x y) = NeedInput (go s . x) (go s . y) + go s (HaveOutput p o) = HaveOutput (go s p) o + in go s0 (c0 Done) +{-# INLINABLE thread #-} + +-- | Run 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +runStateLC + :: Monad m => + s -> ConduitT i o (SL.StateT s m) r -> ConduitT i o m (r, s) +runStateLC = thread (,) SL.runStateT +{-# INLINABLE runStateLC #-} + +-- | Evaluate 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +evalStateLC + :: Monad m => + s -> ConduitT i o (SL.StateT s m) r -> ConduitT i o m r +evalStateLC s p = fmap fst $ runStateLC s p +{-# INLINABLE evalStateLC #-} + +-- | Execute 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +execStateLC + :: Monad m => + s -> ConduitT i o (SL.StateT s m) r -> ConduitT i o m s +execStateLC s p = fmap snd $ runStateLC s p +{-# INLINABLE execStateLC #-} + + +-- | Wrap the base monad in 'SS.StateT' +-- +-- Since 1.0.11 +stateC + :: Monad m => + (s -> ConduitT i o m (a, s)) -> ConduitT i o (SS.StateT s m) a +stateC k = do + s <- lift SS.get + (r, s') <- transPipe lift (k s) + lift (SS.put s') + return r +{-# INLINABLE stateC #-} + +-- | Run 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +runStateC + :: Monad m => + s -> ConduitT i o (SS.StateT s m) r -> ConduitT i o m (r, s) +runStateC = thread (,) SS.runStateT +{-# INLINABLE runStateC #-} + +-- | Evaluate 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +evalStateC + :: Monad m => + s -> ConduitT i o (SS.StateT s m) r -> ConduitT i o m r +evalStateC s p = fmap fst $ runStateC s p +{-# INLINABLE evalStateC #-} + +-- | Execute 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +execStateC + :: Monad m => + s -> ConduitT i o (SS.StateT s m) r -> ConduitT i o m s +execStateC s p = fmap snd $ runStateC s p +{-# INLINABLE execStateC #-} + + +-- | Wrap the base monad in 'WL.WriterT' +-- +-- Since 1.0.11 +writerLC + :: (Monad m, Monoid w) => + ConduitT i o m (b, w) -> ConduitT i o (WL.WriterT w m) b +writerLC p = do + (r, w) <- transPipe lift p + lift $ WL.tell w + return r +{-# INLINABLE writerLC #-} + +-- | Run 'WL.WriterT' in the base monad +-- +-- Since 1.0.11 +runWriterLC + :: (Monad m, Monoid w) => + ConduitT i o (WL.WriterT w m) r -> ConduitT i o m (r, w) +runWriterLC = thread (,) run mempty + where + run m w = do + (a, w') <- WL.runWriterT m + return (a, w `mappend` w') +{-# INLINABLE runWriterLC #-} + +-- | Execute 'WL.WriterT' in the base monad +-- +-- Since 1.0.11 +execWriterLC + :: (Monad m, Monoid w) => + ConduitT i o (WL.WriterT w m) r -> ConduitT i o m w +execWriterLC p = fmap snd $ runWriterLC p +{-# INLINABLE execWriterLC #-} + + +-- | Wrap the base monad in 'WS.WriterT' +-- +-- Since 1.0.11 +writerC + :: (Monad m, Monoid w) => + ConduitT i o m (b, w) -> ConduitT i o (WS.WriterT w m) b +writerC p = do + (r, w) <- transPipe lift p + lift $ WS.tell w + return r +{-# INLINABLE writerC #-} + +-- | Run 'WS.WriterT' in the base monad +-- +-- Since 1.0.11 +runWriterC + :: (Monad m, Monoid w) => + ConduitT i o (WS.WriterT w m) r -> ConduitT i o m (r, w) +runWriterC = thread (,) run mempty + where + run m w = do + (a, w') <- WS.runWriterT m + return (a, w `mappend` w') +{-# INLINABLE runWriterC #-} + +-- | Execute 'WS.WriterT' in the base monad +-- +-- Since 1.0.11 +execWriterC + :: (Monad m, Monoid w) => + ConduitT i o (WS.WriterT w m) r -> ConduitT i o m w +execWriterC p = fmap snd $ runWriterC p +{-# INLINABLE execWriterC #-} + + +-- | Wrap the base monad in 'RWSL.RWST' +-- +-- Since 1.0.11 +rwsLC + :: (Monad m, Monoid w) => + (r -> s -> ConduitT i o m (a, s, w)) -> ConduitT i o (RWSL.RWST r w s m) a +rwsLC k = do + i <- lift RWSL.ask + s <- lift RWSL.get + (r, s', w) <- transPipe lift (k i s) + lift $ do + RWSL.put s' + RWSL.tell w + return r +{-# INLINABLE rwsLC #-} + +-- | Run 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +runRWSLC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSL.RWST r w s m) res + -> ConduitT i o m (res, s, w) +runRWSLC r s0 = thread toRes run (s0, mempty) + where + toRes a (s, w) = (a, s, w) + run m (s, w) = do + (res, s', w') <- RWSL.runRWST m r s + return (res, (s', w `mappend` w')) +{-# INLINABLE runRWSLC #-} + +-- | Evaluate 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +evalRWSLC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSL.RWST r w s m) res + -> ConduitT i o m (res, w) +evalRWSLC i s p = fmap f $ runRWSLC i s p + where f x = let (r, _, w) = x in (r, w) +{-# INLINABLE evalRWSLC #-} + +-- | Execute 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +execRWSLC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSL.RWST r w s m) res + -> ConduitT i o m (s, w) +execRWSLC i s p = fmap f $ runRWSLC i s p + where f x = let (_, s2, w2) = x in (s2, w2) +{-# INLINABLE execRWSLC #-} + +-- | Wrap the base monad in 'RWSS.RWST' +-- +-- Since 1.0.11 +rwsC + :: (Monad m, Monoid w) => + (r -> s -> ConduitT i o m (a, s, w)) -> ConduitT i o (RWSS.RWST r w s m) a +rwsC k = do + i <- lift RWSS.ask + s <- lift RWSS.get + (r, s', w) <- transPipe lift (k i s) + lift $ do + RWSS.put s' + RWSS.tell w + return r +{-# INLINABLE rwsC #-} + +-- | Run 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +runRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSS.RWST r w s m) res + -> ConduitT i o m (res, s, w) +runRWSC r s0 = thread toRes run (s0, mempty) + where + toRes a (s, w) = (a, s, w) + run m (s, w) = do + (res, s', w') <- RWSS.runRWST m r s + return (res, (s', w `mappend` w')) +{-# INLINABLE runRWSC #-} + +-- | Evaluate 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +evalRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSS.RWST r w s m) res + -> ConduitT i o m (res, w) +evalRWSC i s p = fmap f $ runRWSC i s p + where f x = let (r, _, w) = x in (r, w) +{-# INLINABLE evalRWSC #-} + +-- | Execute 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +execRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitT i o (RWSS.RWST r w s m) res + -> ConduitT i o m (s, w) +execRWSC i s p = fmap f $ runRWSC i s p + where f x = let (_, s2, w2) = x in (s2, w2) +{-# INLINABLE execRWSC #-} diff --git a/src/Data/Conduit/List.hs b/src/Data/Conduit/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/List.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +-- | /NOTE/ It is recommended to start using "Data.Conduit.Combinators" instead +-- of this module. +-- +-- Higher-level functions to interact with the elements of a stream. Most of +-- these are based on list functions. +-- +-- Note that these functions all deal with individual elements of a stream as a +-- sort of \"black box\", where there is no introspection of the contained +-- elements. Values such as @ByteString@ and @Text@ will likely need to be +-- treated specially to deal with their contents properly (@Word8@ and @Char@, +-- respectively). See the @Data.Conduit.Binary@ and @Data.Conduit.Text@ +-- modules in the @conduit-extra@ package. +module Data.Conduit.List + ( -- * Sources + sourceList + , sourceNull + , unfold + , unfoldEither + , unfoldM + , unfoldEitherM + , enumFromTo + , iterate + , replicate + , replicateM + -- * Sinks + -- ** Pure + , fold + , foldMap + , uncons + , unconsEither + , take + , drop + , head + , peek + , consume + , sinkNull + -- ** Monadic + , foldMapM + , foldM + , unconsM + , unconsEitherM + , mapM_ + -- * Conduits + -- ** Pure + , map + , mapMaybe + , mapFoldable + , catMaybes + , concat + , concatMap + , concatMapAccum + , scanl + , scan + , mapAccum + , chunksOf + , groupBy + , groupOn1 +#if MIN_VERSION_base(4,9,0) + , groupOn +#endif + , isolate + , filter + -- ** Monadic + , mapM + , iterM + , scanlM + , scanM + , mapAccumM + , mapMaybeM + , mapFoldableM + , concatMapM + , concatMapAccumM + -- * Misc + , sequence + ) where + +import qualified Prelude +import Prelude + ( ($), return, (==), (-), Int + , (.), id, Maybe (..), Monad + , Either (..) + , Bool (..) + , (>>) + , (>>=) + , seq + , otherwise + , Enum, Eq + , maybe + , (<=) + , (>) + , error + , (++) + , show + ) +import Data.Monoid (Monoid, mempty, mappend) +import qualified Data.Foldable as F +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty (NonEmpty ((:|))) +#endif +import Data.Conduit +import Data.Conduit.Internal.Conduit (unconsM, unconsEitherM) +import Data.Conduit.Internal.Fusion +import Data.Conduit.Internal.List.Stream +import qualified Data.Conduit.Internal as CI +import Data.Functor.Identity (Identity (runIdentity)) +import Control.Monad (when, (<=<), liftM, void) +import Control.Monad.Trans.Class (lift) + +-- Defines INLINE_RULE0, INLINE_RULE, STREAMING0, and STREAMING. +#include "fusion-macros.h" + +-- | Generate a source from a seed value. +-- +-- Subject to fusion +-- +-- Since 0.4.2 +unfold, unfoldC :: Monad m + => (b -> Maybe (a, b)) + -> b + -> ConduitT i a m () +unfoldC f = + go + where + go seed = + case f seed of + Just (a, seed') -> yield a >> go seed' + Nothing -> return () +{-# INLINE unfoldC #-} +STREAMING(unfold, unfoldC, unfoldS, f x) + +-- | Generate a source from a seed value with a return value. +-- +-- Subject to fusion +-- +-- @since 1.2.11 +unfoldEither, unfoldEitherC :: Monad m + => (b -> Either r (a, b)) + -> b + -> ConduitT i a m r +unfoldEitherC f = + go + where + go seed = + case f seed of + Right (a, seed') -> yield a >> go seed' + Left r -> return r +{-# INLINE unfoldEitherC #-} +STREAMING(unfoldEither, unfoldEitherC, unfoldEitherS, f x) + +-- | A monadic unfold. +-- +-- Subject to fusion +-- +-- Since 1.1.2 +unfoldM, unfoldMC :: Monad m + => (b -> m (Maybe (a, b))) + -> b + -> ConduitT i a m () +unfoldMC f = + go + where + go seed = do + mres <- lift $ f seed + case mres of + Just (a, seed') -> yield a >> go seed' + Nothing -> return () +STREAMING(unfoldM, unfoldMC, unfoldMS, f seed) + +-- | A monadic unfoldEither. +-- +-- Subject to fusion +-- +-- @since 1.2.11 +unfoldEitherM, unfoldEitherMC :: Monad m + => (b -> m (Either r (a, b))) + -> b + -> ConduitT i a m r +unfoldEitherMC f = + go + where + go seed = do + mres <- lift $ f seed + case mres of + Right (a, seed') -> yield a >> go seed' + Left r -> return r +STREAMING(unfoldEitherM, unfoldEitherMC, unfoldEitherMS, f seed) + +-- | Split a pure conduit into head and tail. +-- This is equivalent to @runIdentity . unconsM@. +-- +-- Note that you have to 'sealConduitT' it first. +-- +-- Since 1.3.3 +uncons :: SealedConduitT () o Identity () + -> Maybe (o, SealedConduitT () o Identity ()) +uncons = runIdentity . unconsM + +-- | Split a pure conduit into head and tail or return its result if it is done. +-- This is equivalent to @runIdentity . unconsEitherM@. +-- +-- Note that you have to 'sealConduitT' it first. +-- +-- Since 1.3.3 +unconsEither :: SealedConduitT () o Identity r + -> Either r (o, SealedConduitT () o Identity r) +unconsEither = runIdentity . unconsEitherM + +-- | Yield the values from the list. +-- +-- Subject to fusion +sourceList, sourceListC :: Monad m => [a] -> ConduitT i a m () +sourceListC = Prelude.mapM_ yield +{-# INLINE sourceListC #-} +STREAMING(sourceList, sourceListC, sourceListS, xs) + +-- | Enumerate from a value to a final value, inclusive, via 'succ'. +-- +-- This is generally more efficient than using @Prelude@\'s @enumFromTo@ and +-- combining with @sourceList@ since this avoids any intermediate data +-- structures. +-- +-- Subject to fusion +-- +-- Since 0.4.2 +enumFromTo, enumFromToC :: (Enum a, Prelude.Ord a, Monad m) + => a + -> a + -> ConduitT i a m () +enumFromToC x0 y = + loop x0 + where + loop x + | x Prelude.> y = return () + | otherwise = yield x >> loop (Prelude.succ x) +{-# INLINE enumFromToC #-} +STREAMING(enumFromTo, enumFromToC, enumFromToS, x0 y) + +-- | Produces an infinite stream of repeated applications of f to x. +-- +-- Subject to fusion +-- +iterate, iterateC :: Monad m => (a -> a) -> a -> ConduitT i a m () +iterateC f = + go + where + go a = yield a >> go (f a) +{-# INLINE iterateC #-} +STREAMING(iterate, iterateC, iterateS, f a) + +-- | Replicate a single value the given number of times. +-- +-- Subject to fusion +-- +-- Since 1.2.0 +replicate, replicateC :: Monad m => Int -> a -> ConduitT i a m () +replicateC cnt0 a = + loop cnt0 + where + loop i + | i <= 0 = return () + | otherwise = yield a >> loop (i - 1) +{-# INLINE replicateC #-} +STREAMING(replicate, replicateC, replicateS, cnt0 a) + +-- | Replicate a monadic value the given number of times. +-- +-- Subject to fusion +-- +-- Since 1.2.0 +replicateM, replicateMC :: Monad m => Int -> m a -> ConduitT i a m () +replicateMC cnt0 ma = + loop cnt0 + where + loop i + | i <= 0 = return () + | otherwise = lift ma >>= yield >> loop (i - 1) +{-# INLINE replicateMC #-} +STREAMING(replicateM, replicateMC, replicateMS, cnt0 ma) + +-- | A strict left fold. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +fold, foldC :: Monad m + => (b -> a -> b) + -> b + -> ConduitT a o m b +foldC f = + loop + where + loop !accum = await >>= maybe (return accum) (loop . f accum) +{-# INLINE foldC #-} +STREAMING(fold, foldC, foldS, f accum) + +-- | A monadic strict left fold. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +foldM, foldMC :: Monad m + => (b -> a -> m b) + -> b + -> ConduitT a o m b +foldMC f = + loop + where + loop accum = do + await >>= maybe (return accum) go + where + go a = do + accum' <- lift $ f accum a + accum' `seq` loop accum' +{-# INLINE foldMC #-} +STREAMING(foldM, foldMC, foldMS, f accum) + +----------------------------------------------------------------- +-- These are for cases where- for whatever reason- stream fusion cannot be +-- applied. +connectFold :: Monad m => ConduitT () a m () -> (b -> a -> b) -> b -> m b +connectFold (CI.ConduitT src0) f = + go (src0 CI.Done) + where + go (CI.Done ()) b = return b + go (CI.HaveOutput src a) b = go src Prelude.$! f b a + go (CI.NeedInput _ c) b = go (c ()) b + go (CI.Leftover src ()) b = go src b + go (CI.PipeM msrc) b = do + src <- msrc + go src b +{-# INLINE connectFold #-} +{-# RULES "conduit: $$ fold" forall src f b. runConduit (src .| fold f b) = connectFold src f b #-} + +connectFoldM :: Monad m => ConduitT () a m () -> (b -> a -> m b) -> b -> m b +connectFoldM (CI.ConduitT src0) f = + go (src0 CI.Done) + where + go (CI.Done ()) b = return b + go (CI.HaveOutput src a) b = do + !b' <- f b a + go src b' + go (CI.NeedInput _ c) b = go (c ()) b + go (CI.Leftover src ()) b = go src b + go (CI.PipeM msrc) b = do + src <- msrc + go src b +{-# INLINE connectFoldM #-} +{-# RULES "conduit: $$ foldM" forall src f b. runConduit (src .| foldM f b) = connectFoldM src f b #-} +----------------------------------------------------------------- + +-- | A monoidal strict left fold. +-- +-- Subject to fusion +-- +-- Since 0.5.3 +foldMap :: (Monad m, Monoid b) + => (a -> b) + -> ConduitT a o m b +INLINE_RULE(foldMap, f, let combiner accum = mappend accum . f in fold combiner mempty) + +-- | A monoidal strict left fold in a Monad. +-- +-- Since 1.0.8 +foldMapM :: (Monad m, Monoid b) + => (a -> m b) + -> ConduitT a o m b +INLINE_RULE(foldMapM, f, let combiner accum = liftM (mappend accum) . f in foldM combiner mempty) + +-- | Apply the action to all values in the stream. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +mapM_, mapM_C :: Monad m + => (a -> m ()) + -> ConduitT a o m () +mapM_C f = awaitForever $ lift . f +{-# INLINE mapM_C #-} +STREAMING(mapM_, mapM_C, mapM_S, f) + +srcMapM_ :: Monad m => ConduitT () a m () -> (a -> m ()) -> m () +srcMapM_ (CI.ConduitT src) f = + go (src CI.Done) + where + go (CI.Done ()) = return () + go (CI.PipeM mp) = mp >>= go + go (CI.Leftover p ()) = go p + go (CI.HaveOutput p o) = f o >> go p + go (CI.NeedInput _ c) = go (c ()) +{-# INLINE srcMapM_ #-} +{-# RULES "conduit: connect to mapM_" [2] forall f src. runConduit (src .| mapM_ f) = srcMapM_ src f #-} + +-- | Ignore a certain number of values in the stream. This function is +-- semantically equivalent to: +-- +-- > drop i = take i >> return () +-- +-- However, @drop@ is more efficient as it does not need to hold values in +-- memory. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +drop, dropC :: Monad m + => Int + -> ConduitT a o m () +dropC = + loop + where + loop i | i <= 0 = return () + loop count = await >>= maybe (return ()) (\_ -> loop (count - 1)) +{-# INLINE dropC #-} +STREAMING(drop, dropC, dropS, i) + +-- | Take some values from the stream and return as a list. If you want to +-- instead create a conduit that pipes data to another sink, see 'isolate'. +-- This function is semantically equivalent to: +-- +-- > take i = isolate i =$ consume +-- +-- Subject to fusion +-- +-- Since 0.3.0 +take, takeC :: Monad m + => Int + -> ConduitT a o m [a] +takeC = + loop id + where + loop front count | count <= 0 = return $ front [] + loop front count = await >>= maybe + (return $ front []) + (\x -> loop (front . (x:)) (count - 1)) +{-# INLINE takeC #-} +STREAMING(take, takeC, takeS, i) + +-- | Take a single value from the stream, if available. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +head, headC :: Monad m => ConduitT a o m (Maybe a) +headC = await +{-# INLINE headC #-} +STREAMING0(head, headC, headS) + +-- | Look at the next value in the stream, if available. This function will not +-- change the state of the stream. +-- +-- Since 0.3.0 +peek :: Monad m => ConduitT a o m (Maybe a) +peek = await >>= maybe (return Nothing) (\x -> leftover x >> return (Just x)) + +-- | Apply a transformation to all values in a stream. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +map, mapC :: Monad m => (a -> b) -> ConduitT a b m () +mapC f = awaitForever $ yield . f +{-# INLINE mapC #-} +STREAMING(map, mapC, mapS, f) + +-- Since a Source never has any leftovers, fusion rules on it are safe. +{- +{-# RULES "conduit: source/map fusion .|" forall f src. src .| map f = mapFuseRight src f #-} + +mapFuseRight :: Monad m => ConduitT () a m () -> (a -> b) -> ConduitT () b m () +mapFuseRight src f = CIC.mapOutput f src +{-# INLINE mapFuseRight #-} +-} + +{- + +It might be nice to include these rewrite rules, but they may have subtle +differences based on leftovers. + +{-# RULES "conduit: map-to-mapOutput pipeL" forall f src. pipeL src (map f) = mapOutput f src #-} +{-# RULES "conduit: map-to-mapOutput $=" forall f src. src $= (map f) = mapOutput f src #-} +{-# RULES "conduit: map-to-mapOutput pipe" forall f src. pipe src (map f) = mapOutput f src #-} +{-# RULES "conduit: map-to-mapOutput >+>" forall f src. src >+> (map f) = mapOutput f src #-} + +{-# RULES "conduit: map-to-mapInput pipeL" forall f sink. pipeL (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} +{-# RULES "conduit: map-to-mapInput =$" forall f sink. map f =$ sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} +{-# RULES "conduit: map-to-mapInput pipe" forall f sink. pipe (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} +{-# RULES "conduit: map-to-mapInput >+>" forall f sink. map f >+> sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} + +{-# RULES "conduit: map-to-mapOutput .|" forall f con. con .| map f = mapOutput f con #-} +{-# RULES "conduit: map-to-mapInput .|" forall f con. map f .| con = mapInput f (Prelude.const Prelude.Nothing) con #-} + +{-# INLINE [1] map #-} + +-} + +-- | Apply a monadic transformation to all values in a stream. +-- +-- If you do not need the transformed values, and instead just want the monadic +-- side-effects of running the action, see 'mapM_'. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +mapM, mapMC :: Monad m => (a -> m b) -> ConduitT a b m () +mapMC f = awaitForever $ \a -> lift (f a) >>= yield +{-# INLINE mapMC #-} +STREAMING(mapM, mapMC, mapMS, f) + +-- | Apply a monadic action on all values in a stream. +-- +-- This @Conduit@ can be used to perform a monadic side-effect for every +-- value, whilst passing the value through the @Conduit@ as-is. +-- +-- > iterM f = mapM (\a -> f a >>= \() -> return a) +-- +-- Subject to fusion +-- +-- Since 0.5.6 +iterM, iterMC :: Monad m => (a -> m ()) -> ConduitT a a m () +iterMC f = awaitForever $ \a -> lift (f a) >> yield a +{-# INLINE iterMC #-} +STREAMING(iterM, iterMC, iterMS, f) + +-- | Apply a transformation that may fail to all values in a stream, discarding +-- the failures. +-- +-- Subject to fusion +-- +-- Since 0.5.1 +mapMaybe, mapMaybeC :: Monad m => (a -> Maybe b) -> ConduitT a b m () +mapMaybeC f = awaitForever $ maybe (return ()) yield . f +{-# INLINE mapMaybeC #-} +STREAMING(mapMaybe, mapMaybeC, mapMaybeS, f) + +-- | Apply a monadic transformation that may fail to all values in a stream, +-- discarding the failures. +-- +-- Subject to fusion +-- +-- Since 0.5.1 +mapMaybeM, mapMaybeMC :: Monad m => (a -> m (Maybe b)) -> ConduitT a b m () +mapMaybeMC f = awaitForever $ maybe (return ()) yield <=< lift . f +{-# INLINE mapMaybeMC #-} +STREAMING(mapMaybeM, mapMaybeMC, mapMaybeMS, f) + +-- | Filter the @Just@ values from a stream, discarding the @Nothing@ values. +-- +-- Subject to fusion +-- +-- Since 0.5.1 +catMaybes, catMaybesC :: Monad m => ConduitT (Maybe a) a m () +catMaybesC = awaitForever $ maybe (return ()) yield +{-# INLINE catMaybesC #-} +STREAMING0(catMaybes, catMaybesC, catMaybesS) + +-- | Generalization of 'catMaybes'. It puts all values from +-- 'F.Foldable' into stream. +-- +-- Subject to fusion +-- +-- Since 1.0.6 +concat, concatC :: (Monad m, F.Foldable f) => ConduitT (f a) a m () +concatC = awaitForever $ F.mapM_ yield +{-# INLINE concatC #-} +STREAMING0(concat, concatC, concatS) + +-- | Apply a transformation to all values in a stream, concatenating the output +-- values. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +concatMap, concatMapC :: Monad m => (a -> [b]) -> ConduitT a b m () +concatMapC f = awaitForever $ sourceList . f +{-# INLINE concatMapC #-} +STREAMING(concatMap, concatMapC, concatMapS, f) + +-- | Apply a monadic transformation to all values in a stream, concatenating +-- the output values. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +concatMapM, concatMapMC :: Monad m => (a -> m [b]) -> ConduitT a b m () +concatMapMC f = awaitForever $ sourceList <=< lift . f +{-# INLINE concatMapMC #-} +STREAMING(concatMapM, concatMapMC, concatMapMS, f) + +-- | 'concatMap' with a strict accumulator. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +concatMapAccum, concatMapAccumC :: Monad m => (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m () +concatMapAccumC f x0 = void (mapAccum f x0) .| concat +{-# INLINE concatMapAccumC #-} +STREAMING(concatMapAccum, concatMapAccumC, concatMapAccumS, f x0) + +-- | Deprecated synonym for @mapAccum@ +-- +-- Since 1.0.6 +scanl :: Monad m => (a -> s -> (s, b)) -> s -> ConduitT a b m () +scanl f s = void $ mapAccum f s +{-# DEPRECATED scanl "Use mapAccum instead" #-} + +-- | Deprecated synonym for @mapAccumM@ +-- +-- Since 1.0.6 +scanlM :: Monad m => (a -> s -> m (s, b)) -> s -> ConduitT a b m () +scanlM f s = void $ mapAccumM f s +{-# DEPRECATED scanlM "Use mapAccumM instead" #-} + +-- | Analog of @mapAccumL@ for lists. Note that in contrast to @mapAccumL@, the function argument +-- takes the accumulator as its second argument, not its first argument, and the accumulated value +-- is strict. +-- +-- Subject to fusion +-- +-- Since 1.1.1 +mapAccum, mapAccumC :: Monad m => (a -> s -> (s, b)) -> s -> ConduitT a b m s +mapAccumC f = + loop + where + loop !s = await >>= maybe (return s) go + where + go a = case f a s of + (s', b) -> yield b >> loop s' +STREAMING(mapAccum, mapAccumC, mapAccumS, f s) + +-- | Monadic `mapAccum`. +-- +-- Subject to fusion +-- +-- Since 1.1.1 +mapAccumM, mapAccumMC :: Monad m => (a -> s -> m (s, b)) -> s -> ConduitT a b m s +mapAccumMC f = + loop + where + loop !s = await >>= maybe (return s) go + where + go a = do (s', b) <- lift $ f a s + yield b + loop s' +{-# INLINE mapAccumMC #-} +STREAMING(mapAccumM, mapAccumMC, mapAccumMS, f s) + +-- | Analog of 'Prelude.scanl' for lists. +-- +-- Subject to fusion +-- +-- Since 1.1.1 +scan :: Monad m => (a -> b -> b) -> b -> ConduitT a b m b +INLINE_RULE(scan, f, mapAccum (\a b -> let r = f a b in (r, r))) + +-- | Monadic @scanl@. +-- +-- Subject to fusion +-- +-- Since 1.1.1 +scanM :: Monad m => (a -> b -> m b) -> b -> ConduitT a b m b +INLINE_RULE(scanM, f, mapAccumM (\a b -> f a b >>= \r -> return (r, r))) + +-- | 'concatMapM' with a strict accumulator. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +concatMapAccumM, concatMapAccumMC :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> ConduitT a b m () +concatMapAccumMC f x0 = void (mapAccumM f x0) .| concat +{-# INLINE concatMapAccumMC #-} +STREAMING(concatMapAccumM, concatMapAccumMC, concatMapAccumMS, f x0) + +-- | Generalization of 'mapMaybe' and 'concatMap'. It applies function +-- to all values in a stream and send values inside resulting +-- 'Foldable' downstream. +-- +-- Subject to fusion +-- +-- Since 1.0.6 +mapFoldable, mapFoldableC :: (Monad m, F.Foldable f) => (a -> f b) -> ConduitT a b m () +mapFoldableC f = awaitForever $ F.mapM_ yield . f +{-# INLINE mapFoldableC #-} +STREAMING(mapFoldable, mapFoldableC, mapFoldableS, f) + +-- | Monadic variant of 'mapFoldable'. +-- +-- Subject to fusion +-- +-- Since 1.0.6 +mapFoldableM, mapFoldableMC :: (Monad m, F.Foldable f) => (a -> m (f b)) -> ConduitT a b m () +mapFoldableMC f = awaitForever $ F.mapM_ yield <=< lift . f +{-# INLINE mapFoldableMC #-} +STREAMING(mapFoldableM, mapFoldableMC, mapFoldableMS, f) + +-- | Consume all values from the stream and return as a list. Note that this +-- will pull all values into memory. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +consume, consumeC :: Monad m => ConduitT a o m [a] +consumeC = + loop id + where + loop front = await >>= maybe (return $ front []) (\x -> loop $ front . (x:)) +{-# INLINE consumeC #-} +STREAMING0(consume, consumeC, consumeS) + +-- | Group a stream into chunks of a given size. The last chunk may contain +-- fewer than n elements. +-- +-- Subject to fusion +-- +-- Since 1.2.9 +chunksOf :: Monad m => Int -> ConduitT a [a] m () +chunksOf n = if n > 0 then loop n id else error $ "chunksOf size must be positive (given " ++ show n ++ ")" + where + loop 0 rest = yield (rest []) >> loop n id + loop count rest = await >>= \ma -> case ma of + Nothing -> case rest [] of + [] -> return () + nonempty -> yield nonempty + Just a -> loop (count - 1) (rest . (a :)) + +-- | Grouping input according to an equality function. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +groupBy, groupByC :: Monad m => (a -> a -> Bool) -> ConduitT a [a] m () +groupByC f = + start + where + start = await >>= maybe (return ()) (loop id) + + loop rest x = + await >>= maybe (yield (x : rest [])) go + where + go y + | f x y = loop (rest . (y:)) x + | otherwise = yield (x : rest []) >> loop id y +STREAMING(groupBy, groupByC, groupByS, f) + +-- | 'groupOn1' is similar to @groupBy id@ +-- +-- returns a pair, indicating there are always 1 or more items in the grouping. +-- This is designed to be converted into a NonEmpty structure +-- but it avoids a dependency on another package +-- +-- > import Data.List.NonEmpty +-- > +-- > groupOn1 :: (Monad m, Eq b) => (a -> b) -> Conduit a m (NonEmpty a) +-- > groupOn1 f = CL.groupOn1 f .| CL.map (uncurry (:|)) +-- +-- Subject to fusion +-- +-- Since 1.1.7 +groupOn1, groupOn1C :: (Monad m, Eq b) + => (a -> b) + -> ConduitT a (a, [a]) m () +groupOn1C f = + start + where + start = await >>= maybe (return ()) (loop id) + + loop rest x = + await >>= maybe (yield (x, rest [])) go + where + go y + | f x == f y = loop (rest . (y:)) x + | otherwise = yield (x, rest []) >> loop id y +STREAMING(groupOn1, groupOn1C, groupOn1S, f) + +#if MIN_VERSION_base(4,9,0) +-- | Like 'groupOn1', but returning a 'NonEmpty' structure. +-- +-- @since 1.3.5 +groupOn :: (Monad m, Eq b) + => (a -> b) + -> ConduitT a (NonEmpty a) m () +groupOn f = groupOn1 f .| map (Prelude.uncurry (:|)) +#endif + +-- | Ensure that the inner sink consumes no more than the given number of +-- values. Note this this does /not/ ensure that the sink consumes all of those +-- values. To get the latter behavior, combine with 'sinkNull', e.g.: +-- +-- > src $$ do +-- > x <- isolate count =$ do +-- > x <- someSink +-- > sinkNull +-- > return x +-- > someOtherSink +-- > ... +-- +-- Subject to fusion +-- +-- Since 0.3.0 +isolate, isolateC :: Monad m => Int -> ConduitT a a m () +isolateC = + loop + where + loop count | count <= 0 = return () + loop count = await >>= maybe (return ()) (\x -> yield x >> loop (count - 1)) +STREAMING(isolate, isolateC, isolateS, count) + +-- | Keep only values in the stream passing a given predicate. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +filter, filterC :: Monad m => (a -> Bool) -> ConduitT a a m () +filterC f = awaitForever $ \i -> when (f i) (yield i) +STREAMING(filter, filterC, filterS, f) + +filterFuseRight + :: Monad m + => ConduitT i o m () + -> (o -> Bool) + -> ConduitT i o m () +filterFuseRight (CI.ConduitT src) f = CI.ConduitT $ \rest -> let + go (CI.Done ()) = rest () + go (CI.PipeM mp) = CI.PipeM (liftM go mp) + go (CI.Leftover p i) = CI.Leftover (go p) i + go (CI.HaveOutput p o) + | f o = CI.HaveOutput (go p) o + | otherwise = go p + go (CI.NeedInput p c) = CI.NeedInput (go . p) (go . c) + in go (src CI.Done) +-- Intermediate finalizers are dropped, but this is acceptable: the next +-- yielded value would be demanded by downstream in any event, and that new +-- finalizer will always override the existing finalizer. +{-# RULES "conduit: source/filter fusion .|" forall f src. src .| filter f = filterFuseRight src f #-} +{-# INLINE filterFuseRight #-} + +-- | Ignore the remainder of values in the source. Particularly useful when +-- combined with 'isolate'. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +sinkNull, sinkNullC :: Monad m => ConduitT i o m () +sinkNullC = awaitForever $ \_ -> return () +{-# INLINE sinkNullC #-} +STREAMING0(sinkNull, sinkNullC, sinkNullS) + +srcSinkNull :: Monad m => ConduitT () o m () -> m () +srcSinkNull (CI.ConduitT src) = + go (src CI.Done) + where + go (CI.Done ()) = return () + go (CI.PipeM mp) = mp >>= go + go (CI.Leftover p ()) = go p + go (CI.HaveOutput p _) = go p + go (CI.NeedInput _ c) = go (c ()) +{-# INLINE srcSinkNull #-} +{-# RULES "conduit: connect to sinkNull" forall src. runConduit (src .| sinkNull) = srcSinkNull src #-} + +-- | A source that outputs no values. Note that this is just a type-restricted +-- synonym for 'mempty'. +-- +-- Subject to fusion +-- +-- Since 0.3.0 +sourceNull, sourceNullC :: Monad m => ConduitT i o m () +sourceNullC = return () +{-# INLINE sourceNullC #-} +STREAMING0(sourceNull, sourceNullC, sourceNullS) + +-- | Run a @Pipe@ repeatedly, and output its result value downstream. Stops +-- when no more input is available from upstream. +-- +-- Since 0.5.0 +sequence :: Monad m + => ConduitT i o m o -- ^ @Pipe@ to run repeatedly + -> ConduitT i o m () +sequence sink = + self + where + self = awaitForever $ \i -> leftover i >> sink >>= yield diff --git a/src/Data/Streaming/FileRead.hs b/src/Data/Streaming/FileRead.hs new file mode 100644 --- /dev/null +++ b/src/Data/Streaming/FileRead.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +-- | The standard @openFile@ call on Windows causing problematic file locking +-- in some cases. This module provides a cross-platform file reading API +-- without the file locking problems on Windows. +-- +-- This module /always/ opens files in binary mode. +-- +-- @readChunk@ will return an empty @ByteString@ on EOF. +module Data.Streaming.FileRead + ( ReadHandle + , openFile + , closeFile + , readChunk + ) where + +#if WINDOWS + +import System.Win32File + +#else + +import qualified System.IO as IO +import qualified Data.ByteString as S +import Data.ByteString.Lazy.Internal (defaultChunkSize) + +newtype ReadHandle = ReadHandle IO.Handle + +openFile :: FilePath -> IO ReadHandle +openFile fp = ReadHandle `fmap` IO.openBinaryFile fp IO.ReadMode + +closeFile :: ReadHandle -> IO () +closeFile (ReadHandle h) = IO.hClose h + +readChunk :: ReadHandle -> IO S.ByteString +readChunk (ReadHandle h) = S.hGetSome h defaultChunkSize + +#endif diff --git a/src/Data/Streaming/Filesystem.hs b/src/Data/Streaming/Filesystem.hs new file mode 100644 --- /dev/null +++ b/src/Data/Streaming/Filesystem.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Streaming functions for interacting with the filesystem. +module Data.Streaming.Filesystem + ( DirStream + , openDirStream + , readDirStream + , closeDirStream + , FileType (..) + , getFileType + ) where + +import Data.Typeable (Typeable) + +#if WINDOWS + +import qualified System.Win32 as Win32 +import System.FilePath (()) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Directory (doesFileExist, doesDirectoryExist) + +data DirStream = DirStream !Win32.HANDLE !Win32.FindData !(IORef Bool) + deriving Typeable + +openDirStream :: FilePath -> IO DirStream +openDirStream fp = do + (h, fdat) <- Win32.findFirstFile $ fp "*" + imore <- newIORef True -- always at least two records, "." and ".." + return $! DirStream h fdat imore + +closeDirStream :: DirStream -> IO () +closeDirStream (DirStream h _ _) = Win32.findClose h + +readDirStream :: DirStream -> IO (Maybe FilePath) +readDirStream ds@(DirStream h fdat imore) = do + more <- readIORef imore + if more + then do + filename <- Win32.getFindDataFileName fdat + Win32.findNextFile h fdat >>= writeIORef imore + if filename == "." || filename == ".." + then readDirStream ds + else return $ Just filename + else return Nothing + +isSymlink :: FilePath -> IO Bool +isSymlink _ = return False + +getFileType :: FilePath -> IO FileType +getFileType fp = do + isFile <- doesFileExist fp + if isFile + then return FTFile + else do + isDir <- doesDirectoryExist fp + return $ if isDir then FTDirectory else FTOther + +#else + +import System.Posix.Directory (DirStream, openDirStream, closeDirStream) +import qualified System.Posix.Directory as Posix +import qualified System.Posix.Files as PosixF +import Control.Exception (try, IOException) + +readDirStream :: DirStream -> IO (Maybe FilePath) +readDirStream ds = do + fp <- Posix.readDirStream ds + case fp of + "" -> return Nothing + "." -> readDirStream ds + ".." -> readDirStream ds + _ -> return $ Just fp + +getFileType :: FilePath -> IO FileType +getFileType fp = do + s <- PosixF.getSymbolicLinkStatus fp + case () of + () + | PosixF.isRegularFile s -> return FTFile + | PosixF.isDirectory s -> return FTDirectory + | PosixF.isSymbolicLink s -> do + es' <- try $ PosixF.getFileStatus fp + case es' of + Left (_ :: IOException) -> return FTOther + Right s' + | PosixF.isRegularFile s' -> return FTFileSym + | PosixF.isDirectory s' -> return FTDirectorySym + | otherwise -> return FTOther + | otherwise -> return FTOther + +#endif + +data FileType + = FTFile + | FTFileSym -- ^ symlink to file + | FTDirectory + | FTDirectorySym -- ^ symlink to a directory + | FTOther + deriving (Show, Read, Eq, Ord, Typeable) diff --git a/src/System/Win32File.hsc b/src/System/Win32File.hsc new file mode 100644 --- /dev/null +++ b/src/System/Win32File.hsc @@ -0,0 +1,100 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module System.Win32File + ( openFile + , readChunk + , closeFile + , ReadHandle + ) where + +import Foreign.C.String (CString) +import Foreign.Ptr (castPtr) +import Foreign.Marshal.Alloc (mallocBytes, free) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +#if __GLASGOW_HASKELL__ >= 704 +import Foreign.C.Types (CInt (..)) +#else +import Foreign.C.Types (CInt) +#endif +import Foreign.C.Error (throwErrnoIfMinus1Retry) +import Foreign.Ptr (Ptr) +import Data.Bits (Bits, (.|.)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Unsafe as BU +import qualified Data.ByteString.Internal as BI +import Data.Text (pack) +import Data.Text.Encoding (encodeUtf16LE) +import Data.Word (Word8) +import Prelude hiding (read) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Data.ByteString.Lazy.Internal (defaultChunkSize) + + +#include +#include +#include +#include + +newtype OFlag = OFlag CInt + deriving (Num, Bits, Show, Eq) + +#{enum OFlag, OFlag + , oBinary = _O_BINARY + , oRdonly = _O_RDONLY + , oWronly = _O_WRONLY + , oCreat = _O_CREAT + } + +newtype SHFlag = SHFlag CInt + deriving (Num, Bits, Show, Eq) + +#{enum SHFlag, SHFlag + , shDenyno = _SH_DENYNO + } + +newtype PMode = PMode CInt + deriving (Num, Bits, Show, Eq) + +#{enum PMode, PMode + , pIread = _S_IREAD + , pIwrite = _S_IWRITE + } + +foreign import ccall "_wsopen" + c_wsopen :: CString -> OFlag -> SHFlag -> PMode -> IO CInt + +foreign import ccall "_read" + c_read :: ReadHandle -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall "_write" + c_write :: ReadHandle -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall "_close" + closeFile :: ReadHandle -> IO () + +newtype ReadHandle = ReadHandle CInt + +openFile :: FilePath -> IO ReadHandle +openFile fp = do + -- need to append a null char + -- note that useAsCString is not sufficient, as we need to have two + -- null octets to account for UTF16 encoding + let bs = encodeUtf16LE $ pack $ fp ++ "\0" + h <- BU.unsafeUseAsCString bs $ \str -> + throwErrnoIfMinus1Retry "Data.Streaming.FileRead.openFile" $ + c_wsopen + str + (oBinary .|. oRdonly) + shDenyno + pIread + return $ ReadHandle h + +readChunk :: ReadHandle -> IO S.ByteString +readChunk fd = do + fp <- mallocPlainForeignPtrBytes defaultChunkSize + withForeignPtr fp $ \p -> do + len <- throwErrnoIfMinus1Retry "System.Win32File.read" $ c_read fd p + (fromIntegral defaultChunkSize) + if len == 0 + then return $! S.empty + else return $! BI.PS fp 0 (fromIntegral len) diff --git a/test/Data/Conduit/Extra/ZipConduitSpec.hs b/test/Data/Conduit/Extra/ZipConduitSpec.hs --- a/test/Data/Conduit/Extra/ZipConduitSpec.hs +++ b/test/Data/Conduit/Extra/ZipConduitSpec.hs @@ -12,7 +12,7 @@ conduit2 = CL.concatMap (replicate 2) conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 sink = CL.consume - res <- src $$ conduit =$ sink + res <- runConduit $ src .| conduit .| sink res `shouldBe` [2, 1, 1, 3, 2, 2, 4, 3, 3] it "sequenceConduits" $ do let src = mapM_ yield [1..3 :: Int] @@ -22,7 +22,7 @@ x <- sequenceConduits [conduit1, conduit2] yield $ length x + 10 sink = CL.consume - res <- src $$ conduit =$ sink + res <- runConduit $ src .| conduit .| sink res `shouldBe` [2, 1, 1, 3, 2, 2, 4, 3, 3, 12] it "ZipConduitMonad" $ do let src = mapM_ yield [1..3 :: Int] @@ -30,5 +30,5 @@ conduit2 = CL.map id conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 sink = CL.consume - res <- src $$ conduit =$ sink + res <- runConduit $ src .| conduit .| sink res `shouldBe` [2, 1, 3, 2, 4, 3] diff --git a/test/Data/Conduit/StreamSpec.hs b/test/Data/Conduit/StreamSpec.hs --- a/test/Data/Conduit/StreamSpec.hs +++ b/test/Data/Conduit/StreamSpec.hs @@ -146,19 +146,19 @@ Prelude.map f qit "mapM" $ \(getBlind -> (f :: Int -> M Int)) -> - mapM f `checkConduitM` + mapM f `checkConduitT` Prelude.mapM f qit "mapMS" $ \(getBlind -> (f :: Int -> M Int)) -> - mapMS f `checkStreamConduitM` + mapMS f `checkStreamConduitT` Prelude.mapM f qit "iterM" $ \(getBlind -> (f :: Int -> M ())) -> - iterM f `checkConduitM` + iterM f `checkConduitT` iterML f qit "iterMS" $ \(getBlind -> (f :: Int -> M ())) -> - iterMS f `checkStreamConduitM` + iterMS f `checkStreamConduitT` iterML f qit "mapMaybe" $ \(getBlind -> (f :: Int -> Maybe Int)) -> @@ -170,11 +170,11 @@ Data.Maybe.mapMaybe f qit "mapMaybeM" $ \(getBlind -> (f :: Int -> M (Maybe Int))) -> - mapMaybeM f `checkConduitM` + mapMaybeM f `checkConduitT` mapMaybeML f qit "mapMaybeMS" $ \(getBlind -> (f :: Int -> M (Maybe Int))) -> - mapMaybeMS f `checkStreamConduitM` + mapMaybeMS f `checkStreamConduitT` mapMaybeML f qit "catMaybes" $ \() -> @@ -202,11 +202,11 @@ (Prelude.concatMap f :: [Int] -> [Int]) qit "concatMapM" $ \(getBlind -> (f :: Int -> M [Int])) -> - concatMapM f `checkConduitM` + concatMapM f `checkConduitT` concatMapML f qit "concatMapMS" $ \(getBlind -> (f :: Int -> M [Int])) -> - concatMapMS f `checkStreamConduitM` + concatMapMS f `checkStreamConduitT` concatMapML f qit "concatMapAccum" $ \(getBlind -> (f :: Int -> Int -> (Int, [Int])), initial :: Int) -> @@ -250,11 +250,11 @@ mapFoldableL f qit "mapFoldableM" $ \(getBlind -> (f :: Int -> M [Int])) -> - mapFoldableM f `checkConduitM` + mapFoldableM f `checkConduitT` mapFoldableML f qit "mapFoldableMS" $ \(getBlind -> (f :: Int -> M [Int])) -> - mapFoldableMS f `checkStreamConduitM` + mapFoldableMS f `checkStreamConduitT` mapFoldableML f qit "consume" $ \() -> @@ -312,67 +312,67 @@ -------------------------------------------------------------------------------- -- Quickcheck utilities for pure conduits / streams -checkProducer :: (Show a, Eq a) => Source Identity a -> [a] -> Property +checkProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property checkProducer c l = checkProducerM' runIdentity c (return l) -checkStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property +checkStreamProducer :: (Show a, Eq a) => StreamConduitT () a Identity () -> [a] -> Property checkStreamProducer s l = checkStreamProducerM' runIdentity s (return l) -checkInfiniteProducer :: (Show a, Eq a) => Source Identity a -> [a] -> Property +checkInfiniteProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property checkInfiniteProducer c l = checkInfiniteProducerM' runIdentity c (return l) -checkInfiniteStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property +checkInfiniteStreamProducer :: (Show a, Eq a) => StreamConduitT () a Identity () -> [a] -> Property checkInfiniteStreamProducer s l = checkInfiniteStreamProducerM' runIdentity s (return l) -checkConsumer :: (Show b, Eq b) => Consumer Int Identity b -> ([Int] -> b) -> Property +checkConsumer :: (Show b, Eq b) => ConduitT Int Void Identity b -> ([Int] -> b) -> Property checkConsumer c l = checkConsumerM' runIdentity c (return . l) checkStreamConsumer :: (Show b, Eq b) => StreamConsumer Int Identity b -> ([Int] -> b) -> Property checkStreamConsumer c l = checkStreamConsumerM' runIdentity c (return . l) -checkConduit :: (Show a, Arbitrary a, Show b, Eq b) => Conduit a Identity b -> ([a] -> [b]) -> Property -checkConduit c l = checkConduitM' runIdentity c (return . l) +checkConduit :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b Identity () -> ([a] -> [b]) -> Property +checkConduit c l = checkConduitT' runIdentity c (return . l) -checkStreamConduit :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a Identity b -> ([a] -> [b]) -> Property -checkStreamConduit c l = checkStreamConduitM' runIdentity c (return . l) +checkStreamConduit :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduitT a b Identity () -> ([a] -> [b]) -> Property +checkStreamConduit c l = checkStreamConduitT' runIdentity c (return . l) --- checkConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitM a b Identity r -> ([a] -> ([b], r)) -> Property +-- checkConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b Identity r -> ([a] -> ([b], r)) -> Property -- checkConduitResult c l = checkConduitResultM' runIdentity c (return . l) -checkStreamConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitM a b Identity r -> ([a] -> ([b], r)) -> Property +checkStreamConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b Identity r -> ([a] -> ([b], r)) -> Property checkStreamConduitResult c l = checkStreamConduitResultM' runIdentity c (return . l) -------------------------------------------------------------------------------- -- Quickcheck utilities for conduits / streams in the M monad. -checkProducerM :: (Show a, Eq a) => Source M a -> M [a] -> Property +checkProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property checkProducerM = checkProducerM' runM checkStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property checkStreamProducerM = checkStreamProducerM' runM -checkInfiniteProducerM :: (Show a, Eq a) => Source M a -> M [a] -> Property +checkInfiniteProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property checkInfiniteProducerM = checkInfiniteProducerM' (fst . runM) checkInfiniteStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property checkInfiniteStreamProducerM = checkInfiniteStreamProducerM' (fst . runM) -checkConsumerM :: (Show b, Eq b) => Consumer Int M b -> ([Int] -> M b) -> Property +checkConsumerM :: (Show b, Eq b) => ConduitT Int Void M b -> ([Int] -> M b) -> Property checkConsumerM = checkConsumerM' runM checkStreamConsumerM :: (Show b, Eq b) => StreamConsumer Int M b -> ([Int] -> M b) -> Property checkStreamConsumerM = checkStreamConsumerM' runM -checkConduitM :: (Show a, Arbitrary a, Show b, Eq b) => Conduit a M b -> ([a] -> M [b]) -> Property -checkConduitM = checkConduitM' runM +checkConduitT :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b M () -> ([a] -> M [b]) -> Property +checkConduitT = checkConduitT' runM -checkStreamConduitM :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a M b -> ([a] -> M [b]) -> Property -checkStreamConduitM = checkStreamConduitM' runM +checkStreamConduitT :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a M b -> ([a] -> M [b]) -> Property +checkStreamConduitT = checkStreamConduitT' runM --- checkConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitM a b M r -> ([a] -> M ([b], r)) -> Property +-- checkConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b M r -> ([a] -> M ([b], r)) -> Property -- checkConduitResultM = checkConduitResultM' runM -checkStreamConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitM a b M r -> ([a] -> M ([b], r)) -> Property +checkStreamConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b M r -> ([a] -> M ([b], r)) -> Property checkStreamConduitResultM = checkStreamConduitResultM' runM -------------------------------------------------------------------------------- @@ -381,11 +381,11 @@ checkProducerM' :: (Show a, Monad m, Show b, Eq b) => (m [a] -> b) - -> Source m a + -> ConduitT () a m () -> m [a] -> Property checkProducerM' f c l = - f (preventFusion c $$ consume) + f (runConduit (preventFusion c .| consume)) === f l @@ -401,12 +401,12 @@ checkInfiniteProducerM' :: (Show a, Monad m, Show b, Eq b) => (m [a] -> b) - -> Source m a + -> ConduitT () a m () -> m [a] -> Property checkInfiniteProducerM' f s l = checkProducerM' f - (preventFusion s $= isolate 10) + (preventFusion s .| isolate 10) (liftM (Prelude.take 10) l) checkInfiniteStreamProducerM' :: (Show a, Monad m, Show b, Eq b) @@ -421,11 +421,11 @@ checkConsumerM' :: (Show a, Monad m, Show b, Eq b) => (m a -> b) - -> Consumer Int m a + -> ConduitT Int Void m a -> ([Int] -> m a) -> Property checkConsumerM' f c l = forAll arbitrary $ \xs -> - f (sourceList xs $$ preventFusion c) + f (runConduit (sourceList xs .| preventFusion c)) === f (l xs) @@ -439,22 +439,22 @@ === f (l xs) -checkConduitM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) +checkConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) => (m [b] -> c) - -> Conduit a m b + -> ConduitT a b m () -> ([a] -> m [b]) -> Property -checkConduitM' f c l = forAll arbitrary $ \xs -> - f (sourceList xs $= preventFusion c $$ consume) +checkConduitT' f c l = forAll arbitrary $ \xs -> + f (runConduit (sourceList xs .| preventFusion c .| consume)) === f (l xs) -checkStreamConduitM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) +checkStreamConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) => (m [b] -> c) -> StreamConduit a m b -> ([a] -> m [b]) -> Property -checkStreamConduitM' f s l = forAll arbitrary $ \xs -> +checkStreamConduitT' f s l = forAll arbitrary $ \xs -> f (liftM fst $ evalStream $ s $ sourceListS xs emptyStream) === f (l xs) @@ -464,17 +464,17 @@ -- -- checkConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) -- => (m ([b], r) -> c) --- -> ConduitM a b m r +-- -> ConduitT a b m r -- -> ([a] -> m ([b], r)) -- -> Property -- checkConduitResultM' f c l = FIXME forAll arbitrary $ \xs -> --- f (sourceList xs $= preventFusion c $$ consume) +-- f (sourceList xs .| preventFusion c $$ consume) -- === -- f (l xs) checkStreamConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) => (m ([b], r) -> c) - -> StreamConduitM a b m r + -> StreamConduitT a b m r -> ([a] -> m ([b], r)) -> Property checkStreamConduitResultM' f s l = forAll arbitrary $ \xs -> diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,664 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module Spec (spec) where + +import Conduit +import Prelude hiding (FilePath) +import Data.Maybe (listToMaybe) +import Data.Conduit.Combinators (slidingWindow, chunksOfE, chunksOfExactlyE) +import Data.List (intersperse, sort, find, mapAccumL) +import Safe (tailSafe) +import System.FilePath (takeExtension, ()) +import Test.Hspec +import Test.Hspec.QuickCheck +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.IORef +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS +import Control.Monad (liftM) +import Control.Monad.ST (runST) +import Control.Monad.Trans.Writer +import qualified System.IO as IO +#if ! MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid (..)) +import Control.Applicative ((<$>), (<*>)) +#endif +#if MIN_VERSION_mono_traversable(1,0,0) +import Data.Sequences (LazySequence (..), Utf8 (..)) +#else +import Data.Sequences.Lazy +import Data.Textual.Encoding +#endif +import qualified Data.NonNull as NN +import GHC.IO.Handle (hDuplicateTo) +import qualified Data.ByteString as S +import Data.ByteString.Builder (byteString, toLazyByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified StreamSpec +import UnliftIO.Exception (pureTry) + +spec :: Spec +spec = do + describe "yieldMany" $ do + it "list" $ + runConduitPure (yieldMany [1..10] .| sinkList) + `shouldBe` [1..10] + it "Text" $ + runConduitPure (yieldMany ("Hello World" :: T.Text) .| sinkList) + `shouldBe` "Hello World" + it "unfold" $ + let f 11 = Nothing + f i = Just (show i, i + 1) + in runConduitPure (unfoldC f 1 .| sinkList) + `shouldBe` map show [1..10] + it "enumFromTo" $ + runConduitPure (enumFromToC 1 10 .| sinkList) `shouldBe` [1..10] + it "iterate" $ + let f i = i + 1 + src = iterateC f seed + seed = 1 + count = 10 + res = runConduitPure $ src .| takeC count .| sinkList + in res `shouldBe` take count (iterate f seed) + it "repeat" $ + let src = repeatC seed + seed = 1 + count = 10 + res = runConduitPure $ src .| takeC count .| sinkList + in res `shouldBe` take count (repeat seed) + it "replicate" $ + let src = replicateC count seed + seed = 1 + count = 10 + res = runConduitPure $ src .| sinkList + in res `shouldBe` replicate count seed + it "sourceLazy" $ + let tss = ["foo", "bar", "baz"] + tl = TL.fromChunks tss + res = runConduitPure $ sourceLazy tl .| sinkList + in res `shouldBe` tss + it "repeatM" $ + let src = repeatMC (return seed) + seed = 1 + count = 10 + res = runConduitPure $ src .| takeC count .| sinkList + in res `shouldBe` take count (repeat seed) + it "repeatWhileM" $ do + ref <- newIORef 0 + let f = atomicModifyIORef ref $ \i -> (succ i, succ i) + src = repeatWhileMC f (< 11) + res <- runConduit $ src .| sinkList + res `shouldBe` [1..10] + it "replicateM" $ do + ref <- newIORef 0 + let f = atomicModifyIORef ref $ \i -> (succ i, succ i) + src = replicateMC 10 f + res <- runConduit $ src .| sinkList + res `shouldBe` [1..10] + it "sourceFile" $ do + let contents = concat $ replicate 10000 $ "this is some content\n" + fp = "tmp" + writeFile fp contents + res <- runConduitRes $ sourceFile fp .| sinkLazy + nocrBL res `shouldBe` TL.encodeUtf8 (TL.pack contents) + it "sourceHandle" $ do + let contents = concat $ replicate 10000 $ "this is some content\n" + fp = "tmp" + writeFile fp contents + res <- IO.withBinaryFile "tmp" IO.ReadMode $ \h -> + runConduit $ sourceHandle h .| sinkLazy + nocrBL res `shouldBe` TL.encodeUtf8 (TL.pack contents) + it "sourceIOHandle" $ do + let contents = concat $ replicate 10000 $ "this is some content\n" + fp = "tmp" + writeFile fp contents + let open = IO.openBinaryFile "tmp" IO.ReadMode + res <- runConduitRes $ sourceIOHandle open .| sinkLazy + nocrBL res `shouldBe` TL.encodeUtf8 (TL.pack contents) + prop "stdin" $ \(S.pack -> content) -> do + S.writeFile "tmp" content + IO.withBinaryFile "tmp" IO.ReadMode $ \h -> do + hDuplicateTo h IO.stdin + x <- runConduit $ stdinC .| foldC + x `shouldBe` content + let hasExtension' ext fp = takeExtension fp == ext + it "sourceDirectory" $ do + res <- runConduitRes + $ sourceDirectory "test" .| filterC (not . hasExtension' ".swp") .| sinkList + sort res `shouldBe` + [ "test" "Data" + , "test" "Spec.hs" + , "test" "StreamSpec.hs" + , "test" "doctests.hs" + , "test" "main.hs" + , "test" "subdir" + ] + it "sourceDirectoryDeep" $ do + res1 <- runConduitRes + $ sourceDirectoryDeep False "test" .| filterC (not . hasExtension' ".swp") .| sinkList + res2 <- runConduitRes + $ sourceDirectoryDeep True "test" .| filterC (not . hasExtension' ".swp") .| sinkList + sort res1 `shouldBe` + [ "test" "Data" "Conduit" "Extra" "ZipConduitSpec.hs" + , "test" "Data" "Conduit" "StreamSpec.hs" + , "test" "Spec.hs" + , "test" "StreamSpec.hs" + , "test" "doctests.hs" + , "test" "main.hs" + , "test" "subdir" "dummyfile.txt" + ] + sort res1 `shouldBe` sort res2 + prop "drop" $ \(T.pack -> input) count -> + runConduitPure (yieldMany input .| (dropC count >>= \() -> sinkList)) + `shouldBe` T.unpack (T.drop count input) + prop "dropE" $ \(T.pack -> input) -> + runConduitPure (yield input .| (dropCE 5 >>= \() -> foldC)) + `shouldBe` T.drop 5 input + prop "dropWhile" $ \(T.pack -> input) sep -> + runConduitPure (yieldMany input .| (dropWhileC (<= sep) >>= \() -> sinkList)) + `shouldBe` T.unpack (T.dropWhile (<= sep) input) + prop "dropWhileE" $ \(T.pack -> input) sep -> + runConduitPure (yield input .| (dropWhileCE (<= sep) >>= \() -> foldC)) + `shouldBe` T.dropWhile (<= sep) input + it "fold" $ + let list = [[1..10], [11..20]] + src = yieldMany list + res = runConduitPure $ src .| foldC + in res `shouldBe` concat list + it "foldE" $ + let list = [[1..10], [11..20]] + src = yieldMany $ Identity list + res = runConduitPure $ src .| foldCE + in res `shouldBe` concat list + it "foldl" $ + let res = runConduitPure $ yieldMany [1..10] .| foldlC (+) 0 + in res `shouldBe` sum [1..10] + it "foldlE" $ + let res = runConduitPure $ yield [1..10] .| foldlCE (+) 0 + in res `shouldBe` sum [1..10] + it "foldMap" $ + let src = yieldMany [1..10] + res = runConduitPure $ src .| foldMapC return + in res `shouldBe` [1..10] + it "foldMapE" $ + let src = yield [1..10] + res = runConduitPure $ src .| foldMapCE return + in res `shouldBe` [1..10] + prop "all" $ \ (input :: [Int]) -> runConduitPure (yieldMany input .| allC even) `shouldBe` all evenInt input + prop "allE" $ \ (input :: [Int]) -> runConduitPure (yield input .| allCE even) `shouldBe` all evenInt input + prop "any" $ \ (input :: [Int]) -> runConduitPure (yieldMany input .| anyC even) `shouldBe` any evenInt input + prop "anyE" $ \ (input :: [Int]) -> runConduitPure (yield input .| anyCE even) `shouldBe` any evenInt input + prop "and" $ \ (input :: [Bool]) -> runConduitPure (yieldMany input .| andC) `shouldBe` and input + prop "andE" $ \ (input :: [Bool]) -> runConduitPure (yield input .| andCE) `shouldBe` and input + prop "or" $ \ (input :: [Bool]) -> runConduitPure (yieldMany input .| orC) `shouldBe` or input + prop "orE" $ \ (input :: [Bool]) -> runConduitPure (yield input .| orCE) `shouldBe` or input + prop "elem" $ \x xs -> runConduitPure (yieldMany xs .| elemC x) `shouldBe` elemInt x xs + prop "elemE" $ \x xs -> runConduitPure (yield xs .| elemCE x) `shouldBe` elemInt x xs + prop "notElem" $ \x xs -> runConduitPure (yieldMany xs .| notElemC x) `shouldBe` notElemInt x xs + prop "notElemE" $ \x xs -> runConduitPure (yield xs .| notElemCE x) `shouldBe` notElemInt x xs + prop "sinkVector regular" $ \xs -> do + res <- runConduit $ yieldMany xs .| sinkVector + res `shouldBe` V.fromList (xs :: [Int]) + prop "sinkVector unboxed" $ \xs -> do + res <- runConduit $ yieldMany xs .| sinkVector + res `shouldBe` VU.fromList (xs :: [Int]) + prop "sinkVector storable" $ \xs -> do + res <- runConduit $ yieldMany xs .| sinkVector + res `shouldBe` VS.fromList (xs :: [Int]) + prop "sinkVectorN regular" $ \xs' -> do + let maxSize = 20 + xs = take maxSize xs' + res <- runConduit $ yieldMany xs' .| sinkVectorN maxSize + res `shouldBe` V.fromList (xs :: [Int]) + prop "sinkVectorN unboxed" $ \xs' -> do + let maxSize = 20 + xs = take maxSize xs' + res <- runConduit $ yieldMany xs' .| sinkVectorN maxSize + res `shouldBe` VU.fromList (xs :: [Int]) + prop "sinkVectorN storable" $ \xs' -> do + let maxSize = 20 + xs = take maxSize xs' + res <- runConduit $ yieldMany xs' .| sinkVectorN maxSize + res `shouldBe` VS.fromList (xs :: [Int]) + prop "sinkBuilder" $ \(map S.pack -> inputs) -> + let builder = runConduitPure $ yieldMany inputs .| foldMapC byteString + ltext = toLazyByteString builder + in ltext `shouldBe` fromChunks inputs + prop "sinkLazyBuilder" $ \(map S.pack -> inputs) -> + let lbs = runConduitPure (yieldMany (map byteString inputs) .| sinkLazyBuilder) + in lbs `shouldBe` fromChunks inputs + prop "sinkNull" $ \xs toSkip -> do + res <- runConduit $ yieldMany xs .| do + takeC toSkip .| sinkNull + sinkList + res `shouldBe` drop toSkip (xs :: [Int]) + prop "awaitNonNull" $ \xs -> + fmap NN.toNullable (runConduitPure $ yieldMany xs .| awaitNonNull) + `shouldBe` listToMaybe (filter (not . null) (xs :: [[Int]])) + prop "headE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| ((,) <$> headCE <*> foldC)) + `shouldBe` (listToMaybe $ concat xs, drop 1 $ concat xs) + prop "peek" $ \xs -> + runConduitPure (yieldMany xs .| ((,) <$> peekC <*> sinkList)) + `shouldBe` (listToMaybe xs, xs :: [Int]) + prop "peekE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| ((,) <$> peekCE <*> foldC)) + `shouldBe` (listToMaybe $ concat xs, concat xs) + prop "last" $ \xs -> + runConduitPure (yieldMany xs .| lastC) + `shouldBe` listToMaybe (reverse (xs :: [Int])) + prop "lastE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| lastCE) + `shouldBe` listToMaybe (reverse (concat xs)) + prop "length" $ \xs -> + runConduitPure (yieldMany xs .| lengthC) + `shouldBe` length (xs :: [Int]) + prop "lengthE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| lengthCE) + `shouldBe` length (concat xs) + prop "lengthIf" $ \x xs -> + runConduitPure (yieldMany xs .| lengthIfC (< x)) + `shouldBe` length (filter (< x) xs :: [Int]) + prop "lengthIfE" $ \x (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| lengthIfCE (< x)) + `shouldBe` length (filter (< x) (concat xs)) + prop "maximum" $ \xs -> + runConduitPure (yieldMany xs .| maximumC) + `shouldBe` (if null (xs :: [Int]) then Nothing else Just (maximum xs)) + prop "maximumE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| maximumCE) + `shouldBe` (if null (concat xs) then Nothing else Just (maximum $ concat xs)) + prop "minimum" $ \xs -> + runConduitPure (yieldMany xs .| minimumC) + `shouldBe` (if null (xs :: [Int]) then Nothing else Just (minimum xs)) + prop "minimumE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| minimumCE) + `shouldBe` (if null (concat xs) then Nothing else Just (minimum $ concat xs)) + prop "null" $ \xs -> + runConduitPure (yieldMany xs .| nullC) + `shouldBe` null (xs :: [Int]) + prop "nullE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| ((,) <$> nullCE <*> foldC)) + `shouldBe` (null (concat xs), concat xs) + prop "sum" $ \xs -> + runConduitPure (yieldMany xs .| sumC) + `shouldBe` sum (xs :: [Int]) + prop "sumE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| sumCE) + `shouldBe` sum (concat xs) + prop "product" $ \xs -> + runConduitPure (yieldMany xs .| productC) + `shouldBe` product (xs :: [Int]) + prop "productE" $ \ (xs :: [[Int]]) -> + runConduitPure (yieldMany xs .| productCE) + `shouldBe` product (concat xs) + prop "find" $ \x xs -> + runConduitPure (yieldMany xs .| findC (< x)) + `shouldBe` find (< x) (xs :: [Int]) + prop "mapM_" $ \xs -> + let res = execWriter $ runConduit $ yieldMany xs .| mapM_C (tell . return) + in res `shouldBe` (xs :: [Int]) + prop "mapM_E" $ \xs -> + let res = execWriter $ runConduit $ yield xs .| mapM_CE (tell . return) + in res `shouldBe` (xs :: [Int]) + prop "foldM" $ \ (xs :: [Int]) -> do + res <- runConduit $ yieldMany xs .| foldMC addM 0 + res `shouldBe` sum xs + prop "foldME" $ \ (xs :: [Int]) -> do + res <- runConduit $ yield xs .| foldMCE addM 0 + res `shouldBe` sum xs + it "foldMapM" $ + let src = yieldMany [1..10] + res = runConduitPure $ src .| foldMapMC (return . return) + in res `shouldBe` [1..10] + it "foldMapME" $ + let src = yield [1..10] + res = runConduitPure $ src .| foldMapMCE (return . return) + in res `shouldBe` [1..10] + it "sinkFile" $ do + let contents = mconcat $ replicate 1000 $ "this is some content\n" + fp = "tmp" + runConduitRes $ yield contents .| sinkFile fp + res <- S.readFile fp + res `shouldBe` contents + it "sinkHandle" $ do + let contents = mconcat $ replicate 1000 $ "this is some content\n" + fp = "tmp" + IO.withBinaryFile "tmp" IO.WriteMode $ \h -> runConduit $ yield contents .| sinkHandle h + res <- S.readFile fp + res `shouldBe` contents + it "sinkIOHandle" $ do + let contents = mconcat $ replicate 1000 $ "this is some content\n" + fp = "tmp" + open = IO.openBinaryFile "tmp" IO.WriteMode + runConduitRes $ yield contents .| sinkIOHandle open + res <- S.readFile fp + res `shouldBe` contents + prop "map" $ \input -> + runConduitPure (yieldMany input .| mapC succChar .| sinkList) + `shouldBe` map succChar input + prop "mapE" $ \(map V.fromList -> inputs) -> + runConduitPure (yieldMany inputs .| mapCE succChar .| foldC) + `shouldBe` V.map succChar (V.concat inputs) + prop "omapE" $ \(map T.pack -> inputs) -> + runConduitPure (yieldMany inputs .| omapCE succChar .| foldC) + `shouldBe` T.map succChar (T.concat inputs) + prop "concatMap" $ \ (input :: [Int]) -> + runConduitPure (yieldMany input .| concatMapC showInt .| sinkList) + `shouldBe` concatMap showInt input + prop "concatMapE" $ \ (input :: [Int]) -> + runConduitPure (yield input .| concatMapCE showInt .| foldC) + `shouldBe` concatMap showInt input + prop "take" $ \(T.pack -> input) count -> + runConduitPure (yieldMany input .| (takeC count >>= \() -> mempty) .| sinkList) + `shouldBe` T.unpack (T.take count input) + prop "takeE" $ \(T.pack -> input) count -> + runConduitPure (yield input .| (takeCE count >>= \() -> mempty) .| foldC) + `shouldBe` T.take count input + prop "takeWhile" $ \(T.pack -> input) sep -> + runConduitPure (yieldMany input .| do + x <- (takeWhileC (<= sep) >>= \() -> mempty) .| sinkList + y <- sinkList + return (x, y)) + `shouldBe` span (<= sep) (T.unpack input) + prop "takeWhileE" $ \(T.pack -> input) sep -> + runConduitPure (yield input .| do + x <- (takeWhileCE (<= sep) >>= \() -> mempty) .| foldC + y <- foldC + return (x, y)) + `shouldBe` T.span (<= sep) input + it "takeExactly" $ + let src = yieldMany [1..10] + sink = do + x <- takeExactlyC 5 $ return 1 + y <- sinkList + return (x, y) + res = runConduitPure $ src .| sink + in res `shouldBe` (1, [6..10]) + it "takeExactlyE" $ + let src = yield ("Hello World" :: T.Text) + sink = do + takeExactlyCE 5 (mempty :: ConduitT T.Text Void Identity ()) + y <- sinkLazy + return y + res = runConduitPure $ src .| sink + in res `shouldBe` " World" + it "takeExactlyE Vector" $ do + let src = yield (V.fromList $ T.unpack "Hello World") + sink = do + x <- takeExactlyCE 5 $ return 1 + y <- foldC + return (x, y) + res <- runConduit $ src .| sink + res `shouldBe` (1, V.fromList $ T.unpack " World") + it "takeExactlyE 2" $ + let src = yield ("Hello World" :: T.Text) + sink = do + x <- takeExactlyCE 5 $ return 1 + y <- sinkLazy + return (x, y) + res = runConduitPure $ src .| sink + -- FIXME type signature on next line is necessary in GHC 7.6.3 to + -- avoid a crash: + -- + -- test: internal error: ARR_WORDS object entered! + -- (GHC version 7.6.3 for x86_64_unknown_linux) + -- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug + -- Aborted (core dumped) + -- + -- Report upstream when packages are released + in res `shouldBe` (1, " World" :: TL.Text) + prop "concat" $ \input -> + runConduitPure (yield (T.pack input) .| concatC .| sinkList) + `shouldBe` input + prop "filter" $ \input -> + runConduitPure (yieldMany input .| filterC evenInt .| sinkList) + `shouldBe` filter evenInt input + prop "filterE" $ \input -> + runConduitPure (yield input .| filterCE evenInt .| foldC) + `shouldBe` filter evenInt input + prop "mapWhile" $ \input (min 20 -> highest) -> + let f i | i < highest = Just (i + 2 :: Int) + | otherwise = Nothing + res = runConduitPure $ yieldMany input .| do + x <- (mapWhileC f >>= \() -> mempty) .| sinkList + y <- sinkList + return (x, y) + (taken, dropped) = span (< highest) input + in res `shouldBe` (map (+ 2) taken, dropped) + prop "conduitVector" $ \(take 200 -> input) size' -> do + let size = min 30 $ succ $ abs size' + res <- runConduit $ yieldMany input .| conduitVector size .| sinkList + res `shouldSatisfy` all (\v -> V.length v <= size) + drop 1 (reverse res) `shouldSatisfy` all (\v -> V.length v == size) + V.concat res `shouldBe` V.fromList (input :: [Int]) + prop "scanl" $ \input seed -> + let f a b = a + b :: Int + res = runConduitPure $ yieldMany input .| scanlC f seed .| sinkList + in res `shouldBe` scanl f seed input + prop "mapAccumWhile" $ \input (min 20 -> highest) -> + let f i accum | i < highest = Right (i + accum, 2 * i :: Int) + | otherwise = Left accum + res = runConduitPure $ yieldMany input .| do + (s, x) <- fuseBoth (mapAccumWhileC f 0) sinkList + y <- sinkList + return (s, x, y) + (taken, dropped) = span (< highest) input + in res `shouldBe` (sum taken, map (* 2) taken, tailSafe dropped) + prop "concatMapAccum" $ \(input :: [Int]) -> + let f a accum = (a + accum, [a, accum]) + res = runConduitPure $ yieldMany input .| concatMapAccumC f 0 .| sinkList + expected = concat $ snd $ mapAccumL (flip f) 0 input + in res `shouldBe` expected + prop "intersperse" $ \xs x -> + runConduitPure (yieldMany xs .| intersperseC x .| sinkList) + `shouldBe` intersperse (x :: Int) xs + prop "mapM" $ \input -> + runConduitPure (yieldMany input .| mapMC (return . succChar) .| sinkList) + `shouldBe` map succChar input + prop "mapME" $ \(map V.fromList -> inputs) -> + runConduitPure (yieldMany inputs .| mapMCE (return . succChar) .| foldC) + `shouldBe` V.map succChar (V.concat inputs) + prop "omapME" $ \(map T.pack -> inputs) -> + runConduitPure (yieldMany inputs .| omapMCE (return . succChar) .| foldC) + `shouldBe` T.map succChar (T.concat inputs) + prop "concatMapM" $ \ (input :: [Int]) -> + runConduitPure (yieldMany input .| concatMapMC (return . showInt) .| sinkList) + `shouldBe` concatMap showInt input + prop "filterM" $ \input -> + runConduitPure (yieldMany input .| filterMC (return . evenInt) .| sinkList) + `shouldBe` filter evenInt input + prop "filterME" $ \input -> + runConduitPure (yield input .| filterMCE (return . evenInt) .| foldC) + `shouldBe` filter evenInt input + prop "iterM" $ \input -> do + (x, y) <- runWriterT $ runConduit $ yieldMany input .| iterMC (tell . return) .| sinkList + x `shouldBe` (input :: [Int]) + y `shouldBe` input + prop "scanlM" $ \input seed -> + let f a b = a + b :: Int + fm a b = return $ a + b + res = runConduitPure $ yieldMany input .| scanlMC fm seed .| sinkList + in res `shouldBe` scanl f seed input + prop "mapAccumWhileM" $ \input (min 20 -> highest) -> + let f i accum | i < highest = Right (i + accum, 2 * i :: Int) + | otherwise = Left accum + res = runConduitPure $ yieldMany input .| do + (s, x) <- fuseBoth (mapAccumWhileMC ((return.).f) 0) sinkList + y <- sinkList + return (s, x, y) + (taken, dropped) = span (< highest) input + in res `shouldBe` (sum taken, map (* 2) taken, tailSafe dropped) + prop "concatMapAccumM" $ \(input :: [Int]) -> + let f a accum = (a + accum, [a, accum]) + res = runConduitPure $ yieldMany input .| concatMapAccumMC ((return.).f) 0 .| sinkList + expected = concat $ snd $ mapAccumL (flip f) 0 input + in res `shouldBe` expected + prop "encode UTF8" $ \(map T.pack -> inputs) -> do + let expected = encodeUtf8 $ fromChunks inputs + actual <- runConduit + $ yieldMany inputs + .| encodeUtf8C + .| sinkLazy + actual `shouldBe` expected + prop "encode/decode UTF8" $ \(map T.pack -> inputs) (min 50 . max 1 . abs -> chunkSize) -> do + let expected = fromChunks inputs + actual <- runConduit + $ yieldMany inputs + .| encodeUtf8C + .| concatC + .| conduitVector chunkSize + .| mapC (S.pack . V.toList) + .| decodeUtf8C + .| sinkLazy + actual `shouldBe` expected + it "invalid UTF8 is an exception" $ + case runConduit $ yield "\129" .| decodeUtf8C .| sinkLazy of + Left _ -> return () :: IO () + Right x -> error $ "this should have failed, got: " ++ show x + prop "encode/decode UTF8 lenient" $ \(map T.pack -> inputs) (min 50 . max 1 . abs -> chunkSize) -> do + let expected = fromChunks inputs + actual <- runConduit + $ yieldMany inputs + .| encodeUtf8C + .| concatC + .| conduitVector chunkSize + .| mapC (S.pack . V.toList) + .| decodeUtf8LenientC + .| sinkLazy + actual `shouldBe` expected + prop "line" $ \(map T.pack -> input) size -> + let src = yieldMany input + sink = do + x <- lineC $ takeCE size .| foldC + y <- foldC + return (x, y) + res = runConduitPure $ src .| sink + expected = + let (x, y) = T.break (== '\n') (T.concat input) + in (T.take size x, T.drop 1 y) + in res `shouldBe` expected + prop "lineAscii" $ \(map S.pack -> input) size -> + let src = yieldMany input + sink = do + x <- lineAsciiC $ takeCE size .| foldC + y <- foldC + return (x, y) + res = runConduitPure $ src .| sink + expected = + let (x, y) = S.break (== 10) (S.concat input) + in (S.take size x, S.drop 1 y) + in res `shouldBe` expected + prop "unlines" $ \(map T.pack -> input) -> + runConduitPure (yieldMany input .| unlinesC .| foldC) + `shouldBe` T.unlines input + prop "unlinesAscii" $ \(map S.pack -> input) -> + runConduitPure (yieldMany input .| unlinesAsciiC .| foldC) + `shouldBe` S8.unlines input + prop "linesUnbounded" $ \(map T.pack -> input) -> + runConduitPure (yieldMany input .| (linesUnboundedC >>= \() -> mempty) .| sinkList) + `shouldBe` T.lines (T.concat input) + prop "linesUnboundedAscii" $ \(map S.pack -> input) -> + runConduitPure (yieldMany input .| (linesUnboundedAsciiC >>= \() -> mempty) .| sinkList) + `shouldBe` S8.lines (S.concat input) + it "slidingWindow 0" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 0 .| sinkList + in res `shouldBe` [[1],[2],[3],[4],[5]] + it "slidingWindow 1" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 1 .| sinkList + in res `shouldBe` [[1],[2],[3],[4],[5]] + it "slidingWindow 2" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 2 .| sinkList + in res `shouldBe` [[1,2],[2,3],[3,4],[4,5]] + it "slidingWindow 3" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 3 .| sinkList + in res `shouldBe` [[1,2,3],[2,3,4],[3,4,5]] + it "slidingWindow 4" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 4 .| sinkList + in res `shouldBe` [[1,2,3,4],[2,3,4,5]] + it "slidingWindow 5" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 5 .| sinkList + in res `shouldBe` [[1,2,3,4,5]] + it "slidingWindow 6" $ + let res = runConduitPure $ yieldMany [1..5] .| slidingWindow 6 .| sinkList + in res `shouldBe` [[1,2,3,4,5]] + it "chunksOfE 1" $ + let res = runConduitPure $ yieldMany [[1,2], [3,4], [5,6]] .| chunksOfE 3 .| sinkList + in res `shouldBe` [[1,2,3], [4,5,6]] + it "chunksOfE 2 (last smaller)" $ + let res = runConduitPure $ yieldMany [[1,2], [3,4], [5,6,7]] .| chunksOfE 3 .| sinkList + in res `shouldBe` [[1,2,3], [4,5,6], [7]] + it "chunksOfE (ByteString)" $ + let res = runConduitPure $ yieldMany [S8.pack "01234", "56789ab", "cdef", "h"] .| chunksOfE 4 .| sinkList + in res `shouldBe` ["0123", "4567", "89ab", "cdef", "h"] + it "chunksOfExactlyE 1" $ + let res = runConduitPure $ yieldMany [[1,2], [3,4], [5,6]] .| chunksOfExactlyE 3 .| sinkList + in res `shouldBe` [[1,2,3], [4,5,6]] + it "chunksOfExactlyE 2 (last smaller; thus not yielded)" $ + let res = runConduitPure $ yieldMany [[1,2], [3,4], [5,6,7]] .| chunksOfExactlyE 3 .| sinkList + in res `shouldBe` [[1,2,3], [4,5,6]] + prop "vectorBuilder" $ \(values :: [[Int]]) ((+1) . (`mod` 30) . abs -> size) -> do + let res = runST $ runConduit + $ yieldMany values + .| vectorBuilderC size mapM_CE + .| sinkList + expected = + loop $ concat values + where + loop [] = [] + loop x = + VU.fromList y : loop z + where + (y, z) = splitAt size x + res `shouldBe` expected + prop "mapAccumS" $ \input -> + let ints = [1..] + f a s = liftM (:s) $ mapC (* a) .| takeC a .| sinkList + res = reverse $ runConduitPure $ yieldMany input + .| mapAccumS f [] (yieldMany ints) + expected = loop input ints + where loop [] _ = [] + loop (a:as) xs = let (y, ys) = Prelude.splitAt a xs + in map (* a) y : loop as ys + in res `shouldBe` expected + prop "peekForever" $ \(strs' :: [String]) -> do + let strs = filter (not . null) strs' + res1 <- runConduit $ yieldMany strs .| linesUnboundedC .| sinkList + res2 <- runConduit $ yieldMany strs .| peekForever (lineC $ foldC >>= yield) .| sinkList + res2 `shouldBe` res1 + prop "peekForeverE" $ \(strs :: [String]) -> do + res1 <- runConduit $ yieldMany strs .| linesUnboundedC .| sinkList + res2 <- runConduit $ yieldMany strs .| peekForeverE (lineC $ foldC >>= yield) .| sinkList + res2 `shouldBe` res1 + StreamSpec.spec + +evenInt :: Int -> Bool +evenInt = even + +elemInt :: Int -> [Int] -> Bool +elemInt = elem + +notElemInt :: Int -> [Int] -> Bool +notElemInt = notElem + +addM :: Monad m => Int -> Int -> m Int +addM x y = return (x + y) + +succChar :: Char -> Char +succChar c = + case pureTry (succ c) of + Left _ -> 'X' -- QuickCheck may generate characters out of range + Right x -> x + +showInt :: Int -> String +showInt = Prelude.show + +nocrBL :: L8.ByteString -> L8.ByteString +nocrBL = L8.filter (/= '\r') diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamSpec.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module StreamSpec where + +import Control.Arrow (first) +import Control.Applicative +import qualified Control.Monad +import Control.Monad (liftM) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.State (StateT(..), get, put) +import Data.Conduit +import Data.Conduit.Combinators +import Data.Conduit.Combinators.Stream +import Data.Conduit.Internal.Fusion +import Data.Conduit.Internal.List.Stream (takeS, sourceListS, mapS) +import qualified Data.List +import Data.MonoTraversable +import Data.Monoid (Monoid(..)) +import qualified Data.NonNull as NonNull +import Data.Sequence (Seq) +import qualified Data.Sequences as Seq +import Data.Vector (Vector) +import qualified Prelude +import Prelude + ((.), ($), (>>=), (=<<), return, id, Maybe(..), Either(..), Monad, + Bool(..), Int, Eq, Show, String, Functor, fst, snd, either) +import qualified Safe +import qualified System.IO as IO +import System.IO.Unsafe +import Test.Hspec +import Test.QuickCheck +import Data.Semigroup (Semigroup (..)) + +spec :: Spec +spec = do + describe "Comparing list function to" $ do + qit "yieldMany" $ + \(mono :: Seq Int) -> + yieldMany mono `checkProducer` + otoList mono + qit "sourceListS" $ + \(mono :: Seq Int) -> + yieldManyS mono `checkStreamProducer` + otoList mono + qit "repeatM" $ + \(getBlind -> (f :: M Int)) -> + repeatM f `checkInfiniteProducerM` + repeatML f + qit "repeatMS" $ + \(getBlind -> (f :: M Int)) -> + repeatMS f `checkInfiniteStreamProducerM` + repeatML f + qit "repeatWhileM" $ + \(getBlind -> (f :: M Int), getBlind -> g) -> + repeatWhileM f g `checkInfiniteProducerM` + repeatWhileML f g + qit "repeatWhileMS" $ + \(getBlind -> (f :: M Int), getBlind -> g) -> + repeatWhileMS f g `checkInfiniteStreamProducerM` + repeatWhileML f g + qit "foldl1" $ + \(getBlind -> f) -> + foldl1 f `checkConsumer` + foldl1L f + qit "foldl1S" $ + \(getBlind -> f) -> + foldl1S f `checkStreamConsumer` + foldl1L f + qit "all" $ + \(getBlind -> f) -> + all f `checkConsumer` + Prelude.all f + qit "allS" $ + \(getBlind -> f) -> + allS f `checkStreamConsumer` + Prelude.all f + qit "any" $ + \(getBlind -> f) -> + any f `checkConsumer` + Prelude.any f + qit "anyS" $ + \(getBlind -> f) -> + anyS f `checkStreamConsumer` + Prelude.any f + qit "last" $ + \() -> + last `checkConsumer` + Safe.lastMay + qit "lastS" $ + \() -> + lastS `checkStreamConsumer` + Safe.lastMay + qit "lastE" $ + \(getBlind -> f) -> + let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int + in (map g .| lastE) `checkConsumer` + (lastEL . Prelude.map g :: [Int] -> Maybe Int) + qit "lastES" $ + \(getBlind -> f) -> + let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int + in (lastES . mapS g) `checkStreamConsumer` + (lastEL . Prelude.map g :: [Int] -> Maybe Int) + qit "find" $ + \(getBlind -> f) -> + find f `checkConsumer` + Data.List.find f + qit "findS" $ + \(getBlind -> f) -> + findS f `checkStreamConsumer` + Data.List.find f + qit "concatMap" $ + \(getBlind -> (f :: Int -> Seq Int)) -> + concatMap f `checkConduit` + concatMapL f + qit "concatMapS" $ + \(getBlind -> (f :: Int -> Seq Int)) -> + concatMapS f `checkStreamConduit` + concatMapL f + qit "concatMapM" $ + \(getBlind -> (f :: Int -> M (Seq Int))) -> + concatMapM f `checkConduitT` + concatMapML f + qit "concatMapMS" $ + \(getBlind -> (f :: Int -> M (Seq Int))) -> + concatMapMS f `checkStreamConduitT` + concatMapML f + qit "concat" $ + \() -> + concat `checkConduit` + (concatL :: [Seq Int] -> [Int]) + qit "concatS" $ + \() -> + concatS `checkStreamConduit` + (concatL :: [Seq Int] -> [Int]) + qit "scanl" $ + \(getBlind -> (f :: Int -> Int -> Int), initial) -> + scanl f initial `checkConduit` + Prelude.scanl f initial + qit "scanlS" $ + \(getBlind -> (f :: Int -> Int -> Int), initial) -> + scanlS f initial `checkStreamConduit` + Prelude.scanl f initial + qit "scanlM" $ + \(getBlind -> (f :: Int -> Int -> M Int), initial) -> + scanlM f initial `checkConduitT` + scanlML f initial + qit "scanlMS" $ + \(getBlind -> (f :: Int -> Int -> M Int), initial) -> + scanlMS f initial `checkStreamConduitT` + scanlML f initial + qit "mapAccumWhileS" $ + \(getBlind -> ( f :: Int -> [Int] -> Either [Int] ([Int], Int)) + , initial :: [Int]) -> + mapAccumWhileS f initial `checkStreamConduitResult` + mapAccumWhileL f initial + qit "mapAccumWhileMS" $ + \(getBlind -> ( f :: Int -> [Int] -> M (Either [Int] ([Int], Int))) + , initial :: [Int]) -> + mapAccumWhileMS f initial `checkStreamConduitResultM` + mapAccumWhileML f initial + qit "intersperse" $ + \(sep :: Int) -> + intersperse sep `checkConduit` + Data.List.intersperse sep + qit "intersperseS" $ + \(sep :: Int) -> + intersperseS sep `checkStreamConduit` + Data.List.intersperse sep + qit "filterM" $ + \(getBlind -> (f :: Int -> M Bool)) -> + filterM f `checkConduitT` + Control.Monad.filterM f + qit "filterMS" $ + \(getBlind -> (f :: Int -> M Bool)) -> + filterMS f `checkStreamConduitT` + Control.Monad.filterM f + describe "comparing normal conduit function to" $ do + qit "slidingWindowS" $ + \(getSmall -> n) -> + slidingWindowS n `checkStreamConduit` + (\xs -> runConduitPure $ + yieldMany xs .| preventFusion (slidingWindow n) .| sinkList + :: [Seq Int]) + qit "splitOnUnboundedES" $ + \(getBlind -> (f :: Int -> Bool)) -> + splitOnUnboundedES f `checkStreamConduit` + (\xs -> runConduitPure $ + yieldMany xs .| preventFusion (splitOnUnboundedE f) .| sinkList + :: [Seq Int]) + qit "sinkVectorS" $ + \() -> checkStreamConsumerM' + unsafePerformIO + (sinkVectorS :: forall o. StreamConduitT Int o IO.IO (Vector Int)) + (\xs -> runConduit $ yieldMany xs .| preventFusion sinkVector) + qit "sinkVectorNS" $ + \(getSmall . getNonNegative -> n) -> checkStreamConsumerM' + unsafePerformIO + (sinkVectorNS n :: forall o. StreamConduitT Int o IO.IO (Vector Int)) + (\xs -> runConduit $ yieldMany xs .| preventFusion (sinkVectorN n)) + +#if !MIN_VERSION_QuickCheck(2,8,2) +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = Seq.fromList <$> arbitrary +#endif + +repeatML :: Monad m => m a -> m [a] +repeatML = Prelude.sequence . Prelude.repeat + +repeatWhileML :: Monad m => m a -> (a -> Bool) -> m [a] +repeatWhileML m f = go + where + go = do + x <- m + if f x + then liftM (x:) go + else return [] + +foldl1L :: (a -> a -> a) -> [a] -> Maybe a +foldl1L _ [] = Nothing +foldl1L f xs = Just $ Prelude.foldl1 f xs + +lastEL :: Seq.IsSequence seq + => [seq] -> Maybe (Element seq) +lastEL = Prelude.foldl go Nothing + where + go _ (NonNull.fromNullable -> Just l) = Just (NonNull.last l) + go mlast _ = mlast + +concatMapL :: MonoFoldable mono + => (a -> mono) -> [a] -> [Element mono] +concatMapL f = Prelude.concatMap (otoList . f) + +concatMapML :: (Monad m, MonoFoldable mono) + => (a -> m mono) -> [a] -> m [Element mono] +concatMapML f = liftM (Prelude.concatMap otoList) . Prelude.mapM f + +concatL :: MonoFoldable mono + => [mono] -> [Element mono] +concatL = Prelude.concatMap otoList + +scanlML :: Monad m => (a -> b -> m a) -> a -> [b] -> m [a] +scanlML f = go + where + go l [] = return [l] + go l (r:rs) = do + l' <- f l r + liftM (l:) (go l' rs) + +mapAccumWhileL :: (a -> s -> Either s (s, b)) -> s -> [a] -> ([b], s) +mapAccumWhileL f = (runIdentity.) . mapAccumWhileML ((return.) . f) + +mapAccumWhileML :: Monad m => + (a -> s -> m (Either s (s, b))) -> s -> [a] -> m ([b], s) +mapAccumWhileML f = go + where go s [] = return ([], s) + go s (a:as) = f a s >>= either + (return . ([], )) + (\(s', b) -> liftM (first (b:)) $ go s' as) + +--FIXME: the following code is directly copied from the conduit test +--suite. How to share this code?? + +qit :: (Arbitrary a, Testable prop, Show a) + => String -> (a -> prop) -> Spec +qit n f = it n $ property $ forAll arbitrary f + +-------------------------------------------------------------------------------- +-- Quickcheck utilities for pure conduits / streams + +checkProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property +checkProducer c l = checkProducerM' runIdentity c (return l) + +checkStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property +checkStreamProducer s l = checkStreamProducerM' runIdentity s (return l) + +checkInfiniteProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property +checkInfiniteProducer c l = checkInfiniteProducerM' runIdentity c (return l) + +checkInfiniteStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property +checkInfiniteStreamProducer s l = checkInfiniteStreamProducerM' runIdentity s (return l) + +checkConsumer :: (Show b, Eq b) => ConduitT Int Void Identity b -> ([Int] -> b) -> Property +checkConsumer c l = checkConsumerM' runIdentity c (return . l) + +checkStreamConsumer :: (Show b, Eq b) => StreamConduitT Int o Identity b -> ([Int] -> b) -> Property +checkStreamConsumer c l = checkStreamConsumerM' runIdentity c (return . l) + +checkConduit :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b Identity () -> ([a] -> [b]) -> Property +checkConduit c l = checkConduitT' runIdentity c (return . l) + +checkStreamConduit :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a Identity b -> ([a] -> [b]) -> Property +checkStreamConduit c l = checkStreamConduitT' runIdentity c (return . l) + +-- checkConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b Identity r -> ([a] -> ([b], r)) -> Property +-- checkConduitResult c l = checkConduitResultM' runIdentity c (return . l) + +checkStreamConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b Identity r -> ([a] -> ([b], r)) -> Property +checkStreamConduitResult c l = checkStreamConduitResultM' runIdentity c (return . l) + +-------------------------------------------------------------------------------- +-- Quickcheck utilities for conduits / streams in the M monad. + +checkProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property +checkProducerM = checkProducerM' runM + +checkStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property +checkStreamProducerM = checkStreamProducerM' runM + +checkInfiniteProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property +checkInfiniteProducerM = checkInfiniteProducerM' (fst . runM) + +checkInfiniteStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property +checkInfiniteStreamProducerM = checkInfiniteStreamProducerM' (fst . runM) + +checkConsumerM :: (Show b, Eq b) => ConduitT Int Void M b -> ([Int] -> M b) -> Property +checkConsumerM = checkConsumerM' runM + +checkStreamConsumerM :: (Show b, Eq b) => StreamConduitT Int o M b -> ([Int] -> M b) -> Property +checkStreamConsumerM = checkStreamConsumerM' runM + +checkConduitT :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b M () -> ([a] -> M [b]) -> Property +checkConduitT = checkConduitT' runM + +checkStreamConduitT :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduitT a b M () -> ([a] -> M [b]) -> Property +checkStreamConduitT = checkStreamConduitT' runM + +-- checkConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b M r -> ([a] -> M ([b], r)) -> Property +-- checkConduitResultM = checkConduitResultM' runM + +checkStreamConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b M r -> ([a] -> M ([b], r)) -> Property +checkStreamConduitResultM = checkStreamConduitResultM' runM + +-------------------------------------------------------------------------------- +-- Quickcheck utilities for monadic streams / conduits +-- These are polymorphic in which Monad is used. + +checkProducerM' :: (Show a, Monad m, Show b, Eq b) + => (m [a] -> b) + -> ConduitT () a m () + -> m [a] + -> Property +checkProducerM' f c l = + f (runConduit $ preventFusion c .| sinkList) + === + f l + +checkStreamProducerM' :: (Show a, Monad m, Show b, Eq b) + => (m [a] -> b) + -> StreamConduitT () a m () + -> m [a] + -> Property +checkStreamProducerM' f s l = + f (liftM fst $ evalStream $ s emptyStream) + === + f l + +checkInfiniteProducerM' :: (Show a, Monad m, Show b, Eq b) + => (m [a] -> b) + -> ConduitT () a m () + -> m [a] + -> Property +checkInfiniteProducerM' f s l = + checkProducerM' f + (preventFusion s .| take 10) + (liftM (Prelude.take 10) l) + +checkInfiniteStreamProducerM' :: (Show a, Monad m, Show b, Eq b) + => (m [a] -> b) + -> StreamConduitT () a m () + -> m [a] + -> Property +checkInfiniteStreamProducerM' f s l = + f (liftM snd $ evalStream $ takeS 10 $ s emptyStream) + === + f (liftM (Prelude.take 10) l) + +checkConsumerM' :: (Show a, Monad m, Show b, Eq b) + => (m a -> b) + -> ConduitT Int Void m a + -> ([Int] -> m a) + -> Property +checkConsumerM' f c l = forAll arbitrary $ \xs -> + f (runConduit $ yieldMany xs .| preventFusion c) + === + f (l xs) + +checkStreamConsumerM' :: (Show a, Monad m, Show b, Eq b) + => (m a -> b) + -> StreamConduitT Int o m a + -> ([Int] -> m a) + -> Property +checkStreamConsumerM' f s l = forAll (arbitrary) $ \xs -> + f (liftM snd $ evalStream $ s $ sourceListS xs emptyStream) + === + f (l xs) + +checkConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) + => (m [b] -> c) + -> ConduitT a b m () + -> ([a] -> m [b]) + -> Property +checkConduitT' f c l = forAll arbitrary $ \xs -> + f (runConduit $ yieldMany xs .| preventFusion c .| sinkList) + === + f (l xs) + +checkStreamConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) + => (m [b] -> c) + -> StreamConduit a m b + -> ([a] -> m [b]) + -> Property +checkStreamConduitT' f s l = forAll arbitrary $ \xs -> + f (liftM fst $ evalStream $ s $ sourceListS xs emptyStream) + === + f (l xs) + +-- TODO: Fixing this would allow comparing conduit sinkListrs against +-- their list versions. +-- +-- checkConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) +-- => (m ([b], r) -> c) +-- -> ConduitT a b m r +-- -> ([a] -> m ([b], r)) +-- -> Property +-- checkConduitResultM' f c l = FIXME forAll arbitrary $ \xs -> +-- f (runConduit $ yieldMany xs .| preventFusion c .| sinkList) +-- === +-- f (l xs) + +checkStreamConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) + => (m ([b], r) -> c) + -> StreamConduitT a b m r + -> ([a] -> m ([b], r)) + -> Property +checkStreamConduitResultM' f s l = forAll arbitrary $ \xs -> + f (evalStream $ s $ sourceListS xs emptyStream) + === + f (l xs) + +emptyStream :: Monad m => Stream m () () +emptyStream = Stream (\_ -> return $ Stop ()) (return ()) + +evalStream :: Monad m => Stream m o r -> m ([o], r) +evalStream (Stream step s0) = go =<< s0 + where + go s = do + res <- step s + case res of + Stop r -> return ([], r) + Skip s' -> go s' + Emit s' x -> liftM (\(l, r) -> (x:l, r)) (go s') + +-------------------------------------------------------------------------------- +-- Misc utilities + +-- Prefer this to creating an orphan instance for Data.Monoid.Sum: + +newtype Sum a = Sum a + deriving (Eq, Show, Arbitrary) + +instance Prelude.Num a => Semigroup (Sum a) where + Sum x <> Sum y = Sum $ x Prelude.+ y +instance Prelude.Num a => Monoid (Sum a) where + mempty = Sum 0 + mappend (Sum x) (Sum y) = Sum $ x Prelude.+ y + +preventFusion :: a -> a +preventFusion = id +{-# INLINE [0] preventFusion #-} + +newtype M a = M (StateT Int Identity a) + deriving (Functor, Applicative, Monad) + +instance Arbitrary a => Arbitrary (M a) where + arbitrary = do + f <- arbitrary + return $ do + s <- M get + let (x, s') = f s + M (put s') + return x + +runM :: M a -> (a, Int) +runM (M m) = runIdentity $ runStateT m 0 + +-------------------------------------------------------------------------------- +-- Utilities from QuickCheck-2.7 (absent in earlier versions) + +#if !MIN_VERSION_QuickCheck(2,7,0) +getBlind :: Blind a -> a +getBlind (Blind x) = x + +-- | @Small x@: generates values of @x@ drawn from a small range. +-- The opposite of 'Large'. +newtype Small a = Small {getSmall :: a} + deriving (Prelude.Ord, Prelude.Eq, Prelude.Enum, Prelude.Show, Prelude.Num) + +instance Prelude.Integral a => Arbitrary (Small a) where + arbitrary = Prelude.fmap Small arbitrarySizedIntegral + shrink (Small x) = Prelude.map Small (shrinkIntegral x) + +(===) :: (Show a, Eq a) => a -> a -> Property +x === y = whenFail + (Prelude.fail $ Prelude.show x Prelude.++ " should match " Prelude.++ Prelude.show y) + (x Prelude.== y) +#endif diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["Data/Conduit.hs"] diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -5,70 +5,86 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.Hspec import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (getPositive) import Test.QuickCheck.Monadic (assert, monadicIO, run) +import Data.Conduit (runConduit, (.|), ConduitT, runConduitPure, runConduitRes) import qualified Data.Conduit as C import qualified Data.Conduit.Lift as C import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.List as CL import Data.Typeable (Typeable) -import Control.Exception (throw) -import Control.Monad.Trans.Resource as C (runResourceT) +import Control.Exception (throw, evaluate) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Control.Monad.State.Strict (modify) import Data.Maybe (fromMaybe,catMaybes,fromJust) import qualified Data.List as DL import qualified Data.List.Split as DLS (chunksOf) import Control.Monad.ST (runST) import Data.Monoid import qualified Data.IORef as I +import Data.Tuple (swap) import Control.Monad.Trans.Resource (allocate, resourceForkIO) import Control.Concurrent (threadDelay, killThread) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer (execWriter, tell, runWriterT) -import Control.Monad.Trans.State (evalStateT, get, put, modify) -import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Monad.Trans.State (evalStateT, get, put) import qualified Control.Monad.Writer as W -import Control.Applicative (pure, (<$>), (<*>)) +import Control.Applicative (pure, (<$>), (<*>), liftA2) import qualified Control.Monad.Catch as Catch import Data.Functor.Identity (Identity,runIdentity) import Control.Monad (forever, void) import Data.Void (Void) import qualified Control.Concurrent.MVar as M -import Control.Monad.Error (catchError, throwError, Error) +import Control.Monad.Except (catchError, throwError) import qualified Data.Map as Map import qualified Data.Conduit.Extra.ZipConduitSpec as ZipConduit import qualified Data.Conduit.StreamSpec as Stream +import qualified Spec (@=?) :: (Eq a, Show a) => a -> a -> IO () (@=?) = flip shouldBe -- Quickcheck property for testing equivalence of list processing -- functions and their conduit counterparts -equivToList :: Eq b => ([a] -> [b]) -> CI.Conduit a Identity b -> [a] -> Bool +equivToList :: Eq b => ([a] -> [b]) -> ConduitT a b Identity () -> [a] -> Bool equivToList f conduit xs = - f xs == runIdentity (CL.sourceList xs C.$$ conduit C.=$= CL.consume) + f xs == runConduitPure (CL.sourceList xs .| conduit .| CL.consume) +-- | Check that two conduits produce the same outputs and return the same result. +bisimilarTo :: (Eq a, Eq r) => ConduitT () a Identity r -> ConduitT () a Identity r -> Bool +left `bisimilarTo` right = + C.runConduitPure (toListRes left) == C.runConduitPure (toListRes right) + where + -- | Sink a conduit into a list and return it alongside the result. + -- So it is, essentially, @sinkList@ plus result. + toListRes :: Monad m => ConduitT () a m r -> ConduitT () Void m ([a], r) + toListRes cond = swap <$> C.fuseBoth cond CL.consume + main :: IO () main = hspec $ do + describe "Combinators" Spec.spec describe "data loss rules" $ do it "consumes the source to quickly" $ do - x <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do - strings <- CL.map show C.=$ CL.take 5 + x <- runConduitRes $ CL.sourceList [1..10 :: Int] .| do + strings <- CL.map show .| CL.take 5 liftIO $ putStr $ unlines strings CL.fold (+) 0 40 `shouldBe` x it "correctly consumes a chunked resource" $ do - x <- runResourceT $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) C.$$ do - strings <- CL.map show C.=$ CL.take 5 + x <- runConduitRes $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) .| do + strings <- CL.map show .| CL.take 5 liftIO $ putStr $ unlines strings CL.fold (+) 0 40 `shouldBe` x describe "filter" $ do it "even" $ do - x <- runResourceT $ CL.sourceList [1..10] C.$$ CL.filter even C.=$ CL.consume + x <- runConduitRes $ CL.sourceList [1..10] .| CL.filter even .| CL.consume x `shouldBe` filter even [1..10 :: Int] prop "concat" $ equivToList (concat :: [[Int]]->[Int]) CL.concat @@ -119,28 +135,28 @@ describe "sum" $ do it "works for 1..10" $ do - x <- runResourceT $ CL.sourceList [1..10] C.$$ CL.fold (+) (0 :: Int) + x <- runConduitRes $ CL.sourceList [1..10] .| CL.fold (+) (0 :: Int) x `shouldBe` sum [1..10] prop "is idempotent" $ \list -> - (runST $ CL.sourceList list C.$$ CL.fold (+) (0 :: Int)) + (runST $ runConduit $ CL.sourceList list .| CL.fold (+) (0 :: Int)) == sum list describe "foldMap" $ do it "sums 1..10" $ do - Sum x <- CL.sourceList [1..(10 :: Int)] C.$$ CL.foldMap Sum + Sum x <- runConduit $ CL.sourceList [1..(10 :: Int)] .| CL.foldMap Sum x `shouldBe` sum [1..10] it "preserves order" $ do - x <- CL.sourceList [[4],[2],[3],[1]] C.$$ CL.foldMap (++[(9 :: Int)]) + x <- runConduit $ CL.sourceList [[4],[2],[3],[1]] .| CL.foldMap (++[(9 :: Int)]) x `shouldBe` [4,9,2,9,3,9,1,9] describe "foldMapM" $ do it "sums 1..10" $ do - Sum x <- CL.sourceList [1..(10 :: Int)] C.$$ CL.foldMapM (return . Sum) + Sum x <- runConduit $ CL.sourceList [1..(10 :: Int)] .| CL.foldMapM (return . Sum) x `shouldBe` sum [1..10] it "preserves order" $ do - x <- CL.sourceList [[4],[2],[3],[1]] C.$$ CL.foldMapM (return . (++[(9 :: Int)])) + x <- runConduit $ CL.sourceList [[4],[2],[3],[1]] .| CL.foldMapM (return . (++[(9 :: Int)])) x `shouldBe` [4,9,2,9,3,9,1,9] describe "unfold" $ do @@ -148,7 +164,7 @@ let f 0 = Nothing f i = Just (show i, i - 1) seed = 10 :: Int - x <- CL.unfold f seed C.$$ CL.consume + x <- runConduit $ CL.unfold f seed .| CL.consume let y = DL.unfoldr f seed x `shouldBe` y @@ -157,54 +173,76 @@ let f 0 = Nothing f i = Just (show i, i - 1) seed = 10 :: Int - x <- CL.unfoldM (return . f) seed C.$$ CL.consume + x <- runConduit $ CL.unfoldM (return . f) seed .| CL.consume let y = DL.unfoldr f seed x `shouldBe` y + describe "uncons" $ do + prop "folds to list" $ \xs -> + let src = C.sealConduitT $ CL.sourceList xs in + (xs :: [Int]) == DL.unfoldr CL.uncons src + + prop "works with unfold" $ \xs -> + let src = CL.sourceList xs in + CL.unfold CL.uncons (C.sealConduitT src) `bisimilarTo` (src :: ConduitT () Int Identity ()) + + describe "unconsEither" $ do + let + eitherToMaybe :: Either l a -> Maybe a + eitherToMaybe (Left _) = Nothing + eitherToMaybe (Right a) = Just a + prop "folds outputs to list" $ \xs -> + let src = C.sealConduitT $ CL.sourceList xs in + (xs :: [Int]) == DL.unfoldr (eitherToMaybe . CL.unconsEither) src + + prop "works with unfoldEither" $ \(xs, r) -> + let src = CL.sourceList xs *> pure r in + CL.unfoldEither CL.unconsEither (C.sealConduitT src) `bisimilarTo` (src :: ConduitT () Int Identity Int) + describe "Monoid instance for Source" $ do it "mappend" $ do - x <- runResourceT $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) C.$$ CL.fold (+) 0 + x <- runConduitRes $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) .| CL.fold (+) 0 x `shouldBe` sum [1..10] it "mconcat" $ do - x <- runResourceT $ mconcat + x <- runConduitRes $ mconcat [ CL.sourceList [1..5 :: Int] , CL.sourceList [6..10] , CL.sourceList [11..20] - ] C.$$ CL.fold (+) 0 + ] .| CL.fold (+) 0 x `shouldBe` sum [1..20] describe "zipping" $ do it "zipping two small lists" $ do - res <- runResourceT $ CI.zipSources (CL.sourceList [1..10]) (CL.sourceList [11..12]) C.$$ CL.consume + res <- runConduitRes $ CI.zipSources (CL.sourceList [1..10]) (CL.sourceList [11..12]) .| CL.consume res @=? zip [1..10 :: Int] [11..12 :: Int] describe "zipping sinks" $ do it "take all" $ do - res <- runResourceT $ CL.sourceList [1..10] C.$$ CI.zipSinks CL.consume CL.consume + res <- runConduitRes $ CL.sourceList [1..10] .| CI.zipSinks CL.consume CL.consume res @=? ([1..10 :: Int], [1..10 :: Int]) it "take fewer on left" $ do - res <- runResourceT $ CL.sourceList [1..10] C.$$ CI.zipSinks (CL.take 4) CL.consume + res <- runConduitRes $ CL.sourceList [1..10] .| CI.zipSinks (CL.take 4) CL.consume res @=? ([1..4 :: Int], [1..10 :: Int]) it "take fewer on right" $ do - res <- runResourceT $ CL.sourceList [1..10] C.$$ CI.zipSinks CL.consume (CL.take 4) + res <- runConduitRes $ CL.sourceList [1..10] .| CI.zipSinks CL.consume (CL.take 4) res @=? ([1..10 :: Int], [1..4 :: Int]) describe "Monad instance for Sink" $ do it "binding" $ do - x <- runResourceT $ CL.sourceList [1..10] C.$$ do + x <- runConduitRes $ CL.sourceList [1..10] .| do _ <- CL.take 5 CL.fold (+) (0 :: Int) x `shouldBe` sum [6..10] describe "Applicative instance for Sink" $ do it "<$> and <*>" $ do - x <- runResourceT $ CL.sourceList [1..10] C.$$ + x <- runConduitRes $ CL.sourceList [1..10] .| (+) <$> pure 5 <*> CL.fold (+) (0 :: Int) x `shouldBe` sum [1..10] + 5 describe "resumable sources" $ do it "simple" $ do - (x, y, z) <- runResourceT $ do + (x, y, z) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] (src2, x) <- src1 C.$$+ CL.take 5 (src3, y) <- src2 C.$$++ CL.fold (+) 0 @@ -216,127 +254,134 @@ describe "conduits" $ do it "map, left" $ do - x <- runResourceT $ + x <- runConduitRes $ CL.sourceList [1..10] - C.$= CL.map (* 2) - C.$$ CL.fold (+) 0 + .| CL.map (* 2) + .| CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, left >+>" $ do - x <- runResourceT $ - CI.ConduitM - ((CI.unConduitM (CL.sourceList [1..10]) CI.Done - CI.>+> CI.injectLeftovers (flip CI.unConduitM CI.Done $ CL.map (* 2))) >>=) - C.$$ CL.fold (+) 0 + x <- runConduitRes $ + CI.ConduitT + ((CI.unConduitT (CL.sourceList [1..10]) CI.Done + CI.>+> CI.injectLeftovers ((\c -> c `CI.unConduitT` CI.Done) $ CL.map (* 2))) >>=) + .| CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, right" $ do - x <- runResourceT $ + x <- runConduitRes $ CL.sourceList [1..10] - C.$$ CL.map (* 2) - C.=$ CL.fold (+) 0 + .| CL.map (* 2) + .| CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] - prop "chunksOf" $ equivToList - (DLS.chunksOf 5 :: [Int]->[[Int]]) (CL.chunksOf 5) + prop "chunksOf" $ \(positive, xs) -> + let p = getPositive positive + conduit = CL.sourceList xs .| CL.chunksOf p .| CL.consume + in DLS.chunksOf p (xs :: [Int]) == runConduitPure conduit - prop "chunksOf (negative)" $ equivToList - (map (:[]) :: [Int]->[[Int]]) (CL.chunksOf (-5)) + it "chunksOf (zero)" $ + let conduit = return () .| CL.chunksOf 0 .| CL.consume + in evaluate (runConduitPure conduit) `shouldThrow` anyException + it "chunksOf (negative)" $ + let conduit = return () .| CL.chunksOf (-5) .| CL.consume + in evaluate (runConduitPure conduit) `shouldThrow` anyException + it "groupBy" $ do let input = [1::Int, 1, 2, 3, 3, 3, 4, 5, 5] - x <- runResourceT $ CL.sourceList input - C.$$ CL.groupBy (==) - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.groupBy (==) + .| CL.consume x `shouldBe` DL.groupBy (==) input it "groupBy (nondup begin/end)" $ do let input = [1::Int, 2, 3, 3, 3, 4, 5] - x <- runResourceT $ CL.sourceList input - C.$$ CL.groupBy (==) - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.groupBy (==) + .| CL.consume x `shouldBe` DL.groupBy (==) input it "groupOn1" $ do let input = [1::Int, 1, 2, 3, 3, 3, 4, 5, 5] - x <- runResourceT $ CL.sourceList input - C.$$ CL.groupOn1 id - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.groupOn1 id + .| CL.consume x `shouldBe` [(1,[1]), (2, []), (3,[3,3]), (4,[]), (5, [5])] it "groupOn1 (nondup begin/end)" $ do let input = [1::Int, 2, 3, 3, 3, 4, 5] - x <- runResourceT $ CL.sourceList input - C.$$ CL.groupOn1 id - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.groupOn1 id + .| CL.consume x `shouldBe` [(1,[]), (2, []), (3,[3,3]), (4,[]), (5, [])] it "mapMaybe" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] - x <- runResourceT $ CL.sourceList input - C.$$ CL.mapMaybe ((+2) <$>) - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.mapMaybe ((+2) <$>) + .| CL.consume x `shouldBe` [3, 4, 5] it "mapMaybeM" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] - x <- runResourceT $ CL.sourceList input - C.$$ CL.mapMaybeM (return . ((+2) <$>)) - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.mapMaybeM (return . ((+2) <$>)) + .| CL.consume x `shouldBe` [3, 4, 5] it "catMaybes" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] - x <- runResourceT $ CL.sourceList input - C.$$ CL.catMaybes - C.=$ CL.consume + x <- runConduitRes $ CL.sourceList input + .| CL.catMaybes + .| CL.consume x `shouldBe` [1, 2, 3] it "concatMap" $ do let input = [1, 11, 21] - x <- runResourceT $ CL.sourceList input - C.$$ CL.concatMap (\i -> enumFromTo i (i + 9)) - C.=$ CL.fold (+) (0 :: Int) + x <- runConduitRes $ CL.sourceList input + .| CL.concatMap (\i -> enumFromTo i (i + 9)) + .| CL.fold (+) (0 :: Int) x `shouldBe` sum [1..30] it "bind together" $ do - let conduit = CL.map (+ 5) C.=$= CL.map (* 2) - x <- runResourceT $ CL.sourceList [1..10] C.$= conduit C.$$ CL.fold (+) 0 + let conduit = CL.map (+ 5) .| CL.map (* 2) + x <- runConduitRes $ CL.sourceList [1..10] .| conduit .| CL.fold (+) 0 x `shouldBe` sum (map (* 2) $ map (+ 5) [1..10 :: Int]) #if !FAST describe "isolate" $ do it "bound to resumable source" $ do - (x, y) <- runResourceT $ do + (x, y) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] - (src2, x) <- src1 C.$= CL.isolate 5 C.$$+ CL.consume + (src2, x) <- src1 .| CL.isolate 5 C.$$+ CL.consume y <- src2 C.$$+- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [] it "bound to sink, non-resumable" $ do - (x, y) <- runResourceT $ do - CL.sourceList [1..10 :: Int] C.$$ do - x <- CL.isolate 5 C.=$ CL.consume + (x, y) <- runConduitRes $ do + CL.sourceList [1..10 :: Int] .| do + x <- CL.isolate 5 .| CL.consume y <- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [6..10] it "bound to sink, resumable" $ do - (x, y) <- runResourceT $ do + (x, y) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] - (src2, x) <- src1 C.$$+ CL.isolate 5 C.=$ CL.consume + (src2, x) <- src1 C.$$+ CL.isolate 5 .| CL.consume y <- src2 C.$$+- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [6..10] it "consumes all data" $ do - x <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do - CL.isolate 5 C.=$ CL.sinkNull + x <- runConduitRes $ CL.sourceList [1..10 :: Int] .| do + CL.isolate 5 .| CL.sinkNull CL.consume x `shouldBe` [6..10] @@ -348,9 +393,9 @@ Nothing -> return 0 Just a -> (+a) . fromMaybe 0 <$> CL.head - res <- runResourceT $ CL.sourceList [1..11 :: Int] - C.$= CL.sequence sumSink - C.$$ CL.consume + res <- runConduitRes $ CL.sourceList [1..11 :: Int] + .| CL.sequence sumSink + .| CL.consume res `shouldBe` [3, 7, 11, 15, 19, 11] it "sink with unpull behaviour" $ do @@ -360,16 +405,16 @@ Nothing -> return 0 Just a -> (+a) . fromMaybe 0 <$> CL.peek - res <- runResourceT $ CL.sourceList [1..11 :: Int] - C.$= CL.sequence sumSink - C.$$ CL.consume + res <- runConduitRes $ CL.sourceList [1..11 :: Int] + .| CL.sequence sumSink + .| CL.consume res `shouldBe` [3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 11] #endif describe "peek" $ do it "works" $ do - (a, b) <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do + (a, b) <- runConduitRes $ CL.sourceList [1..10 :: Int] .| do a <- CL.peek b <- CL.consume return (a, b) @@ -377,51 +422,52 @@ describe "unbuffering" $ do it "works" $ do - x <- runResourceT $ do + x <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] (src2, ()) <- src1 C.$$+ CL.drop 5 src2 C.$$+- CL.fold (+) 0 x `shouldBe` sum [6..10] describe "operators" $ do - it "only use =$=" $ - runIdentity + it "only use .|" $ + runConduitPure ( CL.sourceList [1..10 :: Int] - C.$$ CL.map (+ 1) - C.=$ CL.map (subtract 1) - C.=$ CL.mapM (return . (* 2)) - C.=$ CL.map (`div` 2) - C.=$ CL.fold (+) 0 + .| CL.map (+ 1) + .| CL.map (subtract 1) + .| CL.mapM (return . (* 2)) + .| CL.map (`div` 2) + .| CL.fold (+) 0 ) `shouldBe` sum [1..10] it "only use =$" $ - runIdentity + runConduitPure ( CL.sourceList [1..10 :: Int] - C.$$ CL.map (+ 1) - C.=$ CL.map (subtract 1) - C.=$ CL.map (* 2) - C.=$ CL.map (`div` 2) - C.=$ CL.fold (+) 0 + .| CL.map (+ 1) + .| CL.map (subtract 1) + .| CL.map (* 2) + .| CL.map (`div` 2) + .| CL.fold (+) 0 ) `shouldBe` sum [1..10] it "chain" $ do - x <- CL.sourceList [1..10 :: Int] - C.$= CL.map (+ 1) - C.$= CL.map (+ 1) - C.$= CL.map (+ 1) - C.$= CL.map (subtract 3) - C.$= CL.map (* 2) - C.$$ CL.map (`div` 2) - C.=$ CL.map (+ 1) - C.=$ CL.map (+ 1) - C.=$ CL.map (+ 1) - C.=$ CL.map (subtract 3) - C.=$ CL.fold (+) 0 + x <- runConduit + $ CL.sourceList [1..10 :: Int] + .| CL.map (+ 1) + .| CL.map (+ 1) + .| CL.map (+ 1) + .| CL.map (subtract 3) + .| CL.map (* 2) + .| CL.map (`div` 2) + .| CL.map (+ 1) + .| CL.map (+ 1) + .| CL.map (+ 1) + .| CL.map (subtract 3) + .| CL.fold (+) 0 x `shouldBe` sum [1..10] describe "termination" $ do it "terminates early" $ do let src = forever $ C.yield () - x <- src C.$$ CL.head + x <- runConduit $ src .| CL.head x `shouldBe` Just () it "bracket" $ do ref <- I.newIORef (0 :: Int) @@ -429,7 +475,7 @@ (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) - val <- C.runResourceT $ src C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 + val <- runConduitRes $ src .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 3 @@ -440,7 +486,7 @@ (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) src' = CL.sourceList $ repeat 1 - val <- C.runResourceT $ (src' >> src) C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 + val <- runConduitRes $ (src' >> src) .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 0 @@ -450,7 +496,7 @@ (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) - val <- C.runResourceT $ src C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 + val <- runConduitRes $ src .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 3 @@ -461,7 +507,7 @@ (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) src' = CL.sourceList $ repeat 1 - val <- C.runResourceT $ (src' >> src) C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 + val <- runConduitRes $ (src' >> src) .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 0 @@ -471,20 +517,20 @@ ref <- I.newIORef [] let add x = I.modifyIORef ref (x:) adder' = CI.NeedInput (\a -> liftIO (add a) >> adder') return - adder = CI.ConduitM (adder' >>=) - residue x = CI.ConduitM $ \rest -> CI.Leftover (rest ()) x + adder = CI.ConduitT (adder' >>=) + residue x = CI.ConduitT $ \rest -> CI.Leftover (rest ()) x - _ <- C.yield 1 C.$$ adder + _ <- runConduit $ C.yield 1 .| adder x <- I.readIORef ref x `shouldBe` [1 :: Int] I.writeIORef ref [] - _ <- C.yield 1 C.$$ (residue 2 >> residue 3) >> adder + _ <- runConduit $ C.yield 1 .| ((residue 2 >> residue 3) >> adder) y <- I.readIORef ref y `shouldBe` [1, 2, 3] I.writeIORef ref [] - _ <- C.yield 1 C.$$ residue 2 >> (residue 3 >> adder) + _ <- runConduit $ C.yield 1 .| (residue 2 >> (residue 3 >> adder)) z <- I.readIORef ref z `shouldBe` [1, 2, 3] I.writeIORef ref [] @@ -494,18 +540,12 @@ let is = [1..10] ++ undefined src [] = return () src (x:xs) = C.yield x >> src xs - x <- src is C.$$ CL.take 10 + x <- runConduit $ src is .| CL.take 10 x `shouldBe` [1..10 :: Int] it' "yield terminates (2)" $ do let is = [1..10] ++ undefined - x <- mapM_ C.yield is C.$$ CL.take 10 + x <- runConduit $ mapM_ C.yield is .| CL.take 10 x `shouldBe` [1..10 :: Int] - it' "yieldOr finalizer called" $ do - iref <- I.newIORef (0 :: Int) - let src = mapM_ (\i -> C.yieldOr i $ I.writeIORef iref i) [1..] - src C.$$ CL.isolate 10 C.=$ CL.sinkNull - x <- I.readIORef iref - x `shouldBe` 10 describe "upstream results" $ do it' "works" $ do @@ -518,17 +558,17 @@ describe "input/output mapping" $ do it' "mapOutput" $ do - x <- C.mapOutput (+ 1) (CL.sourceList [1..10 :: Int]) C.$$ CL.fold (+) 0 + x <- runConduit $ C.mapOutput (+ 1) (CL.sourceList [1..10 :: Int]) .| CL.fold (+) 0 x `shouldBe` sum [2..11] it' "mapOutputMaybe" $ do - x <- C.mapOutputMaybe (\i -> if even i then Just i else Nothing) (CL.sourceList [1..10 :: Int]) C.$$ CL.fold (+) 0 + x <- runConduit $ C.mapOutputMaybe (\i -> if even i then Just i else Nothing) (CL.sourceList [1..10 :: Int]) .| CL.fold (+) 0 x `shouldBe` sum [2, 4..10] it' "mapInput" $ do - xyz <- (CL.sourceList $ map show [1..10 :: Int]) C.$$ do + xyz <- runConduit $ (CL.sourceList $ map show [1..10 :: Int]) .| do (x, y) <- C.mapInput read (Just . show) $ ((do - x <- CL.isolate 5 C.=$ CL.fold (+) 0 + x <- CL.isolate 5 .| CL.fold (+) 0 y <- CL.peek - return (x :: Int, y :: Maybe Int)) :: C.Sink Int IO (Int, Maybe Int)) + return (x :: Int, y :: Maybe Int)) :: ConduitT Int Void IO (Int, Maybe Int)) z <- CL.consume return (x, y, concat z) @@ -536,12 +576,12 @@ describe "left/right identity" $ do it' "left identity" $ do - x <- CL.sourceList [1..10 :: Int] C.$$ CI.ConduitM (CI.idP >>=) C.=$ CL.fold (+) 0 - y <- CL.sourceList [1..10 :: Int] C.$$ CL.fold (+) 0 + x <- runConduit $ CL.sourceList [1..10 :: Int] .| CI.ConduitT (CI.idP >>=) .| CL.fold (+) 0 + y <- runConduit $ CL.sourceList [1..10 :: Int] .| CL.fold (+) 0 x `shouldBe` y it' "right identity" $ do - x <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ flip CI.unConduitM CI.Done $ CL.fold (+) 0) CI.>+> CI.idP - y <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ flip CI.unConduitM CI.Done $ CL.fold (+) 0) + x <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ (\c -> c `CI.unConduitT` CI.Done) $ CL.fold (+) 0) CI.>+> CI.idP + y <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ (\c -> c `CI.unConduitT` CI.Done) $ CL.fold (+) 0) x `shouldBe` y describe "generalizing" $ do @@ -570,122 +610,32 @@ describe "iterate" $ do it' "works" $ do - res <- CL.iterate (+ 1) (1 :: Int) C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 + res <- runConduit $ CL.iterate (+ 1) (1 :: Int) .| CL.isolate 10 .| CL.fold (+) 0 res `shouldBe` sum [1..10] prop "replicate" $ \cnt' -> do let cnt = min cnt' 100 - res <- CL.replicate cnt () C.$$ CL.consume + res <- runConduit $ CL.replicate cnt () .| CL.consume res `shouldBe` replicate cnt () prop "replicateM" $ \cnt' -> do ref <- I.newIORef 0 let cnt = min cnt' 100 - res <- CL.replicateM cnt (I.modifyIORef ref (+ 1)) C.$$ CL.consume + res <- runConduit $ CL.replicateM cnt (I.modifyIORef ref (+ 1)) .| CL.consume res `shouldBe` replicate cnt () ref' <- I.readIORef ref ref' `shouldBe` (if cnt' <= 0 then 0 else cnt) - describe "unwrapResumable" $ do - it' "works" $ do - ref <- I.newIORef (0 :: Int) - let src0 = do - C.yieldOr () $ I.writeIORef ref 1 - C.yieldOr () $ I.writeIORef ref 2 - C.yieldOr () $ I.writeIORef ref 3 - (rsrc0, Just ()) <- src0 C.$$+ CL.head - - x0 <- I.readIORef ref - x0 `shouldBe` 0 - - (_, final) <- C.unwrapResumable rsrc0 - - x1 <- I.readIORef ref - x1 `shouldBe` 0 - - final - - x2 <- I.readIORef ref - x2 `shouldBe` 1 - - it' "isn't called twice" $ do - ref <- I.newIORef (0 :: Int) - let src0 = do - C.yieldOr () $ I.writeIORef ref 1 - C.yieldOr () $ I.writeIORef ref 2 - (rsrc0, Just ()) <- src0 C.$$+ CL.head - - x0 <- I.readIORef ref - x0 `shouldBe` 0 - - (src1, final) <- C.unwrapResumable rsrc0 - - x1 <- I.readIORef ref - x1 `shouldBe` 0 - - Just () <- src1 C.$$ CL.head - - x2 <- I.readIORef ref - x2 `shouldBe` 2 - - final - - x3 <- I.readIORef ref - x3 `shouldBe` 2 - - it' "source isn't used" $ do - ref <- I.newIORef (0 :: Int) - let src0 = do - C.yieldOr () $ I.writeIORef ref 1 - C.yieldOr () $ I.writeIORef ref 2 - (rsrc0, Just ()) <- src0 C.$$+ CL.head - - x0 <- I.readIORef ref - x0 `shouldBe` 0 - - (src1, final) <- C.unwrapResumable rsrc0 - - x1 <- I.readIORef ref - x1 `shouldBe` 0 - - () <- src1 C.$$ return () - - x2 <- I.readIORef ref - x2 `shouldBe` 0 - - final - - x3 <- I.readIORef ref - x3 `shouldBe` 1 describe "injectLeftovers" $ do it "works" $ do let src = mapM_ CI.yield [1..10 :: Int] - conduit = CI.injectLeftovers $ flip CI.unConduitM CI.Done $ C.awaitForever $ \i -> do + conduit = CI.injectLeftovers $ (\c -> c `CI.unConduitT` CI.Done) $ C.awaitForever $ \i -> do js <- CL.take 2 mapM_ C.leftover $ reverse js C.yield i - res <- CI.ConduitM ((src CI.>+> CI.injectLeftovers conduit) >>=) C.$$ CL.consume + res <- runConduit $ CI.ConduitT ((src CI.>+> CI.injectLeftovers conduit) >>=) .| CL.consume res `shouldBe` [1..10] - describe "up-upstream finalizers" $ do - it "pipe" $ do - let p1 = CI.await >>= maybe (return ()) CI.yield - p2 = idMsg "p2-final" - p3 = idMsg "p3-final" - idMsg msg = CI.addCleanup (const $ tell [msg]) $ CI.awaitForever CI.yield - printer = CI.awaitForever $ lift . tell . return . show - src = mapM_ CI.yield [1 :: Int ..] - let run' p = execWriter $ CI.runPipe $ printer CI.<+< p CI.<+< src - run' (p1 CI.<+< (p2 CI.<+< p3)) `shouldBe` run' ((p1 CI.<+< p2) CI.<+< p3) - it "conduit" $ do - let p1 = C.await >>= maybe (return ()) C.yield - p2 = idMsg "p2-final" - p3 = idMsg "p3-final" - idMsg msg = C.addCleanup (const $ tell [msg]) $ C.awaitForever C.yield - printer = C.awaitForever $ lift . tell . return . show - src = CL.sourceList [1 :: Int ..] - let run' p = execWriter $ src C.$$ p C.=$ printer - run' ((p3 C.=$= p2) C.=$= p1) `shouldBe` run' (p3 C.=$= (p2 C.=$= p1)) describe "monad transformer laws" $ do it "transPipe" $ do let source = CL.sourceList $ replicate 10 () @@ -702,15 +652,15 @@ lift $ get >>= lift . tell' C.yield i - x <- runWriterT $ source C.$$ C.transPipe (`evalStateT` 1) replaceNum1 C.=$ CL.consume - y <- runWriterT $ source C.$$ C.transPipe (`evalStateT` 1) replaceNum2 C.=$ CL.consume + x <- runWriterT $ runConduit $ source .| C.transPipe (`evalStateT` 1) replaceNum1 .| CL.consume + y <- runWriterT $ runConduit $ source .| C.transPipe (`evalStateT` 1) replaceNum2 .| CL.consume x `shouldBe` y describe "iterM" $ do prop "behavior" $ \l -> monadicIO $ do let counter ref = CL.iterM (const $ liftIO $ M.modifyMVar_ ref (\i -> return $! i + 1)) v <- run $ do ref <- M.newMVar 0 - CL.sourceList l C.$= counter ref C.$$ CL.mapM_ (const $ return ()) + runConduit $ CL.sourceList l .| counter ref .| CL.mapM_ (const $ return ()) M.readMVar ref assert $ v == length (l :: [Int]) @@ -718,7 +668,7 @@ let runTest h = run $ do ref <- M.newMVar (0 :: Int) let f = action ref - s <- CL.sourceList (l :: [Int]) C.$= h f C.$$ CL.fold (+) 0 + s <- runConduit $ CL.sourceList (l :: [Int]) .| h f .| CL.fold (+) 0 c <- M.readMVar ref return (c, s) @@ -732,109 +682,34 @@ describe "generalizing" $ do it "works" $ do - let src :: Int -> C.Source IO Int + let src :: Int -> ConduitT () Int IO () src i = CL.sourceList [1..i] - sink :: C.Sink Int IO Int + sink :: ConduitT Int Void IO Int sink = CL.fold (+) 0 - res <- C.yield 10 C.$$ C.awaitForever (C.toProducer . src) C.=$ (C.toConsumer sink >>= C.yield) C.=$ C.await + res <- runConduit $ C.yield 10 .| C.awaitForever (C.toProducer . src) .| (C.toConsumer sink >>= C.yield) .| C.await res `shouldBe` Just (sum [1..10]) describe "mergeSource" $ do it "works" $ do - let src :: C.Source IO String + let src :: ConduitT () String IO () src = CL.sourceList ["A", "B", "C"] - withIndex :: C.Conduit String IO (Integer, String) + withIndex :: ConduitT String (Integer, String) IO () withIndex = CI.mergeSource (CL.sourceList [1..]) - output <- src C.$= withIndex C.$$ CL.consume + output <- runConduit $ src .| withIndex .| CL.consume output `shouldBe` [(1, "A"), (2, "B"), (3, "C")] it "does stop processing when the source exhausted" $ do - let src :: C.Source IO Integer + let src :: ConduitT () Integer IO () src = CL.sourceList [1..] - withShortAlphaIndex :: C.Conduit Integer IO (String, Integer) + withShortAlphaIndex :: ConduitT Integer (String, Integer) IO () withShortAlphaIndex = CI.mergeSource (CL.sourceList ["A", "B", "C"]) - output <- src C.$= withShortAlphaIndex C.$$ CL.consume - output `shouldBe` [("A", 1), ("B", 2), ("C", 3)] - - let modFlag ref cur next = do - prev <- I.atomicModifyIORef ref $ (,) next - prev `shouldBe` cur - flagShouldBe ref expect = do - cur <- I.readIORef ref - cur `shouldBe` expect - it "properly run the finalizer - When the main Conduit is fully consumed" $ do - called <- I.newIORef ("RawC" :: String) - let src :: MonadIO m => C.Source m String - src = CL.sourceList ["A", "B", "C"] - withIndex :: MonadIO m => C.Conduit String m (Integer, String) - withIndex = C.addCleanup (\f -> liftIO $ modFlag called "AllocC-3" ("FinalC:" ++ show f)) . CI.mergeSource $ do - liftIO $ modFlag called "RawC" "AllocC-1" - C.yield 1 - liftIO $ modFlag called "AllocC-1" "AllocC-2" - C.yield 2 - liftIO $ modFlag called "AllocC-2" "AllocC-3" - C.yield 3 - liftIO $ modFlag called "AllocC-3" "AllocC-4" - C.yield 4 - output <- src C.$= withIndex C.$$ CL.consume - output `shouldBe` [(1, "A"), (2, "B"), (3, "C")] - called `flagShouldBe` "FinalC:True" - it "properly run the finalizer - When the branch Source is fully consumed" $ do - called <- I.newIORef ("RawS" :: String) - let src :: MonadIO m => C.Source m Integer - src = CL.sourceList [1..] - withIndex :: MonadIO m => C.Conduit Integer m (String, Integer) - withIndex = C.addCleanup (\f -> liftIO $ modFlag called "AllocS-C" ("FinalS:" ++ show f)) . CI.mergeSource $ do - liftIO $ modFlag called "RawS" "AllocS-A" - C.yield "A" - liftIO $ modFlag called "AllocS-A" "AllocS-B" - C.yield "B" - liftIO $ modFlag called "AllocS-B" "AllocS-C" - C.yield "C" - output <- src C.$= withIndex C.$$ CL.consume + output <- runConduit $ src .| withShortAlphaIndex .| CL.consume output `shouldBe` [("A", 1), ("B", 2), ("C", 3)] - called `flagShouldBe` "FinalS:True" - it "properly DO NOT run the finalizer - When nothing consumed" $ do - called <- I.newIORef ("Raw0" :: String) - let src :: MonadIO m => C.Source m String - src = CL.sourceList ["A", "B", "C"] - withIndex :: MonadIO m => C.Conduit String m (Integer, String) - withIndex = C.addCleanup (\f -> liftIO $ modFlag called "WONT CALLED" ("Final0:" ++ show f)) . CI.mergeSource $ do - liftIO $ modFlag called "Raw0" "Alloc0-1" - C.yield 1 - output <- src C.$= withIndex C.$$ return () - output `shouldBe` () - called `flagShouldBe` "Raw0" - it "properly run the finalizer - When only one item consumed" $ do - called <- I.newIORef ("Raw1" :: String) - let src :: MonadIO m => C.Source m Integer - src = CL.sourceList [1..] - withIndex :: MonadIO m => C.Conduit Integer m (String, Integer) - withIndex = C.addCleanup (\f -> liftIO $ modFlag called "Alloc1-A" ("Final1:" ++ show f)) . CI.mergeSource $ do - liftIO $ modFlag called "Raw1" "Alloc1-A" - C.yield "A" - liftIO $ modFlag called "Alloc1-A" "Alloc1-B" - C.yield "B" - liftIO $ modFlag called "Alloc1-B" "Alloc1-C" - C.yield "C" - output <- src C.$= withIndex C.$= CL.isolate 1 C.$$ CL.consume - output `shouldBe` [("A", 1)] - called `flagShouldBe` "Final1:False" - - it "handles finalizers" $ do - ref <- I.newIORef (0 :: Int) - let src1 = C.addCleanup - (const $ I.modifyIORef ref (+1)) - (mapM_ C.yield [1 :: Int ..]) - src2 = mapM_ C.yield ("hi" :: String) - res1 <- src1 C.$$ C.mergeSource src2 C.=$ CL.consume - res1 `shouldBe` [('h', 1), ('i', 2)] - i1 <- I.readIORef ref - i1 `shouldBe` 1 - - res2 <- src2 C.$$ C.mergeSource src1 C.=$ CL.consume - res2 `shouldBe` [(1, 'h'), (2, 'i')] - i2 <- I.readIORef ref - i2 `shouldBe` 2 + it "does not drop upstream items" $ do + let num = CL.sourceList [1 .. 10 :: Int] + let chr = CL.sourceList ['a' .. 'c'] + (output, remainder) <- runConduit $ num .| liftA2 (,) (CI.mergeSource chr .| CL.consume) CL.consume + output `shouldBe` [('a', 1), ('b', 2), ('c', 3)] + remainder `shouldBe` [4 .. 10] describe "passthroughSink" $ do it "works" $ do @@ -842,7 +717,7 @@ let sink = CL.fold (+) (0 :: Int) conduit = C.passthroughSink sink (I.writeIORef ref) input = [1..10] - output <- mapM_ C.yield input C.$$ conduit C.=$ CL.consume + output <- runConduit $ mapM_ C.yield input .| conduit .| CL.consume output `shouldBe` input x <- I.readIORef ref x `shouldBe` sum input @@ -851,7 +726,7 @@ let sink = CL.fold (+) (0 :: Int) conduit = C.passthroughSink sink (I.writeIORef ref) input = [undefined] - mapM_ C.yield input C.$$ conduit C.=$ return () + runConduit $ mapM_ C.yield input .| conduit .| return () x <- I.readIORef ref x `shouldBe` (-1) @@ -859,7 +734,7 @@ ref <- I.newIORef (-1 :: Int) let sink = CL.mapM_ (I.writeIORef ref) conduit = C.passthroughSink sink (const (return ())) - res <- mapM_ C.yield [1..] C.$$ conduit C.=$ CL.take 5 + res <- runConduit $ mapM_ C.yield [1..] .| conduit .| CL.take 5 res `shouldBe` [1..5] x <- I.readIORef ref x `shouldBe` 5 @@ -876,131 +751,32 @@ lift $ return () C.yield 3 lift $ return () - (src C.$$ CL.consume) `shouldBe` Right [1, 2, 4 :: Int] + runConduit (src .| CL.consume) `shouldBe` Right [1, 2, 4 :: Int] describe "WriterT" $ it "pass" $ let writer = W.pass $ do - W.tell [1 :: Int] - pure ((), (2:)) - in execWriter (C.runConduit writer) `shouldBe` [2, 1] - - describe "finalizers" $ do - it "promptness" $ do - imsgs <- I.newIORef [] - let add x = liftIO $ do - msgs <- I.readIORef imsgs - I.writeIORef imsgs $ msgs ++ [x] - src' = C.bracketP - (add "acquire") - (const $ add "release") - (const $ C.addCleanup (const $ add "inside") (mapM_ C.yield [1..5])) - src = do - src' C.$= CL.isolate 4 - add "computation" - sink = CL.mapM (\x -> add (show x) >> return x) C.=$ CL.consume - - res <- C.runResourceT $ src C.$$ sink - - msgs <- I.readIORef imsgs - -- FIXME this would be better msgs `shouldBe` words "acquire 1 2 3 4 inside release computation" - msgs `shouldBe` words "acquire 1 2 3 4 release inside computation" - - res `shouldBe` [1..4 :: Int] - - it "left associative" $ do - imsgs <- I.newIORef [] - let add x = liftIO $ do - msgs <- I.readIORef imsgs - I.writeIORef imsgs $ msgs ++ [x] - p1 = C.bracketP (add "start1") (const $ add "stop1") (const $ add "inside1" >> C.yield ()) - p2 = C.bracketP (add "start2") (const $ add "stop2") (const $ add "inside2" >> C.await >>= maybe (return ()) C.yield) - p3 = C.bracketP (add "start3") (const $ add "stop3") (const $ add "inside3" >> C.await) - - res <- C.runResourceT $ (p1 C.$= p2) C.$$ p3 - res `shouldBe` Just () - - msgs <- I.readIORef imsgs - msgs `shouldBe` words "start3 inside3 start2 inside2 start1 inside1 stop3 stop2 stop1" - - it "right associative" $ do - imsgs <- I.newIORef [] - let add x = liftIO $ do - msgs <- I.readIORef imsgs - I.writeIORef imsgs $ msgs ++ [x] - p1 = C.bracketP (add "start1") (const $ add "stop1") (const $ add "inside1" >> C.yield ()) - p2 = C.bracketP (add "start2") (const $ add "stop2") (const $ add "inside2" >> C.await >>= maybe (return ()) C.yield) - p3 = C.bracketP (add "start3") (const $ add "stop3") (const $ add "inside3" >> C.await) - - res <- C.runResourceT $ p1 C.$$ (p2 C.=$ p3) - res `shouldBe` Just () - - msgs <- I.readIORef imsgs - msgs `shouldBe` words "start3 inside3 start2 inside2 start1 inside1 stop3 stop2 stop1" - - describe "dan burton's associative tests" $ do - let tellLn = tell . (++ "\n") - finallyP fin = CI.addCleanup (const fin) - printer = CI.awaitForever $ lift . tellLn . show - idMsg msg = finallyP (tellLn msg) CI.idP - takeP 0 = return () - takeP n = CI.awaitE >>= \ex -> case ex of - Left _u -> return () - Right i -> CI.yield i >> takeP (pred n) - - testPipe p = execWriter $ runPipe $ printer <+< p <+< CI.sourceList ([1..] :: [Int]) - - p1 = takeP (1 :: Int) - p2 = idMsg "foo" - p3 = idMsg "bar" - - (<+<) = (CI.<+<) - runPipe = CI.runPipe - - test1L = testPipe $ (p1 <+< p2) <+< p3 - test1R = testPipe $ p1 <+< (p2 <+< p3) - - _test2L = testPipe $ (p2 <+< p1) <+< p3 - _test2R = testPipe $ p2 <+< (p1 <+< p3) - - test3L = testPipe $ (p2 <+< p3) <+< p1 - test3R = testPipe $ p2 <+< (p3 <+< p1) - - verify testL testR p1' p2' p3' - | testL == testR = return () :: IO () - | otherwise = error $ unlines - [ "FAILURE" - , "" - , "(" ++ p1' ++ " <+< " ++ p2' ++ ") <+< " ++ p3' - , "------------------" - , testL - , "" - , p1' ++ " <+< (" ++ p2' ++ " <+< " ++ p3' ++ ")" - , "------------------" - , testR - ] - - it "test1" $ verify test1L test1R "p1" "p2" "p3" - -- FIXME this is broken it "test2" $ verify test2L test2R "p2" "p1" "p3" - it "test3" $ verify test3L test3R "p2" "p3" "p1" + W.tell [1 :: Int] + pure ((), (2:)) + in execWriter (runConduit writer) `shouldBe` [2, 1] describe "Data.Conduit.Lift" $ do it "execStateC" $ do let sink = C.execStateLC 0 $ CL.mapM_ $ modify . (+) src = mapM_ C.yield [1..10 :: Int] - res <- src C.$$ sink + res <- runConduit $ src .| sink res `shouldBe` sum [1..10] it "execWriterC" $ do let sink = C.execWriterLC $ CL.mapM_ $ tell . return src = mapM_ C.yield [1..10 :: Int] - res <- src C.$$ sink + res <- runConduit $ src .| sink res `shouldBe` [1..10] - it "runErrorC" $ do - let sink = C.runErrorC $ do - x <- C.catchErrorC (lift $ throwError "foo") return + it "runExceptC" $ do + let sink = C.runExceptC $ do + x <- C.catchExceptC (lift $ throwError "foo") return return $ x ++ "bar" - res <- return () C.$$ sink + res <- runConduit $ return () .| sink res `shouldBe` Right ("foobar" :: String) it "runMaybeC" $ do @@ -1009,7 +785,7 @@ () <- lift $ MaybeT $ return Nothing C.yield 2 sink = CL.consume - res <- src C.$$ sink + res <- runConduit $ src .| sink res `shouldBe` [1 :: Int] describe "sequenceSources" $ do @@ -1022,7 +798,7 @@ , (2, src2) , (3, src3) ] - res <- srcs C.$$ CL.consume + res <- runConduit $ srcs .| CL.consume res `shouldBe` [ Map.fromList [(1, 1), (2, 3), (3, 2)] , Map.fromList [(1, 2), (2, 2), (3, 2)] @@ -1030,8 +806,8 @@ ] describe "zipSink" $ do it "zip equal-sized" $ do - x <- runResourceT $ - CL.sourceList [1..100] C.$$ + x <- runConduitRes $ + CL.sourceList [1..100] .| C.sequenceSinks [ CL.fold (+) 0, (`mod` 101) <$> CL.fold (*) 1 ] x `shouldBe` [5050, 100 :: Integer] @@ -1040,16 +816,16 @@ let sink = C.getZipSink $ (*) <$> C.ZipSink (CL.fold (+) 0) <*> C.ZipSink (Data.Maybe.fromJust <$> C.await) - x <- C.runResourceT $ CL.sourceList [100,99..1] C.$$ sink + x <- runConduitRes $ CL.sourceList [100,99..1] .| sink x `shouldBe` (505000 :: Integer) describe "upstream results" $ do it "fuseBoth" $ do let upstream = do C.yield ("hello" :: String) - CL.isolate 5 C.=$= CL.fold (+) 0 + CL.isolate 5 .| CL.fold (+) 0 downstream = C.fuseBoth upstream CL.consume - res <- CL.sourceList [1..10 :: Int] C.$$ do + res <- runConduit $ CL.sourceList [1..10 :: Int] .| do (x, y) <- downstream z <- CL.consume return (x, y, z) @@ -1057,22 +833,22 @@ it "fuseBothMaybe with no result" $ do let src = mapM_ C.yield [1 :: Int ..] - sink = CL.isolate 5 C.=$= CL.fold (+) 0 - (mup, down) <- C.runConduit $ C.fuseBothMaybe src sink + sink = CL.isolate 5 .| CL.fold (+) 0 + (mup, down) <- runConduit $ C.fuseBothMaybe src sink mup `shouldBe` (Nothing :: Maybe ()) down `shouldBe` sum [1..5] it "fuseBothMaybe with result" $ do let src = mapM_ C.yield [1 :: Int .. 5] - sink = CL.isolate 6 C.=$= CL.fold (+) 0 - (mup, down) <- C.runConduit $ C.fuseBothMaybe src sink + sink = CL.isolate 6 .| CL.fold (+) 0 + (mup, down) <- runConduit $ C.fuseBothMaybe src sink mup `shouldBe` Just () down `shouldBe` sum [1..5] it "fuseBothMaybe with almost result" $ do let src = mapM_ C.yield [1 :: Int .. 5] - sink = CL.isolate 5 C.=$= CL.fold (+) 0 - (mup, down) <- C.runConduit $ C.fuseBothMaybe src sink + sink = CL.isolate 5 .| CL.fold (+) 0 + (mup, down) <- runConduit $ C.fuseBothMaybe src sink mup `shouldBe` (Nothing :: Maybe ()) down `shouldBe` sum [1..5] @@ -1083,8 +859,8 @@ () <- Catch.throwM DummyError C.yield 2 src' = do - Catch.catch src (\DummyError -> C.yield (3 :: Int)) - res <- src' C.$$ CL.consume + CI.catchC src (\DummyError -> C.yield (3 :: Int)) + res <- runConduit $ src' .| CL.consume res `shouldBe` [1, 3] describe "sourceToList" $ do @@ -1104,5 +880,4 @@ data DummyError = DummyError deriving (Show, Eq, Typeable) -instance Error DummyError instance Catch.Exception DummyError diff --git a/test/subdir/dummyfile.txt b/test/subdir/dummyfile.txt new file mode 100644 --- /dev/null +++ b/test/subdir/dummyfile.txt