conduit-1.3.1.1/benchmarks/0000755000000000000000000000000013252136110013615 5ustar0000000000000000conduit-1.3.1.1/src/0000755000000000000000000000000013252136110012267 5ustar0000000000000000conduit-1.3.1.1/src/Data/0000755000000000000000000000000013263402245013147 5ustar0000000000000000conduit-1.3.1.1/src/Data/Conduit/0000755000000000000000000000000013300752462014555 5ustar0000000000000000conduit-1.3.1.1/src/Data/Conduit/Combinators/0000755000000000000000000000000013253417150017034 5ustar0000000000000000conduit-1.3.1.1/src/Data/Conduit/Internal/0000755000000000000000000000000013356206034016331 5ustar0000000000000000conduit-1.3.1.1/src/Data/Conduit/Internal/List/0000755000000000000000000000000013252136110017234 5ustar0000000000000000conduit-1.3.1.1/src/Data/Streaming/0000755000000000000000000000000013300752462015101 5ustar0000000000000000conduit-1.3.1.1/src/System/0000755000000000000000000000000013441662516013571 5ustar0000000000000000conduit-1.3.1.1/test/0000755000000000000000000000000013276512674012502 5ustar0000000000000000conduit-1.3.1.1/test/Data/0000755000000000000000000000000013244553114013340 5ustar0000000000000000conduit-1.3.1.1/test/Data/Conduit/0000755000000000000000000000000013252136110014735 5ustar0000000000000000conduit-1.3.1.1/test/Data/Conduit/Extra/0000755000000000000000000000000013252136110016020 5ustar0000000000000000conduit-1.3.1.1/test/subdir/0000755000000000000000000000000013252136110013747 5ustar0000000000000000conduit-1.3.1.1/src/Data/Conduit.hs0000644000000000000000000000376513263402245015123 0ustar0000000000000000{-# 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 , 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) conduit-1.3.1.1/src/Data/Conduit/Combinators.hs0000644000000000000000000022665113263405440017404 0ustar0000000000000000{-# 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 , 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) -- | '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 = chunksOfE 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 conduit-1.3.1.1/src/Data/Conduit/List.hs0000644000000000000000000005730613263405440016036 0ustar0000000000000000{-# 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. -- -- 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 -> 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) -- | 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 => 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) -> 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 = 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) -> 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) -- | 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 conduit-1.3.1.1/src/Data/Conduit/Internal.hs0000644000000000000000000000134513252136110016660 0ustar0000000000000000{-# 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, mapOutput, mapOutputMaybe, transPipe, yield, yieldM) import Data.Conduit.Internal.Pipe import Data.Conduit.Internal.Fusion conduit-1.3.1.1/src/Data/Conduit/Lift.hs0000644000000000000000000003150613252136110016004 0ustar0000000000000000{-# 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 #-} conduit-1.3.1.1/src/Data/Conduit/Internal/Fusion.hs0000644000000000000000000002363713263410231020134 0ustar0000000000000000{-# 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 #-} conduit-1.3.1.1/src/Data/Conduit/Internal/List/Stream.hs0000644000000000000000000003430213252136110021025 0ustar0000000000000000{-# 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 #-} conduit-1.3.1.1/src/Data/Conduit/Combinators/Stream.hs0000644000000000000000000003427313252136110020625 0ustar0000000000000000{-# 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 #-} conduit-1.3.1.1/src/Conduit.hs0000644000000000000000000000302613252136110014231 0ustar0000000000000000{-# 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) conduit-1.3.1.1/src/Data/Conduit/Internal/Pipe.hs0000644000000000000000000004612513252136110017562 0ustar0000000000000000{-# 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 -- ** 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 #-} -- | 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) #-} -} conduit-1.3.1.1/src/Data/Conduit/Internal/Conduit.hs0000644000000000000000000013306513356206034020302 0ustar0000000000000000{-# 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 -- ** 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 , 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) 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 (<*>) #-} 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 => Source m o -> Pipe l i o u m () sourceToPipe = go . flip unConduitT 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 => Sink i m r -> Pipe l i o u m r sinkToPipe = go . injectLeftovers . flip unConduitT 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 unConduitT 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 => Source m a -> Producer m a 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 => Sink a m b -> Consumer a 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 -> E.catch (run (liftM go mp)) (return . flip unConduitT rest . 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 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 => Sink i m r -> Sink i m r' -> Sink i 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 => Source m a -> Source m b -> Source m (a, b) 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 => Source m (a -> b) -> Source m a -> Source m b 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 => Source m i -> Conduit a m (i, a) mergeSource = loop . sealConduitT where loop :: Monad m => SealedConduitT () i m () -> Conduit a m (i, a) loop src0 = await >>= maybe (return ()) go where go a = do (src1, mi) <- lift $ src0 $$++ await case mi of Nothing -> return () 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 (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 lazily as the -- underlying monad. -- -- Since 1.2.6 sourceToList :: Monad m => Source m a -> m [a] sourceToList = go . flip unConduitT 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 = ($$) -- | 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 => Conduit a m b -> ConduitM b c m r -> ConduitM 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 => ConduitM a b m () -- ^ upstream -> ConduitM b c m r -- ^ downstream -> ConduitM 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 => Consumer i 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) -- | 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 (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 () -> Sink a 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 () -> Sink a 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 () -> Conduit a m b -> 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 :: 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 => 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 -> Conduit b m c -> 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 #-} conduit-1.3.1.1/src/Data/Conduit/Combinators/Unqualified.hs0000644000000000000000000010016213252136110021627 0ustar0000000000000000{-# 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 #-} conduit-1.3.1.1/src/Data/Streaming/FileRead.hs0000644000000000000000000000166113252136110017104 0ustar0000000000000000{-# 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 conduit-1.3.1.1/src/Data/Streaming/Filesystem.hs0000644000000000000000000000576313252136110017564 0ustar0000000000000000{-# 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) conduit-1.3.1.1/src/System/Win32File.hsc0000644000000000000000000000531613441662516015777 0ustar0000000000000000{-# 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) conduit-1.3.1.1/test/main.hs0000644000000000000000000010146013252136110013741 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.Hspec import Test.Hspec.QuickCheck (prop) 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 (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 Control.Monad.Trans.Resource (allocate, resourceForkIO) import Control.Concurrent (threadDelay, killThread) 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) import qualified Control.Monad.Writer as W import Control.Applicative (pure, (<$>), (<*>)) 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.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]) -> ConduitT a b Identity () -> [a] -> Bool equivToList f conduit xs = f xs == runConduitPure (CL.sourceList xs .| conduit .| CL.consume) main :: IO () main = hspec $ do describe "Combinators" Spec.spec describe "data loss rules" $ do it "consumes the source to quickly" $ do 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 <- 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 <- 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 describe "mapFoldable" $ do prop "list" $ equivToList (concatMap (:[]) :: [Int]->[Int]) (CL.mapFoldable (:[])) let f x = if odd x then Just x else Nothing prop "Maybe" $ equivToList (catMaybes . map f :: [Int]->[Int]) (CL.mapFoldable f) prop "scan" $ equivToList (tail . scanl (+) 0 :: [Int]->[Int]) (void $ CL.scan (+) 0) -- mapFoldableM and scanlM are fully polymorphic in type of monad -- so it suffice to check only with Identity. describe "mapFoldableM" $ do prop "list" $ equivToList (concatMap (:[]) :: [Int]->[Int]) (CL.mapFoldableM (return . (:[]))) let f x = if odd x then Just x else Nothing prop "Maybe" $ equivToList (catMaybes . map f :: [Int]->[Int]) (CL.mapFoldableM (return . f)) prop "scanM" $ equivToList (tail . scanl (+) 0) (void $ CL.scanM (\a s -> return $ a + s) (0 :: Int)) describe "ResourceT" $ do it "resourceForkIO" $ do counter <- I.newIORef 0 let w = allocate (I.atomicModifyIORef counter $ \i -> (i + 1, ())) (const $ I.atomicModifyIORef counter $ \i -> (i - 1, ())) runResourceT $ do _ <- w _ <- resourceForkIO $ return () _ <- resourceForkIO $ return () sequence_ $ replicate 1000 $ do tid <- resourceForkIO $ return () liftIO $ killThread tid _ <- resourceForkIO $ return () _ <- resourceForkIO $ return () return () -- give enough of a chance to the cleanup code to finish threadDelay 1000 res <- I.readIORef counter res `shouldBe` (0 :: Int) describe "sum" $ do it "works for 1..10" $ do x <- runConduitRes $ CL.sourceList [1..10] .| CL.fold (+) (0 :: Int) x `shouldBe` sum [1..10] prop "is idempotent" $ \list -> (runST $ runConduit $ CL.sourceList list .| CL.fold (+) (0 :: Int)) == sum list describe "foldMap" $ do it "sums 1..10" $ do Sum x <- runConduit $ CL.sourceList [1..(10 :: Int)] .| CL.foldMap Sum x `shouldBe` sum [1..10] it "preserves order" $ do 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 <- runConduit $ CL.sourceList [1..(10 :: Int)] .| CL.foldMapM (return . Sum) x `shouldBe` sum [1..10] it "preserves order" $ do 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 it "works" $ do let f 0 = Nothing f i = Just (show i, i - 1) seed = 10 :: Int x <- runConduit $ CL.unfold f seed .| CL.consume let y = DL.unfoldr f seed x `shouldBe` y describe "unfoldM" $ do it "works" $ do let f 0 = Nothing f i = Just (show i, i - 1) seed = 10 :: Int x <- runConduit $ CL.unfoldM (return . f) seed .| CL.consume let y = DL.unfoldr f seed x `shouldBe` y describe "Monoid instance for Source" $ do it "mappend" $ do x <- runConduitRes $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) .| CL.fold (+) 0 x `shouldBe` sum [1..10] it "mconcat" $ do x <- runConduitRes $ mconcat [ CL.sourceList [1..5 :: Int] , CL.sourceList [6..10] , CL.sourceList [11..20] ] .| CL.fold (+) 0 x `shouldBe` sum [1..20] describe "zipping" $ do it "zipping two small lists" $ do 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 <- 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 <- 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 <- 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 <- 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 <- 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) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] (src2, x) <- src1 C.$$+ CL.take 5 (src3, y) <- src2 C.$$++ CL.fold (+) 0 z <- src3 C.$$+- CL.consume return (x, y, z) x `shouldBe` [1..5] :: IO () y `shouldBe` sum [6..10] z `shouldBe` [] describe "conduits" $ do it "map, left" $ do x <- runConduitRes $ CL.sourceList [1..10] .| CL.map (* 2) .| CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, left >+>" $ do x <- runConduitRes $ CI.ConduitT ((CI.unConduitT (CL.sourceList [1..10]) CI.Done CI.>+> CI.injectLeftovers (flip CI.unConduitT CI.Done $ CL.map (* 2))) >>=) .| CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, right" $ do x <- runConduitRes $ CL.sourceList [1..10] .| 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 (negative)" $ equivToList (map (:[]) :: [Int]->[[Int]]) (CL.chunksOf (-5)) it "groupBy" $ do let input = [1::Int, 1, 2, 3, 3, 3, 4, 5, 5] 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 <- 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 <- 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 <- 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 <- 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 <- 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 <- runConduitRes $ CL.sourceList input .| CL.catMaybes .| CL.consume x `shouldBe` [1, 2, 3] it "concatMap" $ do let input = [1, 11, 21] 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) .| 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) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] (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) <- 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) <- runConduitRes $ do let src1 = CL.sourceList [1..10 :: Int] (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 <- runConduitRes $ CL.sourceList [1..10 :: Int] .| do CL.isolate 5 .| CL.sinkNull CL.consume x `shouldBe` [6..10] describe "sequence" $ do it "simple sink" $ do let sumSink = do ma <- CL.head case ma of Nothing -> return 0 Just a -> (+a) . fromMaybe 0 <$> CL.head 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 let sumSink = do ma <- CL.head case ma of Nothing -> return 0 Just a -> (+a) . fromMaybe 0 <$> CL.peek 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) <- runConduitRes $ CL.sourceList [1..10 :: Int] .| do a <- CL.peek b <- CL.consume return (a, b) (a, b) `shouldBe` (Just 1, [1..10]) describe "unbuffering" $ do it "works" $ 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 .|" $ runConduitPure ( CL.sourceList [1..10 :: Int] .| 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 =$" $ runConduitPure ( CL.sourceList [1..10 :: Int] .| 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 <- 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 <- runConduit $ src .| CL.head x `shouldBe` Just () it "bracket" $ do ref <- I.newIORef (0 :: Int) let src = C.bracketP (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) val <- runConduitRes $ src .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 3 it "bracket skipped if not needed" $ do ref <- I.newIORef (0 :: Int) let src = C.bracketP (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) src' = CL.sourceList $ repeat 1 val <- runConduitRes $ (src' >> src) .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 0 it "bracket + toPipe" $ do ref <- I.newIORef (0 :: Int) let src = C.bracketP (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) val <- runConduitRes $ src .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 3 it "bracket skipped if not needed" $ do ref <- I.newIORef (0 :: Int) let src = C.bracketP (I.modifyIORef ref (+ 1)) (\() -> I.modifyIORef ref (+ 2)) (\() -> forever $ C.yield (1 :: Int)) src' = CL.sourceList $ repeat 1 val <- runConduitRes $ (src' >> src) .| CL.isolate 10 .| CL.fold (+) 0 val `shouldBe` 10 i <- I.readIORef ref i `shouldBe` 0 describe "invariant violations" $ do it "leftovers without input" $ do ref <- I.newIORef [] let add x = I.modifyIORef ref (x:) adder' = CI.NeedInput (\a -> liftIO (add a) >> adder') return adder = CI.ConduitT (adder' >>=) residue x = CI.ConduitT $ \rest -> CI.Leftover (rest ()) x _ <- runConduit $ C.yield 1 .| adder x <- I.readIORef ref x `shouldBe` [1 :: Int] I.writeIORef ref [] _ <- runConduit $ C.yield 1 .| ((residue 2 >> residue 3) >> adder) y <- I.readIORef ref y `shouldBe` [1, 2, 3] I.writeIORef ref [] _ <- runConduit $ C.yield 1 .| (residue 2 >> (residue 3 >> adder)) z <- I.readIORef ref z `shouldBe` [1, 2, 3] I.writeIORef ref [] describe "sane yield/await'" $ do it' "yield terminates" $ do let is = [1..10] ++ undefined src [] = return () src (x:xs) = C.yield x >> src xs x <- runConduit $ src is .| CL.take 10 x `shouldBe` [1..10 :: Int] it' "yield terminates (2)" $ do let is = [1..10] ++ undefined x <- runConduit $ mapM_ C.yield is .| CL.take 10 x `shouldBe` [1..10 :: Int] describe "upstream results" $ do it' "works" $ do let foldUp :: (b -> a -> b) -> b -> CI.Pipe l a Void u IO (u, b) foldUp f b = CI.awaitE >>= either (\u -> return (u, b)) (\a -> let b' = f b a in b' `seq` foldUp f b') passFold :: (b -> a -> b) -> b -> CI.Pipe l a a () IO b passFold f b = CI.await >>= maybe (return b) (\a -> let b' = f b a in b' `seq` CI.yield a >> passFold f b') (x, y) <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> passFold (+) 0 CI.>+> foldUp (*) 1 (x, y) `shouldBe` (sum [1..10], product [1..10]) describe "input/output mapping" $ do it' "mapOutput" $ do x <- runConduit $ C.mapOutput (+ 1) (CL.sourceList [1..10 :: Int]) .| CL.fold (+) 0 x `shouldBe` sum [2..11] it' "mapOutputMaybe" $ do 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 <- runConduit $ (CL.sourceList $ map show [1..10 :: Int]) .| do (x, y) <- C.mapInput read (Just . show) $ ((do x <- CL.isolate 5 .| CL.fold (+) 0 y <- CL.peek return (x :: Int, y :: Maybe Int)) :: ConduitT Int Void IO (Int, Maybe Int)) z <- CL.consume return (x, y, concat z) xyz `shouldBe` (sum [1..5], Just 6, "678910") describe "left/right identity" $ do it' "left identity" $ do 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.unConduitT CI.Done $ CL.fold (+) 0) CI.>+> CI.idP y <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ flip CI.unConduitT CI.Done $ CL.fold (+) 0) x `shouldBe` y describe "generalizing" $ do it' "works" $ do x <- CI.runPipe $ CI.sourceToPipe (CL.sourceList [1..10 :: Int]) CI.>+> CI.conduitToPipe (CL.map (+ 1)) CI.>+> CI.sinkToPipe (CL.fold (+) 0) x `shouldBe` sum [2..11] describe "withUpstream" $ do it' "works" $ do let src = mapM_ CI.yield [1..10 :: Int] >> return True fold f = loop where loop accum = CI.await >>= maybe (return accum) go where go a = let accum' = f accum a in accum' `seq` loop accum' sink = CI.withUpstream $ fold (+) 0 res <- CI.runPipe $ src CI.>+> sink res `shouldBe` (True, sum [1..10]) describe "iterate" $ do it' "works" $ do 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 <- runConduit $ CL.replicate cnt () .| CL.consume res `shouldBe` replicate cnt () prop "replicateM" $ \cnt' -> do ref <- I.newIORef 0 let cnt = min cnt' 100 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 "injectLeftovers" $ do it "works" $ do let src = mapM_ CI.yield [1..10 :: Int] conduit = CI.injectLeftovers $ flip CI.unConduitT CI.Done $ C.awaitForever $ \i -> do js <- CL.take 2 mapM_ C.leftover $ reverse js C.yield i res <- runConduit $ CI.ConduitT ((src CI.>+> CI.injectLeftovers conduit) >>=) .| CL.consume res `shouldBe` [1..10] describe "monad transformer laws" $ do it "transPipe" $ do let source = CL.sourceList $ replicate 10 () let tell' x = tell [x :: Int] let replaceNum1 = C.awaitForever $ \() -> do i <- lift get lift $ (put $ i + 1) >> (get >>= lift . tell') C.yield i let replaceNum2 = C.awaitForever $ \() -> do i <- lift get lift $ put $ i + 1 lift $ get >>= lift . tell' C.yield i 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 runConduit $ CL.sourceList l .| counter ref .| CL.mapM_ (const $ return ()) M.readMVar ref assert $ v == length (l :: [Int]) prop "mapM_ equivalence" $ \l -> monadicIO $ do let runTest h = run $ do ref <- M.newMVar (0 :: Int) let f = action ref s <- runConduit $ CL.sourceList (l :: [Int]) .| h f .| CL.fold (+) 0 c <- M.readMVar ref return (c, s) action ref = const $ liftIO $ M.modifyMVar_ ref (\i -> return $! i + 1) (c1, s1) <- runTest CL.iterM (c2, s2) <- runTest (\f -> CL.mapM (\a -> f a >>= \() -> return a)) assert $ c1 == c2 assert $ s1 == s2 describe "generalizing" $ do it "works" $ do let src :: Int -> ConduitT () Int IO () src i = CL.sourceList [1..i] sink :: ConduitT Int Void IO Int sink = CL.fold (+) 0 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 :: ConduitT () String IO () src = CL.sourceList ["A", "B", "C"] withIndex :: ConduitT String (Integer, String) IO () withIndex = CI.mergeSource (CL.sourceList [1..]) 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 :: ConduitT () Integer IO () src = CL.sourceList [1..] withShortAlphaIndex :: ConduitT Integer (String, Integer) IO () withShortAlphaIndex = CI.mergeSource (CL.sourceList ["A", "B", "C"]) output <- runConduit $ src .| withShortAlphaIndex .| CL.consume output `shouldBe` [("A", 1), ("B", 2), ("C", 3)] describe "passthroughSink" $ do it "works" $ do ref <- I.newIORef (-1) let sink = CL.fold (+) (0 :: Int) conduit = C.passthroughSink sink (I.writeIORef ref) input = [1..10] output <- runConduit $ mapM_ C.yield input .| conduit .| CL.consume output `shouldBe` input x <- I.readIORef ref x `shouldBe` sum input it "does nothing when downstream does nothing" $ do ref <- I.newIORef (-1) let sink = CL.fold (+) (0 :: Int) conduit = C.passthroughSink sink (I.writeIORef ref) input = [undefined] runConduit $ mapM_ C.yield input .| conduit .| return () x <- I.readIORef ref x `shouldBe` (-1) it "handles the last input correctly #304" $ do ref <- I.newIORef (-1 :: Int) let sink = CL.mapM_ (I.writeIORef ref) conduit = C.passthroughSink sink (const (return ())) res <- runConduit $ mapM_ C.yield [1..] .| conduit .| CL.take 5 res `shouldBe` [1..5] x <- I.readIORef ref x `shouldBe` 5 describe "mtl instances" $ do it "ErrorT" $ do let src = flip catchError (const $ C.yield 4) $ do lift $ return () C.yield 1 lift $ return () C.yield 2 lift $ return () () <- throwError DummyError lift $ return () C.yield 3 lift $ return () 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 (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 <- 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 <- runConduit $ src .| sink res `shouldBe` [1..10] it "runExceptC" $ do let sink = C.runExceptC $ do x <- C.catchExceptC (lift $ throwError "foo") return return $ x ++ "bar" res <- runConduit $ return () .| sink res `shouldBe` Right ("foobar" :: String) it "runMaybeC" $ do let src = void $ C.runMaybeC $ do C.yield 1 () <- lift $ MaybeT $ return Nothing C.yield 2 sink = CL.consume res <- runConduit $ src .| sink res `shouldBe` [1 :: Int] describe "sequenceSources" $ do it "works" $ do let src1 = mapM_ C.yield [1, 2, 3 :: Int] src2 = mapM_ C.yield [3, 2, 1] src3 = mapM_ C.yield $ repeat 2 srcs = C.sequenceSources $ Map.fromList [ (1 :: Int, src1) , (2, src2) , (3, src3) ] res <- runConduit $ srcs .| CL.consume res `shouldBe` [ Map.fromList [(1, 1), (2, 3), (3, 2)] , Map.fromList [(1, 2), (2, 2), (3, 2)] , Map.fromList [(1, 3), (2, 1), (3, 2)] ] describe "zipSink" $ do it "zip equal-sized" $ do x <- runConduitRes $ CL.sourceList [1..100] .| C.sequenceSinks [ CL.fold (+) 0, (`mod` 101) <$> CL.fold (*) 1 ] x `shouldBe` [5050, 100 :: Integer] it "zip distinct sizes" $ do let sink = C.getZipSink $ (*) <$> C.ZipSink (CL.fold (+) 0) <*> C.ZipSink (Data.Maybe.fromJust <$> C.await) 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 .| CL.fold (+) 0 downstream = C.fuseBoth upstream CL.consume res <- runConduit $ CL.sourceList [1..10 :: Int] .| do (x, y) <- downstream z <- CL.consume return (x, y, z) res `shouldBe` (sum [1..5], ["hello"], [6..10]) it "fuseBothMaybe with no result" $ do let src = mapM_ C.yield [1 :: Int ..] 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 .| 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 .| CL.fold (+) 0 (mup, down) <- runConduit $ C.fuseBothMaybe src sink mup `shouldBe` (Nothing :: Maybe ()) down `shouldBe` sum [1..5] describe "catching exceptions" $ do it "works" $ do let src = do C.yield 1 () <- Catch.throwM DummyError C.yield 2 src' = do CI.catchC src (\DummyError -> C.yield (3 :: Int)) res <- runConduit $ src' .| CL.consume res `shouldBe` [1, 3] describe "sourceToList" $ do it "works lazily in Identity" $ do let src = C.yield 1 >> C.yield 2 >> throw DummyError let res = runIdentity $ C.sourceToList src take 2 res `shouldBe` [1, 2 :: Int] it "is not lazy in IO" $ do let src = C.yield 1 >> C.yield (2 :: Int) >> throw DummyError C.sourceToList src `shouldThrow` (==DummyError) ZipConduit.spec Stream.spec it' :: String -> IO () -> Spec it' = it data DummyError = DummyError deriving (Show, Eq, Typeable) instance Catch.Exception DummyError conduit-1.3.1.1/test/Data/Conduit/Extra/ZipConduitSpec.hs0000644000000000000000000000254513252136110021265 0ustar0000000000000000module Data.Conduit.Extra.ZipConduitSpec (spec) where import Test.Hspec import Data.Conduit import qualified Data.Conduit.List as CL import Control.Applicative ((<*), pure) spec :: Spec spec = describe "Data.Conduit.Extra.ZipConduit" $ do it "ZipConduit" $ 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.consume 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] conduit1 = CL.map (+1) conduit2 = CL.concatMap (replicate 2) conduit = do x <- sequenceConduits [conduit1, conduit2] yield $ length x + 10 sink = CL.consume 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] conduit1 = CL.mapM (pure . (+1)) conduit2 = CL.map id conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 sink = CL.consume res <- runConduit $ src .| conduit .| sink res `shouldBe` [2, 1, 3, 2, 4, 3] conduit-1.3.1.1/test/Data/Conduit/StreamSpec.hs0000644000000000000000000005332213252136110017344 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Data.Conduit.StreamSpec where import Control.Applicative import qualified Control.Monad import Control.Monad (MonadPlus(..), liftM) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.State (StateT(..), get, put) import Data.Conduit import Data.Conduit.Internal.Fusion import Data.Conduit.Internal.List.Stream import Data.Conduit.List import qualified Data.Foldable as F import Data.Function (on) import qualified Data.List import qualified Data.Maybe import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Prelude ((.), ($), (>>=), (=<<), return, (==), Int, id, Maybe(..), Monad, Eq, Show, String, Functor, fst, snd) import qualified Prelude import qualified Safe import Test.Hspec import Test.QuickCheck spec :: Spec spec = describe "Comparing list function to" $ do qit "unfold" $ \(getBlind -> f, initial :: Int) -> unfold f initial `checkInfiniteProducer` (Data.List.unfoldr f initial :: [Int]) qit "unfoldS" $ \(getBlind -> f, initial :: Int) -> unfoldS f initial `checkInfiniteStreamProducer` (Data.List.unfoldr f initial :: [Int]) qit "unfoldM" $ \(getBlind -> f, initial :: Int) -> unfoldM f initial `checkInfiniteProducerM` (unfoldrM f initial :: M [Int]) qit "unfoldMS" $ \(getBlind -> f, initial :: Int) -> unfoldMS f initial `checkInfiniteStreamProducerM` (unfoldrM f initial :: M [Int]) qit "sourceList" $ \(xs :: [Int]) -> sourceList xs `checkProducer` xs qit "sourceListS" $ \(xs :: [Int]) -> sourceListS xs `checkStreamProducer` xs qit "enumFromTo" $ \(fr :: Small Int, to :: Small Int) -> enumFromTo fr to `checkProducer` Prelude.enumFromTo fr to qit "enumFromToS" $ \(fr :: Small Int, to :: Small Int) -> enumFromToS fr to `checkStreamProducer` Prelude.enumFromTo fr to qit "enumFromToS_int" $ \(getSmall -> fr :: Int, getSmall -> to :: Int) -> enumFromToS_int fr to `checkStreamProducer` Prelude.enumFromTo fr to qit "iterate" $ \(getBlind -> f, initial :: Int) -> iterate f initial `checkInfiniteProducer` Prelude.iterate f initial qit "iterateS" $ \(getBlind -> f, initial :: Int) -> iterateS f initial `checkInfiniteStreamProducer` Prelude.iterate f initial qit "replicate" $ \(getSmall -> n, getSmall -> x) -> replicate n x `checkProducer` (Prelude.replicate n x :: [Int]) qit "replicateS" $ \(getSmall -> n, getSmall -> x) -> replicateS n x `checkStreamProducer` (Prelude.replicate n x :: [Int]) qit "replicateM" $ \(getSmall -> n, getBlind -> f) -> replicateM n f `checkProducerM` (Control.Monad.replicateM n f :: M [Int]) qit "replicateMS" $ \(getSmall -> n, getBlind -> f) -> replicateMS n f `checkStreamProducerM` (Control.Monad.replicateM n f :: M [Int]) qit "fold" $ \(getBlind -> f, initial :: Int) -> fold f initial `checkConsumer` Data.List.foldl' f initial qit "foldS" $ \(getBlind -> f, initial :: Int) -> foldS f initial `checkStreamConsumer` Data.List.foldl' f initial qit "foldM" $ \(getBlind -> f, initial :: Int) -> foldM f initial `checkConsumerM` (Control.Monad.foldM f initial :: [Int] -> M Int) qit "foldMS" $ \(getBlind -> f, initial :: Int) -> foldMS f initial `checkStreamConsumerM` (Control.Monad.foldM f initial :: [Int] -> M Int) qit "foldMap" $ \(getBlind -> (f :: Int -> Sum Int)) -> foldMap f `checkConsumer` F.foldMap f qit "mapM_" $ \(getBlind -> (f :: Int -> M ())) -> mapM_ f `checkConsumerM` Prelude.mapM_ f qit "mapM_S" $ \(getBlind -> (f :: Int -> M ())) -> mapM_S f `checkStreamConsumerM` Prelude.mapM_ f qit "take" $ \(getSmall -> n) -> take n `checkConsumer` Prelude.take n qit "takeS" $ \(getSmall -> n) -> takeS n `checkStreamConsumer` Prelude.take n qit "head" $ \() -> head `checkConsumer` Safe.headMay qit "headS" $ \() -> headS `checkStreamConsumer` Safe.headMay qit "peek" $ \() -> peek `checkConsumer` Safe.headMay qit "map" $ \(getBlind -> (f :: Int -> Int)) -> map f `checkConduit` Prelude.map f qit "mapS" $ \(getBlind -> (f :: Int -> Int)) -> mapS f `checkStreamConduit` Prelude.map f qit "mapM" $ \(getBlind -> (f :: Int -> M Int)) -> mapM f `checkConduitT` Prelude.mapM f qit "mapMS" $ \(getBlind -> (f :: Int -> M Int)) -> mapMS f `checkStreamConduitT` Prelude.mapM f qit "iterM" $ \(getBlind -> (f :: Int -> M ())) -> iterM f `checkConduitT` iterML f qit "iterMS" $ \(getBlind -> (f :: Int -> M ())) -> iterMS f `checkStreamConduitT` iterML f qit "mapMaybe" $ \(getBlind -> (f :: Int -> Maybe Int)) -> mapMaybe f `checkConduit` Data.Maybe.mapMaybe f qit "mapMaybeS" $ \(getBlind -> (f :: Int -> Maybe Int)) -> mapMaybeS f `checkStreamConduit` Data.Maybe.mapMaybe f qit "mapMaybeM" $ \(getBlind -> (f :: Int -> M (Maybe Int))) -> mapMaybeM f `checkConduitT` mapMaybeML f qit "mapMaybeMS" $ \(getBlind -> (f :: Int -> M (Maybe Int))) -> mapMaybeMS f `checkStreamConduitT` mapMaybeML f qit "catMaybes" $ \() -> catMaybes `checkConduit` (Data.Maybe.catMaybes :: [Maybe Int] -> [Int]) qit "catMaybesS" $ \() -> catMaybesS `checkStreamConduit` (Data.Maybe.catMaybes :: [Maybe Int] -> [Int]) qit "concat" $ \() -> concat `checkConduit` (Prelude.concat :: [[Int]] -> [Int]) qit "concatS" $ \() -> concatS `checkStreamConduit` (Prelude.concat :: [[Int]] -> [Int]) qit "concatMap" $ \(getBlind -> f) -> concatMap f `checkConduit` (Prelude.concatMap f :: [Int] -> [Int]) qit "concatMapS" $ \(getBlind -> f) -> concatMapS f `checkStreamConduit` (Prelude.concatMap f :: [Int] -> [Int]) qit "concatMapM" $ \(getBlind -> (f :: Int -> M [Int])) -> concatMapM f `checkConduitT` concatMapML f qit "concatMapMS" $ \(getBlind -> (f :: Int -> M [Int])) -> concatMapMS f `checkStreamConduitT` concatMapML f qit "concatMapAccum" $ \(getBlind -> (f :: Int -> Int -> (Int, [Int])), initial :: Int) -> concatMapAccum f initial `checkConduit` concatMapAccumL f initial qit "concatMapAccumS" $ \(getBlind -> (f :: Int -> Int -> (Int, [Int])), initial :: Int) -> concatMapAccumS f initial `checkStreamConduit` concatMapAccumL f initial {-qit "mapAccum" $ \(getBlind -> (f :: Int -> Int -> (Int, [Int])), initial :: Int) -> mapAccum f initial `checkConduitResult` mapAccumL f initial-} qit "mapAccumS" $ \(getBlind -> (f :: Int -> Int -> (Int, [Int])), initial :: Int) -> mapAccumS f initial `checkStreamConduitResult` mapAccumL f initial {-qit "mapAccumM" $ \(getBlind -> (f :: Int -> Int -> M (Int, [Int])), initial :: Int) -> mapAccumM f initial `checkConduitResultM` mapAccumML f initial-} qit "mapAccumMS" $ \(getBlind -> (f :: Int -> Int -> M (Int, [Int])), initial :: Int) -> mapAccumMS f initial `checkStreamConduitResultM` mapAccumML f initial {-qit "scan" $ \(getBlind -> (f :: Int -> Int -> Int), initial :: Int) -> scan f initial `checkConduitResult` scanL f initial-} {-qit "scanM" $ \(getBlind -> (f :: Int -> Int -> M Int), initial :: Int) -> scanM f initial `checkConduitResultM` scanML f initial-} qit "mapFoldable" $ \(getBlind -> (f :: Int -> [Int])) -> mapFoldable f `checkConduit` mapFoldableL f qit "mapFoldableS" $ \(getBlind -> (f :: Int -> [Int])) -> mapFoldableS f `checkStreamConduit` mapFoldableL f qit "mapFoldableM" $ \(getBlind -> (f :: Int -> M [Int])) -> mapFoldableM f `checkConduitT` mapFoldableML f qit "mapFoldableMS" $ \(getBlind -> (f :: Int -> M [Int])) -> mapFoldableMS f `checkStreamConduitT` mapFoldableML f qit "consume" $ \() -> consume `checkConsumer` id qit "consumeS" $ \() -> consumeS `checkStreamConsumer` id qit "groupBy" $ \(getBlind -> f) -> groupBy f `checkConduit` (Data.List.groupBy f :: [Int] -> [[Int]]) qit "groupByS" $ \(getBlind -> f) -> groupByS f `checkStreamConduit` (Data.List.groupBy f :: [Int] -> [[Int]]) qit "groupOn1" $ \(getBlind -> (f :: Int -> Int)) -> groupOn1 f `checkConduit` groupOn1L f qit "groupOn1S" $ \(getBlind -> (f :: Int -> Int)) -> groupOn1S f `checkStreamConduit` groupOn1L f qit "isolate" $ \n -> isolate n `checkConduit` (Data.List.take n :: [Int] -> [Int]) qit "isolateS" $ \n -> isolateS n `checkStreamConduit` (Data.List.take n :: [Int] -> [Int]) qit "filter" $ \(getBlind -> f) -> filter f `checkConduit` (Data.List.filter f :: [Int] -> [Int]) qit "filterS" $ \(getBlind -> f) -> filterS f `checkStreamConduit` (Data.List.filter f :: [Int] -> [Int]) qit "sourceNull" $ \() -> sourceNull `checkProducer` ([] :: [Int]) qit "sourceNullS" $ \() -> sourceNullS `checkStreamProducer` ([] :: [Int]) 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) => StreamConduitT () a Identity () -> [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) => StreamConduitT () a Identity () -> [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) => StreamConsumer Int 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) => 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) => 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) => StreamConsumer Int 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) => StreamConduit a M b -> ([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 .| consume)) === f l checkStreamProducerM' :: (Show a, Monad m, Show b, Eq b) => (m [a] -> b) -> StreamSource m a -> 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 .| isolate 10) (liftM (Prelude.take 10) l) checkInfiniteStreamProducerM' :: (Show a, Monad m, Show b, Eq b) => (m [a] -> b) -> StreamSource m a -> 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 (sourceList xs .| preventFusion c)) === f (l xs) checkStreamConsumerM' :: (Show a, Monad m, Show b, Eq b) => (m a -> b) -> StreamConsumer Int 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 (sourceList xs .| preventFusion c .| consume)) === 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 consumers 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 (sourceList xs .| preventFusion c $$ consume) -- === -- 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 #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif 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 -------------------------------------------------------------------------------- -- List versions of some functions iterML :: Monad m => (a -> m ()) -> [a] -> m [a] iterML f = Prelude.mapM (\a -> f a >>= \() -> return a) mapMaybeML :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeML f = liftM Data.Maybe.catMaybes . Prelude.mapM f concatMapML :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapML f = liftM Prelude.concat . Prelude.mapM f concatMapAccumL :: (a -> s -> (s, [b])) -> s -> [a] -> [b] concatMapAccumL f acc0 = runIdentity . concatMapAccumML (\a acc -> return $ f a acc) acc0 mapAccumL :: (a -> s -> (s, b)) -> s -> [a] -> ([b], s) mapAccumL f acc0 = runIdentity . mapAccumML (\a acc -> return $ f a acc) acc0 concatMapAccumML :: Monad m => (a -> s -> m (s, [b])) -> s -> [a] -> m [b] concatMapAccumML f acc0 = liftM (Prelude.concat . fst) . mapAccumML f acc0 scanL :: (a -> b -> b) -> b -> [a] -> ([b], b) scanL f = mapAccumL (\a b -> let r = f a b in (r, r)) scanML :: Monad m => (a -> b -> m b) -> b -> [a] -> m ([b], b) scanML f = mapAccumML (\a b -> f a b >>= \r -> return (r, r)) mapFoldableL :: F.Foldable f => (a -> f b) -> [a] -> [b] mapFoldableL f = runIdentity . mapFoldableML (return . f) mapFoldableML :: (Monad m, F.Foldable f) => (a -> m (f b)) -> [a] -> m [b] mapFoldableML f = concatMapML (liftM F.toList . f) groupOn1L :: Eq b => (a -> b) -> [a] -> [(a, [a])] groupOn1L f = Data.List.map (\(x:xs) -> (x, xs)) . Data.List.groupBy ((==) `on` f) mapAccumML :: Monad m => (a -> s -> m (s, b)) -> s -> [a] -> m ([b], s) mapAccumML f s0 = go s0 where go s [] = return ([], s) go s (x:xs) = do (s', r) <- f x s liftM (\(l, o) -> (r:l, o)) $ go s' xs -------------------------------------------------------------------------------- -- Utilities taken from monad-loops package -- http://hackage.haskell.org/package/monad-loops -- |See 'Data.List.unfoldr'. This is a monad-friendly version of that. unfoldrM :: (Monad m) => (a -> m (Maybe (b,a))) -> a -> m [b] unfoldrM = unfoldrM' -- |See 'Data.List.unfoldr'. This is a monad-friendly version of that, with a -- twist. Rather than returning a list, it returns any MonadPlus type of your -- choice. unfoldrM' :: (Monad m, MonadPlus f) => (a -> m (Maybe (b,a))) -> a -> m (f b) unfoldrM' f = go where go z = do x <- f z case x of Nothing -> return mzero Just (x', z') -> do xs <- go z' return (return x' `mplus` xs) conduit-1.3.1.1/test/Spec.hs0000644000000000000000000007414713276512674013745 0ustar0000000000000000{-# 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 System.IO.Silently (hCapture) 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 "print" $ \vals -> do let expected = Prelude.unlines $ map showInt vals (actual, ()) <- hCapture [IO.stdout] $ runConduit $ yieldMany vals .| printC actual `shouldBe` expected #ifndef WINDOWS prop "stdout" $ \ (vals :: [String]) -> do let expected = concat vals (actual, ()) <- hCapture [IO.stdout] $ runConduit $ yieldMany (map T.pack vals) .| encodeUtf8C .| stdoutC actual `shouldBe` expected prop "stderr" $ \ (vals :: [String]) -> do let expected = concat vals (actual, ()) <- hCapture [IO.stderr] $ runConduit $ yieldMany (map T.pack vals) .| encodeUtf8C .| stderrC actual `shouldBe` expected #endif 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') conduit-1.3.1.1/test/StreamSpec.hs0000644000000000000000000004605213252137154015101 0ustar0000000000000000{-# 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 conduit-1.3.1.1/benchmarks/unfused.hs0000644000000000000000000000455013252136110015626 0ustar0000000000000000{-# LANGUAGE RankNTypes, BangPatterns #-} -- Compare low-level, fused, unfused, and partially fused import Data.Conduit import qualified Data.Conduit.List as CL import Gauge.Main -- | unfused enumFromToC :: (Eq a, Monad m, Enum a) => a -> a -> ConduitT i a m () enumFromToC x0 y = loop x0 where loop x | x == y = yield x | otherwise = yield x >> loop (succ x) {-# INLINE enumFromToC #-} -- | unfused mapC :: Monad m => (a -> b) -> ConduitT a b m () mapC f = awaitForever $ yield . f {-# INLINE mapC #-} -- | unfused foldC :: Monad m => (b -> a -> b) -> b -> ConduitT a o m b foldC f = loop where loop !b = await >>= maybe (return b) (loop . f b) {-# INLINE foldC #-} main :: IO () main = defaultMain [ bench "low level" $ flip whnf upper0 $ \upper -> let loop x t | x > upper = t | otherwise = loop (x + 1) (t + ((x * 2) + 1)) in loop 1 0 , bench "completely fused" $ flip whnf upper0 $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.map (* 2) .| CL.map (+ 1) .| CL.fold (+) 0 , bench "runConduit, completely fused" $ flip whnf upper0 $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.map (* 2) .| CL.map (+ 1) .| CL.fold (+) 0 , bench "completely unfused" $ flip whnf upper0 $ \upper -> runConduitPure $ enumFromToC 1 upper .| mapC (* 2) .| mapC (+ 1) .| foldC (+) 0 , bench "beginning fusion" $ flip whnf upper0 $ \upper -> runConduitPure $ (CL.enumFromTo 1 upper .| CL.map (* 2)) .| mapC (+ 1) .| foldC (+) 0 , bench "middle fusion" $ flip whnf upper0 $ \upper -> runConduitPure $ enumFromToC 1 upper .| (CL.map (* 2) .| CL.map (+ 1)) .| foldC (+) 0 , bench "ending fusion" $ flip whnf upper0 $ \upper -> runConduitPure $ enumFromToC 1 upper .| mapC (* 2) .| (CL.map (+ 1) .| CL.fold (+) 0) , bench "performance of CL.enumFromTo without fusion" $ flip whnf upper0 $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| mapC (* 2) .| (CL.map (+ 1) .| CL.fold (+) 0) ] where upper0 = 100000 :: Int conduit-1.3.1.1/benchmarks/optimize-201408.hs0000644000000000000000000003532513252136110016555 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} -- Collection of three benchmarks: a simple integral sum, monte carlo analysis, -- and sliding vector. import Control.DeepSeq import Control.Monad (foldM) import Control.Monad (when, liftM) import Control.Monad.IO.Class (liftIO) import Gauge.Main import Data.Conduit import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.List as CL import qualified Data.Foldable as F import Data.IORef import Data.List (foldl') import Data.Monoid (mempty) import qualified Data.Sequence as Seq import qualified Data.Vector as VB import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as VM import qualified Data.Vector.Unboxed as VU import System.Environment (withArgs) import qualified System.Random.MWC as MWC import Test.Hspec data TestBench = TBGroup String [TestBench] | TBBench Benchmark | forall a b. (Eq b, Show b) => TBPure String a b (a -> b) | forall a. (Eq a, Show a) => TBIO String a (IO a) | forall a. (Eq a, Show a) => TBIOTest String (a -> IO ()) (IO a) | forall a. (Eq a, Show a) => TBIOBench String a (IO a) (IO ()) toSpec :: TestBench -> Spec toSpec (TBGroup name tbs) = describe name $ mapM_ toSpec tbs toSpec (TBBench _) = return () toSpec (TBPure name a b f) = it name $ f a `shouldBe` b toSpec (TBIO name a f) = it name $ f >>= (`shouldBe` a) toSpec (TBIOTest name spec f) = it name $ f >>= spec toSpec (TBIOBench name a f _) = it name $ f >>= (`shouldBe` a) toBench :: TestBench -> Benchmark toBench (TBGroup name tbs) = bgroup name $ map toBench tbs toBench (TBBench b) = b toBench (TBPure name a _ f) = bench name $ whnf f a toBench (TBIO name _ f) = bench name $ whnfIO f toBench (TBIOTest name _ f) = bench name $ whnfIO f toBench (TBIOBench name _ _ f) = bench name $ whnfIO f runTestBench :: [TestBench] -> IO () runTestBench tbs = do withArgs [] $ hspec $ mapM_ toSpec tbs defaultMain $ map toBench tbs main :: IO () main = runTestBench =<< sequence [ sumTB , mapSumTB , monteCarloTB , fmap (TBGroup "sliding window") $ sequence [ slidingWindow 10 , slidingWindow 30 , slidingWindow 100 , slidingWindow 1000 ] ] ----------------------------------------------------------------------- sumTB :: IO TestBench sumTB = do upperRef <- newIORef upper0 return $ TBGroup "sum" [ TBPure "Data.List.foldl'" upper0 expected $ \upper -> foldl' (+) 0 [1..upper] , TBIO "Control.Monad.foldM" expected $ do upper <- readIORef upperRef foldM plusM 0 [1..upper] , TBPure "low level" upper0 expected $ \upper -> let go x !t | x > upper = t | otherwise = go (x + 1) (t + x) in go 1 0 , TBIO "boxed vectors, I/O" expected $ do upper <- readIORef upperRef VB.foldM' plusM 0 $ VB.enumFromTo 1 upper , TBPure "boxed vectors" upper0 expected $ \upper -> VB.foldl' (+) 0 (VB.enumFromTo 1 upper) , TBPure "unboxed vectors" upper0 expected $ \upper -> VU.foldl' (+) 0 (VU.enumFromTo 1 upper) , TBPure "conduit, pure, fold" upper0 expected $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.fold (+) 0 , TBPure "conduit, pure, foldM" upper0 expected $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.foldM plusM 0 , TBIO "conduit, IO, fold" expected $ do upper <- readIORef upperRef runConduit $ CL.enumFromTo 1 upper .| CL.fold (+) 0 , TBIO "conduit, IO, foldM" expected $ do upper <- readIORef upperRef runConduit $ CL.enumFromTo 1 upper .| CL.foldM plusM 0 ] where upper0 = 10000 :: Int expected = sum [1..upper0] plusM x y = return $! x + y ----------------------------------------------------------------------- mapSumTB :: IO TestBench mapSumTB = return $ TBGroup "map + sum" [ TBPure "boxed vectors" upper0 expected $ \upper -> VB.foldl' (+) 0 $ VB.map (+ 1) $ VB.map (* 2) $ VB.enumFromTo 1 upper , TBPure "unboxed vectors" upper0 expected $ \upper -> VU.foldl' (+) 0 $ VU.map (+ 1) $ VU.map (* 2) $ VU.enumFromTo 1 upper , TBPure "conduit, connect1" upper0 expected $ \upper -> runConduitPure $ CL.enumFromTo 1 upper .| CL.map (* 2) .| CL.map (+ 1) .| CL.fold (+) 0 ] where upper0 = 10000 :: Int expected = sum $ map (+ 1) $ map (* 2) [1..upper0] ----------------------------------------------------------------------- monteCarloTB :: IO TestBench monteCarloTB = return $ TBGroup "monte carlo" [ TBIOTest "conduit" closeEnough $ do gen <- MWC.createSystemRandom 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) (0 :: Int) return $ fromIntegral successes / fromIntegral count * 4 , TBIOTest "low level" closeEnough $ do gen <- MWC.createSystemRandom let go :: Int -> Int -> IO Double go 0 !t = return $! fromIntegral t / fromIntegral count * 4 go i !t = do (x, y) <- MWC.uniform gen let t' | x*x + y*(y :: Double) < 1 = t + 1 | otherwise = t go (i - 1) t' go count (0 :: Int) ] where count = 100000 :: Int closeEnough x | abs (x - 3.14159 :: Double) < 0.2 = return () | otherwise = error $ "Monte carlo analysis too inaccurate: " ++ show x ----------------------------------------------------------------------- slidingWindow :: Int -> IO TestBench slidingWindow window = do upperRef <- newIORef upper0 return $ TBGroup (show window) [ TBIOBench "low level, Seq" expected (swLowLevelSeq window upperRef id (\x y -> x . (F.toList y:)) ($ [])) (swLowLevelSeq window upperRef () (\() y -> rnf y) id) , TBIOBench "conduit, Seq" expected (swConduitSeq window upperRef id (\x y -> x . (F.toList y:)) ($ [])) (swConduitSeq window upperRef () (\() y -> rnf y) id) {- https://ghc.haskell.org/trac/ghc/ticket/9446 , TBIOBench "low level, boxed Vector" expected (swLowLevelVector window upperRef id (\x y -> x . (VB.toList y:)) ($ [])) (swLowLevelVector window upperRef () (\() y -> rnf (y :: VB.Vector Int)) id) -} , TBBench $ bench "low level, boxed Vector" $ whnfIO $ swLowLevelVector window upperRef () (\() y -> rnf (y :: VB.Vector Int)) id {- https://ghc.haskell.org/trac/ghc/ticket/9446 , TBIOBench "conduit, boxed Vector" expected (swConduitVector window upperRef id (\x y -> x . (VB.toList y:)) ($ [])) (swConduitVector window upperRef () (\() y -> rnf (y :: VB.Vector Int)) id) -} , TBBench $ bench "conduit, boxed Vector" $ whnfIO $ swConduitVector window upperRef () (\() y -> rnf (y :: VB.Vector Int)) id , TBIOBench "low level, unboxed Vector" expected (swLowLevelVector window upperRef id (\x y -> x . (VU.toList y:)) ($ [])) (swLowLevelVector window upperRef () (\() y -> rnf (y :: VU.Vector Int)) id) , TBIOBench "conduit, unboxed Vector" expected (swConduitVector window upperRef id (\x y -> x . (VU.toList y:)) ($ [])) (swConduitVector window upperRef () (\() y -> rnf (y :: VU.Vector Int)) id) ] where upper0 = 10000 expected = loop [1..upper0] where loop input | length x == window = x : loop y | otherwise = [] where x = take window input y = drop 1 input swLowLevelSeq :: Int -> IORef Int -> t -> (t -> Seq.Seq Int -> t) -> (t -> t') -> IO t' swLowLevelSeq window upperRef t0 f final = do upper <- readIORef upperRef let phase1 i !s | i > window = phase2 i s t0 | otherwise = phase1 (i + 1) (s Seq.|> i) phase2 i !s !t | i > upper = t' | otherwise = phase2 (i + 1) s' t' where t' = f t s s' = Seq.drop 1 s Seq.|> i return $! final $! phase1 1 mempty swLowLevelVector :: V.Vector v Int => Int -> IORef Int -> t -> (t -> v Int -> t) -> (t -> t') -> IO t' swLowLevelVector window upperRef t0 f final = do upper <- readIORef upperRef let go !i !t _ _ _ | i > upper = return $! final $! t go !i !t !end _mv mv2 | end == bufSz = newBuf >>= go i t sz mv2 go !i !t !end mv mv2 = do VM.unsafeWrite mv end i when (end > sz) $ VM.unsafeWrite mv2 (end - sz) i let end' = end + 1 t' <- if end' < sz then return t else do v <- V.unsafeFreeze $ VM.unsafeSlice (end' - sz) sz mv return $! f t v go (i + 1) t' end' mv mv2 mv <- newBuf mv2 <- newBuf go 1 t0 0 mv mv2 where sz = window bufSz = 2 * window newBuf = VM.new bufSz swConduitSeq :: Int -> IORef Int -> t -> (t -> Seq.Seq Int -> t) -> (t -> t') -> IO t' swConduitSeq window upperRef t0 f final = do upper <- readIORef upperRef t <- runConduit $ CL.enumFromTo 1 upper .| slidingWindowC window .| CL.fold f t0 return $! final t swConduitVector :: V.Vector v Int => Int -> IORef Int -> t -> (t -> v Int -> t) -> (t -> t') -> IO t' swConduitVector window upperRef t0 f final = do upper <- readIORef upperRef t <- runConduit $ CL.enumFromTo 1 upper .| slidingVectorC window .| CL.fold f t0 return $! final t 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 -> ConduitT a (Seq.Seq a) m () slidingWindowCC sz = go sz mempty where goContinue st = await >>= maybe (return ()) (\x -> do let st' = st Seq.|> x yield st' >> goContinue (Seq.drop 1 st') ) go 0 st = yield st >> goContinue (Seq.drop 1 st) go !n st = CL.head >>= \m -> case m of Nothing | n < sz -> yield st | otherwise -> return () Just x -> go (n-1) (st Seq.|> x) {-# INLINE slidingWindowCC #-} slidingWindowS :: Monad m => Int -> CI.Stream m a () -> CI.Stream m (Seq.Seq a) () slidingWindowS sz (CI.Stream step ms0) = CI.Stream step' $ liftM (\s -> Left (s, sz, mempty)) ms0 where step' (Left (s, 0, st)) = return $ CI.Emit (Right (s, st)) st step' (Left (s, i, st)) = do res <- step s return $ case res of CI.Stop () -> CI.Stop () CI.Skip s' -> CI.Skip $ Left (s', i, st) CI.Emit s' a -> CI.Skip $ Left (s', i - 1, st Seq.|> a) step' (Right (s, st)) = do res <- step s return $ case res of CI.Stop () -> CI.Stop () CI.Skip s' -> CI.Skip $ Right (s', st) CI.Emit s' a -> let st' = Seq.drop 1 st Seq.|> a in CI.Emit (Right (s', st')) st' {-# INLINE slidingWindowS #-} 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 -> ConduitT a (v a) IO () slidingVectorCC sz = do mv <- newBuf mv2 <- newBuf go 0 mv mv2 where bufSz = 2 * sz newBuf = liftIO (VM.new bufSz) go !end _mv mv2 | end == bufSz = newBuf >>= go sz mv2 go !end mv mv2 = do mx <- await case mx of Nothing -> when (end > 0 && end < sz) $ do v <- liftIO $ V.unsafeFreeze $ VM.take end mv yield v Just x -> do liftIO $ do VM.unsafeWrite mv end x when (end > sz) $ VM.unsafeWrite mv2 (end - sz) x let end' = end + 1 when (end' >= sz) $ do v <- liftIO $ V.unsafeFreeze $ VM.unsafeSlice (end' - sz) sz mv yield v go end' mv mv2 slidingVectorS :: V.Vector v a => Int -> CI.Stream IO a () -> CI.Stream IO (v a) () slidingVectorS sz (CI.Stream step ms0) = CI.Stream step' ms1 where bufSz = 2 * sz newBuf = liftIO (VM.new bufSz) ms1 = do s <- ms0 mv <- newBuf mv2 <- newBuf return (s, 0, mv, mv2) step' (_, -1, _, _) = return $ CI.Stop () step' (s, end, _mv, mv2) | end == bufSz = do mv3 <- newBuf return $ CI.Skip (s, sz, mv2, mv3) step' (s, end, mv, mv2) = do res <- step s case res of CI.Stop () | end > 0 && end < sz -> do v <- liftIO $ V.unsafeFreeze $ VM.take end mv return $ CI.Emit (s, -1, mv, mv2) v | otherwise -> return $ CI.Stop () CI.Skip s' -> return $ CI.Skip (s', end, mv, mv2) CI.Emit s' x -> liftIO $ do VM.unsafeWrite mv end x when (end > sz) $ VM.unsafeWrite mv2 (end - sz) x let end' = end + 1 state = (s', end', mv, mv2) if end' >= sz then do v <- V.unsafeFreeze $ VM.unsafeSlice (end' - sz) sz mv return $ CI.Emit state v else return $ CI.Skip state {-# INLINE slidingVectorS #-} conduit-1.3.1.1/LICENSE0000644000000000000000000000207513244553114012521 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. conduit-1.3.1.1/Setup.lhs0000755000000000000000000000016213244553114013322 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain conduit-1.3.1.1/conduit.cabal0000644000000000000000000001156613441662627014163 0ustar0000000000000000Name: conduit Version: 1.3.1.1 Synopsis: Streaming data processing library. description: `conduit` is a solution to the streaming data problem, allowing for production, transformation, and consumption of streams of data in constant memory. It is an alternative to lazy I\/O which guarantees deterministic resource handling. . For more information about conduit in general, and how this package in particular fits into the ecosystem, see [the conduit homepage](https://github.com/snoyberg/conduit#readme). . Hackage documentation generation is not reliable. For up to date documentation, please see: . License: MIT License-file: LICENSE Author: Michael Snoyman Maintainer: michael@snoyman.com Category: Data, Conduit Build-type: Simple Cabal-version: >=1.8 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 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 Data.Conduit.Combinators.Unqualified Data.Streaming.FileRead Data.Streaming.Filesystem Build-depends: base >= 4.9 && < 5 , resourcet >= 1.2 && < 1.3 , transformers >= 0.4 , mtl , primitive , 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 conduit-test 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 , base , hspec >= 1.3 , QuickCheck >= 2.7 , transformers , mtl , resourcet , containers , exceptions >= 0.6 , safe , split >= 0.2.0.0 , 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 -- type: exitcode-stdio-1.0 -- ghc-options: -threaded -- build-depends: base, directory, doctest >= 0.8 -- benchmark utf8-memory-usage -- type: exitcode-stdio-1.0 -- hs-source-dirs: benchmarks -- build-depends: base -- , text-stream-decode -- , bytestring -- , text -- , conduit -- main-is: utf8-memory-usage.hs -- ghc-options: -Wall -O2 -with-rtsopts=-s benchmark optimize-201408 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks build-depends: base , conduit , vector , deepseq , containers , transformers , hspec , mwc-random , gauge , kan-extensions main-is: optimize-201408.hs ghc-options: -Wall -O2 -rtsopts benchmark unfused type: exitcode-stdio-1.0 hs-source-dirs: benchmarks build-depends: base , conduit , gauge , transformers main-is: unfused.hs ghc-options: -Wall -O2 -rtsopts source-repository head type: git location: git://github.com/snoyberg/conduit.git conduit-1.3.1.1/test/doctests.hs0000644000000000000000000000013113244553114014646 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest ["Data/Conduit.hs"] conduit-1.3.1.1/test/subdir/dummyfile.txt0000644000000000000000000000000013252136110016471 0ustar0000000000000000conduit-1.3.1.1/README.md0000644000000000000000000000065313244553114012773 0ustar0000000000000000## conduit `conduit` is a solution to the streaming data problem, allowing for production, transformation, and consumption of streams of data in constant memory. It is an alternative to lazy I\/O which guarantees deterministic resource handling. For more information about conduit in general, and how this package in particular fits into the ecosystem, see [the conduit homepage](https://github.com/snoyberg/conduit#readme). conduit-1.3.1.1/ChangeLog.md0000644000000000000000000001316113441662621013666 0ustar0000000000000000# ChangeLog for conduit ## 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 * Add `Semigroup` instances [#345](https://github.com/snoyberg/conduit/pull/345) ## 1.2.12.1 * Fix `pass` in `ConduitM` `MonadWriter` instance ## 1.2.12 * Add `exceptC`, `runExceptC` and `catchExceptC` to `Data.Conduit.Lift` ## 1.2.11 * Add `unfoldEither` and `unfoldEitherM` to `Data.Conduit.List` ## 1.2.10 * Add `PrimMonad` instances for `ConduitM` and `Pipe` [#306](https://github.com/snoyberg/conduit/pull/306) ## 1.2.9.1 * Ensure downstream and inner sink receive same inputs in `passthroughSink` [#304](https://github.com/snoyberg/conduit/issues/304) ## 1.2.9 * `chunksOf` [#296](https://github.com/snoyberg/conduit/pull/296) ## 1.2.8 * Implement [the reskinning idea](http://www.snoyman.com/blog/2016/09/proposed-conduit-reskin): * `.|` * `runConduitPure` * `runConduitRes` ## 1.2.7 * Expose yieldM for ConduitM [#270](https://github.com/snoyberg/conduit/pull/270) ## 1.2.6.6 * Fix test suite compilation on older GHCs ## 1.2.6.5 * In zipConduitApp, left bias not respected mixing monadic and non-monadic conduits [#263](https://github.com/snoyberg/conduit/pull/263) ## 1.2.6.4 * Fix benchmark by adding a type signature ## 1.2.6.3 * Doc updates ## 1.2.6.2 * resourcet cannot be built with GHC 8 [#242](https://github.com/snoyberg/conduit/issues/242) * Remove upper bound on transformers [#253](https://github.com/snoyberg/conduit/issues/253) ## 1.2.6 * `sourceToList` * Canonicalise Monad instances [#237](https://github.com/snoyberg/conduit/pull/237) ## 1.2.5 * mapAccum and mapAccumM should be strict in their state [#218](https://github.com/snoyberg/conduit/issues/218) ## 1.2.4.1 * Some documentation improvements ## 1.2.4 * [fuseBothMaybe](https://github.com/snoyberg/conduit/issues/199) __1.2.3__ Expose `connect` and `fuse` as synonyms for `$$` and `=$=`, respectively. __1.2.2__ Lots more stream fusion. __1.2__ Two performance optimizations added. (1) A stream fusion framework. This is a non-breaking change. (2) Codensity transform applied to the `ConduitM` datatype. This only affects users importing the `.Internal` module. Both changes are thoroughly described in the following to blog posts: [Speeding up conduit](https://www.fpcomplete.com/blog/2014/08/iap-speeding-up-conduit), and [conduit stream fusion](https://www.fpcomplete.com/blog/2014/08/conduit-stream-fusion). __1.1__ Refactoring into conduit and conduit-extra packages. Core functionality is now in conduit, whereas most common helper modules (including Text, Binary, Zlib, etc) are in conduit-extra. To upgrade to this version, there should only be import list and conduit file changes necessary. __1.0__ Simplified the user-facing interface back to the Source, Sink, and Conduit types, with Producer and Consumer for generic code. Error messages have been simplified, and optional leftovers and upstream terminators have been removed from the external API. Some long-deprecated functions were finally removed. __0.5__ The internals of the package are now separated to the .Internal module, leaving only the higher-level interface in the advertised API. Internally, switched to a `Leftover` constructor and slightly tweaked the finalization semantics. __0.4__ Inspired by the design of the pipes package: we now have a single unified type underlying `Source`, `Sink`, and `Conduit`. This type is named `Pipe`. There are type synonyms provided for the other three types. Additionally, `BufferedSource` is no longer provided. Instead, the connect-and-resume operator, `$$+`, can be used for the same purpose. __0.3__ ResourceT has been greatly simplified, specialized for IO, and moved into a separate package. Instead of hard-coding ResourceT into the conduit datatypes, they can now live around any monad. The Conduit datatype has been enhanced to better allow generation of streaming output. The SourceResult, SinkResult, and ConduitResult datatypes have been removed entirely. __0.2__ Instead of storing state in mutable variables, we now use CPS. A `Source` returns the next `Source`, and likewise for `Sink`s and `Conduit`s. Not only does this take better advantage of GHC\'s optimizations (about a 20% speedup), but it allows some operations to have a reduction in algorithmic complexity from exponential to linear. This also allowed us to remove the `Prepared` set of types. Also, the `State` functions (e.g., `sinkState`) use better constructors for return types, avoiding the need for a dummy state on completion. __0.1__ `BufferedSource` is now an abstract type, and has a much more efficient internal representation. The result was a 41% speedup on microbenchmarks (note: do not expect speedups anywhere near that in real usage). In general, we are moving towards `BufferedSource` being a specific tool used internally as needed, but using `Source` for all external APIs. __0.0__ Initial release. conduit-1.3.1.1/fusion-macros.h0000644000000000000000000000214013244553114014443 0ustar0000000000000000#define INLINE_RULE0(new,old) ;\ new = old ;\ {-# INLINE [0] new #-} ;\ {-# RULES "inline new" new = old #-} #define INLINE_RULE(new,vars,body) ;\ new vars = body ;\ {-# INLINE [0] new #-} ;\ {-# RULES "inline new" forall vars. new vars = body #-} #define STREAMING0(name, nameC, nameS) ;\ name = nameC ;\ {-# INLINE [0] name #-} ;\ {-# RULES "unstream name" \ name = unstream (streamConduit nameC nameS) \ #-} #define STREAMING(name, nameC, nameS, vars) ;\ name = nameC ;\ {-# INLINE [0] name #-} ;\ {-# RULES "unstream name" forall vars. \ name vars = unstream (streamConduit (nameC vars) (nameS vars)) \ #-}