├── Setup.hs ├── .gitignore ├── default.nix ├── LICENSE ├── README.md ├── Conduit ├── Simple.idr ├── Simple │ ├── Compat.hs │ └── Core.hs └── Simple.hs ├── simple-conduit.cabal └── test └── bench.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /Setup 3 | *.glob 4 | *.vo 5 | /Conduit/Simple.ibc 6 | /Conduit/test 7 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bifunctors, bytestring, chunked-data 2 | , containers, either, exceptions, filepath, free, lifted-async 3 | , lifted-base, mmorph, monad-control, mono-traversable, mtl 4 | , mwc-random, primitive, semigroups, stdenv, stm, streaming-commons 5 | , text, transformers, transformers-base, vector 6 | }: 7 | mkDerivation { 8 | pname = "simple-conduit"; 9 | version = "0.5.1"; 10 | src = ./.; 11 | libraryHaskellDepends = [ 12 | base bifunctors bytestring chunked-data containers either 13 | exceptions filepath free lifted-async lifted-base mmorph 14 | monad-control mono-traversable mtl mwc-random primitive semigroups 15 | stm streaming-commons text transformers transformers-base vector 16 | ]; 17 | homepage = "http://github.com/jwiegley/simple-conduit"; 18 | description = "A simple streaming I/O library based on monadic folds"; 19 | license = stdenv.lib.licenses.bsd3; 20 | } 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | opyright (c) 2014 John Wiegley 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A brain-dead effectful streaming library, just to see how much we can get away 2 | with, using as little as possible. I.e., the one-legged centipede version of 3 | conduit. :-) 4 | 5 | Features conspicuously lacking: 6 | 7 | - Conduits are not Monads, which omits a lot of important use cases 8 | - No leftovers 9 | 10 | Features surprisingly present: 11 | 12 | - Much simpler types; Void is no longer needed, for example 13 | - No special operators are needed; conduit pipelines can be expressed 14 | using only function application ($) 15 | - Performance beats conduit in simple cases (139ms vs. 259ms) 16 | - Early termination by consumers 17 | - Notification of uptream termination 18 | - monad-control can be used for resource control 19 | - Prompt finalization 20 | - Sources are Monoids (though making it an instance takes more work) 21 | 22 | What's interesting is that this library is simply a convenience for chaining 23 | monadic folds, and nothing more. I find it interesting how much of conduit 24 | can be expressed using only that abstraction. 25 | 26 | See also my 27 | [blog article](http://newartisans.com/2014/06/simpler-conduit-library/) about 28 | this library. 29 | -------------------------------------------------------------------------------- /Conduit/Simple.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | data Identity a = Id a 4 | 5 | runIdentity : Identity a -> a 6 | runIdentity (Id a) = a 7 | 8 | instance Functor Identity where 9 | map f (Id x) = Id (f x) 10 | 11 | instance Applicative Identity where 12 | pure = Id 13 | (Id f) <$> (Id x) = Id (f x) 14 | 15 | instance Monad Identity where 16 | (Id m) >>= f = f m 17 | 18 | data Source : {r : Type} -> (m : Type -> Type) -> (a : Type) -> Type where 19 | Src : (r -> (r -> a -> m r) -> m r) -> Source {r} m a 20 | 21 | runSource : {r : Type} -> Source {r} m a -> r -> (r -> a -> m r) -> m r 22 | runSource (Src await) = await 23 | 24 | Conduit : {r : Type} -> Type -> (Type -> Type) -> Type -> Type 25 | Conduit {r} a m b = Source {r} m a -> Source {r} m b 26 | 27 | Sink : {r : Type} -> Type -> (Type -> Type) -> Type -> Type 28 | Sink {r} a m s = Source {r} m a -> m s 29 | 30 | instance Functor (Source {r} m) where 31 | map f (Src await) = Src $ \z, yield => await z (\r => yield r . f) 32 | 33 | foldM : Monad m => (r -> a -> m r) -> r -> List a -> m r 34 | foldM f z [] = return z 35 | foldM f z (x :: xs) = f z x >>= flip (foldM f) xs 36 | 37 | source : {r : Type} -> (r -> (r -> a -> m r) -> m r) -> Source {r} m a 38 | source = Src 39 | 40 | sourceList : Monad m => List a -> Source m a 41 | sourceList xs = source $ \z, yield => foldM yield z xs 42 | 43 | mapC : Monad m => {r : Type} -> (a -> b) -> Conduit {r} a m b 44 | mapC = map 45 | 46 | sinkList : Monad m => Sink {r = List a} a m (List a) 47 | sinkList (Src await) = await Prelude.List.Nil (\xs, x => return (x :: xs)) 48 | 49 | main : IO () 50 | main = print $ runIdentity $ sinkList $ mapC (+1) $ sourceList [1..10] 51 | -------------------------------------------------------------------------------- /simple-conduit.cabal: -------------------------------------------------------------------------------- 1 | Name: simple-conduit 2 | Version: 0.6.0 3 | Synopsis: A simple streaming I/O library based on monadic folds 4 | Description: 5 | @simple-conduit@ follows a similar UI to the more capable @conduit@ library, 6 | but reduces the scope of what it can solve down to what can be expressed by 7 | chaining monadic folds that allow for early termination. This allows for 8 | more predictable resource management behavior, at the cost of not allowing 9 | scenarios that @conduit@ is better designed. 10 | 11 | License: BSD3 12 | License-file: LICENSE 13 | Author: John Wiegley 14 | Maintainer: johnw@newartisans.com 15 | Category: Data, Conduit 16 | Build-type: Simple 17 | Cabal-version: >=1.8 18 | Homepage: http://github.com/jwiegley/simple-conduit 19 | 20 | Library 21 | ghc-options: -Wall -O2 -funbox-strict-fields 22 | Exposed-modules: 23 | Conduit.Simple 24 | Conduit.Simple.Compat 25 | Conduit.Simple.Core 26 | Build-depends: 27 | base >= 4.3 && < 5 28 | , bifunctors 29 | , bytestring 30 | , chunked-data 31 | , containers 32 | , either 33 | , exceptions 34 | , filepath 35 | , free 36 | , lifted-async 37 | , lifted-base >= 0.1 38 | , mmorph 39 | , monad-control >= 1.0.0 40 | , mono-traversable >= 1.0 && < 1.1 41 | , mtl 42 | , mwc-random 43 | , primitive 44 | , semigroups 45 | , stm 46 | , streaming-commons 47 | , text 48 | , transformers >= 0.2.2 && < 0.6 49 | , transformers-base >= 0.4.1 && < 0.6 50 | , vector 51 | 52 | benchmark bench 53 | hs-source-dirs: . 54 | ghc-options: -O2 -funbox-strict-fields 55 | other-modules: Conduit.Simple.Compat 56 | main-is: test/bench.hs 57 | type: exitcode-stdio-1.0 58 | cpp-options: -DTEST 59 | build-depends: 60 | simple-conduit 61 | , base 62 | , vector 63 | , hspec >= 1.3 64 | , QuickCheck 65 | , transformers 66 | , lifted-async 67 | , stm 68 | , foldl 69 | , transformers-base 70 | , primitive 71 | , chunked-data 72 | , CC-delcont 73 | , bytestring 74 | , mono-traversable 75 | , streaming-commons 76 | , filepath 77 | , mwc-random 78 | , lifted-base 79 | , monad-control 80 | , either 81 | , exceptions 82 | , free 83 | , mmorph 84 | , bifunctors 85 | , semigroups 86 | , mtl 87 | , void 88 | , containers 89 | , text 90 | , criterion 91 | , conduit 92 | , conduit-extra 93 | , conduit-combinators 94 | 95 | source-repository head 96 | type: git 97 | location: git://github.com/jwiegley/simple-conduit.git 98 | -------------------------------------------------------------------------------- /test/bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import qualified Conduit as C 7 | import Conduit.Simple 8 | import Conduit.Simple.Compat 9 | import Control.Arrow 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import Criterion.Main (defaultMain, bench, nf) 13 | import Data.Functor.Identity 14 | import Data.Monoid 15 | import qualified Data.Vector as V 16 | import qualified Data.Text as T 17 | import Data.Text.Encoding 18 | import System.IO.Unsafe (unsafePerformIO) 19 | 20 | main :: IO () 21 | main = do 22 | xs <- yieldMany [1..10] $= mapC (+2) $$ sinkList 23 | print (xs :: [Int]) 24 | 25 | ys <- yieldMany [1..10] $$ mapC (+2) =$ sinkList 26 | print (ys :: [Int]) 27 | 28 | zs <- yieldMany [1..10] $= dropC 5 $= mapC (+2) $$ sinkList 29 | print (zs :: [Int]) 30 | 31 | ws <- yieldMany [1..10] $= takeC 5 $= mapC (+2) $$ sinkList 32 | print (ws :: [Int]) 33 | 34 | us <- (sourceFile "simple-conduit.cabal" <> sourceFile "README.md") 35 | $= takeC 1 36 | $$ sinkList 37 | print (T.unpack (decodeUtf8 (Prelude.head us))) 38 | 39 | vs <- sinkList 40 | $ (proc x -> do y <- mapC (+1) -< x 41 | g <- takeC 1 -< y 42 | returnA -< g) 43 | $ yieldMany ([1..10] :: [Int]) 44 | print (vs :: [Int]) 45 | 46 | x <- sinkList $ returnC $ sumC $ mapC (+1) $ yieldMany ([1..10] :: [Int]) 47 | print x 48 | 49 | yieldMany ([1..10] :: [Int]) $$ mapM_C (liftIO . print) 50 | 51 | defaultMain 52 | [ -- bench "centipede1" $ nf (runIdentity . useThis) ([1..1000000] :: [Int]) 53 | -- , bench "conduit1" $ nf (runIdentity . useThat) ([1..1000000] :: [Int]) 54 | -- , bench "centipede2" $ nf (runIdentity . useThis) ([1..1000000] :: [Int]) 55 | -- , bench "centipede3" $ nf (runIdentity . useThis2) ([1..1000000] :: [Int]) 56 | -- , bench "conduit2" $ nf (runIdentity . useThat) ([1..1000000] :: [Int]) 57 | -- , 58 | bench "rechunk1" $ nf (unsafePerformIO . rechunk1) 59 | (replicate 10 [1..10000]) 60 | , bench "rechunk1IO" $ nf (unsafePerformIO . rechunk1IO) 61 | (replicate 10 [1..10000]) 62 | , bench "C.rechunk1" $ nf (unsafePerformIO . conduitRechunk1) 63 | (replicate 10 [1..10000]) 64 | , bench "C.rechunk3" $ nf (unsafePerformIO . conduitRechunk3) 65 | (replicate 10 [1..10000]) 66 | ] 67 | where 68 | useThis xs = yieldMany xs $= mapC (+2) $$ sinkList 69 | useThis2 xs = yieldMany2 xs $= mapC (+2) $$ sinkList2 70 | useThat xs = C.yieldMany xs C.$= C.mapC (+2) C.$$ C.sinkList 71 | 72 | rechunk1 :: [[Int]] -> IO [V.Vector Int] 73 | rechunk1 xs = sourceList xs 74 | $= concatC 75 | =$= concatMapC (\x -> [x, x]) 76 | =$= conduitVector 512 77 | $$ sinkList 78 | 79 | rechunk1IO :: [[Int]] -> IO [V.Vector Int] 80 | rechunk1IO xs = sourceList xs 81 | $= concatC 82 | =$= concatMapC (\x -> [x, x]) 83 | =$= conduitVector 512 84 | $$ sinkList 85 | 86 | -- rechunk2 = 87 | -- mapC (concatMap $ replicate 2) =$= loop 88 | -- where 89 | -- loop = do 90 | -- x <- takeCE 512 $= foldC 91 | -- unless (null x) $ yield x >> loop 92 | 93 | conduitRechunk1 :: [[Int]] -> IO [V.Vector Int] 94 | conduitRechunk1 xs = C.yieldMany xs 95 | C.$= C.concatC 96 | C.=$= C.concatMapC (\x -> [x, x]) 97 | C.=$= C.conduitVector 512 98 | C.$$ C.sinkList 99 | 100 | -- conduitRechunk2 :: [[Int]] -> IO [V.Vector Int] 101 | -- conduitRechunk2 xs = C.yieldMany xs 102 | -- C.$= C.mapC (concatMap $ replicate 2) 103 | -- C.=$= loop 104 | -- C.$$ C.sinkList 105 | -- where 106 | -- loop = do 107 | -- x <- C.takeCE 512 C.=$= C.foldC 108 | -- unless (null x) $ C.yield x >> loop 109 | 110 | conduitRechunk3 :: [[Int]] -> IO [V.Vector Int] 111 | conduitRechunk3 xs = C.yieldMany xs 112 | C.$= C.vectorBuilderC 512 (\yield' -> C.mapM_CE (\x -> yield' x >> yield' x)) 113 | C.$$ C.sinkList 114 | 115 | yieldMany2 :: Monad m => [a] -> Source m a 116 | yieldMany2 xs = source $ \z yield -> foldM yield z xs 117 | {-# INLINE yieldMany2 #-} 118 | 119 | sinkList2 :: Monad m => Sink a m [a] 120 | sinkList2 = liftM (liftM ($ [])) $ sink id $ \r x -> return (r . (x:)) 121 | {-# INLINE sinkList2 #-} 122 | -------------------------------------------------------------------------------- /Conduit/Simple/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Conduit.Simple.Compat 6 | ( ($=), (=$), (=$=), ($$) 7 | , sequenceSources 8 | -- , toFoldM, fromFoldM 9 | -- , adaptFrom, adaptTo 10 | ) where 11 | 12 | import Conduit.Simple.Core 13 | -- import Control.Category (Category) 14 | -- import Control.Exception.Lifted (finally) 15 | -- import Control.Foldl (FoldM(..)) 16 | -- import Control.Monad (liftM) 17 | -- import Control.Monad.CC hiding (control) 18 | -- import Control.Monad.Cont 19 | -- import Control.Monad.Logic 20 | -- import Control.Monad.Trans.Class (lift) 21 | -- import Control.Monad.Trans.Control 22 | -- import Control.Monad.Trans.Either (EitherT(..)) 23 | -- import Control.Monad.Trans.Maybe 24 | -- import Crypto.Hash 25 | -- import qualified Data.ByteString as B 26 | -- import Data.Foldable 27 | -- import Data.Functor.Identity 28 | -- import qualified Data.Machine as M 29 | import Data.Traversable 30 | 31 | -- import qualified Data.Conduit.Internal as C (Source, Producer, 32 | -- ConduitM(..), Pipe(..)) 33 | 34 | -- | Compose a 'Source' and a 'Conduit' into a new 'Source'. Note that this 35 | -- is just flipped function application, so ($) can be used to achieve the 36 | -- same thing. 37 | infixl 1 $= 38 | ($=) :: a -> (a -> b) -> b 39 | ($=) = flip ($) 40 | 41 | -- | Compose a 'Conduit' and a 'Sink' into a new 'Sink'. Note that this is 42 | -- just function composition, so (.) can be used to achieve the same thing. 43 | infixr 2 =$ 44 | (=$) :: (a -> b) -> (b -> c) -> a -> c 45 | (=$) = flip (.) 46 | 47 | -- | Compose two 'Conduit'. This is also just function composition. 48 | infixr 2 =$= 49 | (=$=) :: (a -> b) -> (b -> c) -> a -> c 50 | (=$=) = flip (.) 51 | 52 | -- | Compose a 'Source' and a 'Sink' and compute the result. Note that this 53 | -- is just flipped function application, so ($) can be used to achieve the 54 | -- same thing. 55 | infixr 0 $$ 56 | ($$) :: a -> (a -> b) -> b 57 | ($$) = flip ($) 58 | 59 | -- | Sequence a collection of sources. 60 | -- 61 | -- >>> sinkList $ sequenceSources [yieldOne 1, yieldOne 2, yieldOne 3] 62 | -- [[1,2,3]] 63 | sequenceSources :: (Traversable f, Monad m) => f (Source m a) -> Source m (f a) 64 | sequenceSources = sequenceA 65 | 66 | {- 67 | -- | Convert a 'Control.Foldl.FoldM' fold abstraction into a Sink. 68 | -- 69 | -- NOTE: This requires ImpredicativeTypes in the code that uses it. 70 | -- 71 | -- >>> fromFoldM (FoldM ((return .) . (+)) (return 0) return) $ yieldMany [1..10] 72 | -- 55 73 | fromFoldM :: Monad m => FoldM m a b -> Sink a m b 74 | fromFoldM (FoldM step start done) src = 75 | start >>= (\r -> sink r ((lift .) . step) src) >>= done 76 | 77 | -- | Convert a Sink into a 'Control.Foldl.FoldM', passing it as a continuation 78 | -- over the elements. 79 | -- 80 | -- >>> toFoldM sumC (\f -> Control.Foldl.foldM f [1..10]) 81 | -- 55 82 | toFoldM :: Monad m => Sink a m b -> (forall r. FoldM m a r -> m r) -> m b 83 | toFoldM s f = s $ source $ \z yield -> 84 | lift $ f $ FoldM ((unwrap .) . yield) (return z) return 85 | 86 | -- | Turns any conduit 'Producer' into a simple-conduit 'Source'. 87 | -- Finalization is taken care of, as is processing of leftovers, provided 88 | -- the base monad implements @MonadBaseControl IO@. 89 | adaptFrom :: forall m a. MonadBaseControl IO m => C.Producer m a -> Source m a 90 | adaptFrom (C.ConduitM m) = source go 91 | where 92 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 93 | go z yield = f z m 94 | where 95 | f r (C.HaveOutput p c o) = yield r o >>= \r' -> f r' p `finally` lift c 96 | f r (C.NeedInput _ u) = f r (u ()) 97 | f r (C.Done ()) = return r 98 | f r (C.PipeM mp) = lift mp >>= f r 99 | f r (C.Leftover p l) = yield r l >>= flip f p 100 | 101 | -- | Turn a non-resource dependent simple-conduit into a conduit 'Source'. 102 | -- 103 | -- Finalization data would be lost in this transfer, and so is denied by 104 | -- lack of an instance for @MonadBaseControl IO@. Further, the resulting 105 | -- pipeline must be run under 'Control.Monad.CC.runCCT', so really this is 106 | -- more a curiosity than anything else. 107 | adaptTo :: MonadDelimitedCont p s m => Source m a -> C.Source m a 108 | adaptTo src = C.ConduitM $ C.PipeM $ reset $ \p -> 109 | liftM C.Done $ unwrap $ runSource src () $ \() x -> 110 | lift $ shift p $ \k -> 111 | return $ C.HaveOutput (C.PipeM $ k (return ())) (return ()) x 112 | 113 | fromLogicT :: Monad m => LogicT m a -> Source m a 114 | fromLogicT (LogicT await) = source $ \z yield -> 115 | lift $ await (go yield) (return z) 116 | where 117 | go yield x mr = do 118 | r <- mr 119 | eres <- runEitherT $ yield r x 120 | case eres of 121 | Left e -> return e -- no short-circuiting here! 122 | Right r -> return r 123 | 124 | -- toLogicT :: forall m a. Monad m => Source m a -> LogicT m a 125 | -- toLogicT (Source (ContT await)) = LogicT $ \yield mz -> do 126 | -- z <- mz 127 | -- liftM (either id id) . runEitherT $ 128 | -- runIdentity (await (\x -> Identity $ liftM lift $ yield x . return)) z 129 | 130 | fromMachine :: forall m k a. Monad m => M.MachineT m k a -> Source m a 131 | fromMachine mach = source go 132 | where 133 | go :: forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r 134 | go z yield = loop mach z 135 | where 136 | loop :: M.MachineT m k a -> r -> EitherT r m r 137 | loop (M.MachineT m) r = do 138 | step <- lift m 139 | case step of 140 | M.Stop -> return r 141 | M.Yield x k -> loop k r >>= flip yield x 142 | M.Await _ _ e -> loop e r 143 | 144 | -- toMachine :: forall m k s a. (Category k, Monad m) 145 | -- => Source m a -> s -> M.MachineT m (k a) s 146 | -- toMachine (Source (ContT await)) seed = 147 | -- M.construct $ M.PlanT 148 | -- (\r -> ) 149 | -- (\a mr -> ) 150 | -- (\f kz mr -> ) 151 | -- (return seed) 152 | -- liftM (either id id) . runEitherT $ 153 | -- runIdentity (await go) seed 154 | -- where 155 | -- go :: a -> Identity (s -> EitherT s (M.PlanT (k a) a m) ()) 156 | -- go x = Identity $ liftM lift $ \r -> M.yield x 157 | 158 | -- | A 'Sink' that hashes a stream of 'B.ByteString'@s@ and creates a digest 159 | -- @d@. 160 | sinkHash :: (Monad m, HashAlgorithm hash) => Sink B.ByteString m (Digest hash) 161 | sinkHash = liftM hashFinalize . sink hashInit ((return .) . hashUpdate) 162 | 163 | -- | Hashes the whole contents of the given file in constant memory. This 164 | -- function is just a convenient wrapper around 'sinkHash'. 165 | hashFile :: (MonadIO m, HashAlgorithm hash) => FilePath -> m (Digest hash) 166 | hashFile = liftIO . sinkHash . sourceFile 167 | -} 168 | -------------------------------------------------------------------------------- /Conduit/Simple/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- | Please see the project README for more details: 12 | -- 13 | -- https://github.com/jwiegley/simple-conduit/blob/master/README.md 14 | -- 15 | -- Also see this blog article: 16 | -- 17 | -- https://www.newartisans.com/2014/06/simpler-conduit-library 18 | 19 | module Conduit.Simple.Core where 20 | 21 | import Control.Applicative (Alternative((<|>), empty), 22 | Applicative((<*>), pure)) 23 | import Control.Arrow (first) 24 | import Control.Monad.Catch (MonadThrow(..), MonadMask, MonadCatch) 25 | import qualified Control.Monad.Catch as Catch 26 | import Control.Monad.Cont 27 | import Control.Monad.Error.Class (MonadError(..)) 28 | import Control.Monad.Free 29 | import Control.Monad.Morph (MMonad(..), MFunctor(..)) 30 | import Control.Monad.Reader.Class (MonadReader(..)) 31 | import Control.Monad.State.Class (MonadState(..)) 32 | import Control.Monad.Trans.Either (EitherT(..), left) 33 | import Control.Monad.Writer.Class (MonadWriter(..)) 34 | import Data.Bifunctor (Bifunctor(bimap)) 35 | import Data.Foldable (Foldable(foldMap)) 36 | import Data.Functor.Identity 37 | import Data.Semigroup (Monoid(..), Semigroup((<>))) 38 | 39 | -- | A Source is a short-circuiting monadic fold. 40 | -- 41 | -- 'Source' forms a Monad that behaves as 'ListT'; for example: 42 | -- 43 | -- @ 44 | -- do x <- yieldMany [1..3] 45 | -- line <- sourceFile "foo.txt" 46 | -- return (x, line) 47 | -- @ 48 | -- 49 | -- This yields the cross-product of [3] and the lines in the files, but only 50 | -- reading chunks from the file as needed by the sink. 51 | -- 52 | -- To skip to the next value in a Source, use the function 'skip' or 'mempty'; 53 | -- to close the source, use 'close'. For example: 54 | -- 55 | -- @ 56 | -- do x <- yieldMany [1..10] 57 | -- if x == 2 || x == 9 58 | -- then return x 59 | -- else if x < 5 60 | -- then skip 61 | -- else close 62 | -- @ 63 | -- 64 | -- This outputs the list @[2]@. 65 | -- 66 | -- A key difference from the @conduit@ library is that monadic chaining of 67 | -- sources with '>>' follows 'ListT', and not concatenation as in conduit. To 68 | -- achieve conduit-style behavior, use the Monoid instance: 69 | -- 70 | -- >>> sinkList $ yieldMany [1..3] <> yieldMany [4..6] 71 | -- [1,2,3,4,5,6] 72 | newtype Source m a = Source { getSource :: forall r. Cont (r -> EitherT r m r) a } 73 | deriving Functor 74 | 75 | -- | A 'Conduit' is a "Source homomorphism", or simple a mapping between 76 | -- sources. There is no need for it to be a type synonym, except to save 77 | -- repetition across type signatures. 78 | type Conduit a m b = Source m a -> Source m b 79 | 80 | -- | A 'Sink' folds a 'Source' down to its result value. It is simply a 81 | -- convenient type synonym for functions mapping a 'Source' to some result 82 | -- type. 83 | type Sink a m r = Source m a -> m r 84 | 85 | instance Monad m => Semigroup (Source m a) where 86 | x <> y = source $ \r c -> runSource x r c >>= \r' -> runSource y r' c 87 | 88 | instance Monad m => Monoid (Source m a) where 89 | mempty = skip 90 | mappend = (<>) 91 | 92 | instance Monad m => Alternative (Source m) where 93 | empty = skip 94 | (<|>) = (<>) 95 | 96 | instance Monad m => MonadPlus (Source m) where 97 | mzero = skip 98 | mplus = (<|>) 99 | 100 | instance Applicative (Source m) where 101 | pure = return 102 | f <*> x = source $ \z yield -> 103 | runSource f z (\r f' -> runSource x r (\s x' -> yield s (f' x'))) 104 | 105 | instance Monad (Source m) where 106 | return x = Source $ return x 107 | Source m >>= f = Source $ join (liftM (getSource . f) m) 108 | 109 | instance MFunctor Source where 110 | hoist nat m = source $ runSource (hoist nat m) 111 | 112 | instance MMonad Source where 113 | embed f m = source $ runSource (embed f m) 114 | 115 | instance MonadIO m => MonadIO (Source m) where 116 | liftIO m = source $ \r yield -> liftIO m >>= yield r 117 | 118 | instance MonadTrans Source where 119 | lift m = source $ \r yield -> lift m >>= yield r 120 | 121 | instance (Functor f, MonadFree f m) => MonadFree f (Source m) where 122 | wrap t = source $ \r h -> wrap $ fmap (\p -> runSource p r h) t 123 | 124 | -- jww (2014-06-15): If it weren't for the universally quantified r... 125 | -- instance MonadCont (Source m) where 126 | -- callCC f = source $ \z c -> runSource (f (\x -> source $ \r _ -> c r x)) z c 127 | 128 | instance MonadReader r m => MonadReader r (Source m) where 129 | ask = lift ask 130 | local f = conduit $ \r yield -> local f . yield r 131 | reader = lift . reader 132 | 133 | instance MonadState s m => MonadState s (Source m) where 134 | get = lift get 135 | put = lift . put 136 | state = lift . state 137 | 138 | instance MonadWriter w m => MonadWriter w (Source m) where 139 | writer = lift . writer 140 | tell = lift . tell 141 | listen = conduit $ \r yield x -> 142 | listen (return ()) >>= yield r . first (const x) 143 | pass = conduit $ \r yield (x, f) -> pass (return ((), f)) >> yield r x 144 | 145 | instance MonadError e m => MonadError e (Source m) where 146 | throwError = lift . throwError 147 | catchError src f = source $ \z yield -> EitherT $ 148 | runEitherT (runSource src z yield) 149 | `catchError` \e -> runEitherT (runSource (f e) z yield) 150 | 151 | instance MonadThrow m => MonadThrow (Source m) where 152 | throwM = lift . throwM 153 | 154 | instance MonadCatch m => MonadCatch (Source m) where 155 | catch src f = source $ \z yield -> EitherT $ 156 | runEitherT (runSource src z yield) 157 | `Catch.catch` \e -> runEitherT (runSource (f e) z yield) 158 | 159 | instance MonadMask m => MonadMask (Source m) where 160 | mask a = source $ \z yield -> EitherT $ Catch.mask $ \u -> 161 | runEitherT $ runSource (a $ \b -> source $ \r yield' -> 162 | EitherT $ liftM Right $ u $ sink r yield' b) z yield 163 | uninterruptibleMask a = 164 | source $ \z yield -> EitherT $ Catch.uninterruptibleMask $ \u -> 165 | runEitherT $ runSource (a $ \b -> source $ \r yield' -> 166 | EitherT $ liftM Right $ u $ sink r yield' b) z yield 167 | 168 | instance Foldable (Source Identity) where 169 | foldMap f = runIdentity . sink mempty (\r x -> return $ r `mappend` f x) 170 | 171 | -- | Promote any sink to a source. This can be used as if it were a source 172 | -- transformer (aka, a conduit): 173 | -- 174 | -- >>> sinkList $ returnC $ sumC $ mapC (+1) $ yieldMany [1..10] 175 | -- [65] 176 | -- 177 | -- Note that 'returnC' is a synonym for 'Control.Monad.Trans.Class.lift'. 178 | returnC :: Monad m => m a -> Source m a 179 | returnC = lift 180 | 181 | prod :: Source m (Cont (r -> EitherT r m r) (Source m a)) 182 | -> Cont (r -> EitherT r m r) (Source m a) 183 | prod (Source (ContT src)) = ContT $ \yield -> src $ \(ContT x) -> x yield 184 | 185 | close :: Monad m => Source m a 186 | close = source $ const . left 187 | 188 | skip :: Monad m => Source m a 189 | skip = source $ const . return 190 | 191 | runSource :: Source m a -> r -> (r -> a -> EitherT r m r) -> EitherT r m r 192 | runSource (Source (ContT src)) z yield = 193 | runIdentity (src (\x -> Identity $ \r -> yield r x)) z 194 | 195 | lowerSource :: (Monad m, Monoid a) => Source m a -> m a 196 | lowerSource src = unwrap $ runSource src mempty ((return .) . mappend) 197 | 198 | source :: (forall r. r -> (r -> a -> EitherT r m r) -> EitherT r m r) -> Source m a 199 | source await = Source $ ContT $ \yield -> Identity $ \z -> 200 | await z (\r x -> runIdentity (yield x) r) 201 | 202 | conduit :: (forall r. r -> (r -> b -> EitherT r m r) -> a -> EitherT r m r) 203 | -> Conduit a m b 204 | conduit f src = source $ \z c -> runSource src z (`f` c) 205 | 206 | -- | Most of the time conduits pass the fold variable through unmolested, but 207 | -- sometimes you need to ignore that variable and use your own within a 208 | -- stage of the pipeline. This is done by wrapping the fold variable in a 209 | -- tuple and then unwrapping it when the conduit is done. 'conduitWith' 210 | -- makes this transparent. 211 | conduitWith :: Monad m 212 | => s 213 | -> (forall r. (r, s) -> (r -> b -> EitherT (r, s) m (r, s)) -> a 214 | -> EitherT (r, s) m (r, s)) 215 | -> Conduit a m b 216 | conduitWith s f src = source $ \z yield -> 217 | rewrap fst $ runSource src (z, s) $ \(r, t) -> 218 | f (r, t) (\r' -> rewrap (, t) . yield r') 219 | 220 | unwrap :: Monad m => EitherT a m a -> m a 221 | unwrap k = either id id `liftM` runEitherT k 222 | 223 | rewrap :: Monad m => (a -> b) -> EitherT a m a -> EitherT b m b 224 | rewrap f k = EitherT $ bimap f f `liftM` runEitherT k 225 | 226 | sink :: forall m a r. Monad m => r -> (r -> a -> EitherT r m r) -> Sink a m r 227 | sink z f src = either id id `liftM` runEitherT (runSource src z f) 228 | 229 | awaitForever :: (a -> Source m b) -> Conduit a m b 230 | awaitForever = (=<<) 231 | -------------------------------------------------------------------------------- /Conduit/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | -- | Please see the project README for more details: 11 | -- 12 | -- https://github.com/jwiegley/simple-conduit/blob/master/README.md 13 | -- 14 | -- Also see this blog article: 15 | -- 16 | -- https://www.newartisans.com/2014/06/simpler-conduit-library 17 | 18 | module Conduit.Simple 19 | ( Source(..), Conduit, Sink 20 | , runSource, lowerSource, source, conduit, conduitWith, sink 21 | , returnC, close, skip, awaitForever 22 | , yieldMany, sourceList 23 | , unfoldC 24 | , enumFromToC 25 | , iterateC 26 | , repeatC 27 | , replicateC 28 | , sourceLazy 29 | , repeatMC 30 | , repeatWhileMC 31 | , replicateMC 32 | , sourceHandle 33 | , sourceFile 34 | , sourceIOHandle 35 | , stdinC 36 | , initRepeat 37 | , initReplicate 38 | , sourceRandom 39 | , sourceRandomN 40 | , sourceRandomGen 41 | , sourceRandomNGen 42 | , sourceDirectory 43 | , sourceDirectoryDeep 44 | , dropC 45 | , dropCE 46 | , dropWhileC 47 | , dropWhileCE 48 | , foldC 49 | , foldCE 50 | , foldlC 51 | , foldlCE 52 | , foldMapC 53 | , foldMapCE 54 | , allC 55 | , allCE 56 | , anyC 57 | , anyCE 58 | , andC 59 | , andCE 60 | , orC 61 | , orCE 62 | , elemC 63 | , elemCE 64 | , notElemC 65 | , notElemCE 66 | , sinkLazy 67 | , sinkList 68 | , sinkVector 69 | , sinkBuilder 70 | , sinkLazyBuilder 71 | , sinkNull 72 | , awaitNonNull 73 | , headCE 74 | , lastC 75 | , lastCE 76 | , lengthC 77 | , lengthCE 78 | , lengthIfC 79 | , lengthIfCE 80 | , maximumC 81 | , maximumCE 82 | , minimumC 83 | , minimumCE 84 | , sumC 85 | , sumCE 86 | , productC 87 | , productCE 88 | , findC 89 | , mapM_C 90 | , mapM_CE 91 | , foldMC 92 | , foldMCE 93 | , foldMapMC 94 | , foldMapMCE 95 | , sinkFile 96 | , sinkHandle 97 | , sinkIOHandle 98 | , printC 99 | , stdoutC 100 | , stderrC 101 | , mapC 102 | , mapCE 103 | , omapCE 104 | , concatMapC 105 | , concatMapCE 106 | , takeC 107 | , takeCE 108 | , takeWhileC 109 | , takeWhileCE 110 | , takeExactlyC 111 | , takeExactlyCE 112 | , concatC 113 | , filterC 114 | , filterCE 115 | , mapWhileC 116 | , conduitVector 117 | , scanlC 118 | , concatMapAccumC 119 | , intersperseC 120 | , encodeBase64C 121 | , decodeBase64C 122 | , encodeBase64URLC 123 | , decodeBase64URLC 124 | , encodeBase16C 125 | , decodeBase16C 126 | , mapMC 127 | , mapMCE 128 | , omapMCE 129 | , concatMapMC 130 | , filterMC 131 | , filterMCE 132 | , iterMC 133 | , scanlMC 134 | , concatMapAccumMC 135 | , encodeUtf8C 136 | , decodeUtf8C 137 | , lineC 138 | , lineAsciiC 139 | , unlinesC 140 | , unlinesAsciiC 141 | , linesUnboundedC_ 142 | , linesUnboundedC, linesC 143 | , linesUnboundedAsciiC, linesAsciiC 144 | , sourceMaybeMVar 145 | , sourceMaybeTMVar 146 | , asyncC 147 | , sourceTChan 148 | , sourceTQueue 149 | , sourceTBQueue 150 | , untilMC 151 | , whileMC 152 | , zipSinks 153 | 154 | , ($=), (=$), (=$=), ($$) 155 | , sequenceSources 156 | ) where 157 | 158 | import Conduit.Simple.Compat 159 | import Conduit.Simple.Core 160 | import Control.Applicative ((<$>)) 161 | import Control.Concurrent.Async.Lifted 162 | import Control.Concurrent.Lifted hiding (yield) 163 | import Control.Concurrent.STM 164 | import Control.Exception.Lifted (bracket) 165 | import Control.Monad.Base (MonadBase(..)) 166 | import Control.Monad.Catch (MonadThrow) 167 | import Control.Monad.Cont 168 | import Control.Monad.Primitive 169 | import Control.Monad.Trans.Control 170 | import Control.Monad.Trans.Either (EitherT(..), left) 171 | import Data.Builder (Builder(builderToLazy), ToBuilder(..)) 172 | import Data.ByteString (ByteString) 173 | import Data.IOData (IOData(hGetChunk, hPut)) 174 | import Data.List (unfoldr) 175 | import Data.MonoTraversable 176 | import Data.NonNull as NonNull (NonNull, fromNullable) 177 | import Data.Semigroup (Any(..), All(..), Monoid(..), Semigroup((<>))) 178 | import Data.Sequences as Seq (SemiSequence(..), singleton, 179 | IsSequence(break, drop, dropWhile, 180 | fromList, splitAt)) 181 | import Data.Sequences (LazySequence(fromChunks, toChunks)) 182 | import qualified Data.Streaming.Filesystem as F 183 | import Data.Text (Text) 184 | import Data.Text.Encoding (encodeUtf8) 185 | import Data.Traversable (Traversable) 186 | import qualified Data.Vector.Generic as V 187 | import qualified Data.Vector.Generic.Mutable as VM 188 | import Data.Word (Word8) 189 | import System.FilePath (()) 190 | import System.IO (stdout, stdin, stderr, openFile, hClose, 191 | Handle, IOMode(ReadMode, WriteMode)) 192 | import System.Random.MWC as MWC (Gen, Variate(uniform), 193 | createSystemRandom) 194 | 195 | yieldMany :: (Monad m, MonoFoldable mono) => mono -> Source m (Element mono) 196 | yieldMany xs = source $ \z yield -> ofoldlM yield z xs 197 | 198 | sourceList :: Monad m => [a] -> Source m a 199 | sourceList xs = source $ \z yield -> foldM yield z xs 200 | 201 | unfoldC :: forall m a b. Monad m => (b -> Maybe (a, b)) -> b -> Source m a 202 | unfoldC = (sourceList .) . Data.List.unfoldr 203 | 204 | enumFromToC :: forall m a. (Monad m, Enum a, Eq a) => a -> a -> Source m a 205 | enumFromToC = (sourceList .) . enumFromTo 206 | 207 | iterateC :: forall m a. Monad m => (a -> a) -> a -> Source m a 208 | iterateC = (sourceList .) . iterate 209 | 210 | repeatC :: forall m a. Monad m => a -> Source m a 211 | repeatC = sourceList . Prelude.repeat 212 | 213 | replicateC :: forall m a. Monad m => Int -> a -> Source m a 214 | replicateC = (sourceList .) . Prelude.replicate 215 | 216 | sourceLazy :: (Monad m, LazySequence lazy strict) => lazy -> Source m strict 217 | sourceLazy = sourceList . toChunks 218 | 219 | repeatMC :: forall m a. Monad m => m a -> Source m a 220 | repeatMC x = source go 221 | where 222 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 223 | go z yield = loop z 224 | where 225 | loop r = loop =<< yield r =<< lift x 226 | 227 | repeatWhileMC :: forall m a. Monad m => m a -> (a -> Bool) -> Source m a 228 | repeatWhileMC m f = source go 229 | where 230 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 231 | go z yield = loop z 232 | where 233 | loop r = do 234 | x <- lift m 235 | if f x 236 | then loop =<< yield r x 237 | else return r 238 | 239 | replicateMC :: forall m a. Monad m => Int -> m a -> Source m a 240 | replicateMC n m = source $ go n 241 | where 242 | go :: Int -> r -> (r -> a -> EitherT r m r) -> EitherT r m r 243 | go i z yield = loop i z 244 | where 245 | loop n' r | n' > 0 = loop (n' - 1) =<< yield r =<< lift m 246 | loop _ r = return r 247 | 248 | sourceHandle :: forall m a. (MonadIO m, MonoFoldable a, IOData a) => Handle -> Source m a 249 | sourceHandle h = source go 250 | where 251 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 252 | go z yield = loop z 253 | where 254 | loop y = do 255 | x <- liftIO $ hGetChunk h 256 | if onull x 257 | then return y 258 | else loop =<< yield y x 259 | {-# SPECIALIZE sourceHandle :: (MonoFoldable a, IOData a) => Handle -> Source IO a #-} 260 | 261 | sourceFile :: (MonadBaseControl IO m, MonadIO m, MonoFoldable a, IOData a) 262 | => FilePath -> Source m a 263 | sourceFile path = source $ \z yield -> 264 | liftBaseOp (bracket (openFile path ReadMode) hClose) 265 | (\h -> runSource (sourceHandle h) z yield) 266 | {-# SPECIALIZE sourceFile :: (MonoFoldable a, IOData a) => FilePath -> Source IO a #-} 267 | 268 | sourceIOHandle :: (MonadBaseControl IO m, MonadIO m, MonoFoldable a, IOData a) 269 | => IO Handle -> Source m a 270 | sourceIOHandle f = source $ \z yield -> 271 | liftBaseOp (bracket f hClose) $ \h -> 272 | runSource (sourceHandle h) z yield 273 | {-# SPECIALIZE sourceIOHandle :: (MonoFoldable a, IOData a) => IO Handle -> Source IO a #-} 274 | 275 | stdinC :: (MonadBaseControl IO m, MonadIO m, MonoFoldable a, IOData a) => Source m a 276 | stdinC = sourceHandle stdin 277 | {-# SPECIALIZE stdinC :: (MonoFoldable a, IOData a) => Source IO a #-} 278 | 279 | initRepeat :: Monad m => m seed -> (seed -> m a) -> Source m a 280 | initRepeat mseed f = source $ \z yield -> 281 | lift mseed >>= \seed -> runSource (repeatMC (f seed)) z yield 282 | 283 | initReplicate :: Monad m => m seed -> (seed -> m a) -> Int -> Source m a 284 | initReplicate mseed f n = source $ \z yield -> 285 | lift mseed >>= \seed -> runSource (replicateMC n (f seed)) z yield 286 | 287 | sourceRandom :: (Variate a, MonadIO m) => Source m a 288 | sourceRandom = 289 | initRepeat (liftIO MWC.createSystemRandom) (liftIO . MWC.uniform) 290 | 291 | sourceRandomN :: (Variate a, MonadIO m) => Int -> Source m a 292 | sourceRandomN = 293 | initReplicate (liftIO MWC.createSystemRandom) (liftIO . MWC.uniform) 294 | 295 | sourceRandomGen :: (Variate a, MonadBase base m, PrimMonad base) 296 | => Gen (PrimState base) -> Source m a 297 | sourceRandomGen gen = initRepeat (return gen) (liftBase . MWC.uniform) 298 | 299 | sourceRandomNGen :: (Variate a, MonadBase base m, PrimMonad base) 300 | => Gen (PrimState base) -> Int -> Source m a 301 | sourceRandomNGen gen = initReplicate (return gen) (liftBase . MWC.uniform) 302 | 303 | sourceDirectory :: forall m. MonadBaseControl IO m 304 | => FilePath -> Source m FilePath 305 | sourceDirectory dir = source $ \z yield -> 306 | liftBaseOp (bracket (F.openDirStream dir) F.closeDirStream) 307 | (go z yield) 308 | where 309 | go :: r -> (r -> FilePath -> EitherT r m r) -> F.DirStream -> EitherT r m r 310 | go z yield ds = loop z 311 | where 312 | loop r = do 313 | mfp <- liftBase $ F.readDirStream ds 314 | case mfp of 315 | Nothing -> return r 316 | Just fp -> loop =<< yield r (dir fp) 317 | {-# SPECIALIZE sourceDirectory :: FilePath -> Source IO FilePath #-} 318 | 319 | sourceDirectoryDeep :: forall m. MonadBaseControl IO m 320 | => Bool -> FilePath -> Source m FilePath 321 | sourceDirectoryDeep followSymlinks startDir = source go 322 | where 323 | go :: r -> (r -> FilePath -> EitherT r m r) -> EitherT r m r 324 | go z yield = start startDir z 325 | where 326 | start dir r = runSource (sourceDirectory dir) r entry 327 | entry r fp = do 328 | ft <- liftBase $ F.getFileType fp 329 | case ft of 330 | F.FTFile -> yield r fp 331 | F.FTFileSym -> yield r fp 332 | F.FTDirectory -> start fp r 333 | F.FTDirectorySym 334 | | followSymlinks -> start fp r 335 | | otherwise -> return r 336 | F.FTOther -> return r 337 | {-# SPECIALIZE sourceDirectoryDeep :: Bool -> FilePath -> Source IO FilePath #-} 338 | 339 | dropC :: Monad m => Int -> Conduit a m a 340 | dropC n = conduitWith n go 341 | where 342 | go (r, n') _ _ | n' > 0 = return (r, n' - 1) 343 | go (r, _) yield x = yield r x 344 | 345 | dropCE :: (Monad m, IsSequence seq) => Index seq -> Conduit seq m seq 346 | dropCE n = conduitWith n go 347 | where 348 | go (r, n') yield s 349 | | onull y = return (r, n' - xn) 350 | | otherwise = yield r y 351 | where 352 | (x, y) = Seq.splitAt n' s 353 | xn = n' - fromIntegral (olength x) 354 | 355 | dropWhileC :: Monad m => (a -> Bool) -> Conduit a m a 356 | dropWhileC f = conduitWith f go 357 | where 358 | go (r, k) _ x | k x = return (r, k) 359 | -- Change out the predicate for one that always fails 360 | go (r, _) yield x = fmap (const (const False)) <$> yield r x 361 | 362 | dropWhileCE :: (Monad m, IsSequence seq) 363 | => (Element seq -> Bool) 364 | -> Conduit seq m seq 365 | dropWhileCE f = conduitWith f go 366 | where 367 | go (r, k) yield s 368 | | onull x = return (r, k) 369 | | otherwise = fmap (const (const False)) <$> yield r s 370 | where 371 | x = Seq.dropWhile k s 372 | 373 | foldC :: (Monad m, Monoid a) => Sink a m a 374 | foldC = foldMapC id 375 | 376 | foldCE :: (Monad m, MonoFoldable mono, Monoid (Element mono)) 377 | => Sink mono m (Element mono) 378 | foldCE = foldlC (\acc mono -> acc `mappend` ofoldMap id mono) mempty 379 | 380 | foldlC :: Monad m => (a -> b -> a) -> a -> Sink b m a 381 | foldlC f z = sink z ((return .) . f) 382 | 383 | foldlCE :: (Monad m, MonoFoldable mono) 384 | => (a -> Element mono -> a) -> a -> Sink mono m a 385 | foldlCE f = foldlC (ofoldl' f) 386 | 387 | foldMapC :: (Monad m, Monoid b) => (a -> b) -> Sink a m b 388 | foldMapC f = foldlC (\acc x -> acc `mappend` f x) mempty 389 | 390 | foldMapCE :: (Monad m, MonoFoldable mono, Monoid w) 391 | => (Element mono -> w) -> Sink mono m w 392 | foldMapCE = foldMapC . ofoldMap 393 | 394 | allC :: Monad m => (a -> Bool) -> Sink a m Bool 395 | allC f = liftM getAll `liftM` foldMapC (All . f) 396 | 397 | allCE :: (Monad m, MonoFoldable mono) 398 | => (Element mono -> Bool) -> Sink mono m Bool 399 | allCE = allC . oall 400 | 401 | anyC :: Monad m => (a -> Bool) -> Sink a m Bool 402 | anyC f = liftM getAny `liftM` foldMapC (Any . f) 403 | 404 | anyCE :: (Monad m, MonoFoldable mono) 405 | => (Element mono -> Bool) -> Sink mono m Bool 406 | anyCE = anyC . oany 407 | 408 | andC :: Monad m => Sink Bool m Bool 409 | andC = allC id 410 | 411 | andCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) 412 | => Sink mono m Bool 413 | andCE = allCE id 414 | 415 | orC :: Monad m => Sink Bool m Bool 416 | orC = anyC id 417 | 418 | orCE :: (Monad m, MonoFoldable mono, Element mono ~ Bool) 419 | => Sink mono m Bool 420 | orCE = anyCE id 421 | 422 | elemC :: (Monad m, Eq a) => a -> Sink a m Bool 423 | elemC x = anyC (== x) 424 | 425 | elemCE :: (Monad m, MonoFoldable seq, Eq (Element seq)) => Element seq -> Sink seq m Bool 426 | elemCE = anyC . oelem 427 | 428 | notElemC :: (Monad m, Eq a) => a -> Sink a m Bool 429 | notElemC x = allC (/= x) 430 | 431 | notElemCE :: (Monad m, MonoFoldable seq, Eq (Element seq)) => Element seq -> Sink seq m Bool 432 | notElemCE = allC . onotElem 433 | 434 | produceList :: Monad m => ([a] -> b) -> Sink a m b 435 | produceList f = 436 | liftM (f . ($ [])) . sink id (\front x -> return (front . (x:))) 437 | 438 | sinkLazy :: (Monad m, LazySequence lazy strict) => Sink strict m lazy 439 | sinkLazy = produceList fromChunks 440 | 441 | sinkList :: Monad m => Sink a m [a] 442 | sinkList = produceList id 443 | 444 | sinkVector :: (MonadBase base m, V.Vector v a, PrimMonad base) 445 | => Sink a m (v a) 446 | sinkVector = undefined 447 | 448 | sinkBuilder :: (Monad m, Monoid builder, ToBuilder a builder) 449 | => Sink a m builder 450 | sinkBuilder = foldMapC toBuilder 451 | 452 | sinkLazyBuilder :: (Monad m, Monoid builder, ToBuilder a builder, 453 | Builder builder lazy) 454 | => Sink a m lazy 455 | sinkLazyBuilder = liftM builderToLazy . foldMapC toBuilder 456 | 457 | sinkNull :: Monad m => Sink a m () 458 | sinkNull _ = return () 459 | 460 | awaitNonNull :: (Monad m, MonoFoldable a) => Conduit a m (Maybe (NonNull a)) 461 | awaitNonNull = conduit $ \r yield x -> 462 | maybe (return r) (yield r . Just) (NonNull.fromNullable x) 463 | 464 | headCE :: (Monad m, IsSequence seq) => Sink seq m (Maybe (Element seq)) 465 | headCE = undefined 466 | 467 | -- jww (2014-06-07): These two cannot be implemented without leftover support. 468 | -- peekC :: Monad m => Sink a m (Maybe a) 469 | -- peekC = undefined 470 | 471 | -- peekCE :: (Monad m, MonoFoldable mono) => Sink mono m (Maybe (Element mono)) 472 | -- peekCE = undefined 473 | 474 | lastC :: Monad m => Sink a m (Maybe a) 475 | lastC = sink Nothing (const (return . Just)) 476 | 477 | lastCE :: (Monad m, IsSequence seq) => Sink seq m (Maybe (Element seq)) 478 | lastCE = undefined 479 | 480 | lengthC :: (Monad m, Num len) => Sink a m len 481 | lengthC = foldlC (\x _ -> x + 1) 0 482 | 483 | lengthCE :: (Monad m, Num len, MonoFoldable mono) => Sink mono m len 484 | lengthCE = foldlC (\x y -> x + fromIntegral (olength y)) 0 485 | 486 | lengthIfC :: (Monad m, Num len) => (a -> Bool) -> Sink a m len 487 | lengthIfC f = foldlC (\cnt a -> if f a then cnt + 1 else cnt) 0 488 | 489 | lengthIfCE :: (Monad m, Num len, MonoFoldable mono) 490 | => (Element mono -> Bool) -> Sink mono m len 491 | lengthIfCE f = foldlCE (\cnt a -> if f a then cnt + 1 else cnt) 0 492 | 493 | maximumC :: (Monad m, Ord a) => Sink a m (Maybe a) 494 | maximumC = sink Nothing $ \r y -> return $ Just $ maybe y (max y) r 495 | 496 | maximumCE :: (Monad m, MonoFoldable seq) => Sink seq m (Maybe (Element seq)) 497 | maximumCE = undefined 498 | 499 | minimumC :: (Monad m, Ord a) => Sink a m (Maybe a) 500 | minimumC = sink Nothing $ \r y -> return $ Just $ maybe y (min y) r 501 | 502 | minimumCE :: (Monad m, MonoFoldable seq) => Sink seq m (Maybe (Element seq)) 503 | minimumCE = undefined 504 | 505 | -- jww (2014-06-07): These two cannot be implemented without leftover support. 506 | -- nullC :: Monad m => Sink a m Bool 507 | -- nullC = undefined 508 | 509 | -- nullCE :: (Monad m, MonoFoldable mono) => Sink mono m Bool 510 | -- nullCE = undefined 511 | 512 | sumC :: (Monad m, Num a) => Sink a m a 513 | sumC = foldlC (+) 0 514 | 515 | sumCE :: (Monad m, MonoFoldable mono, Num (Element mono)) 516 | => Sink mono m (Element mono) 517 | sumCE = undefined 518 | 519 | productC :: (Monad m, Num a) => Sink a m a 520 | productC = foldlC (*) 1 521 | 522 | productCE :: (Monad m, MonoFoldable mono, Num (Element mono)) 523 | => Sink mono m (Element mono) 524 | productCE = undefined 525 | 526 | findC :: Monad m => (a -> Bool) -> Sink a m (Maybe a) 527 | findC f = sink Nothing $ \r x -> if f x then left (Just x) else return r 528 | 529 | mapM_C :: Monad m => (a -> m ()) -> Sink a m () 530 | mapM_C f = sink () (const $ lift . f) 531 | 532 | mapM_CE :: (Monad m, MonoFoldable mono) 533 | => (Element mono -> m ()) -> Sink mono m () 534 | mapM_CE = undefined 535 | 536 | foldMC :: Monad m => (a -> b -> m a) -> a -> Sink b m a 537 | foldMC f = flip sink ((lift .) . f) 538 | 539 | foldMCE :: (Monad m, MonoFoldable mono) 540 | => (a -> Element mono -> m a) -> a -> Sink mono m a 541 | foldMCE = undefined 542 | 543 | foldMapMC :: (Monad m, Monoid w) => (a -> m w) -> Sink a m w 544 | foldMapMC f = foldMC (\acc x -> (acc `mappend`) `liftM` f x) mempty 545 | 546 | foldMapMCE :: (Monad m, MonoFoldable mono, Monoid w) 547 | => (Element mono -> m w) -> Sink mono m w 548 | foldMapMCE = undefined 549 | 550 | sinkFile :: (MonadBaseControl IO m, MonadIO m, IOData a) 551 | => FilePath -> Sink a m () 552 | sinkFile fp = sinkIOHandle (liftIO $ openFile fp WriteMode) 553 | 554 | sinkHandle :: (MonadIO m, IOData a) => Handle -> Sink a m () 555 | sinkHandle = mapM_C . hPut 556 | 557 | sinkIOHandle :: (MonadBaseControl IO m, MonadIO m, IOData a) 558 | => IO Handle -> Sink a m () 559 | sinkIOHandle alloc = liftBaseOp (bracket alloc hClose) . flip sinkHandle 560 | 561 | printC :: (Show a, MonadIO m) => Sink a m () 562 | printC = mapM_C (liftIO . print) 563 | 564 | stdoutC :: (MonadIO m, IOData a) => Sink a m () 565 | stdoutC = sinkHandle stdout 566 | 567 | stderrC :: (MonadIO m, IOData a) => Sink a m () 568 | stderrC = sinkHandle stderr 569 | 570 | mapC :: Monad m => (a -> b) -> Conduit a m b 571 | mapC = fmap 572 | 573 | mapCE :: (Monad m, Functor f) => (a -> b) -> Conduit (f a) m (f b) 574 | mapCE = undefined 575 | 576 | omapCE :: (Monad m, MonoFunctor mono) 577 | => (Element mono -> Element mono) -> Conduit mono m mono 578 | omapCE = undefined 579 | 580 | concatMapC :: (Monad m, MonoFoldable mono) 581 | => (a -> mono) -> Conduit a m (Element mono) 582 | concatMapC f = conduit $ \r yield -> ofoldlM yield r . f 583 | 584 | concatMapCE :: (Monad m, MonoFoldable mono, Monoid w) 585 | => (Element mono -> w) -> Conduit mono m w 586 | concatMapCE = undefined 587 | 588 | takeC :: Monad m => Int -> Conduit a m a 589 | takeC n = conduitWith n go 590 | where 591 | go (z', n') yield x 592 | | n' > 1 = next 593 | | n' > 0 = left =<< next 594 | | otherwise = left (z', 0) 595 | where 596 | next = fmap pred <$> yield z' x 597 | 598 | takeCE :: (Monad m, IsSequence seq) => Index seq -> Conduit seq m seq 599 | takeCE = undefined 600 | 601 | -- | This function reads one more element than it yields, which would be a 602 | -- problem if Sinks were monadic, as they are in conduit or pipes. There is 603 | -- no such concept as "resuming where the last conduit left off" in this 604 | -- library. 605 | takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a 606 | takeWhileC f = conduitWith f go 607 | where 608 | go (z', k) yield x | k x = yield z' x 609 | go (z', _) _ _ = left (z', const False) 610 | 611 | takeWhileCE :: (Monad m, IsSequence seq) 612 | => (Element seq -> Bool) -> Conduit seq m seq 613 | takeWhileCE = undefined 614 | 615 | takeExactlyC :: Monad m => Int -> Conduit a m b -> Conduit a m b 616 | takeExactlyC = undefined 617 | 618 | takeExactlyCE :: (Monad m, IsSequence a) 619 | => Index a -> Conduit a m b -> Conduit a m b 620 | takeExactlyCE = undefined 621 | 622 | concatC :: (Monad m, MonoFoldable mono) => Conduit mono m (Element mono) 623 | concatC = awaitForever yieldMany 624 | 625 | filterC :: Monad m => (a -> Bool) -> Conduit a m a 626 | filterC f = awaitForever $ \x -> if f x then return x else skip 627 | 628 | filterCE :: (IsSequence seq, Monad m) 629 | => (Element seq -> Bool) -> Conduit seq m seq 630 | filterCE = undefined 631 | 632 | mapWhileC :: Monad m => (a -> Maybe b) -> Conduit a m b 633 | mapWhileC f = awaitForever $ \x -> case f x of Just y -> return y; _ -> close 634 | 635 | -- | Collect elements into a vector until the size @maxSize@ is reached, then 636 | -- yield that vector downstream. 637 | conduitVector :: (MonadBase base m, V.Vector v a, PrimMonad base) 638 | => Int -> Conduit a m (v a) 639 | conduitVector maxSize src = source $ \z yield -> do 640 | mv <- liftBase $ VM.new maxSize 641 | EitherT $ do 642 | eres <- runEitherT $ runSource src (z, 0) $ \(r, i :: Int) x -> EitherT $ 643 | if i >= maxSize 644 | then do 645 | v <- liftBase $ V.unsafeFreeze mv 646 | runEitherT $ rewrap (, 0) $ yield r v 647 | else do 648 | liftBase $ VM.write mv i x 649 | return $ Right (r, i + 1) 650 | case eres of 651 | Left (z', _) -> return $ Left z' 652 | Right (z', i) 653 | | i > 0 -> do 654 | v <- V.slice 0 i <$> liftBase (V.unsafeFreeze mv) 655 | runEitherT $ yield z' v 656 | | otherwise -> return $ Right z' 657 | {-# SPECIALIZE conduitVector :: (V.Vector v a) => Int -> Conduit a IO (v a) #-} 658 | 659 | scanlC :: Monad m => (a -> b -> a) -> a -> Conduit b m a 660 | scanlC = undefined 661 | 662 | concatMapAccumC :: Monad m => (a -> accum -> (accum, [b])) -> accum -> Conduit a m b 663 | concatMapAccumC = undefined 664 | 665 | intersperseC :: Monad m => a -> Source m a -> Source m a 666 | intersperseC s src = source $ \z yield -> EitherT $ do 667 | eres <- runEitherT $ runSource src (Nothing, z) $ \(my, r) x -> 668 | case my of 669 | Nothing -> return (Just x, r) 670 | Just y -> do 671 | r' <- rewrap (Nothing,) $ yield r y 672 | rewrap (Just x,) $ yield (snd r') s 673 | case eres of 674 | Left (_, r) -> return $ Left r 675 | Right (Nothing, r) -> return $ Right r 676 | Right (Just x, r) -> runEitherT $ yield r x 677 | 678 | encodeBase64C :: Monad m => Conduit ByteString m ByteString 679 | encodeBase64C = undefined 680 | 681 | decodeBase64C :: Monad m => Conduit ByteString m ByteString 682 | decodeBase64C = undefined 683 | 684 | encodeBase64URLC :: Monad m => Conduit ByteString m ByteString 685 | encodeBase64URLC = undefined 686 | 687 | decodeBase64URLC :: Monad m => Conduit ByteString m ByteString 688 | decodeBase64URLC = undefined 689 | 690 | encodeBase16C :: Monad m => Conduit ByteString m ByteString 691 | encodeBase16C = undefined 692 | 693 | decodeBase16C :: Monad m => Conduit ByteString m ByteString 694 | decodeBase16C = undefined 695 | 696 | mapMC :: Monad m => (a -> m b) -> Conduit a m b 697 | mapMC f = (>>= lift . f) 698 | 699 | mapMCE :: (Monad m, Traversable f) => (a -> m b) -> Conduit (f a) m (f b) 700 | mapMCE = undefined 701 | 702 | omapMCE :: (Monad m, MonoTraversable mono) 703 | => (Element mono -> m (Element mono)) -> Conduit mono m mono 704 | omapMCE = undefined 705 | 706 | concatMapMC :: (Monad m, MonoFoldable mono) 707 | => (a -> m mono) -> Conduit a m (Element mono) 708 | concatMapMC f = awaitForever $ yieldMany <=< lift . f 709 | 710 | filterMC :: Monad m => (a -> m Bool) -> Conduit a m a 711 | filterMC f = awaitForever $ \x -> do 712 | res <- lift $ f x 713 | if res 714 | then return x 715 | else skip 716 | 717 | filterMCE :: (Monad m, IsSequence seq) 718 | => (Element seq -> m Bool) -> Conduit seq m seq 719 | filterMCE = undefined 720 | 721 | iterMC :: Monad m => (a -> m ()) -> Conduit a m a 722 | iterMC = undefined 723 | 724 | scanlMC :: Monad m => (a -> b -> m a) -> a -> Conduit b m a 725 | scanlMC = undefined 726 | 727 | concatMapAccumMC :: Monad m 728 | => (a -> accum -> m (accum, [b])) -> accum -> Conduit a m b 729 | concatMapAccumMC = undefined 730 | 731 | encodeUtf8C :: Monad m => Conduit Text m ByteString 732 | encodeUtf8C = mapC encodeUtf8 733 | 734 | decodeUtf8C :: MonadThrow m => Conduit ByteString m Text 735 | decodeUtf8C = undefined 736 | 737 | lineC :: (Monad m, IsSequence seq, Element seq ~ Char) 738 | => Conduit seq m o -> Conduit seq m o 739 | lineC = undefined 740 | 741 | lineAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8) 742 | => Conduit seq m o -> Conduit seq m o 743 | lineAsciiC = undefined 744 | 745 | unlinesC :: (Monad m, IsSequence seq, Element seq ~ Char) 746 | => Conduit seq m seq 747 | unlinesC = concatMapC (: [Seq.singleton '\n']) 748 | 749 | unlinesAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8) 750 | => Conduit seq m seq 751 | unlinesAsciiC = concatMapC (: [Seq.singleton 10]) 752 | 753 | linesUnboundedC_ :: forall m seq. (Monad m, IsSequence seq, Eq (Element seq), Semigroup seq) 754 | => Element seq -> Conduit seq m seq 755 | linesUnboundedC_ sep src = source $ \z yield -> EitherT $ do 756 | eres <- runEitherT $ runSource src (z, n) (go yield) 757 | case eres of 758 | Left (r, _) -> return $ Left r 759 | Right (r, t) 760 | | onull t -> return $ Right r 761 | | otherwise -> runEitherT $ yield r t 762 | where 763 | n = Seq.fromList [] 764 | 765 | go :: (r -> seq -> EitherT r m r) -> (r, seq) -> seq 766 | -> EitherT (r, seq) m (r, seq) 767 | go yield = loop 768 | where 769 | loop (r, t') t 770 | | onull y = return (r, t <> t') 771 | | otherwise = do 772 | r' <- rewrap (, n) $ yield r (t' <> x) 773 | loop r' (Seq.drop 1 y) 774 | where 775 | (x, y) = Seq.break (== sep) t 776 | 777 | linesUnboundedC :: (Monad m, IsSequence seq, Element seq ~ Char, Semigroup seq) 778 | => Conduit seq m seq 779 | linesUnboundedC = linesUnboundedC_ '\n' 780 | 781 | linesUnboundedAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8, Semigroup seq) 782 | => Conduit seq m seq 783 | linesUnboundedAsciiC = linesUnboundedC_ 10 784 | 785 | linesC :: (Monad m, IsSequence seq, Element seq ~ Char, Semigroup seq) 786 | => Conduit seq m seq 787 | linesC = linesUnboundedC 788 | 789 | linesAsciiC :: (Monad m, IsSequence seq, Element seq ~ Word8, Semigroup seq) 790 | => Conduit seq m seq 791 | linesAsciiC = linesUnboundedAsciiC 792 | 793 | -- | Keep taking from an @MVar (Maybe a)@ until it yields 'Nothing'. 794 | sourceMaybeMVar :: forall m a. MonadIO m => MVar (Maybe a) -> Source m a 795 | sourceMaybeMVar var = source go 796 | where 797 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 798 | go z yield = loop z 799 | where 800 | loop r = do 801 | mx <- liftIO $ takeMVar var 802 | case mx of 803 | Nothing -> return r 804 | Just x -> loop =<< yield r x 805 | 806 | -- | Keep taking from an @TMVar (Maybe a)@ until it yields 'Nothing'. 807 | sourceMaybeTMVar :: forall a. TMVar (Maybe a) -> Source STM a 808 | sourceMaybeTMVar var = source go 809 | where 810 | go :: r -> (r -> a -> EitherT r STM r) -> EitherT r STM r 811 | go z yield = loop z 812 | where 813 | loop r = do 814 | mx <- lift $ takeTMVar var 815 | case mx of 816 | Nothing -> return r 817 | Just x -> loop =<< yield r x 818 | 819 | asyncC :: (MonadBaseControl IO m, Monad m) 820 | => (a -> m b) -> Conduit a m (Async (StM m b)) 821 | asyncC f = awaitForever $ lift . async . f 822 | 823 | sourceSTM :: forall container a. (container a -> STM a) 824 | -> (container a -> STM Bool) 825 | -> container a 826 | -> Source STM a 827 | sourceSTM getter tester chan = source go 828 | where 829 | go :: r -> (r -> a -> EitherT r STM r) -> EitherT r STM r 830 | go z yield = loop z 831 | where 832 | loop r = do 833 | x <- lift $ getter chan 834 | r' <- yield r x 835 | mt <- lift $ tester chan 836 | if mt 837 | then return r' 838 | else loop r' 839 | 840 | -- | A Source for exhausting a TChan, but blocks if it is initially empty. 841 | sourceTChan :: forall a. TChan a -> Source STM a 842 | sourceTChan = sourceSTM readTChan isEmptyTChan 843 | 844 | sourceTQueue :: forall a. TQueue a -> Source STM a 845 | sourceTQueue = sourceSTM readTQueue isEmptyTQueue 846 | 847 | sourceTBQueue :: forall a. TBQueue a -> Source STM a 848 | sourceTBQueue = sourceSTM readTBQueue isEmptyTBQueue 849 | 850 | untilMC :: forall m a. Monad m => m a -> m Bool -> Source m a 851 | untilMC m f = source go 852 | where 853 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 854 | go z yield = loop z 855 | where 856 | loop r = do 857 | x <- lift m 858 | r' <- yield r x 859 | c <- lift f 860 | if c then loop r' else return r' 861 | 862 | whileMC :: forall m a. Monad m => m Bool -> m a -> Source m a 863 | whileMC f m = source go 864 | where 865 | go :: r -> (r -> a -> EitherT r m r) -> EitherT r m r 866 | go z yield = loop z 867 | where 868 | loop r = do 869 | c <- lift f 870 | if c 871 | then lift m >>= yield r >>= loop 872 | else return r 873 | 874 | zipSinks :: forall a m r r'. (MonadBaseControl IO m, MonadIO m) 875 | => Sink a m r -> Sink a m r' -> Sink a m (r, r') 876 | zipSinks sink1 sink2 src = do 877 | x <- liftIO newEmptyMVar 878 | y <- liftIO newEmptyMVar 879 | withAsync (sink1 $ sourceMaybeMVar x) $ \a -> 880 | withAsync (sink2 $ sourceMaybeMVar y) $ \b -> do 881 | _ <- runEitherT $ runSource src () $ \() val -> do 882 | liftIO $ putMVar x (Just val) 883 | liftIO $ putMVar y (Just val) 884 | liftIO $ putMVar x Nothing 885 | liftIO $ putMVar y Nothing 886 | waitBoth a b 887 | {-# SPECIALIZE zipSinks :: Sink a IO r -> Sink a IO r' -> Sink a IO (r, r') #-} 888 | --------------------------------------------------------------------------------