conduit-1.0.13/0000755000000000000000000000000012273655254011442 5ustar0000000000000000conduit-1.0.13/LICENSE0000644000000000000000000000207512273655254012453 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.0.13/Setup.lhs0000644000000000000000000000016212273655254013251 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain conduit-1.0.13/conduit.cabal0000644000000000000000000001227112273655254014076 0ustar0000000000000000Name: conduit Version: 1.0.13 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, and fits in the same general solution space as @enumerator@\/@iteratee@ and @pipes@. For a tutorial, please visit . . Release history: . [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. 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/random flag nohandles default: False Description: experimental code to use raw system calls in place of handles. Not recommended for general use Library if os(windows) cpp-options: -DCABAL_OS_WINDOWS other-modules: System.Win32File else other-modules: System.PosixFile if flag(nohandles) cpp-options: -DNO_HANDLES Exposed-modules: Data.Conduit Data.Conduit.Binary Data.Conduit.Text Data.Conduit.List Data.Conduit.Lazy Data.Conduit.Internal Data.Conduit.Util Data.Conduit.Lift Build-depends: base >= 4.3 && < 5 , resourcet >= 0.4.3 && < 0.5 , lifted-base >= 0.1 , transformers-base >= 0.4.1 && < 0.5 , monad-control >= 0.3.1 && < 0.4 , containers , transformers >= 0.2.2 && < 0.4 , mtl , bytestring >= 0.9 , text >= 0.11 , void >= 0.5.5 , mmorph , directory ghc-options: -Wall test-suite test hs-source-dirs: test main-is: main.hs type: exitcode-stdio-1.0 cpp-options: -DTEST build-depends: conduit , base , hspec >= 1.3 , QuickCheck , bytestring , transformers , mtl , text , resourcet , void ghc-options: -Wall --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 source-repository head type: git location: git://github.com/snoyberg/conduit.git conduit-1.0.13/test/0000755000000000000000000000000012273655254012421 5ustar0000000000000000conduit-1.0.13/test/random0000644000000000000000000000200012273655254013614 0ustar0000000000000000cnP_t9pJ!ؖ|9UuރHim@B ̅7eŧ/QYѣE >QQ5oa𻵵C/@p:0翏 VE9V˰.z= [@1&e&#b*v\^XXW$ījrv+4 Aϲ )|;ٔE^59g'1uJ'k5|UKπ@Xˠ Dޑ0ȜfkI^<켏3M[#tpJRkQg)@ߘ6Q?Z͖; 3C?dIAE*9&xJ42N), (<*>)) import Data.Functor.Identity (Identity,runIdentity) import Control.Monad (forever, void) import Data.Void (Void) import qualified Control.Concurrent.MVar as M import Control.Monad.Error (catchError, throwError, Error) (@=?) :: (Eq a, Show a) => a -> a -> IO () (@=?) = flip shouldBe -- Quickcheck property for testing equivalence of list processing -- functions and their conduit counterparts equivToList :: Eq b => ([a] -> [b]) -> CI.Conduit a Identity b -> [a] -> Bool equivToList f conduit xs = f xs == runIdentity (CL.sourceList xs C.$$ conduit C.=$= CL.consume) main :: IO () main = hspec $ do describe "data loss rules" $ do it "consumes the source to quickly" $ do x <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do strings <- CL.map show C.=$ CL.take 5 liftIO $ putStr $ unlines strings CL.fold (+) 0 40 `shouldBe` x it "correctly consumes a chunked resource" $ do x <- runResourceT $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) C.$$ do strings <- CL.map show C.=$ CL.take 5 liftIO $ putStr $ unlines strings CL.fold (+) 0 40 `shouldBe` x describe "filter" $ do it "even" $ do x <- runResourceT $ CL.sourceList [1..10] C.$$ CL.filter even C.=$ CL.consume x `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 "scanl" $ equivToList (tail . scanl (+) 0 :: [Int]->[Int]) (CL.scanl (\a s -> (a+s,a+s)) 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 "scanl" $ equivToList (tail . scanl (+) 0 :: [Int]->[Int]) (CL.scanlM (\a s -> return (a+s,a+s)) 0) 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 <- runResourceT $ CL.sourceList [1..10] C.$$ CL.fold (+) (0 :: Int) x `shouldBe` sum [1..10] prop "is idempotent" $ \list -> (runST $ CL.sourceList list C.$$ CL.fold (+) (0 :: Int)) == sum list describe "foldMap" $ do it "sums 1..10" $ do Sum x <- CL.sourceList [1..(10 :: Int)] C.$$ CL.foldMap Sum x `shouldBe` sum [1..10] it "preserves order" $ do x <- CL.sourceList [[4],[2],[3],[1]] C.$$ CL.foldMap (++[(9 :: Int)]) x `shouldBe` [4,9,2,9,3,9,1,9] describe "foldMapM" $ do it "sums 1..10" $ do Sum x <- CL.sourceList [1..(10 :: Int)] C.$$ CL.foldMapM (return . Sum) x `shouldBe` sum [1..10] it "preserves order" $ do x <- CL.sourceList [[4],[2],[3],[1]] C.$$ 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 <- CL.unfold f seed C.$$ CL.consume let y = DL.unfoldr f seed x `shouldBe` y describe "Monoid instance for Source" $ do it "mappend" $ do x <- runResourceT $ (CL.sourceList [1..5 :: Int] `mappend` CL.sourceList [6..10]) C.$$ CL.fold (+) 0 x `shouldBe` sum [1..10] it "mconcat" $ do x <- runResourceT $ mconcat [ CL.sourceList [1..5 :: Int] , CL.sourceList [6..10] , CL.sourceList [11..20] ] C.$$ CL.fold (+) 0 x `shouldBe` sum [1..20] describe "file access" $ do it "read" $ do bs <- S.readFile "conduit.cabal" bss <- runResourceT $ CB.sourceFile "conduit.cabal" C.$$ CL.consume bs @=? S.concat bss it "read range" $ do S.writeFile "tmp" "0123456789" bss <- runResourceT $ CB.sourceFileRange "tmp" (Just 2) (Just 3) C.$$ CL.consume S.concat bss `shouldBe` "234" it "write" $ do runResourceT $ CB.sourceFile "conduit.cabal" C.$$ CB.sinkFile "tmp" bs1 <- S.readFile "conduit.cabal" bs2 <- S.readFile "tmp" bs1 @=? bs2 it "conduit" $ do runResourceT $ CB.sourceFile "conduit.cabal" C.$= CB.conduitFile "tmp" C.$$ CB.sinkFile "tmp2" bs1 <- S.readFile "conduit.cabal" bs2 <- S.readFile "tmp" bs3 <- S.readFile "tmp2" bs1 @=? bs2 bs1 @=? bs3 describe "zipping" $ do it "zipping two small lists" $ do res <- runResourceT $ C.zipSources (CL.sourceList [1..10]) (CL.sourceList [11..12]) C.$$ CL.consume res @=? zip [1..10 :: Int] [11..12 :: Int] describe "zipping sinks" $ do it "take all" $ do res <- runResourceT $ CL.sourceList [1..10] C.$$ C.zipSinks CL.consume CL.consume res @=? ([1..10 :: Int], [1..10 :: Int]) it "take fewer on left" $ do res <- runResourceT $ CL.sourceList [1..10] C.$$ C.zipSinks (CL.take 4) CL.consume res @=? ([1..4 :: Int], [1..10 :: Int]) it "take fewer on right" $ do res <- runResourceT $ CL.sourceList [1..10] C.$$ C.zipSinks CL.consume (CL.take 4) res @=? ([1..10 :: Int], [1..4 :: Int]) describe "Monad instance for Sink" $ do it "binding" $ do x <- runResourceT $ CL.sourceList [1..10] C.$$ do _ <- CL.take 5 CL.fold (+) (0 :: Int) x `shouldBe` sum [6..10] describe "Applicative instance for Sink" $ do it "<$> and <*>" $ do x <- runResourceT $ CL.sourceList [1..10] C.$$ (+) <$> pure 5 <*> CL.fold (+) (0 :: Int) x `shouldBe` sum [1..10] + 5 describe "resumable sources" $ do it "simple" $ do (x, y, z) <- runResourceT $ 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 <- runResourceT $ CL.sourceList [1..10] C.$= CL.map (* 2) C.$$ CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, left >+>" $ do x <- runResourceT $ CI.ConduitM (CI.unConduitM (CL.sourceList [1..10]) CI.>+> CI.injectLeftovers (CI.unConduitM $ CL.map (* 2))) C.$$ CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "map, right" $ do x <- runResourceT $ CL.sourceList [1..10] C.$$ CL.map (* 2) C.=$ CL.fold (+) 0 x `shouldBe` 2 * sum [1..10 :: Int] it "groupBy" $ do let input = [1::Int, 1, 2, 3, 3, 3, 4, 5, 5] x <- runResourceT $ CL.sourceList input C.$$ CL.groupBy (==) C.=$ CL.consume x `shouldBe` DL.groupBy (==) input it "groupBy (nondup begin/end)" $ do let input = [1::Int, 2, 3, 3, 3, 4, 5] x <- runResourceT $ CL.sourceList input C.$$ CL.groupBy (==) C.=$ CL.consume x `shouldBe` DL.groupBy (==) input it "mapMaybe" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] x <- runResourceT $ CL.sourceList input C.$$ CL.mapMaybe ((+2) <$>) C.=$ CL.consume x `shouldBe` [3, 4, 5] it "mapMaybeM" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] x <- runResourceT $ CL.sourceList input C.$$ CL.mapMaybeM (return . ((+2) <$>)) C.=$ CL.consume x `shouldBe` [3, 4, 5] it "catMaybes" $ do let input = [Just (1::Int), Nothing, Just 2, Nothing, Just 3] x <- runResourceT $ CL.sourceList input C.$$ CL.catMaybes C.=$ CL.consume x `shouldBe` [1, 2, 3] it "concatMap" $ do let input = [1, 11, 21] x <- runResourceT $ CL.sourceList input C.$$ CL.concatMap (\i -> enumFromTo i (i + 9)) C.=$ CL.fold (+) (0 :: Int) x `shouldBe` sum [1..30] it "bind together" $ do let conduit = CL.map (+ 5) C.=$= CL.map (* 2) x <- runResourceT $ CL.sourceList [1..10] C.$= conduit C.$$ CL.fold (+) 0 x `shouldBe` sum (map (* 2) $ map (+ 5) [1..10 :: Int]) #if !FAST describe "isolate" $ do it "bound to resumable source" $ do (x, y) <- runResourceT $ do let src1 = CL.sourceList [1..10 :: Int] (src2, x) <- src1 C.$= CL.isolate 5 C.$$+ CL.consume y <- src2 C.$$+- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [] it "bound to sink, non-resumable" $ do (x, y) <- runResourceT $ do CL.sourceList [1..10 :: Int] C.$$ do x <- CL.isolate 5 C.=$ CL.consume y <- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [6..10] it "bound to sink, resumable" $ do (x, y) <- runResourceT $ do let src1 = CL.sourceList [1..10 :: Int] (src2, x) <- src1 C.$$+ CL.isolate 5 C.=$ CL.consume y <- src2 C.$$+- CL.consume return (x, y) x `shouldBe` [1..5] y `shouldBe` [6..10] it "consumes all data" $ do x <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do CL.isolate 5 C.=$ CL.sinkNull CL.consume x `shouldBe` [6..10] describe "lazy" $ do it' "works inside a ResourceT" $ runResourceT $ do counter <- liftIO $ I.newIORef 0 let incr i = do istate <- liftIO $ I.newIORef $ Just (i :: Int) let loop = do res <- liftIO $ I.atomicModifyIORef istate ((,) Nothing) case res of Nothing -> return () Just x -> do count <- liftIO $ I.atomicModifyIORef counter (\j -> (j + 1, j + 1)) liftIO $ count `shouldBe` i C.yield x loop loop nums <- CLazy.lazyConsume $ mconcat $ map incr [1..10] liftIO $ nums `shouldBe` [1..10] it' "returns nothing outside ResourceT" $ do bss <- runResourceT $ CLazy.lazyConsume $ CB.sourceFile "test/main.hs" bss `shouldBe` [] it' "works with pure sources" $ do nums <- CLazy.lazyConsume $ forever $ C.yield 1 take 100 nums `shouldBe` replicate 100 (1 :: Int) 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 <- runResourceT $ CL.sourceList [1..11 :: Int] C.$= CL.sequence sumSink C.$$ 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 <- runResourceT $ CL.sourceList [1..11 :: Int] C.$= CL.sequence sumSink C.$$ CL.consume res `shouldBe` [3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 11] #endif describe "peek" $ do it "works" $ do (a, b) <- runResourceT $ CL.sourceList [1..10 :: Int] C.$$ do a <- CL.peek b <- CL.consume return (a, b) (a, b) `shouldBe` (Just 1, [1..10]) describe "text" $ do let go enc tenc tdec cenc = do prop (enc ++ " single chunk") $ \chars -> runST $ runExceptionT_ $ do let tl = TL.pack chars lbs = tenc tl src = CL.sourceList $ L.toChunks lbs ts <- src C.$= CT.decode cenc C.$$ CL.consume return $ TL.fromChunks ts == tl prop (enc ++ " many chunks") $ \chars -> runIdentity $ runExceptionT_ $ do let tl = TL.pack chars lbs = tenc tl src = mconcat $ map (CL.sourceList . return . S.singleton) $ L.unpack lbs ts <- src C.$= CT.decode cenc C.$$ CL.consume return $ TL.fromChunks ts == tl -- Check whether raw bytes are decoded correctly, in -- particular that Text decoding produces an error if -- and only if Conduit does. prop (enc ++ " raw bytes") $ \bytes -> let lbs = L.pack bytes src = CL.sourceList $ L.toChunks lbs etl = C.runException $ src C.$= CT.decode cenc C.$$ CL.consume tl' = tdec lbs in case etl of (Left _) -> (return $! TL.toStrict tl') `shouldThrow` anyException (Right tl) -> TL.fromChunks tl `shouldBe` tl' prop (enc ++ " encoding") $ \chars -> runIdentity $ runExceptionT_ $ do let tss = map T.pack chars lbs = tenc $ TL.fromChunks tss src = mconcat $ map (CL.sourceList . return) tss bss <- src C.$= CT.encode cenc C.$$ CL.consume return $ L.fromChunks bss == lbs go "utf8" TLE.encodeUtf8 TLE.decodeUtf8 CT.utf8 go "utf16_le" TLE.encodeUtf16LE TLE.decodeUtf16LE CT.utf16_le go "utf16_be" TLE.encodeUtf16BE TLE.decodeUtf16BE CT.utf16_be go "utf32_le" TLE.encodeUtf32LE TLE.decodeUtf32LE CT.utf32_le go "utf32_be" TLE.encodeUtf32BE TLE.decodeUtf32BE CT.utf32_be describe "text lines" $ do it "works across split lines" $ (CL.sourceList [T.pack "abc", T.pack "d\nef"] C.$= CT.lines C.$$ CL.consume) == [[T.pack "abcd", T.pack "ef"]] it "works with multiple lines in an item" $ (CL.sourceList [T.pack "ab\ncd\ne"] C.$= CT.lines C.$$ CL.consume) == [[T.pack "ab", T.pack "cd", T.pack "e"]] it "works with ending on a newline" $ (CL.sourceList [T.pack "ab\n"] C.$= CT.lines C.$$ CL.consume) == [[T.pack "ab"]] it "works with ending a middle item on a newline" $ (CL.sourceList [T.pack "ab\n", T.pack "cd\ne"] C.$= CT.lines C.$$ CL.consume) == [[T.pack "ab", T.pack "cd", T.pack "e"]] it "is not too eager" $ do x <- CL.sourceList ["foobarbaz", error "ignore me"] C.$$ CT.decode CT.utf8 C.=$ CL.head x `shouldBe` Just "foobarbaz" describe "text lines bounded" $ do it "works across split lines" $ (CL.sourceList [T.pack "abc", T.pack "d\nef"] C.$= CT.linesBounded 80 C.$$ CL.consume) == [[T.pack "abcd", T.pack "ef"]] it "works with multiple lines in an item" $ (CL.sourceList [T.pack "ab\ncd\ne"] C.$= CT.linesBounded 80 C.$$ CL.consume) == [[T.pack "ab", T.pack "cd", T.pack "e"]] it "works with ending on a newline" $ (CL.sourceList [T.pack "ab\n"] C.$= CT.linesBounded 80 C.$$ CL.consume) == [[T.pack "ab"]] it "works with ending a middle item on a newline" $ (CL.sourceList [T.pack "ab\n", T.pack "cd\ne"] C.$= CT.linesBounded 80 C.$$ CL.consume) == [[T.pack "ab", T.pack "cd", T.pack "e"]] it "is not too eager" $ do x <- CL.sourceList ["foobarbaz", error "ignore me"] C.$$ CT.decode CT.utf8 C.=$ CL.head x `shouldBe` Just "foobarbaz" it "throws an exception when lines are too long" $ do x <- C.runExceptionT $ CL.sourceList ["hello\nworld"] C.$$ CT.linesBounded 4 C.=$ CL.consume show x `shouldBe` show (Left $ CT.LengthExceeded 4 :: Either CT.TextException ()) describe "binary isolate" $ do it "works" $ do bss <- runResourceT $ CL.sourceList (replicate 1000 "X") C.$= CB.isolate 6 C.$$ CL.consume S.concat bss `shouldBe` "XXXXXX" describe "unbuffering" $ do it "works" $ do x <- runResourceT $ do let src1 = CL.sourceList [1..10 :: Int] (src2, ()) <- src1 C.$$+ CL.drop 5 src2 C.$$+- CL.fold (+) 0 x `shouldBe` sum [6..10] describe "operators" $ do it "only use =$=" $ runIdentity ( CL.sourceList [1..10 :: Int] C.$$ CL.map (+ 1) C.=$ CL.map (subtract 1) C.=$ CL.mapM (return . (* 2)) C.=$ CL.map (`div` 2) C.=$ CL.fold (+) 0 ) `shouldBe` sum [1..10] it "only use =$" $ runIdentity ( CL.sourceList [1..10 :: Int] C.$$ CL.map (+ 1) C.=$ CL.map (subtract 1) C.=$ CL.map (* 2) C.=$ CL.map (`div` 2) C.=$ CL.fold (+) 0 ) `shouldBe` sum [1..10] it "chain" $ do x <- CL.sourceList [1..10 :: Int] C.$= CL.map (+ 1) C.$= CL.map (+ 1) C.$= CL.map (+ 1) C.$= CL.map (subtract 3) C.$= CL.map (* 2) C.$$ CL.map (`div` 2) C.=$ CL.map (+ 1) C.=$ CL.map (+ 1) C.=$ CL.map (+ 1) C.=$ CL.map (subtract 3) C.=$ CL.fold (+) 0 x `shouldBe` sum [1..10] describe "properly using binary file reading" $ do it "sourceFile" $ do x <- runResourceT $ CB.sourceFile "test/random" C.$$ CL.consume lbs <- L.readFile "test/random" L.fromChunks x `shouldBe` lbs describe "binary head" $ do let go lbs = do x <- CB.head case (x, L.uncons lbs) of (Nothing, Nothing) -> return True (Just y, Just (z, lbs')) | y == z -> go lbs' _ -> return False prop "works" $ \bss' -> let bss = map S.pack bss' in runIdentity $ CL.sourceList bss C.$$ go (L.fromChunks bss) describe "binary takeWhile" $ do prop "works" $ \bss' -> let bss = map S.pack bss' in runIdentity $ do bss2 <- CL.sourceList bss C.$$ CB.takeWhile (>= 5) C.=$ CL.consume return $ L.fromChunks bss2 == L.takeWhile (>= 5) (L.fromChunks bss) prop "leftovers present" $ \bss' -> let bss = map S.pack bss' in runIdentity $ do result <- CL.sourceList bss C.$$ do x <- CB.takeWhile (>= 5) C.=$ CL.consume y <- CL.consume return (S.concat x, S.concat y) let expected = S.span (>= 5) $ S.concat bss if result == expected then return True else error $ show (S.concat bss, result, expected) describe "binary dropWhile" $ do prop "works" $ \bss' -> let bss = map S.pack bss' in runIdentity $ do bss2 <- CL.sourceList bss C.$$ do CB.dropWhile (< 5) CL.consume return $ L.fromChunks bss2 == L.dropWhile (< 5) (L.fromChunks bss) describe "binary take" $ do let go n l = CL.sourceList l C.$$ do a <- CB.take n b <- CL.consume return (a, b) -- Taking nothing should result in an empty Bytestring it "nothing" $ do (a, b) <- runResourceT $ go 0 ["abc", "defg"] a `shouldBe` L.empty L.fromChunks b `shouldBe` "abcdefg" it "normal" $ do (a, b) <- runResourceT $ go 4 ["abc", "defg"] a `shouldBe` "abcd" L.fromChunks b `shouldBe` "efg" -- Taking exactly the data that is available should result in no -- leftover. it "all" $ do (a, b) <- runResourceT $ go 7 ["abc", "defg"] a `shouldBe` "abcdefg" b `shouldBe` [] -- Take as much as possible. it "more" $ do (a, b) <- runResourceT $ go 10 ["abc", "defg"] a `shouldBe` "abcdefg" b `shouldBe` [] describe "normalFuseLeft" $ do it "does not double close conduit" $ do x <- runResourceT $ do let src = CL.sourceList ["foobarbazbin"] src C.$= CB.isolate 10 C.$$ CL.head x `shouldBe` Just "foobarbazb" describe "binary" $ do prop "lines" $ \bss' -> runIdentity $ do let bss = map S.pack bss' bs = S.concat bss src = CL.sourceList bss res <- src C.$$ CB.lines C.=$ CL.consume return $ S8.lines bs == res describe "termination" $ do it "terminates early" $ do let src = forever $ C.yield () x <- src C.$$ 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 <- C.runResourceT $ src C.$$ CL.isolate 10 C.=$ 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 <- C.runResourceT $ (src' >> src) C.$$ CL.isolate 10 C.=$ 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 <- C.runResourceT $ src C.$$ CL.isolate 10 C.=$ 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 <- C.runResourceT $ (src' >> src) C.$$ CL.isolate 10 C.=$ 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.ConduitM adder' residue x = CI.ConduitM $ CI.Leftover (CI.Done ()) x _ <- C.yield 1 C.$$ adder x <- I.readIORef ref x `shouldBe` [1 :: Int] I.writeIORef ref [] _ <- C.yield 1 C.$$ (residue 2 >> residue 3) >> adder y <- I.readIORef ref y `shouldBe` [1, 2, 3] I.writeIORef ref [] _ <- C.yield 1 C.$$ residue 2 >> (residue 3 >> adder) 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 <- src is C.$$ CL.take 10 x `shouldBe` [1..10 :: Int] it' "yield terminates (2)" $ do let is = [1..10] ++ undefined x <- mapM_ C.yield is C.$$ CL.take 10 x `shouldBe` [1..10 :: Int] it' "yieldOr finalizer called" $ do iref <- I.newIORef (0 :: Int) let src = mapM_ (\i -> C.yieldOr i $ I.writeIORef iref i) [1..] src C.$$ CL.isolate 10 C.=$ CL.sinkNull x <- I.readIORef iref x `shouldBe` 10 describe "upstream results" $ do it' "works" $ do 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 <- C.mapOutput (+ 1) (CL.sourceList [1..10 :: Int]) C.$$ CL.fold (+) 0 x `shouldBe` sum [2..11] it' "mapOutputMaybe" $ do x <- C.mapOutputMaybe (\i -> if even i then Just i else Nothing) (CL.sourceList [1..10 :: Int]) C.$$ CL.fold (+) 0 x `shouldBe` sum [2, 4..10] it' "mapInput" $ do xyz <- (CL.sourceList $ map show [1..10 :: Int]) C.$$ do (x, y) <- C.mapInput read (Just . show) $ ((do x <- CL.isolate 5 C.=$ CL.fold (+) 0 y <- CL.peek return (x :: Int, y :: Maybe Int)) :: C.Sink Int 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 <- CL.sourceList [1..10 :: Int] C.$$ CI.ConduitM CI.idP C.=$ CL.fold (+) 0 y <- CL.sourceList [1..10 :: Int] C.$$ CL.fold (+) 0 x `shouldBe` y it' "right identity" $ do x <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ CI.unConduitM $ CL.fold (+) 0) CI.>+> CI.idP y <- CI.runPipe $ mapM_ CI.yield [1..10 :: Int] CI.>+> (CI.injectLeftovers $ CI.unConduitM $ 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 <- CL.iterate (+ 1) (1 :: Int) C.$$ CL.isolate 10 C.=$ CL.fold (+) 0 res `shouldBe` sum [1..10] describe "unwrapResumable" $ do it' "works" $ do ref <- I.newIORef (0 :: Int) let src0 = do C.yieldOr () $ I.writeIORef ref 1 C.yieldOr () $ I.writeIORef ref 2 C.yieldOr () $ I.writeIORef ref 3 (rsrc0, Just ()) <- src0 C.$$+ CL.head x0 <- I.readIORef ref x0 `shouldBe` 0 (_, final) <- C.unwrapResumable rsrc0 x1 <- I.readIORef ref x1 `shouldBe` 0 final x2 <- I.readIORef ref x2 `shouldBe` 1 it' "isn't called twice" $ do ref <- I.newIORef (0 :: Int) let src0 = do C.yieldOr () $ I.writeIORef ref 1 C.yieldOr () $ I.writeIORef ref 2 (rsrc0, Just ()) <- src0 C.$$+ CL.head x0 <- I.readIORef ref x0 `shouldBe` 0 (src1, final) <- C.unwrapResumable rsrc0 x1 <- I.readIORef ref x1 `shouldBe` 0 Just () <- src1 C.$$ CL.head x2 <- I.readIORef ref x2 `shouldBe` 2 final x3 <- I.readIORef ref x3 `shouldBe` 2 it' "source isn't used" $ do ref <- I.newIORef (0 :: Int) let src0 = do C.yieldOr () $ I.writeIORef ref 1 C.yieldOr () $ I.writeIORef ref 2 (rsrc0, Just ()) <- src0 C.$$+ CL.head x0 <- I.readIORef ref x0 `shouldBe` 0 (src1, final) <- C.unwrapResumable rsrc0 x1 <- I.readIORef ref x1 `shouldBe` 0 () <- src1 C.$$ return () x2 <- I.readIORef ref x2 `shouldBe` 0 final x3 <- I.readIORef ref x3 `shouldBe` 1 describe "injectLeftovers" $ do it "works" $ do let src = mapM_ CI.yield [1..10 :: Int] conduit = CI.injectLeftovers $ CI.unConduitM $ C.awaitForever $ \i -> do js <- CL.take 2 mapM_ C.leftover $ reverse js C.yield i res <- CI.ConduitM (src CI.>+> CI.injectLeftovers conduit) C.$$ CL.consume res `shouldBe` [1..10] describe "up-upstream finalizers" $ do it "pipe" $ do let p1 = CI.await >>= maybe (return ()) CI.yield p2 = idMsg "p2-final" p3 = idMsg "p3-final" idMsg msg = CI.addCleanup (const $ tell [msg]) $ CI.awaitForever CI.yield printer = CI.awaitForever $ lift . tell . return . show src = mapM_ CI.yield [1 :: Int ..] let run' p = execWriter $ CI.runPipe $ printer CI.<+< p CI.<+< src run' (p1 CI.<+< (p2 CI.<+< p3)) `shouldBe` run' ((p1 CI.<+< p2) CI.<+< p3) it "conduit" $ do let p1 = C.await >>= maybe (return ()) C.yield p2 = idMsg "p2-final" p3 = idMsg "p3-final" idMsg msg = C.addCleanup (const $ tell [msg]) $ C.awaitForever C.yield printer = C.awaitForever $ lift . tell . return . show src = CL.sourceList [1 :: Int ..] let run' p = execWriter $ src C.$$ p C.=$ printer run' ((p3 C.=$= p2) C.=$= p1) `shouldBe` run' (p3 C.=$= (p2 C.=$= p1)) describe "monad transformer laws" $ do it "transPipe" $ do let source = CL.sourceList $ replicate 10 () 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 $ source C.$$ C.transPipe (`evalStateT` 1) replaceNum1 C.=$ CL.consume y <- runWriterT $ source C.$$ C.transPipe (`evalStateT` 1) replaceNum2 C.=$ CL.consume x `shouldBe` y describe "text decode" $ do it' "doesn't throw runtime exceptions" $ do let x = runIdentity $ runExceptionT $ C.yield "\x89\x243" C.$$ CT.decode CT.utf8 C.=$ CL.consume case x of Left _ -> return () Right t -> error $ "This should have failed: " ++ show t describe "iterM" $ do prop "behavior" $ \l -> monadicIO $ do let counter ref = CL.iterM (const $ liftIO $ M.modifyMVar_ ref (\i -> return $! i + 1)) v <- run $ do ref <- M.newMVar 0 CL.sourceList l C.$= counter ref C.$$ CL.mapM_ (const $ return ()) 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 <- CL.sourceList (l :: [Int]) C.$= h f C.$$ 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 -> C.Source IO Int src i = CL.sourceList [1..i] sink :: C.Sink Int IO Int sink = CL.fold (+) 0 res <- C.yield 10 C.$$ C.awaitForever (C.toProducer . src) C.=$ (C.toConsumer sink >>= C.yield) C.=$ C.await res `shouldBe` Just (sum [1..10]) describe "sinkCacheLength" $ do it' "works" $ C.runResourceT $ do lbs <- liftIO $ L.readFile "test/main.hs" (len, src) <- CB.sourceLbs lbs C.$$ CB.sinkCacheLength lbs' <- src C.$$ CB.sinkLbs liftIO $ do fromIntegral len `shouldBe` L.length lbs lbs' `shouldBe` lbs fromIntegral len `shouldBe` L.length lbs' describe "Data.Conduit.Binary.mapM_" $ do prop "telling works" $ \bytes -> let lbs = L.pack bytes src = CB.sourceLbs lbs sink = CB.mapM_ (tell . return . S.singleton) bss = execWriter $ src C.$$ sink in L.fromChunks bss == lbs 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 <- mapM_ C.yield input C.$$ conduit C.=$ 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] mapM_ C.yield input C.$$ conduit C.=$ return () x <- I.readIORef ref x `shouldBe` (-1) 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 () (src C.$$ CL.consume) `shouldBe` Right [1, 2, 4 :: Int] describe "finalizers" $ do it "promptness" $ do imsgs <- I.newIORef [] let add x = liftIO $ do msgs <- I.readIORef imsgs I.writeIORef imsgs $ msgs ++ [x] src' = C.bracketP (add "acquire") (const $ add "release") (const $ C.addCleanup (const $ add "inside") (mapM_ C.yield [1..5])) src = do src' C.$= CL.isolate 4 add "computation" sink = CL.mapM (\x -> add (show x) >> return x) C.=$ CL.consume res <- C.runResourceT $ src C.$$ sink msgs <- I.readIORef imsgs -- FIXME this would be better msgs `shouldBe` words "acquire 1 2 3 4 inside release computation" msgs `shouldBe` words "acquire 1 2 3 4 release inside computation" res `shouldBe` [1..4 :: Int] it "left associative" $ do imsgs <- I.newIORef [] let add x = liftIO $ do msgs <- I.readIORef imsgs I.writeIORef imsgs $ msgs ++ [x] p1 = C.bracketP (add "start1") (const $ add "stop1") (const $ add "inside1" >> C.yield ()) p2 = C.bracketP (add "start2") (const $ add "stop2") (const $ add "inside2" >> C.await >>= maybe (return ()) C.yield) p3 = C.bracketP (add "start3") (const $ add "stop3") (const $ add "inside3" >> C.await) res <- C.runResourceT $ (p1 C.$= p2) C.$$ p3 res `shouldBe` Just () msgs <- I.readIORef imsgs msgs `shouldBe` words "start3 inside3 start2 inside2 start1 inside1 stop3 stop2 stop1" it "right associative" $ do imsgs <- I.newIORef [] let add x = liftIO $ do msgs <- I.readIORef imsgs I.writeIORef imsgs $ msgs ++ [x] p1 = C.bracketP (add "start1") (const $ add "stop1") (const $ add "inside1" >> C.yield ()) p2 = C.bracketP (add "start2") (const $ add "stop2") (const $ add "inside2" >> C.await >>= maybe (return ()) C.yield) p3 = C.bracketP (add "start3") (const $ add "stop3") (const $ add "inside3" >> C.await) res <- C.runResourceT $ p1 C.$$ (p2 C.=$ p3) res `shouldBe` Just () msgs <- I.readIORef imsgs msgs `shouldBe` words "start3 inside3 start2 inside2 start1 inside1 stop3 stop2 stop1" describe "dan burton's associative tests" $ do let tellLn = tell . (++ "\n") finallyP fin = CI.addCleanup (const fin) printer = CI.awaitForever $ lift . tellLn . show idMsg msg = finallyP (tellLn msg) CI.idP takeP 0 = return () takeP n = CI.awaitE >>= \ex -> case ex of Left _u -> return () Right i -> CI.yield i >> takeP (pred n) testPipe p = execWriter $ runPipe $ printer <+< p <+< CI.sourceList ([1..] :: [Int]) p1 = takeP (1 :: Int) p2 = idMsg "foo" p3 = idMsg "bar" (<+<) = (CI.<+<) runPipe = CI.runPipe test1L = testPipe $ (p1 <+< p2) <+< p3 test1R = testPipe $ p1 <+< (p2 <+< p3) test2L = testPipe $ (p2 <+< p1) <+< p3 test2R = testPipe $ p2 <+< (p1 <+< p3) test3L = testPipe $ (p2 <+< p3) <+< p1 test3R = testPipe $ p2 <+< (p3 <+< p1) verify testL testR p1' p2' p3' | testL == testR = return () :: IO () | otherwise = error $ unlines [ "FAILURE" , "" , "(" ++ p1' ++ " <+< " ++ p2' ++ ") <+< " ++ p3' , "------------------" , testL , "" , p1' ++ " <+< (" ++ p2' ++ " <+< " ++ p3' ++ ")" , "------------------" , testR ] it "test1" $ verify test1L test1R "p1" "p2" "p3" -- FIXME this is broken it "test2" $ verify test2L test2R "p2" "p1" "p3" it "test3" $ verify test3L test3R "p2" "p3" "p1" describe "Data.Conduit.Lift" $ do it "execStateC" $ do let sink = C.execStateC 0 $ CL.mapM_ $ modify . (+) src = mapM_ C.yield [1..10 :: Int] res <- src C.$$ sink res `shouldBe` sum [1..10] it "execWriterC" $ do let sink = C.execWriterC $ CL.mapM_ $ tell . return src = mapM_ C.yield [1..10 :: Int] res <- src C.$$ sink res `shouldBe` [1..10] it "runErrorC" $ do let sink = C.runErrorC $ do x <- C.catchErrorC (lift $ throwError "foo") return return $ x ++ "bar" res <- return () C.$$ 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 <- src C.$$ sink res `shouldBe` [1 :: Int] describe "exception handling" $ do it "catchC" $ do ref <- I.newIORef 0 let src = do C.catchC (CB.sourceFile "some-file-that-does-not-exist") onErr C.handleC onErr $ CB.sourceFile "conduit.cabal" onErr :: MonadIO m => IOException -> m () onErr _ = liftIO $ I.modifyIORef ref (+ 1) contents <- L.readFile "conduit.cabal" res <- C.runResourceT $ src C.$$ CB.sinkLbs res `shouldBe` contents errCount <- I.readIORef ref errCount `shouldBe` (1 :: Int) it "tryC" $ do ref <- I.newIORef undefined let src = do res1 <- C.tryC $ CB.sourceFile "some-file-that-does-not-exist" res2 <- C.tryC $ CB.sourceFile "conduit.cabal" liftIO $ I.writeIORef ref (res1, res2) contents <- L.readFile "conduit.cabal" res <- C.runResourceT $ src C.$$ CB.sinkLbs res `shouldBe` contents exc <- I.readIORef ref case exc :: (Either IOException (), Either IOException ()) of (Left _, Right ()) -> return () _ -> error $ show exc it' :: String -> IO () -> Spec it' = it data DummyError = DummyError deriving (Show, Eq) instance Error DummyError conduit-1.0.13/Data/0000755000000000000000000000000012273655254012313 5ustar0000000000000000conduit-1.0.13/Data/Conduit.hs0000644000000000000000000002605712273655254014266 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | If this is your first time with conduit, you should probably start with -- the tutorial: -- . module Data.Conduit ( -- * Core interface -- ** Types Source , Conduit , Sink , ConduitM -- ** Connect/fuse operators , ($$) , ($=) , (=$) , (=$=) -- ** Primitives , await , yield , leftover -- ** Finalization , bracketP , addCleanup , yieldOr -- ** Exception handling , catchC , handleC , tryC -- * Generalized conduit types , Producer , Consumer , toProducer , toConsumer -- * Utility functions , awaitForever , transPipe , mapOutput , mapOutputMaybe , mapInput -- * Connect-and-resume , ResumableSource , ($$+) , ($$++) , ($$+-) , unwrapResumable -- * Flushing , Flush (..) -- * Newtype wrappers -- ** ZipSource , ZipSource (..) , sequenceSources -- ** ZipSink , ZipSink (..) , sequenceSinks -- * Convenience re-exports , ResourceT , MonadResource , MonadThrow (..) , MonadUnsafeIO (..) , runResourceT , ExceptionT (..) , runExceptionT_ , runException , runException_ , MonadBaseControl ) where import Control.Monad.Trans.Resource import Data.Conduit.Internal hiding (await, awaitForever, yield, yieldOr, leftover, bracketP, addCleanup, transPipe, mapOutput, mapOutputMaybe, mapInput) import qualified Data.Conduit.Internal as CI import Control.Monad.Morph (hoist) import Control.Monad (liftM, forever) import Control.Applicative (Applicative (..)) import Data.Traversable (Traversable (..)) -- Define fixity of all our operators infixr 0 $$ infixl 1 $= infixr 2 =$ infixr 2 =$= infixr 0 $$+ infixr 0 $$++ infixr 0 $$+- -- | 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 ($$) #-} -- | Left fuse, combining a source and a conduit together into a new source. -- -- Both the @Source@ and @Conduit@ will be closed when the newly-created -- @Source@ is closed. -- -- Leftover data from the @Conduit@ will be discarded. -- -- Since 0.4.0 ($=) :: Monad m => Source m a -> Conduit a m b -> Source m b ConduitM src $= ConduitM con = ConduitM $ pipeL src con {-# INLINE ($=) #-} -- | Right fuse, combining a conduit and a sink together into a new sink. -- -- Both the @Conduit@ and @Sink@ will be closed when the newly-created @Sink@ -- is closed. -- -- Leftover data returned from the @Sink@ will be discarded. -- -- Since 0.4.0 (=$) :: Monad m => Conduit a m b -> Sink b m c -> Sink a m c ConduitM con =$ ConduitM sink = ConduitM $ pipeL con sink {-# INLINE (=$) #-} -- | Fusion operator, combining two @Conduit@s together into a new @Conduit@. -- -- Both @Conduit@s will be closed when the newly-created @Conduit@ is closed. -- -- Leftover data returned from the right @Conduit@ will be discarded. -- -- Since 0.4.0 (=$=) :: Monad m => Conduit a m b -> ConduitM b c m r -> ConduitM a c m r ConduitM left =$= ConduitM right = ConduitM $ pipeL left right {-# INLINE (=$=) #-} -- | Wait for a single input value from upstream. If no data is available, -- returns @Nothing@. -- -- Since 0.5.0 await :: Monad m => Consumer i m (Maybe i) await = ConduitM CI.await -- | Send a value downstream to the next component to consume. If the -- downstream component terminates, this call will never return control. If you -- would like to register a cleanup function, please use 'yieldOr' instead. -- -- Since 0.5.0 yield :: Monad m => o -- ^ output value -> ConduitM i o m () yield = ConduitM . CI.yield -- | Provide a single piece of leftover input to be consumed by the next -- component in the current monadic binding. -- -- /Note/: it is highly encouraged to only return leftover values from input -- already consumed from upstream. -- -- Since 0.5.0 leftover :: i -> ConduitM i o m () leftover = ConduitM . CI.leftover -- | Perform some allocation and run an inner component. 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 -> (a -> IO ()) -> (a -> ConduitM i o m r) -> ConduitM i o m r bracketP alloc free inside = ConduitM $ CI.bracketP alloc free $ unConduitM . inside -- | Add some code to be run when the given component cleans up. -- -- The supplied cleanup function will be given a @True@ if the component ran to -- completion, or @False@ if it terminated early due to a downstream component -- terminating. -- -- Note that this function is not exception safe. For that, please use -- 'bracketP'. -- -- Since 0.4.1 addCleanup :: Monad m => (Bool -> m ()) -> ConduitM i o m r -> ConduitM i o m r addCleanup f = ConduitM . CI.addCleanup f . unConduitM -- | Similar to 'yield', but additionally takes a finalizer to be run if the -- downstream component terminates. -- -- Since 0.5.0 yieldOr :: Monad m => o -> m () -- ^ finalizer -> ConduitM i o m () yieldOr o m = ConduitM $ CI.yieldOr o m -- | Wait for input forever, calling the given inner component for each piece of -- new input. Returns the upstream result type. -- -- This function is provided as a convenience for the common pattern of -- @await@ing input, checking if it's @Just@ and then looping. -- -- Since 0.5.0 awaitForever :: Monad m => (i -> ConduitM i o m r) -> ConduitM i o m () awaitForever f = ConduitM $ CI.awaitForever (unConduitM . f) -- | Transform the monad that a @ConduitM@ lives in. -- -- Note that the monad transforming function will be run multiple times, -- resulting in unintuitive behavior in some cases. For a fuller treatment, -- please see: -- -- -- -- This function is just a synonym for 'hoist'. -- -- Since 0.4.0 transPipe :: Monad m => (forall a. m a -> n a) -> ConduitM i o m r -> ConduitM i o n r transPipe = hoist -- | Apply a function to all the output values of a @ConduitM@. -- -- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 -- days. It can also be simulated by fusing with the @map@ conduit from -- "Data.Conduit.List". -- -- Since 0.4.1 mapOutput :: Monad m => (o1 -> o2) -> ConduitM i o1 m r -> ConduitM i o2 m r mapOutput f (ConduitM p) = ConduitM $ CI.mapOutput f p -- | Same as 'mapOutput', but use a function that returns @Maybe@ values. -- -- Since 0.5.0 mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> ConduitM i o1 m r -> ConduitM i o2 m r mapOutputMaybe f (ConduitM p) = ConduitM $ CI.mapOutputMaybe f p -- | Apply a function to all the input values of a @ConduitM@. -- -- Since 0.5.0 mapInput :: Monad m => (i1 -> i2) -- ^ map initial input to new input -> (i2 -> Maybe i1) -- ^ map new leftovers to initial leftovers -> ConduitM i2 o m r -> ConduitM i1 o m r mapInput f g (ConduitM p) = ConduitM $ CI.mapInput f g p -- | The connect-and-resume operator. This does not close the @Source@, but -- instead returns it to be used again. This allows a @Source@ to be used -- incrementally in a large program, without forcing the entire program to live -- in the @Sink@ monad. -- -- Mnemonic: connect + do more. -- -- Since 0.5.0 ($$+) :: Monad m => Source m a -> Sink a m b -> m (ResumableSource m a, b) src $$+ sink = connectResume (ResumableSource src (return ())) sink {-# INLINE ($$+) #-} -- | Continue processing after usage of @$$+@. -- -- Since 0.5.0 ($$++) :: Monad m => ResumableSource m a -> Sink a m b -> m (ResumableSource m a, b) ($$++) = connectResume {-# INLINE ($$++) #-} -- | Complete processing of a @ResumableSource@. This will run the finalizer -- associated with the @ResumableSource@. In order to guarantee process resource -- finalization, you /must/ use this operator after using @$$+@ and @$$++@. -- -- Since 0.5.0 ($$+-) :: Monad m => ResumableSource m a -> Sink a m b -> m b rsrc $$+- sink = do (ResumableSource _ final, res) <- connectResume rsrc sink final return res {-# INLINE ($$+-) #-} -- | 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 'Sink's which allows -- to combine sinks together, generalizing 'zipSources'. A combined sources -- 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 yielding by all of the @Source@s. -- -- Implemented on top of @ZipSource@, see that data type for more details. -- -- 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. -- -- 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 conduit-1.0.13/Data/Conduit/0000755000000000000000000000000012273655254013720 5ustar0000000000000000conduit-1.0.13/Data/Conduit/Binary.hs0000644000000000000000000003234312273655254015505 0ustar0000000000000000{-# LANGUAGE CPP, RankNTypes #-} -- | Functions for interacting with bytes. module Data.Conduit.Binary ( -- * Files and @Handle@s -- | Note that most of these functions live in the @MonadResource@ monad -- to ensure resource finalization even in the presence of exceptions. In -- order to run such code, you will need to use @runResourceT@. -- ** Sources sourceFile , sourceHandle , sourceHandleUnsafe , sourceIOHandle , sourceFileRange , sourceHandleRange -- ** Sinks , sinkFile , sinkHandle , sinkIOHandle -- ** Conduits , conduitFile , conduitHandle -- * Utilities -- ** Sources , sourceLbs -- ** Sinks , head , dropWhile , take , drop , sinkCacheLength , sinkLbs , mapM_ -- ** Conduits , isolate , takeWhile , Data.Conduit.Binary.lines ) where import Prelude hiding (head, take, drop, takeWhile, dropWhile, mapM_) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Conduit import Data.Conduit.List (sourceList, consume) import Control.Exception (assert, finally) import Control.Monad (unless, when) import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Resource (allocate, release) import Control.Monad.Trans.Class (lift) import qualified System.IO as IO import Data.Word (Word8, Word64) import Control.Applicative ((<$>)) import System.Directory (getTemporaryDirectory, removeFile) import Data.ByteString.Lazy.Internal (defaultChunkSize) #if CABAL_OS_WINDOWS import qualified System.Win32File as F #elif NO_HANDLES import qualified System.PosixFile as F #endif import Data.ByteString.Internal (ByteString (PS), inlinePerformIO) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Ptr (plusPtr) import Foreign.Storable (peek) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -- | Stream the contents of a file as binary data. -- -- Since 0.3.0 sourceFile :: MonadResource m => FilePath -> Producer m S.ByteString sourceFile fp = #if CABAL_OS_WINDOWS || NO_HANDLES bracketP (F.openRead fp) F.close loop where loop h = liftIO (F.read h) >>= maybe (return ()) (\bs -> yield bs >> loop h) #else sourceIOHandle (IO.openBinaryFile fp IO.ReadMode) #endif -- | 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 0.3.0 sourceHandle :: MonadIO m => IO.Handle -> Producer m S.ByteString 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.0.12 sourceHandleUnsafe :: MonadIO m => IO.Handle -> Source m ByteString 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 closed it as soon as possible. -- -- Since 0.3.0 sourceIOHandle :: MonadResource m => IO IO.Handle -> Producer m S.ByteString sourceIOHandle alloc = bracketP alloc IO.hClose sourceHandle -- | Stream all incoming data to the given 'IO.Handle'. Note that this function -- will /not/ automatically close the @Handle@ when processing completes. -- -- Since 0.3.0 sinkHandle :: MonadIO m => IO.Handle -> Consumer S.ByteString m () sinkHandle h = awaitForever $ liftIO . S.hPut 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 0.3.0 sinkIOHandle :: MonadResource m => IO IO.Handle -> Consumer S.ByteString m () sinkIOHandle alloc = bracketP alloc IO.hClose sinkHandle -- | Stream the contents of a file as binary data, starting from a certain -- offset and only consuming up to a certain number of bytes. -- -- Since 0.3.0 sourceFileRange :: MonadResource m => FilePath -> Maybe Integer -- ^ Offset -> Maybe Integer -- ^ Maximum count -> Producer m S.ByteString sourceFileRange fp offset count = bracketP (IO.openBinaryFile fp IO.ReadMode) IO.hClose (\h -> sourceHandleRange h offset count) -- | Stream the contents of a handle as binary data, starting from a certain -- offset and only consuming up to a certain number of bytes. -- -- Since 1.0.8 sourceHandleRange :: MonadIO m => IO.Handle -> Maybe Integer -- ^ Offset -> Maybe Integer -- ^ Maximum count -> Producer m S.ByteString sourceHandleRange handle offset count = do case offset of Nothing -> return () Just off -> liftIO $ IO.hSeek handle IO.AbsoluteSeek off case count of Nothing -> pullUnlimited Just c -> pullLimited (fromInteger c) where pullUnlimited = do bs <- liftIO $ S.hGetSome handle 4096 if S.null bs then return () else do yield bs pullUnlimited pullLimited c = do bs <- liftIO $ S.hGetSome handle (min c 4096) let c' = c - S.length bs assert (c' >= 0) $ if S.null bs then return () else do yield bs pullLimited c' -- | Stream all incoming data to the given file. -- -- Since 0.3.0 sinkFile :: MonadResource m => FilePath -> Consumer S.ByteString m () #if NO_HANDLES sinkFile fp = bracketP (F.openWrite fp) F.close loop where loop h = awaitForever $ liftIO . F.write h #else sinkFile fp = sinkIOHandle (IO.openBinaryFile fp IO.WriteMode) #endif -- | Stream the contents of the input to a file, and also send it along the -- pipeline. Similar in concept to the Unix command @tee@. -- -- Since 0.3.0 conduitFile :: MonadResource m => FilePath -> Conduit S.ByteString m S.ByteString conduitFile fp = bracketP (IO.openBinaryFile fp IO.WriteMode) IO.hClose conduitHandle -- | Stream the contents of the input to a @Handle@, and also send it along the -- pipeline. Similar in concept to the Unix command @tee@. Like @sourceHandle@, -- does not close the handle on completion. Related to: @conduitFile@. -- -- Since 1.0.9 conduitHandle :: MonadIO m => IO.Handle -> Conduit S.ByteString m S.ByteString conduitHandle h = awaitForever $ \bs -> liftIO (S.hPut h bs) >> yield bs -- | Ensure that only up to the given number of bytes are consume by the inner -- sink. Note that this does /not/ ensure that all of those bytes are in fact -- consumed. -- -- Since 0.3.0 isolate :: Monad m => Int -> Conduit S.ByteString m S.ByteString isolate = loop where loop 0 = return () loop count = do mbs <- await case mbs of Nothing -> return () Just bs -> do let (a, b) = S.splitAt count bs case count - S.length a of 0 -> do unless (S.null b) $ leftover b yield a count' -> assert (S.null b) $ yield a >> loop count' -- | Return the next byte from the stream, if available. -- -- Since 0.3.0 head :: Monad m => Consumer S.ByteString m (Maybe Word8) head = do mbs <- await case mbs of Nothing -> return Nothing Just bs -> case S.uncons bs of Nothing -> head Just (w, bs') -> leftover bs' >> return (Just w) -- | Return all bytes while the predicate returns @True@. -- -- Since 0.3.0 takeWhile :: Monad m => (Word8 -> Bool) -> Conduit S.ByteString m S.ByteString takeWhile p = loop where loop = await >>= maybe (return ()) go go bs | S.null x = next | otherwise = yield x >> next where next = if S.null y then loop else leftover y (x, y) = S.span p bs -- | Ignore all bytes while the predicate returns @True@. -- -- Since 0.3.0 dropWhile :: Monad m => (Word8 -> Bool) -> Consumer S.ByteString m () dropWhile p = loop where loop = do mbs <- await case S.dropWhile p <$> mbs of Nothing -> return () Just bs | S.null bs -> loop | otherwise -> leftover bs -- | Take the given number of bytes, if available. -- -- Since 0.3.0 take :: Monad m => Int -> Consumer S.ByteString m L.ByteString take 0 = return L.empty take n0 = go n0 id where go n front = await >>= maybe (return $ L.fromChunks $ front []) go' where go' bs = case S.length bs `compare` n of LT -> go (n - S.length bs) (front . (bs:)) EQ -> return $ L.fromChunks $ front [bs] GT -> let (x, y) = S.splitAt n bs in assert (not $ S.null y) $ leftover y >> return (L.fromChunks $ front [x]) -- | Drop up to the given number of bytes. -- -- Since 0.5.0 drop :: Monad m => Int -> Consumer S.ByteString m () drop 0 = return () drop n0 = go n0 where go n = await >>= maybe (return ()) go' where go' bs = case S.length bs `compare` n of LT -> go (n - S.length bs) EQ -> return () GT -> let y = S.drop n bs in assert (not $ S.null y) $ leftover y >> return () -- | Split the input bytes into lines. In other words, split on the LF byte -- (10), and strip it from the output. -- -- Since 0.3.0 lines :: Monad m => Conduit S.ByteString m S.ByteString lines = loop id where loop front = await >>= maybe (finish front) (go front) finish front = let final = front S.empty in unless (S.null final) (yield final) go sofar more = case S.uncons second of Just (_, second') -> yield (sofar first) >> go id second' Nothing -> let rest = sofar more in loop $ S.append rest where (first, second) = S.breakByte 10 more -- | Stream the chunks from a lazy bytestring. -- -- Since 0.5.0 sourceLbs :: Monad m => L.ByteString -> Producer m S.ByteString sourceLbs = sourceList . L.toChunks -- | Stream the input data into a temp file and count the number of bytes -- present. When complete, return a new @Source@ reading from the temp file -- together with the length of the input in bytes. -- -- All resources will be cleaned up automatically. -- -- Since 1.0.5 sinkCacheLength :: (MonadResource m1, MonadResource m2) => Sink S.ByteString m1 (Word64, Source m2 S.ByteString) sinkCacheLength = do tmpdir <- liftIO getTemporaryDirectory (releaseKey, (fp, h)) <- allocate (IO.openBinaryTempFile tmpdir "conduit.cache") (\(fp, h) -> IO.hClose h `finally` removeFile fp) len <- sinkHandleLen h liftIO $ IO.hClose h return (len, sourceFile fp >> release releaseKey) where sinkHandleLen :: MonadResource m => IO.Handle -> Sink S.ByteString m Word64 sinkHandleLen h = loop 0 where loop x = await >>= maybe (return x) go where go bs = do liftIO $ S.hPut h bs loop $ x + fromIntegral (S.length bs) -- | Consume a stream of input into a lazy bytestring. Note that no lazy I\/O -- is performed, but rather all content is read into memory strictly. -- -- Since 1.0.5 sinkLbs :: Monad m => Sink S.ByteString m L.ByteString sinkLbs = fmap L.fromChunks consume mapM_BS :: Monad m => (Word8 -> m ()) -> S.ByteString -> m () mapM_BS f (PS fptr offset len) = do let start = unsafeForeignPtrToPtr fptr `plusPtr` offset end = start `plusPtr` len loop ptr | ptr >= end = inlinePerformIO (touchForeignPtr fptr) `seq` return () | otherwise = do f (inlinePerformIO (peek ptr)) loop (ptr `plusPtr` 1) loop start {-# INLINE mapM_BS #-} -- | Perform a computation on each @Word8@ in a stream. -- -- Since 1.0.10 mapM_ :: Monad m => (Word8 -> m ()) -> Consumer S.ByteString m () mapM_ f = awaitForever (lift . mapM_BS f) {-# INLINE mapM_ #-} conduit-1.0.13/Data/Conduit/Util.hs0000644000000000000000000000333712273655254015177 0ustar0000000000000000-- | Various utility functions versions of @conduit@. module Data.Conduit.Util ( -- * Misc zip , zipSources , zipSinks , passthroughSink ) where import Prelude hiding (zip) import Data.Conduit.Internal (Pipe (..), Source, Sink, ConduitM (..), Conduit, awaitForever, yield, await, zipSinks, zipSources) import Data.Void (absurd) import Control.Monad.Trans.Class (lift) -- | Deprecated synonym for 'zipSources'. -- -- Since 0.3.0 zip :: Monad m => Source m a -> Source m b -> Source m (a, b) zip = zipSources {-# DEPRECATED zip "Use zipSources instead" #-} -- | 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.0.10 passthroughSink :: Monad m => Sink i m r -> (r -> m ()) -- ^ finalizer -> Conduit i m i passthroughSink (ConduitM sink0) final = ConduitM $ go [] sink0 where go _ (Done r) = do lift $ final r awaitForever yield go is (Leftover sink i) = go (i:is) sink go _ (HaveOutput _ _ o) = absurd o go is (PipeM mx) = do x <- lift mx go is x go (i:is) (NeedInput next _) = go is (next i) go [] (NeedInput next done) = do mx <- await case mx of Nothing -> go [] (done ()) Just x -> do yield x go [] (next x) conduit-1.0.13/Data/Conduit/Text.hs0000644000000000000000000003263612273655254015212 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} -- | -- Copyright: 2011 Michael Snoyman, 2010-2011 John Millikin -- License: MIT -- -- Handle streams of text. -- -- Parts of this code were taken from enumerator and adapted for conduits. module Data.Conduit.Text ( -- * Text codecs Codec , encode , decode , utf8 , utf16_le , utf16_be , utf32_le , utf32_be , ascii , iso8859_1 , lines , linesBounded , TextException (..) , takeWhile , dropWhile , take , drop , foldLines , withLine ) where import qualified Prelude import Prelude hiding (head, drop, takeWhile, lines, zip, zip3, zipWith, zipWith3, take, dropWhile) import Control.Arrow (first) import qualified Control.Exception as Exc import Data.Bits ((.&.), (.|.), shiftL) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Maybe (catMaybes) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Word (Word8, Word16) import System.IO.Unsafe (unsafePerformIO) import Data.Typeable (Typeable) import Data.Conduit import qualified Data.Conduit.List as CL import Control.Monad.Trans.Class (lift) import Control.Monad (unless,when) -- | A specific character encoding. -- -- Since 0.3.0 data Codec = Codec { codecName :: T.Text , codecEncode :: T.Text -> (B.ByteString, Maybe (TextException, T.Text)) , codecDecode :: B.ByteString -> (T.Text, Either (TextException, B.ByteString) B.ByteString) } instance Show Codec where showsPrec d c = showParen (d > 10) $ showString "Codec " . shows (codecName c) -- | Emit each line separately -- -- Since 0.4.1 lines :: Monad m => Conduit T.Text m T.Text lines = loop id where loop front = await >>= maybe (finish front) (go front) finish front = let final = front T.empty in unless (T.null final) (yield final) go sofar more = case T.uncons second of Just (_, second') -> yield (sofar first') >> go id second' Nothing -> let rest = sofar more in loop $ T.append rest where (first', second) = T.break (== '\n') more -- | Variant of the lines function with an integer parameter. -- The text length of any emitted line -- never exceeds the value of the paramater. Whenever -- this is about to happen a LengthExceeded exception -- is thrown. This function should be used instead -- of the lines function whenever we are dealing with -- user input (e.g. a file upload) because we can't be sure that -- user input won't have extraordinarily large lines which would -- require large amounts of memory if consumed. linesBounded :: MonadThrow m => Int -> Conduit T.Text m T.Text linesBounded maxLineLen = loop 0 id where loop len front = await >>= maybe (finish front) (go len front) finish front = let final = front T.empty in unless (T.null final) (yield final) go len sofar more = case T.uncons second of Just (_, second') -> do let toYield = sofar first' len' = len + T.length first' when (len' > maxLineLen) (lift $ monadThrow (LengthExceeded maxLineLen)) yield toYield go 0 id second' Nothing -> do let len' = len + T.length more when (len' > maxLineLen) $ (lift $ monadThrow (LengthExceeded maxLineLen)) let rest = sofar more loop len' $ T.append rest where (first', second) = T.break (== '\n') more -- | Convert text into bytes, using the provided codec. If the codec is -- not capable of representing an input character, an exception will be thrown. -- -- Since 0.3.0 encode :: MonadThrow m => Codec -> Conduit T.Text m B.ByteString encode codec = CL.mapM $ \t -> do let (bs, mexc) = codecEncode codec t maybe (return bs) (monadThrow . fst) mexc -- | Convert bytes into text, using the provided codec. If the codec is -- not capable of decoding an input byte sequence, an exception will be thrown. -- -- Since 0.3.0 decode :: MonadThrow m => Codec -> Conduit B.ByteString m T.Text decode codec = loop id where loop front = await >>= maybe (finish front) (go front) finish front = case B.uncons $ front B.empty of Nothing -> return () Just (w, _) -> lift $ monadThrow $ DecodeException codec w go front bs' = case extra of Left (exc, _) -> lift $ monadThrow exc Right bs'' -> yield text >> loop (B.append bs'') where (text, extra) = codecDecode codec bs bs = front bs' -- | -- Since 0.3.0 data TextException = DecodeException Codec Word8 | EncodeException Codec Char | LengthExceeded Int | TextException Exc.SomeException deriving (Show, Typeable) instance Exc.Exception TextException byteSplits :: B.ByteString -> [(B.ByteString, B.ByteString)] byteSplits bytes = loop (B.length bytes) where loop 0 = [(B.empty, bytes)] loop n = B.splitAt n bytes : loop (n - 1) splitSlowly :: (B.ByteString -> T.Text) -> B.ByteString -> (T.Text, Either (TextException, B.ByteString) B.ByteString) splitSlowly dec bytes = valid where valid = firstValid (Prelude.map decFirst splits) splits = byteSplits bytes firstValid = Prelude.head . catMaybes tryDec = tryEvaluate . dec decFirst (a, b) = case tryDec a of Left _ -> Nothing Right text -> Just (text, case tryDec b of Left exc -> Left (TextException exc, b) -- this case shouldn't occur, since splitSlowly -- is only called when parsing failed somewhere Right _ -> Right B.empty) -- | -- Since 0.3.0 utf8 :: Codec utf8 = Codec name enc dec where name = T.pack "UTF-8" enc text = (TE.encodeUtf8 text, Nothing) dec bytes = case splitQuickly bytes >>= maybeDecode of Just (text, extra) -> (text, Right extra) Nothing -> splitSlowly TE.decodeUtf8 bytes -- Whether the given byte is a continuation byte. isContinuation byte = byte .&. 0xC0 == 0x80 -- The number of continuation bytes needed by the given -- non-continuation byte. Returns -1 for an illegal UTF-8 -- non-continuation byte and the whole split quickly must fail so -- as the input is passed to TE.decodeUtf8, which will issue a -- suitable error. required x0 | x0 .&. 0x80 == 0x00 = 0 | x0 .&. 0xE0 == 0xC0 = 1 | x0 .&. 0xF0 == 0xE0 = 2 | x0 .&. 0xF8 == 0xF0 = 3 | otherwise = -1 splitQuickly bytes | B.null l || req == -1 = Nothing | req == B.length r = Just (TE.decodeUtf8 bytes, B.empty) | otherwise = Just (TE.decodeUtf8 l', r') where (l, r) = B.spanEnd isContinuation bytes req = required (B.last l) l' = B.init l r' = B.cons (B.last l) r -- | -- Since 0.3.0 utf16_le :: Codec utf16_le = Codec name enc dec where name = T.pack "UTF-16-LE" enc text = (TE.encodeUtf16LE text, Nothing) dec bytes = case splitQuickly bytes of Just (text, extra) -> (text, Right extra) Nothing -> splitSlowly TE.decodeUtf16LE bytes splitQuickly bytes = maybeDecode (loop 0) where maxN = B.length bytes loop n | n == maxN = decodeAll | (n + 1) == maxN = decodeTo n loop n = let req = utf16Required (B.index bytes n) (B.index bytes (n + 1)) decodeMore = loop $! n + req in if n + req > maxN then decodeTo n else decodeMore decodeTo n = first TE.decodeUtf16LE (B.splitAt n bytes) decodeAll = (TE.decodeUtf16LE bytes, B.empty) -- | -- Since 0.3.0 utf16_be :: Codec utf16_be = Codec name enc dec where name = T.pack "UTF-16-BE" enc text = (TE.encodeUtf16BE text, Nothing) dec bytes = case splitQuickly bytes of Just (text, extra) -> (text, Right extra) Nothing -> splitSlowly TE.decodeUtf16BE bytes splitQuickly bytes = maybeDecode (loop 0) where maxN = B.length bytes loop n | n == maxN = decodeAll | (n + 1) == maxN = decodeTo n loop n = let req = utf16Required (B.index bytes (n + 1)) (B.index bytes n) decodeMore = loop $! n + req in if n + req > maxN then decodeTo n else decodeMore decodeTo n = first TE.decodeUtf16BE (B.splitAt n bytes) decodeAll = (TE.decodeUtf16BE bytes, B.empty) utf16Required :: Word8 -> Word8 -> Int utf16Required x0 x1 = required where required = if x >= 0xD800 && x <= 0xDBFF then 4 else 2 x :: Word16 x = (fromIntegral x1 `shiftL` 8) .|. fromIntegral x0 -- | -- Since 0.3.0 utf32_le :: Codec utf32_le = Codec name enc dec where name = T.pack "UTF-32-LE" enc text = (TE.encodeUtf32LE text, Nothing) dec bs = case utf32SplitBytes TE.decodeUtf32LE bs of Just (text, extra) -> (text, Right extra) Nothing -> splitSlowly TE.decodeUtf32LE bs -- | -- Since 0.3.0 utf32_be :: Codec utf32_be = Codec name enc dec where name = T.pack "UTF-32-BE" enc text = (TE.encodeUtf32BE text, Nothing) dec bs = case utf32SplitBytes TE.decodeUtf32BE bs of Just (text, extra) -> (text, Right extra) Nothing -> splitSlowly TE.decodeUtf32BE bs utf32SplitBytes :: (B.ByteString -> T.Text) -> B.ByteString -> Maybe (T.Text, B.ByteString) utf32SplitBytes dec bytes = split where split = maybeDecode (dec toDecode, extra) len = B.length bytes lenExtra = mod len 4 lenToDecode = len - lenExtra (toDecode, extra) = if lenExtra == 0 then (bytes, B.empty) else B.splitAt lenToDecode bytes -- | -- Since 0.3.0 ascii :: Codec ascii = Codec name enc dec where name = T.pack "ASCII" enc text = (bytes, extra) where (safe, unsafe) = T.span (\c -> ord c <= 0x7F) text bytes = B8.pack (T.unpack safe) extra = if T.null unsafe then Nothing else Just (EncodeException ascii (T.head unsafe), unsafe) dec bytes = (text, extra) where (safe, unsafe) = B.span (<= 0x7F) bytes text = T.pack (B8.unpack safe) extra = if B.null unsafe then Right B.empty else Left (DecodeException ascii (B.head unsafe), unsafe) -- | -- Since 0.3.0 iso8859_1 :: Codec iso8859_1 = Codec name enc dec where name = T.pack "ISO-8859-1" enc text = (bytes, extra) where (safe, unsafe) = T.span (\c -> ord c <= 0xFF) text bytes = B8.pack (T.unpack safe) extra = if T.null unsafe then Nothing else Just (EncodeException iso8859_1 (T.head unsafe), unsafe) dec bytes = (T.pack (B8.unpack bytes), Right B.empty) tryEvaluate :: a -> Either Exc.SomeException a tryEvaluate = unsafePerformIO . Exc.try . Exc.evaluate maybeDecode :: (a, b) -> Maybe (a, b) maybeDecode (a, b) = case tryEvaluate a of Left _ -> Nothing Right _ -> Just (a, b) -- | -- -- Since 1.0.8 takeWhile :: Monad m => (Char -> Bool) -> Conduit T.Text m T.Text takeWhile p = loop where loop = await >>= maybe (return ()) go go t = case T.span p t of (x, y) | T.null y -> yield x >> loop | otherwise -> yield x >> leftover y -- | -- -- Since 1.0.8 dropWhile :: Monad m => (Char -> Bool) -> Consumer T.Text m () dropWhile p = loop where loop = await >>= maybe (return ()) go go t | T.null x = loop | otherwise = leftover x where x = T.dropWhile p t -- | -- -- Since 1.0.8 take :: Monad m => Int -> Conduit T.Text m T.Text take = loop where loop i = await >>= maybe (return ()) (go i) go i t | diff == 0 = yield t | diff < 0 = let (x, y) = T.splitAt i t in yield x >> leftover y | otherwise = yield t >> loop diff where diff = i - T.length t -- | -- -- Since 1.0.8 drop :: Monad m => Int -> Consumer T.Text m () drop = loop where loop i = await >>= maybe (return ()) (go i) go i t | diff == 0 = return () | diff < 0 = leftover $ T.drop i t | otherwise = loop diff where diff = i - T.length t -- | -- -- Since 1.0.8 foldLines :: Monad m => (a -> ConduitM T.Text o m a) -> a -> ConduitM T.Text o m a foldLines f = start where start a = CL.peek >>= maybe (return a) (const $ loop $ f a) loop consumer = do a <- takeWhile (/= '\n') =$= do a <- CL.map (T.filter (/= '\r')) =$= consumer CL.sinkNull return a drop 1 start a -- | -- -- Since 1.0.8 withLine :: Monad m => Sink T.Text m a -> Consumer T.Text m (Maybe a) withLine consumer = toConsumer $ do mx <- CL.peek case mx of Nothing -> return Nothing Just _ -> do x <- takeWhile (/= '\n') =$ do x <- CL.map (T.filter (/= '\r')) =$ consumer CL.sinkNull return x drop 1 return $ Just x conduit-1.0.13/Data/Conduit/Internal.hs0000644000000000000000000007566312273655254016051 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImpredicativeTypes #-} module Data.Conduit.Internal ( -- * Types Pipe (..) , ConduitM (..) , Source , Producer , Sink , Consumer , Conduit , ResumableSource (..) -- * Primitives , await , awaitE , awaitForever , yield , yieldOr , leftover -- * Finalization , bracketP , addCleanup -- * Composition , idP , pipe , pipeL , connectResume , runPipe , injectLeftovers , (>+>) , (<+<) -- * Generalizing , sourceToPipe , sinkToPipe , conduitToPipe , toProducer , toConsumer -- * Exceptions , catchP , handleP , tryP , catchC , handleC , tryC -- * Utilities , transPipe , mapOutput , mapOutputMaybe , mapInput , sourceList , withUpstream , unwrapResumable , Data.Conduit.Internal.enumFromTo , zipSinks , zipSources , zipSourcesApp ) where import Control.Applicative (Applicative (..)) import Control.Exception.Lifted as E (Exception, catch) import Control.Monad ((>=>), liftM, ap, when, liftM2) import Control.Monad.Error.Class(MonadError(..)) import Control.Monad.Reader.Class(MonadReader(..)) import Control.Monad.RWS.Class(MonadRWS()) import Control.Monad.Writer.Class(MonadWriter(..)) import Control.Monad.State.Class(MonadState(..)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Base (MonadBase (liftBase)) import Data.Void (Void, absurd) import Data.Monoid (Monoid (mappend, mempty)) import Control.Monad.Trans.Resource import qualified GHC.Exts import qualified Data.IORef as I import Control.Monad.Morph (MFunctor (..)) -- | The underlying datatype for all the types in this package. In has six -- type parameters: -- -- * /l/ is the type of values that may be left over from this @Pipe@. A @Pipe@ -- with no leftovers would use @Void@ here, and one with leftovers would use -- the same type as the /i/ parameter. Leftovers are automatically provided to -- the next @Pipe@ in the monadic chain. -- -- * /i/ is the type of values for this @Pipe@'s input stream. -- -- * /o/ is the type of values for this @Pipe@'s output stream. -- -- * /u/ is the result type from the upstream @Pipe@. -- -- * /m/ is the underlying monad. -- -- * /r/ is the result type. -- -- A basic intuition is that every @Pipe@ produces a stream of output values -- (/o/), and eventually indicates that this stream is terminated by sending a -- result (/r/). On the receiving end of a @Pipe@, these become the /i/ and /u/ -- parameters. -- -- Since 0.5.0 data Pipe l i o u m r = -- | Provide new output to be sent downstream. This constructor has three -- fields: the next @Pipe@ to be used, a finalization function, and the -- output value. HaveOutput (Pipe l i o u m r) (m ()) o -- | Request more input from upstream. The first field takes a new input -- value and provides a new @Pipe@. The second takes an upstream result -- value, which indicates that upstream is producing no more results. | NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r) -- | Processing with this @Pipe@ is complete, providing the final result. | Done r -- | Require running of a monadic action to get the next @Pipe@. | PipeM (m (Pipe l i o u m r)) -- | Return leftover input, which should be provided to future operations. | Leftover (Pipe l i o u m r) l instance Monad m => Functor (Pipe l i o u m) where fmap = liftM instance Monad m => Applicative (Pipe l i o u m) where pure = return (<*>) = ap instance Monad m => Monad (Pipe l i o u m) where return = Done HaveOutput p c o >>= fp = HaveOutput (p >>= fp) c o NeedInput p c >>= fp = NeedInput (p >=> fp) (c >=> fp) Done x >>= fp = fp x PipeM mp >>= fp = PipeM ((>>= fp) `liftM` mp) Leftover p i >>= fp = Leftover (p >>= fp) i instance MonadBase base m => MonadBase base (Pipe l i o u m) where liftBase = lift . liftBase instance MonadTrans (Pipe l i o u) where lift mr = PipeM (Done `liftM` mr) instance MonadIO m => MonadIO (Pipe l i o u m) where liftIO = lift . liftIO instance MonadThrow m => MonadThrow (Pipe l i o u m) where monadThrow = lift . monadThrow instance MonadActive m => MonadActive (Pipe l i o u m) where monadActive = lift monadActive instance Monad m => Monoid (Pipe l i o u m ()) where mempty = return () mappend = (>>) instance MonadResource m => MonadResource (Pipe l i o u m) where liftResourceT = lift . liftResourceT instance MonadReader r m => MonadReader r (Pipe l i o u m) where ask = lift ask local f (HaveOutput p c o) = HaveOutput (local f p) c o local f (NeedInput p c) = NeedInput (\i -> local f (p i)) (\u -> local f (c u)) local _ (Done x) = Done x local f (PipeM mp) = PipeM (local f mp) local f (Leftover p i) = Leftover (local f p) i -- Provided for doctest #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x, y, z) 0 #endif instance MonadWriter w m => MonadWriter w (Pipe l i o u m) where #if MIN_VERSION_mtl(2, 1, 0) writer = lift . writer #endif tell = lift . tell listen (HaveOutput p c o) = HaveOutput (listen p) c o listen (NeedInput p c) = NeedInput (\i -> listen (p i)) (\u -> listen (c u)) listen (Done x) = Done (x,mempty) listen (PipeM mp) = PipeM $ do (p,w) <- listen mp return $ do (x,w') <- listen p return (x, w `mappend` w') listen (Leftover p i) = Leftover (listen p) i pass (HaveOutput p c o) = HaveOutput (pass p) c o pass (NeedInput p c) = NeedInput (\i -> pass (p i)) (\u -> pass (c u)) pass (PipeM mp) = PipeM $ mp >>= (return . pass) pass (Done (x,_)) = Done x pass (Leftover p i) = Leftover (pass p) i instance MonadState s m => MonadState s (Pipe l i o u m) where get = lift get put = lift . put #if MIN_VERSION_mtl(2, 1, 0) state = lift . state #endif instance MonadRWS r w s m => MonadRWS r w s (Pipe l i o u m) instance MonadError e m => MonadError e (Pipe l i o u m) where throwError = lift . throwError catchError (HaveOutput p c o) f = HaveOutput (catchError p f) c o catchError (NeedInput p c) f = NeedInput (\i -> catchError (p i) f) (\u -> catchError (c u) f) catchError (Done x) _ = Done x catchError (PipeM mp) f = PipeM $ catchError (liftM (flip catchError f) mp) (\e -> return (f e)) catchError (Leftover p i) f = Leftover (catchError p f) i -- | Core datatype of the conduit package. This type represents a general -- component which can consume a stream of input values @i@, produce a stream -- of output values @o@, perform actions in the @m@ monad, and produce a final -- result @r@. The type synonyms provided here are simply wrappers around this -- type. -- -- Since 1.0.0 newtype ConduitM i o m r = ConduitM { unConduitM :: Pipe i i o () m r } deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadThrow, MonadActive, MonadResource, MFunctor) instance MonadReader r m => MonadReader r (ConduitM i o m) where ask = ConduitM ask local f (ConduitM m) = ConduitM (local f m) instance MonadWriter w m => MonadWriter w (ConduitM i o m) where #if MIN_VERSION_mtl(2, 1, 0) writer = ConduitM . writer #endif tell = ConduitM . tell listen (ConduitM m) = ConduitM (listen m) pass (ConduitM m) = ConduitM (pass m) instance MonadState s m => MonadState s (ConduitM i o m) where get = ConduitM get put = ConduitM . put #if MIN_VERSION_mtl(2, 1, 0) state = ConduitM . state #endif instance MonadRWS r w s m => MonadRWS r w s (ConduitM i o m) instance MonadError e m => MonadError e (ConduitM i o m) where throwError = ConduitM . throwError catchError (ConduitM m) f = ConduitM $ catchError m (unConduitM . f) instance MonadBase base m => MonadBase base (ConduitM i o m) where liftBase = lift . liftBase instance Monad m => Monoid (ConduitM i o m ()) where mempty = return () mappend = (>>) -- | Provides a stream of output values, without consuming any input or -- producing a final result. -- -- Since 0.5.0 type Source m o = ConduitM () o m () -- | A component which produces a stream of output values, regardless of the -- input stream. A @Producer@ is a generalization of a @Source@, and can be -- used as either a @Source@ or a @Conduit@. -- -- Since 1.0.0 type Producer m o = forall i. ConduitM i o m () -- | Consumes a stream of input values and produces a final result, without -- producing any output. -- -- > type Sink i m r = ConduitM i Void m r -- -- Since 0.5.0 type Sink i = ConduitM i Void -- | A component which consumes a stream of input values and produces a final -- result, regardless of the output stream. A @Consumer@ is a generalization of -- a @Sink@, and can be used as either a @Sink@ or a @Conduit@. -- -- Since 1.0.0 type Consumer i m r = forall o. ConduitM i o m r -- | Consumes a stream of input values and produces a stream of output values, -- without producing a final result. -- -- Since 0.5.0 type Conduit i m o = ConduitM i o m () -- | A @Source@ which has been started, but has not yet completed. -- -- This type contains both the current state of the @Source@, and the finalizer -- to be run to close it. -- -- Since 0.5.0 data ResumableSource m o = ResumableSource (Source m o) (m ()) -- | Since 1.0.13 instance MFunctor ResumableSource where hoist nat (ResumableSource src m) = ResumableSource (hoist nat src) (nat m) -- | 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 "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 "awaitE >>= either" forall x y. awaitE >>= either x y = NeedInput y x #-} {-# INLINE [1] awaitE #-} -- | Wait for input forever, calling the given inner @Pipe@ for each piece of -- new input. Returns the upstream result type. -- -- Since 0.5.0 awaitForever :: Monad m => (i -> Pipe l i o r m r') -> Pipe l i o r m r awaitForever inner = self where self = awaitE >>= either return (\i -> inner i >> self) {-# INLINE [1] awaitForever #-} -- | Send a single output value downstream. If the downstream @Pipe@ -- terminates, this @Pipe@ will terminate as well. -- -- Since 0.5.0 yield :: Monad m => o -- ^ output value -> Pipe l i o u m () yield = HaveOutput (Done ()) (return ()) {-# INLINE [1] yield #-} -- | Similar to @yield@, but additionally takes a finalizer to be run if the -- downstream @Pipe@ terminates. -- -- Since 0.5.0 yieldOr :: Monad m => o -> m () -- ^ finalizer -> Pipe l i o u m () yieldOr o f = HaveOutput (Done ()) f o {-# INLINE [1] yieldOr #-} {-# RULES "yield o >> p" forall o (p :: Pipe l i o u m r). yield o >> p = HaveOutput p (return ()) o ; "mapM_ yield" mapM_ yield = sourceList ; "yieldOr o c >> p" forall o c (p :: Pipe l i o u m r). yieldOr o c >> p = HaveOutput p c o #-} -- | 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 "leftover l >> p" forall l (p :: Pipe l i o u m r). leftover l >> p = Leftover p l #-} -- | Perform some allocation and run an inner @Pipe@. 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 -> (a -> IO ()) -> (a -> Pipe l i o u m r) -> Pipe l i o u m r bracketP alloc free inside = PipeM start where start = do (key, seed) <- allocate alloc free return $ addCleanup (const $ release key) (inside seed) -- | Add some code to be run when the given @Pipe@ cleans up. -- -- Since 0.4.1 addCleanup :: Monad m => (Bool -> m ()) -- ^ @True@ if @Pipe@ ran to completion, @False@ for early termination. -> Pipe l i o u m r -> Pipe l i o u m r addCleanup cleanup (Done r) = PipeM (cleanup True >> return (Done r)) addCleanup cleanup (HaveOutput src close x) = HaveOutput (addCleanup cleanup src) (cleanup False >> close) x addCleanup cleanup (PipeM msrc) = PipeM (liftM (addCleanup cleanup) msrc) addCleanup cleanup (NeedInput p c) = NeedInput (addCleanup cleanup . p) (addCleanup cleanup . c) addCleanup cleanup (Leftover p i) = Leftover (addCleanup cleanup p) i -- | The identity @Pipe@. -- -- Since 0.5.0 idP :: Monad m => Pipe l a a r m r idP = NeedInput (HaveOutput idP (return ())) Done -- | Compose a left and right pipe together into a complete pipe. The left pipe -- will be automatically closed when the right pipe finishes. -- -- Since 0.5.0 pipe :: Monad m => Pipe l a b r0 m r1 -> Pipe Void b c r1 m r2 -> Pipe l a c r0 m r2 pipe = goRight (return ()) where goRight final left right = case right of HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o NeedInput rp rc -> goLeft rp rc final left Done r2 -> PipeM (final >> return (Done r2)) PipeM mp -> PipeM (liftM recurse mp) Leftover _ i -> absurd i where recurse = goRight final left goLeft rp rc final left = case left of HaveOutput left' final' o -> goRight final' left' (rp o) NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) Done r1 -> goRight (return ()) (Done r1) (rc r1) PipeM mp -> PipeM (liftM recurse mp) Leftover left' i -> Leftover (recurse left') i where recurse = goLeft rp rc final -- | Same as 'pipe', but automatically applies 'injectLeftovers' to the right @Pipe@. -- -- Since 0.5.0 pipeL :: Monad m => Pipe l a b r0 m r1 -> Pipe b b c r1 m r2 -> Pipe l a c r0 m r2 -- Note: The following should be equivalent to the simpler: -- -- pipeL l r = l `pipe` injectLeftovers r -- -- However, this version tested as being significantly more efficient. pipeL = goRight (return ()) where goRight final left right = case right of HaveOutput p c o -> HaveOutput (recurse p) (c >> final) o NeedInput rp rc -> goLeft rp rc final left Done r2 -> PipeM (final >> return (Done r2)) PipeM mp -> PipeM (liftM recurse mp) Leftover right' i -> goRight final (HaveOutput left final i) right' where recurse = goRight final left goLeft rp rc final left = case left of HaveOutput left' final' o -> goRight final' left' (rp o) NeedInput left' lc -> NeedInput (recurse . left') (recurse . lc) Done r1 -> goRight (return ()) (Done r1) (rc r1) PipeM mp -> PipeM (liftM recurse mp) Leftover left' i -> Leftover (recurse left') i where recurse = goLeft rp rc final -- | Connect a @Source@ to a @Sink@ until the latter closes. Returns both the -- most recent state of the @Source@ and the result of the @Sink@. -- -- We use a @ResumableSource@ to keep track of the most recent finalizer -- provided by the @Source@. -- -- Since 0.5.0 connectResume :: Monad m => ResumableSource m o -> Sink o m r -> m (ResumableSource m o, r) connectResume (ResumableSource (ConduitM left0) leftFinal0) (ConduitM right0) = goRight leftFinal0 left0 right0 where goRight leftFinal left right = case right of HaveOutput _ _ o -> absurd o NeedInput rp rc -> goLeft rp rc leftFinal left Done r2 -> return (ResumableSource (ConduitM left) leftFinal, r2) PipeM mp -> mp >>= goRight leftFinal left Leftover p i -> goRight leftFinal (HaveOutput left leftFinal i) p goLeft rp rc leftFinal left = case left of HaveOutput left' leftFinal' o -> goRight leftFinal' left' (rp o) NeedInput _ lc -> recurse (lc ()) Done () -> goRight (return ()) (Done ()) (rc ()) PipeM mp -> mp >>= recurse Leftover p () -> recurse p where recurse = goLeft rp rc leftFinal -- | Run a pipeline until processing completes. -- -- Since 0.5.0 runPipe :: Monad m => Pipe Void () Void () m r -> m r runPipe (HaveOutput _ _ o) = absurd o runPipe (NeedInput _ c) = runPipe (c ()) runPipe (Done r) = return r runPipe (PipeM mp) = mp >>= runPipe runPipe (Leftover _ i) = absurd i -- | Transforms a @Pipe@ that provides leftovers to one which does not, -- allowing it to be composed. -- -- This function will provide any leftover values within this @Pipe@ to any -- calls to @await@. If there are more leftover values than are demanded, the -- remainder are discarded. -- -- Since 0.5.0 injectLeftovers :: Monad m => Pipe i i o u m r -> Pipe l i o u m r injectLeftovers = go [] where go ls (HaveOutput p c o) = HaveOutput (go ls p) c o go (l:ls) (NeedInput p _) = go ls $ p l go [] (NeedInput p c) = NeedInput (go [] . p) (go [] . c) go _ (Done r) = Done r go ls (PipeM mp) = PipeM (liftM (go ls) mp) go ls (Leftover p l) = go (l:ls) p -- | Transform the monad that a @Pipe@ lives in. -- -- Note that the monad transforming function will be run multiple times, -- resulting in unintuitive behavior in some cases. For a fuller treatment, -- please see: -- -- -- -- This function is just a synonym for 'hoist'. -- -- Since 0.4.0 transPipe :: Monad m => (forall a. m a -> n a) -> Pipe l i o u m r -> Pipe l i o u n r transPipe f (HaveOutput p c o) = HaveOutput (transPipe f p) (f c) o transPipe f (NeedInput p c) = NeedInput (transPipe f . p) (transPipe f . c) transPipe _ (Done r) = Done r transPipe f (PipeM mp) = PipeM (f $ liftM (transPipe f) $ collapse mp) where -- Combine a series of monadic actions into a single action. Since we -- throw away side effects between different actions, an arbitrary break -- between actions will lead to a violation of the monad transformer laws. -- Example available at: -- -- http://hpaste.org/75520 collapse mpipe = do pipe' <- mpipe case pipe' of PipeM mpipe' -> collapse mpipe' _ -> return pipe' transPipe f (Leftover p i) = Leftover (transPipe f p) i -- | Apply a function to all the output values of a @Pipe@. -- -- This mimics the behavior of `fmap` for a `Source` and `Conduit` in pre-0.4 -- days. -- -- Since 0.4.1 mapOutput :: Monad m => (o1 -> o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r mapOutput f = go where go (HaveOutput p c o) = HaveOutput (go p) c (f o) go (NeedInput p c) = NeedInput (go . p) (go . c) go (Done r) = Done r go (PipeM mp) = PipeM (liftM (go) mp) go (Leftover p i) = Leftover (go p) i {-# INLINE mapOutput #-} -- | Same as 'mapOutput', but use a function that returns @Maybe@ values. -- -- Since 0.5.0 mapOutputMaybe :: Monad m => (o1 -> Maybe o2) -> Pipe l i o1 u m r -> Pipe l i o2 u m r mapOutputMaybe f = go where go (HaveOutput p c o) = maybe id (\o' p' -> HaveOutput p' c o') (f o) (mapOutputMaybe f p) go (NeedInput p c) = NeedInput (go . p) (go . c) go (Done r) = Done r go (PipeM mp) = PipeM (liftM (go) mp) go (Leftover p i) = Leftover (go p) i {-# INLINE mapOutputMaybe #-} -- | Apply a function to all the input values of a @Pipe@. -- -- Since 0.5.0 mapInput :: Monad m => (i1 -> i2) -- ^ map initial input to new input -> (l2 -> Maybe l1) -- ^ map new leftovers to initial leftovers -> Pipe l2 i2 o u m r -> Pipe l1 i1 o u m r mapInput f f' (HaveOutput p c o) = HaveOutput (mapInput f f' p) c o mapInput f f' (NeedInput p c) = NeedInput (mapInput f f' . p . f) (mapInput f f' . c) mapInput _ _ (Done r) = Done r mapInput f f' (PipeM mp) = PipeM (liftM (mapInput f f') mp) mapInput f f' (Leftover p i) = maybe id (flip Leftover) (f' i) $ mapInput f f' p enumFromTo :: (Enum o, Eq o, Monad m) => o -> o -> Pipe l i o u m () enumFromTo start stop = loop start where loop i | i == stop = HaveOutput (Done ()) (return ()) i | otherwise = HaveOutput (loop (succ i)) (return ()) i {-# INLINE enumFromTo #-} -- | Convert a list into a source. -- -- Since 0.3.0 sourceList :: Monad m => [a] -> Pipe l i a u m () sourceList = go where go [] = Done () go (o:os) = HaveOutput (go os) (return ()) o {-# INLINE [1] sourceList #-} -- | The equivalent of @GHC.Exts.build@ for @Pipe@. -- -- Since 0.4.2 build :: Monad m => (forall b. (o -> b -> b) -> b -> b) -> Pipe l i o u m () build g = g (\o p -> HaveOutput p (return ()) o) (return ()) {-# RULES "sourceList/build" forall (f :: (forall b. (a -> b -> b) -> b -> b)). sourceList (GHC.Exts.build f) = build f #-} sourceToPipe :: Monad m => Source m o -> Pipe l i o u m () sourceToPipe = go . unConduitM where go (HaveOutput p c o) = HaveOutput (go p) c o go (NeedInput _ c) = go $ c () go (Done ()) = Done () go (PipeM mp) = PipeM (liftM go mp) go (Leftover p ()) = go p sinkToPipe :: Monad m => Sink i m r -> Pipe l i o u m r sinkToPipe = go . injectLeftovers . unConduitM 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 . unConduitM where go (HaveOutput p c o) = HaveOutput (go p) c o go (NeedInput p c) = NeedInput (go . p) (const $ go $ c ()) go (Done ()) = Done () go (PipeM mp) = PipeM (liftM go mp) go (Leftover _ l) = absurd l -- | 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) -- | Unwraps a @ResumableSource@ into a @Source@ and a finalizer. -- -- A @ResumableSource@ represents a @Source@ which has already been run, and -- therefore has a finalizer registered. As a result, if we want to turn it -- into a regular @Source@, we need to ensure that the finalizer will be run -- appropriately. By appropriately, I mean: -- -- * If a new finalizer is registered, the old one should not be called. -- -- * If the old one is called, it should not be called again. -- -- This function returns both a @Source@ and a finalizer which ensures that the -- above two conditions hold. Once you call that finalizer, the @Source@ is -- invalidated and cannot be used. -- -- Since 0.5.2 unwrapResumable :: MonadIO m => ResumableSource m o -> m (Source m o, m ()) unwrapResumable (ResumableSource src final) = do ref <- liftIO $ I.newIORef True let final' = do x <- liftIO $ I.readIORef ref when x final return (liftIO (I.writeIORef ref False) >> src, final') 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 (<+<) #-} -- | Generalize a 'Source' to a 'Producer'. -- -- Since 1.0.0 toProducer :: Monad m => Source m a -> Producer m a toProducer = ConduitM . go . unConduitM where go (HaveOutput p c o) = HaveOutput (go p) c o go (NeedInput _ c) = go (c ()) go (Done r) = Done r go (PipeM mp) = PipeM (liftM go mp) go (Leftover p ()) = go p -- | Generalize a 'Sink' to a 'Consumer'. -- -- Since 1.0.0 toConsumer :: Monad m => Sink a m b -> Consumer a m b toConsumer = ConduitM . go . unConduitM where go (HaveOutput _ _ o) = absurd 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 l) = Leftover (go p) l -- | Since 1.0.4 instance MFunctor (Pipe l i o u) where hoist = transPipe -- | See 'catchC' for more details. -- -- Since 1.0.11 catchP :: (MonadBaseControl IO m, Exception e) => Pipe l i o u m r -> (e -> Pipe l i o u m r) -> Pipe l i o u m r catchP p0 onErr = go p0 where go (Done r) = Done r go (PipeM mp) = PipeM $ E.catch (liftM go mp) (return . onErr) go (Leftover p i) = Leftover (go p) i go (NeedInput x y) = NeedInput (go . x) (go . y) go (HaveOutput p c o) = HaveOutput (go p) c o {-# INLINABLE catchP #-} -- | The same as @flip catchP@. -- -- Since 1.0.11 handleP :: (MonadBaseControl IO m, Exception e) => (e -> Pipe l i o u m r) -> Pipe l i o u m r -> Pipe l i o u m r handleP = flip catchP {-# INLINE handleP #-} -- | See 'tryC' for more details. -- -- Since 1.0.11 tryP :: (MonadBaseControl IO m, Exception e) => Pipe l i o u m r -> Pipe l i o u m (Either e r) tryP = go where go (Done r) = Done (Right r) go (PipeM mp) = PipeM $ E.catch (liftM go mp) (return . Done . Left) go (Leftover p i) = Leftover (go p) i go (NeedInput x y) = NeedInput (go . x) (go . y) go (HaveOutput p c o) = HaveOutput (go p) c o {-# INLINABLE tryP #-} -- | 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 handling), you -- should not try to implement combinators such as @onException@ in terms of this -- primitive function. -- -- Note also that the exception handling will /not/ be applied to any -- finalizers generated by this conduit. -- -- Since 1.0.11 catchC :: (MonadBaseControl IO m, Exception e) => ConduitM i o m r -> (e -> ConduitM i o m r) -> ConduitM i o m r catchC (ConduitM p) f = ConduitM (catchP p (unConduitM . f)) {-# INLINE catchC #-} -- | The same as @flip catchC@. -- -- Since 1.0.11 handleC :: (MonadBaseControl IO m, Exception e) => (e -> ConduitM i o m r) -> ConduitM i o m r -> ConduitM i o m r handleC = flip catchC {-# INLINE handleC #-} -- | A version of @try@ for use within a pipeline. See the comments in @catchC@ -- for more details. -- -- Since 1.0.11 tryC :: (MonadBaseControl IO m, Exception e) => ConduitM i o m r -> ConduitM i o m (Either e r) tryC = ConduitM . tryP . unConduitM {-# INLINE tryC #-} -- | Combines two sinks. The new sink will complete when both input sinks have -- completed. -- -- Any leftovers are discarded. -- -- Since 0.4.1 zipSinks :: Monad m => Sink i m r -> Sink i m r' -> Sink i m (r, r') zipSinks (ConduitM x0) (ConduitM y0) = ConduitM $ injectLeftovers x0 >< injectLeftovers y0 where (><) :: Monad m => Pipe Void i Void () m r1 -> Pipe Void i Void () m r2 -> Pipe l i o () m (r1, r2) 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 = Done (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) -- | Combines two sources. The new source will stop producing once either -- source has been exhausted. -- -- Since 1.0.13 zipSources :: Monad m => Source m a -> Source m b -> Source m (a, b) zipSources (ConduitM left0) (ConduitM right0) = ConduitM $ go left0 right0 where go (Leftover left ()) right = go left right go left (Leftover right ()) = go left right go (Done ()) (Done ()) = Done () go (Done ()) (HaveOutput _ close _) = PipeM (close >> return (Done ())) go (HaveOutput _ close _) (Done ()) = PipeM (close >> return (Done ())) go (Done ()) (PipeM _) = Done () go (PipeM _) (Done ()) = Done () go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) go (HaveOutput srcx closex x) (HaveOutput srcy closey y) = HaveOutput (go srcx srcy) (closex >> closey) (x, y) go (NeedInput _ c) right = go (c ()) right go left (NeedInput _ c) = go left (c ()) -- | Combines two sources. The new source will stop producing once either -- source has been exhausted. -- -- Since 1.0.13 zipSourcesApp :: Monad m => Source m (a -> b) -> Source m a -> Source m b zipSourcesApp (ConduitM left0) (ConduitM right0) = ConduitM $ go left0 right0 where go (Leftover left ()) right = go left right go left (Leftover right ()) = go left right go (Done ()) (Done ()) = Done () go (Done ()) (HaveOutput _ close _) = PipeM (close >> return (Done ())) go (HaveOutput _ close _) (Done ()) = PipeM (close >> return (Done ())) go (Done ()) (PipeM _) = Done () go (PipeM _) (Done ()) = Done () go (PipeM mx) (PipeM my) = PipeM (liftM2 go mx my) go (PipeM mx) y@HaveOutput{} = PipeM (liftM (\x -> go x y) mx) go x@HaveOutput{} (PipeM my) = PipeM (liftM (go x) my) go (HaveOutput srcx closex x) (HaveOutput srcy closey y) = HaveOutput (go srcx srcy) (closex >> closey) (x y) go (NeedInput _ c) right = go (c ()) right go left (NeedInput _ c) = go left (c ()) conduit-1.0.13/Data/Conduit/List.hs0000644000000000000000000003360612273655254015177 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- | Higher-level functions to interact with the elements of a stream. Most of -- these are based on list functions. -- -- Note that these functions all deal with individual elements of a stream as a -- sort of \"black box\", where there is no introspection of the contained -- elements. Values such as @ByteString@ and @Text@ will likely need to be -- treated specially to deal with their contents properly (@Word8@ and @Char@, -- respectively). See the "Data.Conduit.Binary" and "Data.Conduit.Text" -- modules. module Data.Conduit.List ( -- * Sources sourceList , sourceNull , unfold , enumFromTo , iterate -- * Sinks -- ** Pure , fold , foldMap , take , drop , head , peek , consume , sinkNull -- ** Monadic , foldMapM , foldM , mapM_ -- * Conduits -- ** Pure , map , mapMaybe , mapFoldable , catMaybes , concat , concatMap , concatMapAccum , scanl , groupBy , isolate , filter -- ** Monadic , mapM , iterM , scanlM , mapMaybeM , mapFoldableM , concatMapM , concatMapAccumM -- * Misc , sequence ) where import qualified Prelude import Prelude ( ($), return, (==), (-), Int , (.), id, Maybe (..), Monad , Bool (..) , (>>) , (>>=) , seq , otherwise , Enum (succ), Eq , maybe , either , (<=) ) import Data.Monoid (Monoid, mempty, mappend) import qualified Data.Foldable as F import Data.Conduit import qualified Data.Conduit.Internal as CI import Control.Monad (when, (<=<), liftM) import Control.Monad.Trans.Class (lift) -- | Generate a source from a seed value. -- -- Since 0.4.2 unfold :: Monad m => (b -> Maybe (a, b)) -> b -> Producer m a unfold f = go where go seed = case f seed of Just (a, seed') -> yield a >> go seed' Nothing -> return () sourceList :: Monad m => [a] -> Producer m a sourceList = Prelude.mapM_ yield -- | 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 0.4.2 enumFromTo :: (Enum a, Eq a, Monad m) => a -> a -> Producer m a enumFromTo x = CI.ConduitM . CI.enumFromTo x {-# INLINE enumFromTo #-} -- | Produces an infinite stream of repeated applications of f to x. iterate :: Monad m => (a -> a) -> a -> Producer m a iterate f = go where go a = yield a >> go (f a) -- | A strict left fold. -- -- Since 0.3.0 fold :: Monad m => (b -> a -> b) -> b -> Consumer a m b fold f = loop where loop accum = await >>= maybe (return accum) go where go a = let accum' = f accum a in accum' `seq` loop accum' -- | A monadic strict left fold. -- -- Since 0.3.0 foldM :: Monad m => (b -> a -> m b) -> b -> Consumer a m b foldM f = loop where loop accum = do await >>= maybe (return accum) go where go a = do accum' <- lift $ f accum a accum' `seq` loop accum' -- | A monoidal strict left fold. -- -- Since 0.5.3 foldMap :: (Monad m, Monoid b) => (a -> b) -> Consumer a m b foldMap f = fold combiner mempty where combiner accum = mappend accum . f -- | A monoidal strict left fold in a Monad. -- -- Since 1.0.8 foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Consumer a m b foldMapM f = foldM combiner mempty where combiner accum = liftM (mappend accum) . f -- | Apply the action to all values in the stream. -- -- Since 0.3.0 mapM_ :: Monad m => (a -> m ()) -> Consumer a m () mapM_ f = awaitForever $ lift . f {-# INLINE [1] mapM_ #-} srcMapM_ :: Monad m => Source m a -> (a -> m ()) -> m () srcMapM_ (CI.ConduitM src) f = go src 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 "connect to mapM_" forall f src. src $$ mapM_ f = srcMapM_ src f #-} -- | Ignore a certain number of values in the stream. This function is -- semantically equivalent to: -- -- > drop i = take i >> return () -- -- However, @drop@ is more efficient as it does not need to hold values in -- memory. -- -- Since 0.3.0 drop :: Monad m => Int -> Consumer a m () drop = loop where loop i | i <= 0 = return () loop count = await >>= maybe (return ()) (\_ -> loop (count - 1)) -- | 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 -- -- Since 0.3.0 take :: Monad m => Int -> Consumer a m [a] take = loop id where loop front 0 = return $ front [] loop front count = await >>= maybe (return $ front []) (\x -> loop (front .(x:)) (count - 1)) -- | Take a single value from the stream, if available. -- -- Since 0.3.0 head :: Monad m => Consumer a m (Maybe a) head = await -- | Look at the next value in the stream, if available. This function will not -- change the state of the stream. -- -- Since 0.3.0 peek :: Monad m => Consumer a m (Maybe a) peek = await >>= maybe (return Nothing) (\x -> leftover x >> return (Just x)) -- | Apply a transformation to all values in a stream. -- -- Since 0.3.0 map :: Monad m => (a -> b) -> Conduit a m b map f = awaitForever $ yield . f {-# INLINE [1] map #-} -- Since a Source never has any leftovers, fusion rules on it are safe. {-# RULES "source/map fusion $=" forall f src. src $= map f = mapFuseRight src f #-} {-# RULES "source/map fusion =$=" forall f src. src =$= map f = mapFuseRight src f #-} mapFuseRight :: Monad m => Source m a -> (a -> b) -> Source m b mapFuseRight (CI.ConduitM src) f = CI.ConduitM (CI.mapOutput f src) {-# INLINE mapFuseRight #-} {- It might be nice to include these rewrite rules, but they may have subtle differences based on leftovers. {-# RULES "map-to-mapOutput pipeL" forall f src. pipeL src (map f) = mapOutput f src #-} {-# RULES "map-to-mapOutput $=" forall f src. src $= (map f) = mapOutput f src #-} {-# RULES "map-to-mapOutput pipe" forall f src. pipe src (map f) = mapOutput f src #-} {-# RULES "map-to-mapOutput >+>" forall f src. src >+> (map f) = mapOutput f src #-} {-# RULES "map-to-mapInput pipeL" forall f sink. pipeL (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} {-# RULES "map-to-mapInput =$" forall f sink. map f =$ sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} {-# RULES "map-to-mapInput pipe" forall f sink. pipe (map f) sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} {-# RULES "map-to-mapInput >+>" forall f sink. map f >+> sink = mapInput f (Prelude.const Prelude.Nothing) sink #-} {-# RULES "map-to-mapOutput =$=" forall f con. con =$= map f = mapOutput f con #-} {-# RULES "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_'. -- -- Since 0.3.0 mapM :: Monad m => (a -> m b) -> Conduit a m b mapM f = awaitForever $ yield <=< lift . 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) -- -- Since 0.5.6 iterM :: Monad m => (a -> m ()) -> Conduit a m a iterM f = awaitForever $ \a -> lift (f a) >> yield a -- | Apply a transformation that may fail to all values in a stream, discarding -- the failures. -- -- Since 0.5.1 mapMaybe :: Monad m => (a -> Maybe b) -> Conduit a m b mapMaybe f = awaitForever $ maybe (return ()) yield . f -- | Apply a monadic transformation that may fail to all values in a stream, -- discarding the failures. -- -- Since 0.5.1 mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Conduit a m b mapMaybeM f = awaitForever $ maybe (return ()) yield <=< lift . f -- | Filter the @Just@ values from a stream, discarding the @Nothing@ values. -- -- Since 0.5.1 catMaybes :: Monad m => Conduit (Maybe a) m a catMaybes = awaitForever $ maybe (return ()) yield -- | Generalization of 'catMaybes'. It puts all values from -- 'F.Foldable' into stream. -- -- Since 1.0.6 concat :: (Monad m, F.Foldable f) => Conduit (f a) m a concat = awaitForever $ F.mapM_ yield -- | Apply a transformation to all values in a stream, concatenating the output -- values. -- -- Since 0.3.0 concatMap :: Monad m => (a -> [b]) -> Conduit a m b concatMap f = awaitForever $ sourceList . f -- | Apply a monadic transformation to all values in a stream, concatenating -- the output values. -- -- Since 0.3.0 concatMapM :: Monad m => (a -> m [b]) -> Conduit a m b concatMapM f = awaitForever $ sourceList <=< lift . f -- | 'concatMap' with an accumulator. -- -- Since 0.3.0 concatMapAccum :: Monad m => (a -> accum -> (accum, [b])) -> accum -> Conduit a m b concatMapAccum f x0 = scanl f x0 =$= concat -- | Analog of 'Prelude.scanl' for lists. -- -- Since 1.0.6 scanl :: Monad m => (a -> s -> (s,b)) -> s -> Conduit a m b scanl f = loop where loop s = await >>= maybe (return ()) go where go a = case f a s of (s',b) -> yield b >> loop s' -- | Monadic scanl. -- -- Since 1.0.6 scanlM :: Monad m => (a -> s -> m (s,b)) -> s -> Conduit a m b scanlM f = loop where loop s = await >>= maybe (return ()) go where go a = do (s',b) <- lift $ f a s yield b >> loop s' -- | 'concatMapM' with an accumulator. -- -- Since 0.3.0 concatMapAccumM :: Monad m => (a -> accum -> m (accum, [b])) -> accum -> Conduit a m b concatMapAccumM f x0 = scanlM f x0 =$= concat -- | Generalization of 'mapMaybe' and 'concatMap'. It applies function -- to all values in a stream and send values inside resulting -- 'Foldable' downstream. -- -- Since 1.0.6 mapFoldable :: (Monad m, F.Foldable f) => (a -> f b) -> Conduit a m b mapFoldable f = awaitForever $ F.mapM_ yield . f -- | Monadic variant of 'mapFoldable'. -- -- Since 1.0.6 mapFoldableM :: (Monad m, F.Foldable f) => (a -> m (f b)) -> Conduit a m b mapFoldableM f = awaitForever $ F.mapM_ yield <=< lift . f -- | Consume all values from the stream and return as a list. Note that this -- will pull all values into memory. For a lazy variant, see -- "Data.Conduit.Lazy". -- -- Since 0.3.0 consume :: Monad m => Consumer a m [a] consume = loop id where loop front = await >>= maybe (return $ front []) (\x -> loop $ front . (x:)) -- | Grouping input according to an equality function. -- -- Since 0.3.0 groupBy :: Monad m => (a -> a -> Bool) -> Conduit a m [a] groupBy 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 -- | 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 -- > ... -- -- Since 0.3.0 isolate :: Monad m => Int -> Conduit a m a isolate = loop where loop 0 = return () loop count = await >>= maybe (return ()) (\x -> yield x >> loop (count - 1)) -- | Keep only values in the stream passing a given predicate. -- -- Since 0.3.0 filter :: Monad m => (a -> Bool) -> Conduit a m a filter f = awaitForever $ \i -> when (f i) (yield i) filterFuseRight :: Monad m => Source m a -> (a -> Bool) -> Source m a filterFuseRight (CI.ConduitM src) f = CI.ConduitM (go src) where go (CI.Done ()) = CI.Done () go (CI.PipeM mp) = CI.PipeM (liftM go mp) go (CI.Leftover p i) = CI.Leftover (go p) i go (CI.HaveOutput p c o) | f o = CI.HaveOutput (go p) c o | otherwise = go p go (CI.NeedInput p c) = CI.NeedInput (go . p) (go . c) -- 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 "source/filter fusion $=" forall f src. src $= filter f = filterFuseRight src f #-} {-# RULES "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'. -- -- Since 0.3.0 sinkNull :: Monad m => Consumer a m () sinkNull = awaitForever $ \_ -> return () {-# RULES "connect to sinkNull" forall src. src $$ sinkNull = srcSinkNull src #-} srcSinkNull :: Monad m => Source m a -> m () srcSinkNull (CI.ConduitM src) = go src 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 #-} -- | A source that outputs no values. Note that this is just a type-restricted -- synonym for 'mempty'. -- -- Since 0.3.0 sourceNull :: Monad m => Producer m a sourceNull = return () -- | Run a @Pipe@ repeatedly, and output its result value downstream. Stops -- when no more input is available from upstream. -- -- Since 0.5.0 sequence :: Monad m => Consumer i m o -- ^ @Pipe@ to run repeatedly -> Conduit i m o sequence sink = self where self = awaitForever $ \i -> leftover i >> sink >>= yield conduit-1.0.13/Data/Conduit/Lift.hs0000644000000000000000000003055512273655254015162 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 ( -- * ErrorT errorC, runErrorC, catchErrorC, -- liftCatchError, -- * MaybeT maybeC, runMaybeC, -- * ReaderT readerC, runReaderC, -- * StateT stateC, runStateC, evalStateC, execStateC, -- ** Strict stateSC, runStateSC, evalStateSC, execStateSC, -- * WriterT writerC, runWriterC, execWriterC, -- ** Strict writerSC, runWriterSC, execWriterSC, -- * RWST rwsC, runRWSC, evalRWSC, execRWSC, -- ** Strict rwsSC, runRWSSC, evalRWSSC, execRWSSC, -- * Utilities distribute ) where import Data.Conduit import Data.Conduit.Internal (ConduitM (..), Pipe (..)) import Control.Monad.Morph (hoist, lift, MFunctor(..), ) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Monoid (Monoid(..)) import qualified Control.Monad.Trans.Error as E import qualified Control.Monad.Trans.Maybe as M import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as SS import qualified Control.Monad.Trans.Writer.Strict as WS import qualified Control.Monad.Trans.RWS.Strict as RWSS import qualified Control.Monad.Trans.State.Lazy as SL import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Control.Monad.Trans.RWS.Lazy as RWSL catAwaitLifted :: (Monad (t (ConduitM o1 o m)), Monad m, MonadTrans t) => ConduitM i o1 (t (ConduitM o1 o m)) () catAwaitLifted = go where go = do x <- lift . lift $ await case x of Nothing -> return () Just x2 -> do yield x2 go catYieldLifted :: (Monad (t (ConduitM i o1 m)), Monad m, MonadTrans t) => ConduitM o1 o (t (ConduitM i o1 m)) () catYieldLifted = go where go = do x <- await case x of Nothing -> return () Just x2 -> do lift . lift $ yield x2 go distribute :: (Monad (t (ConduitM b o m)), Monad m, Monad (t m), MonadTrans t, MFunctor t) => ConduitM b o (t m) () -> t (ConduitM b o m) () distribute p = catAwaitLifted =$= hoist (hoist lift) p $$ catYieldLifted -- | Run 'E.ErrorT' in the base monad -- -- Since 1.0.11 errorC :: (Monad m, Monad (t (E.ErrorT e m)), MonadTrans t, E.Error e, MFunctor t) => t m (Either e b) -> t (E.ErrorT e m) b errorC p = do x <- hoist lift p lift $ E.ErrorT (return x) -- | Run 'E.ErrorT' in the base monad -- -- Since 1.0.11 runErrorC :: (Monad m, E.Error e) => ConduitM i o (E.ErrorT e m) r -> ConduitM i o m (Either e r) runErrorC = ConduitM . go . unConduitM where go (Done r) = Done (Right r) go (PipeM mp) = PipeM $ do eres <- E.runErrorT mp return $ case eres of Left e -> Done $ Left e Right p -> go p go (Leftover p i) = Leftover (go p) i go (HaveOutput p f o) = HaveOutput (go p) (E.runErrorT f >> return ()) o go (NeedInput x y) = NeedInput (go . x) (go . y) {-# INLINABLE runErrorC #-} -- | Catch an error in the base monad -- -- Since 1.0.11 catchErrorC :: (Monad m, E.Error e) => ConduitM i o (E.ErrorT e m) r -> (e -> ConduitM i o (E.ErrorT e m) r) -> ConduitM i o (E.ErrorT e m) r catchErrorC c0 h = ConduitM $ go $ unConduitM c0 where go (Done r) = Done r go (PipeM mp) = PipeM $ do eres <- lift $ E.runErrorT mp return $ case eres of Left e -> unConduitM $ h e Right p -> go p go (Leftover p i) = Leftover (go p) i go (HaveOutput p f o) = HaveOutput (go p) f o go (NeedInput x y) = NeedInput (go . x) (go . y) {-# INLINABLE catchErrorC #-} -- | Wrap the base monad in 'M.MaybeT' -- -- Since 1.0.11 maybeC :: (Monad m, Monad (t (M.MaybeT m)), MonadTrans t, MFunctor t) => t m (Maybe b) -> t (M.MaybeT m) b maybeC p = do x <- hoist lift p lift $ M.MaybeT (return x) {-# INLINABLE maybeC #-} -- | Run 'M.MaybeT' in the base monad -- -- Since 1.0.11 runMaybeC :: Monad m => ConduitM i o (M.MaybeT m) r -> ConduitM i o m (Maybe r) runMaybeC = ConduitM . go . unConduitM where go (Done r) = Done (Just r) go (PipeM mp) = PipeM $ do mres <- M.runMaybeT mp return $ case mres of Nothing -> Done Nothing Just p -> go p go (Leftover p i) = Leftover (go p) i go (HaveOutput p c o) = HaveOutput (go p) (M.runMaybeT c >> return ()) o go (NeedInput x y) = NeedInput (go . x) (go . y) {-# INLINABLE runMaybeC #-} -- | Wrap the base monad in 'R.ReaderT' -- -- Since 1.0.11 readerC :: (Monad m, Monad (t1 (R.ReaderT t m)), MonadTrans t1, MFunctor t1) => (t -> t1 m b) -> t1 (R.ReaderT t m) b readerC k = do i <- lift R.ask hoist lift (k i) {-# INLINABLE readerC #-} -- | Run 'R.ReaderT' in the base monad -- -- Since 1.0.11 runReaderC :: Monad m => r -> ConduitM i o (R.ReaderT r m) res -> ConduitM i o m res runReaderC r = hoist (`R.runReaderT` r) {-# INLINABLE runReaderC #-} -- | Wrap the base monad in 'SL.StateT' -- -- Since 1.0.11 stateC :: (Monad m, Monad (t1 (SL.StateT t m)), MonadTrans t1, MFunctor t1) => (t -> t1 m (b, t)) -> t1 (SL.StateT t m) b stateC k = do s <- lift SL.get (r, s') <- hoist lift (k s) lift (SL.put s') return r {-# INLINABLE stateC #-} thread :: Monad m => (r -> s -> res) -> (forall a. t m a -> s -> m (a, s)) -> s -> ConduitM i o (t m) r -> ConduitM i o m res thread toRes runM s0 = ConduitM . go s0 . unConduitM where go s (Done r) = Done (toRes r s) go s (PipeM mp) = PipeM $ do (p, s') <- runM mp s return $ go s' p go s (Leftover p i) = Leftover (go s p) i go s (NeedInput x y) = NeedInput (go s . x) (go s . y) go s (HaveOutput p f o) = HaveOutput (go s p) (runM f s >> return ()) o {-# INLINABLE thread #-} -- | Run 'SL.StateT' in the base monad -- -- Since 1.0.11 runStateC :: Monad m => s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m (r, s) runStateC = thread (,) SL.runStateT {-# INLINABLE runStateC #-} -- | Evaluate 'SL.StateT' in the base monad -- -- Since 1.0.11 evalStateC :: Monad m => s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m r evalStateC s p = fmap fst $ runStateC s p {-# INLINABLE evalStateC #-} -- | Execute 'SL.StateT' in the base monad -- -- Since 1.0.11 execStateC :: Monad m => s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m s execStateC s p = fmap snd $ runStateC s p {-# INLINABLE execStateC #-} -- | Wrap the base monad in 'SS.StateT' -- -- Since 1.0.11 stateSC :: (Monad m, Monad (t1 (SS.StateT t m)), MonadTrans t1, MFunctor t1) => (t -> t1 m (b, t)) -> t1 (SS.StateT t m) b stateSC k = do s <- lift SS.get (r, s') <- hoist lift (k s) lift (SS.put s') return r {-# INLINABLE stateSC #-} -- | Run 'SS.StateT' in the base monad -- -- Since 1.0.11 runStateSC :: Monad m => s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m (r, s) runStateSC = thread (,) SS.runStateT {-# INLINABLE runStateSC #-} -- | Evaluate 'SS.StateT' in the base monad -- -- Since 1.0.11 evalStateSC :: Monad m => s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m r evalStateSC s p = fmap fst $ runStateSC s p {-# INLINABLE evalStateSC #-} -- | Execute 'SS.StateT' in the base monad -- -- Since 1.0.11 execStateSC :: Monad m => s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m s execStateSC s p = fmap snd $ runStateSC s p {-# INLINABLE execStateSC #-} -- | Wrap the base monad in 'WL.WriterT' -- -- Since 1.0.11 writerC :: (Monad m, Monad (t (WL.WriterT w m)), MonadTrans t, Monoid w, MFunctor t) => t m (b, w) -> t (WL.WriterT w m) b writerC p = do (r, w) <- hoist lift p lift $ WL.tell w return r {-# INLINABLE writerC #-} -- | Run 'WL.WriterT' in the base monad -- -- Since 1.0.11 runWriterC :: (Monad m, Monoid w) => ConduitM i o (WL.WriterT w m) r -> ConduitM i o m (r, w) runWriterC = thread (,) run mempty where run m w = do (a, w') <- WL.runWriterT m return (a, w `mappend` w') {-# INLINABLE runWriterC #-} -- | Execute 'WL.WriterT' in the base monad -- -- Since 1.0.11 execWriterC :: (Monad m, Monoid w) => ConduitM i o (WL.WriterT w m) r -> ConduitM i o m w execWriterC p = fmap snd $ runWriterC p {-# INLINABLE execWriterC #-} -- | Wrap the base monad in 'WS.WriterT' -- -- Since 1.0.11 writerSC :: (Monad m, Monad (t (WS.WriterT w m)), MonadTrans t, Monoid w, MFunctor t) => t m (b, w) -> t (WS.WriterT w m) b writerSC p = do (r, w) <- hoist lift p lift $ WS.tell w return r {-# INLINABLE writerSC #-} -- | Run 'WS.WriterT' in the base monad -- -- Since 1.0.11 runWriterSC :: (Monad m, Monoid w) => ConduitM i o (WS.WriterT w m) r -> ConduitM i o m (r, w) runWriterSC = thread (,) run mempty where run m w = do (a, w') <- WS.runWriterT m return (a, w `mappend` w') {-# INLINABLE runWriterSC #-} -- | Execute 'WS.WriterT' in the base monad -- -- Since 1.0.11 execWriterSC :: (Monad m, Monoid w) => ConduitM i o (WS.WriterT w m) r -> ConduitM i o m w execWriterSC p = fmap snd $ runWriterSC p {-# INLINABLE execWriterSC #-} -- | Wrap the base monad in 'RWSL.RWST' -- -- Since 1.0.11 rwsC :: (Monad m, Monad (t1 (RWSL.RWST t w t2 m)), MonadTrans t1, Monoid w, MFunctor t1) => (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSL.RWST t w t2 m) b rwsC k = do i <- lift RWSL.ask s <- lift RWSL.get (r, s', w) <- hoist lift (k i s) lift $ do RWSL.put s' RWSL.tell w return r {-# INLINABLE rwsC #-} -- | Run 'RWSL.RWST' in the base monad -- -- Since 1.0.11 runRWSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSL.RWST r w s m) res -> ConduitM i o m (res, s, w) runRWSC r s0 = thread toRes run (s0, mempty) where toRes a (s, w) = (a, s, w) run m (s, w) = do (res, s', w') <- RWSL.runRWST m r s return (res, (s', w `mappend` w')) {-# INLINABLE runRWSC #-} -- | Evaluate 'RWSL.RWST' in the base monad -- -- Since 1.0.11 evalRWSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSL.RWST r w s m) res -> ConduitM i o m (res, w) evalRWSC i s p = fmap f $ runRWSC i s p where f x = let (r, _, w) = x in (r, w) {-# INLINABLE evalRWSC #-} -- | Execute 'RWSL.RWST' in the base monad -- -- Since 1.0.11 execRWSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSL.RWST r w s m) res -> ConduitM i o m (s, w) execRWSC i s p = fmap f $ runRWSC i s p where f x = let (_, s2, w2) = x in (s2, w2) {-# INLINABLE execRWSC #-} -- | Wrap the base monad in 'RWSS.RWST' -- -- Since 1.0.11 rwsSC :: (Monad m, Monad (t1 (RWSS.RWST t w t2 m)), MonadTrans t1, Monoid w, MFunctor t1) => (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSS.RWST t w t2 m) b rwsSC k = do i <- lift RWSS.ask s <- lift RWSS.get (r, s', w) <- hoist lift (k i s) lift $ do RWSS.put s' RWSS.tell w return r {-# INLINABLE rwsSC #-} -- | Run 'RWSS.RWST' in the base monad -- -- Since 1.0.11 runRWSSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSS.RWST r w s m) res -> ConduitM i o m (res, s, w) runRWSSC 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 runRWSSC #-} -- | Evaluate 'RWSS.RWST' in the base monad -- -- Since 1.0.11 evalRWSSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSS.RWST r w s m) res -> ConduitM i o m (res, w) evalRWSSC i s p = fmap f $ runRWSSC i s p where f x = let (r, _, w) = x in (r, w) {-# INLINABLE evalRWSSC #-} -- | Execute 'RWSS.RWST' in the base monad -- -- Since 1.0.11 execRWSSC :: (Monad m, Monoid w) => r -> s -> ConduitM i o (RWSS.RWST r w s m) res -> ConduitM i o m (s, w) execRWSSC i s p = fmap f $ runRWSSC i s p where f x = let (_, s2, w2) = x in (s2, w2) {-# INLINABLE execRWSSC #-} conduit-1.0.13/Data/Conduit/Lazy.hs0000644000000000000000000000233112273655254015172 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | Use lazy I\/O for consuming the contents of a source. Warning: All normal -- warnings of lazy I\/O apply. In particular, if you are using this with a -- @ResourceT@ transformer, you must force the list to be evaluated before -- exiting the @ResourceT@. module Data.Conduit.Lazy ( lazyConsume ) where import Data.Conduit import Data.Conduit.Internal (Pipe (..), unConduitM) import System.IO.Unsafe (unsafeInterleaveIO) import Control.Monad.Trans.Control (liftBaseOp_) import Control.Monad.Trans.Resource (MonadActive (monadActive)) -- | Use lazy I\/O to consume all elements from a @Source@. -- -- This function relies on 'monadActive' to determine if the underlying monadic -- state has been closed. -- -- Since 0.3.0 lazyConsume :: (MonadBaseControl IO m, MonadActive m) => Source m a -> m [a] lazyConsume = go . unConduitM where go (Done _) = return [] go (HaveOutput src _ x) = do xs <- liftBaseOp_ unsafeInterleaveIO $ go src return $ x : xs go (PipeM msrc) = liftBaseOp_ unsafeInterleaveIO $ do a <- monadActive if a then msrc >>= go else return [] go (NeedInput _ c) = go (c ()) go (Leftover p _) = go p conduit-1.0.13/System/0000755000000000000000000000000012273655254012726 5ustar0000000000000000conduit-1.0.13/System/Win32File.hsc0000644000000000000000000000500412273655254015126 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module System.Win32File ( openRead , read , close ) 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) #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 :: FD -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "_write" c_write :: FD -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "_close" close :: FD -> IO () newtype FD = FD CInt openRead :: FilePath -> IO FD openRead 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 "System.Win32File.openRead" $ c_wsopen str (oBinary .|. oRdonly) shDenyno pIread return $ FD h read :: FD -> IO (Maybe S.ByteString) read fd = do fp <- mallocPlainForeignPtrBytes 4096 withForeignPtr fp $ \p -> do len <- throwErrnoIfMinus1Retry "System.Win32File.read" $ c_read fd p 4096 if len == 0 then return $! Nothing else return $! Just $! BI.PS fp 0 (fromIntegral len) conduit-1.0.13/System/PosixFile.hsc0000644000000000000000000000454112273655254015333 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module System.PosixFile ( openRead , openWrite , read , write , close ) where import Foreign.C.String (CString, withCString) import Foreign.Ptr (castPtr) import Foreign.Marshal.Alloc (mallocBytes, free) #if __GLASGOW_HASKELL__ >= 704 import Foreign.C.Types (CInt (..)) #else import Foreign.C.Types (CInt) #endif import Foreign.C.Error (throwErrno) import Foreign.Ptr (Ptr) import Data.Bits (Bits, (.|.)) import Data.Word (Word8) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as BU import Prelude hiding (read) #include newtype Flag = Flag CInt deriving (Num, Bits, Show, Eq) #{enum Flag, Flag , oRdonly = O_RDONLY , oWronly = O_WRONLY , oCreat = O_CREAT } foreign import ccall "open" c_open :: CString -> Flag -> CInt -> IO CInt foreign import ccall "read" c_read :: FD -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "write" c_write :: FD -> Ptr Word8 -> CInt -> IO CInt foreign import ccall "close" close :: FD -> IO () newtype FD = FD CInt openRead :: FilePath -> IO FD openRead fp = do h <- withCString fp $ \str -> c_open str oRdonly 438 -- == octal 666 if h < 0 then throwErrno $ "Could not open file: " ++ fp else return $ FD h openWrite :: FilePath -> IO FD openWrite fp = do h <- withCString fp $ \str -> c_open str (oWronly .|. oCreat) 438 -- == octal 666 if h < 0 then throwErrno $ "Could not open file: " ++ fp else return $ FD h read :: FD -> IO (Maybe S.ByteString) read fd = do cstr <- mallocBytes 4096 len <- c_read fd cstr 4096 if len == 0 then free cstr >> return Nothing else fmap Just $ BU.unsafePackCStringFinalizer cstr (fromIntegral len) (free cstr) write :: FD -> S.ByteString -> IO () write _ bs | S.null bs = return () write fd bs = do (written, len) <- BU.unsafeUseAsCStringLen bs $ \(cstr, len') -> do let len = fromIntegral len' written <- c_write fd (castPtr cstr) len return (written, len) case () of () | written == len -> return () | written <= 0 -> throwErrno $ "Error writing to file" | otherwise -> write fd $ BU.unsafeDrop (fromIntegral $ len - written) bs