pipes 4.1.0 → 4.1.1
raw patch · 12 files changed
+4860/−4766 lines, 12 filessetup-changed
Files
- LICENSE +24/−24
- Setup.hs +2/−2
- benchmarks/LiftBench.hs +68/−68
- benchmarks/PreludeBench.hs +85/−85
- pipes.cabal +102/−102
- src/Pipes.hs +504/−498
- src/Pipes/Core.hs +854/−854
- src/Pipes/Internal.hs +258/−248
- src/Pipes/Lift.hs +380/−380
- src/Pipes/Prelude.hs +802/−725
- src/Pipes/Tutorial.hs +1509/−1508
- tests/Main.hs +272/−272
LICENSE view
@@ -1,24 +1,24 @@-Copyright (c) 2012-2014 Gabriel Gonzalez-All rights reserved.--Redistribution and use in source and binary forms, with or without modification,-are permitted provided that the following conditions are met:- * Redistributions of source code must retain the above copyright notice,- this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.- * Neither the name of Gabriel Gonzalez nor the names of other contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2012-2014 Gabriel Gonzalez +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
benchmarks/LiftBench.hs view
@@ -1,68 +1,68 @@-{-# LANGUAGE RankNTypes #-}-module Main (main) where--import Common (commonMain)-import Control.DeepSeq-import Control.Monad.Identity-import qualified Control.Monad.Trans.Reader as R-import qualified Control.Monad.Trans.State.Strict as S-import Criterion.Main-import Data.Monoid-import Pipes-import Pipes.Lift--defaultMax :: Int-defaultMax = 10000--instance NFData a => NFData (Sum a)--main :: IO ()-main = commonMain defaultMax liftBenchmarks--iter :: forall m a . (Monad m , Ord a, Num a) => (a -> m a) -> a -> Effect m a-iter a vmax = loop 0- where- loop n- | n > vmax = return vmax- | otherwise = do- x <- lift $ a n- loop $! x--s_bench :: Int -> Effect (S.StateT Int Identity) Int-s_bench = iter (\n -> S.get >>= (\a -> S.put $! a + n) >> return (n + 1))--r_bench :: Int -> Effect (R.ReaderT Int Identity) Int-r_bench = iter (\n -> R.ask >>= (\a -> return $ n + a))---- Run before Proxy-runB :: (a -> Effect Identity r) -> a -> r-runB f a = runIdentity $ runEffect $ f a---- Run after Proxy-runA :: (Monad m) => (m r -> Identity a) -> Effect m r -> a-runA f a = runIdentity $ f (runEffect a)--liftBenchmarks :: Int -> [Benchmark]-liftBenchmarks vmax =- let applyBench = map ($ vmax)- in- [- bgroup "ReaderT" $- let defT f = (\d -> f d 1)- in applyBench- [- bench "runReaderP_B" . whnf (runB (runReaderP 1) . r_bench)- , bench "runReaderP_A" . whnf (runA (defT R.runReaderT) . r_bench)- ]- , bgroup "StateT" $- let defT f = (\s -> f s 0)- in applyBench- [- bench "runStateP_B" . nf (runB (runStateP 0) . s_bench)- , bench "runStateP_A" . nf (runA (defT S.runStateT) . s_bench)- , bench "evalStateP_B" . whnf (runB (evalStateP 0) . s_bench)- , bench "evalStateP_A" . whnf (runA (defT S.evalStateT) . s_bench)- , bench "execStateP_B" . whnf (runB (execStateP 0) . s_bench)- , bench "execStateP_A" . whnf (runA (defT S.execStateT) . s_bench)- ]- ]+{-# LANGUAGE RankNTypes #-} +module Main (main) where + +import Common (commonMain) +import Control.DeepSeq +import Control.Monad.Identity +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State.Strict as S +import Criterion.Main +import Data.Monoid +import Pipes +import Pipes.Lift + +defaultMax :: Int +defaultMax = 10000 + +instance NFData a => NFData (Sum a) + +main :: IO () +main = commonMain defaultMax liftBenchmarks + +iter :: forall m a . (Monad m , Ord a, Num a) => (a -> m a) -> a -> Effect m a +iter a vmax = loop 0 + where + loop n + | n > vmax = return vmax + | otherwise = do + x <- lift $ a n + loop $! x + +s_bench :: Int -> Effect (S.StateT Int Identity) Int +s_bench = iter (\n -> S.get >>= (\a -> S.put $! a + n) >> return (n + 1)) + +r_bench :: Int -> Effect (R.ReaderT Int Identity) Int +r_bench = iter (\n -> R.ask >>= (\a -> return $ n + a)) + +-- Run before Proxy +runB :: (a -> Effect Identity r) -> a -> r +runB f a = runIdentity $ runEffect $ f a + +-- Run after Proxy +runA :: (Monad m) => (m r -> Identity a) -> Effect m r -> a +runA f a = runIdentity $ f (runEffect a) + +liftBenchmarks :: Int -> [Benchmark] +liftBenchmarks vmax = + let applyBench = map ($ vmax) + in + [ + bgroup "ReaderT" $ + let defT f = (\d -> f d 1) + in applyBench + [ + bench "runReaderP_B" . whnf (runB (runReaderP 1) . r_bench) + , bench "runReaderP_A" . whnf (runA (defT R.runReaderT) . r_bench) + ] + , bgroup "StateT" $ + let defT f = (\s -> f s 0) + in applyBench + [ + bench "runStateP_B" . nf (runB (runStateP 0) . s_bench) + , bench "runStateP_A" . nf (runA (defT S.runStateT) . s_bench) + , bench "evalStateP_B" . whnf (runB (evalStateP 0) . s_bench) + , bench "evalStateP_A" . whnf (runA (defT S.evalStateT) . s_bench) + , bench "execStateP_B" . whnf (runB (execStateP 0) . s_bench) + , bench "execStateP_A" . whnf (runA (defT S.execStateT) . s_bench) + ] + ]
benchmarks/PreludeBench.hs view
@@ -1,85 +1,85 @@-{-# LANGUAGE RankNTypes #-}-module Main (main) where--import Criterion.Main-import Common (commonMain)-import Control.Monad.Identity (Identity, runIdentity)-import Pipes-import qualified Pipes.Prelude as P-import Prelude hiding (enumFromTo)--defaultMax :: Int-defaultMax = 10000--main :: IO ()-main = commonMain defaultMax preludeBenchmarks--enumFromTo :: (Int -> a) -> Int -> Int -> Producer a Identity ()-enumFromTo f n1 n2 = loop n1- where- loop n =- if n <= n2- then do- yield $! f n- loop $! n + 1- else return ()-{-# INLINABLE enumFromTo #-}--drain :: Producer b Identity r -> r-drain p = runIdentity $ runEffect $ for p discard--msum :: (Monad m) => Producer Int m () -> m Int-msum = P.foldM (\a b -> return $ a + b) (return 0) return--scanMSum :: (Monad m) => Pipe Int Int m r-scanMSum = P.scanM (\x y -> return (x + y)) (return 0) return---- Using runIdentity seems to reduce outlier counts.-preludeBenchmarks :: Int -> [Benchmark]-preludeBenchmarks vmax =- let applyBench b = b benchEnum_p- benchEnum_p = enumFromTo id 1 vmax- in- [- bgroup "Folds" $ map applyBench- [- bench "all" . whnf (runIdentity . P.all (<= vmax))- , bench "any" . whnf (runIdentity . P.any (> vmax))- , bench "find" . whnf (runIdentity . P.find (== vmax))- , bench "findIndex" . whnf (runIdentity . P.findIndex (== vmax))- , bench "fold" . whnf (runIdentity . P.fold (+) 0 id)- , bench "foldM" . whnf (runIdentity . msum)- , bench "head" . nf (runIdentity . P.head)- , bench "index" . nf (runIdentity . P.index (vmax-1))- , bench "last" . nf (runIdentity . P.last)- , bench "length" . whnf (runIdentity . P.length)- , bench "null" . whnf (runIdentity . P.null)- , bench "toList" . nf P.toList- ]- , bgroup "Pipes" $ map applyBench- [- bench "chain" . whnf (drain . (>-> P.chain (\_ -> return ())))- , bench "drop" . whnf (drain . (>-> P.drop vmax))- , bench "dropWhile" . whnf (drain . (>-> P.dropWhile (<= vmax)))- , bench "filter" . whnf (drain . (>-> P.filter even))- , bench "findIndices" . whnf (drain . (>-> P.findIndices (<= vmax)))- , bench "map" . whnf (drain . (>-> P.map id))- , bench "mapM" . whnf (drain . (>-> P.mapM return))- , bench "take" . whnf (drain . (>-> P.take vmax))- , bench "takeWhile" . whnf (drain . (>-> P.takeWhile (<= vmax)))- , bench "scan" . whnf (drain . (>-> P.scan (+) 0 id))- , bench "scanM" . whnf (drain . (>-> scanMSum))- ] ++ [- bench "concat" $ whnf (drain . (>-> P.concat)) $ enumFromTo Just 1 vmax- ]- , bgroup "Zips" $ map applyBench- [- bench "zip" . whnf (drain . P.zip benchEnum_p)- , bench "zipWith" . whnf (drain . P.zipWith (+) benchEnum_p)- ]- , bgroup "enumFromTo.vs.each"- [- bench "enumFromTo" $ whnf (drain . enumFromTo id 1) vmax- , bench "each" $ whnf (drain . each) [1..vmax]- ]- ]+{-# LANGUAGE RankNTypes #-} +module Main (main) where + +import Criterion.Main +import Common (commonMain) +import Control.Monad.Identity (Identity, runIdentity) +import Pipes +import qualified Pipes.Prelude as P +import Prelude hiding (enumFromTo) + +defaultMax :: Int +defaultMax = 10000 + +main :: IO () +main = commonMain defaultMax preludeBenchmarks + +enumFromTo :: (Int -> a) -> Int -> Int -> Producer a Identity () +enumFromTo f n1 n2 = loop n1 + where + loop n = + if n <= n2 + then do + yield $! f n + loop $! n + 1 + else return () +{-# INLINABLE enumFromTo #-} + +drain :: Producer b Identity r -> r +drain p = runIdentity $ runEffect $ for p discard + +msum :: (Monad m) => Producer Int m () -> m Int +msum = P.foldM (\a b -> return $ a + b) (return 0) return + +scanMSum :: (Monad m) => Pipe Int Int m r +scanMSum = P.scanM (\x y -> return (x + y)) (return 0) return + +-- Using runIdentity seems to reduce outlier counts. +preludeBenchmarks :: Int -> [Benchmark] +preludeBenchmarks vmax = + let applyBench b = b benchEnum_p + benchEnum_p = enumFromTo id 1 vmax + in + [ + bgroup "Folds" $ map applyBench + [ + bench "all" . whnf (runIdentity . P.all (<= vmax)) + , bench "any" . whnf (runIdentity . P.any (> vmax)) + , bench "find" . whnf (runIdentity . P.find (== vmax)) + , bench "findIndex" . whnf (runIdentity . P.findIndex (== vmax)) + , bench "fold" . whnf (runIdentity . P.fold (+) 0 id) + , bench "foldM" . whnf (runIdentity . msum) + , bench "head" . nf (runIdentity . P.head) + , bench "index" . nf (runIdentity . P.index (vmax-1)) + , bench "last" . nf (runIdentity . P.last) + , bench "length" . whnf (runIdentity . P.length) + , bench "null" . whnf (runIdentity . P.null) + , bench "toList" . nf P.toList + ] + , bgroup "Pipes" $ map applyBench + [ + bench "chain" . whnf (drain . (>-> P.chain (\_ -> return ()))) + , bench "drop" . whnf (drain . (>-> P.drop vmax)) + , bench "dropWhile" . whnf (drain . (>-> P.dropWhile (<= vmax))) + , bench "filter" . whnf (drain . (>-> P.filter even)) + , bench "findIndices" . whnf (drain . (>-> P.findIndices (<= vmax))) + , bench "map" . whnf (drain . (>-> P.map id)) + , bench "mapM" . whnf (drain . (>-> P.mapM return)) + , bench "take" . whnf (drain . (>-> P.take vmax)) + , bench "takeWhile" . whnf (drain . (>-> P.takeWhile (<= vmax))) + , bench "scan" . whnf (drain . (>-> P.scan (+) 0 id)) + , bench "scanM" . whnf (drain . (>-> scanMSum)) + ] ++ [ + bench "concat" $ whnf (drain . (>-> P.concat)) $ enumFromTo Just 1 vmax + ] + , bgroup "Zips" $ map applyBench + [ + bench "zip" . whnf (drain . P.zip benchEnum_p) + , bench "zipWith" . whnf (drain . P.zipWith (+) benchEnum_p) + ] + , bgroup "enumFromTo.vs.each" + [ + bench "enumFromTo" $ whnf (drain . enumFromTo id 1) vmax + , bench "each" $ whnf (drain . each) [1..vmax] + ] + ]
pipes.cabal view
@@ -1,102 +1,102 @@-Name: pipes-Version: 4.1.0-Cabal-Version: >= 1.10-Build-Type: Simple-License: BSD3-License-File: LICENSE-Copyright: 2012-2014 Gabriel Gonzalez-Author: Gabriel Gonzalez-Maintainer: Gabriel439@gmail.com-Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues-Synopsis: Compositional pipelines-Description:- `pipes` is a clean and powerful stream processing library that lets you build- and connect reusable streaming components- .- Advantages over traditional streaming libraries:- .- * /Concise API/: Use simple commands like 'for', ('>->'), 'await', and 'yield'- .- * /Blazing fast/: Implementation tuned for speed, including shortcut fusion- .- * /Lightweight Dependency/: @pipes@ is small and compiles very rapidly,- including dependencies- .- * /Elegant semantics/: Use practical category theory- .- * /ListT/: Correct implementation of 'ListT' that interconverts with pipes- .- * /Bidirectionality/: Implement duplex channels- .- * /Extensive Documentation/: Second to none!- .- Import "Pipes" to use the library.- .- Read "Pipes.Tutorial" for an extensive tutorial.-Category: Control, Pipes-Source-Repository head- Type: git- Location: https://github.com/Gabriel439/Haskell-Pipes-Library--Library- Default-Language: Haskell2010-- HS-Source-Dirs: src- Build-Depends:- base >= 4 && < 5 ,- transformers >= 0.2.0.0 && < 0.4,- mmorph >= 1.0.0 && < 1.1,- mtl >= 2.0.1.0 && < 2.2-- Exposed-Modules:- Pipes,- Pipes.Core,- Pipes.Internal,- Pipes.Lift,- Pipes.Prelude,- Pipes.Tutorial- GHC-Options: -O2 -Wall--Benchmark prelude-benchmarks- Default-Language: Haskell2010- Type: exitcode-stdio-1.0- HS-Source-Dirs: benchmarks- Main-Is: PreludeBench.hs- GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind-- Build-Depends:- base >= 4 && < 5 ,- criterion >= 0.6.2.1 && < 0.9,- mtl >= 2.0.1.0 && < 2.2,- pipes >= 4.0.0 && < 4.2--test-suite tests- Default-Language: Haskell2010- Type: exitcode-stdio-1.0- HS-Source-Dirs: tests- Main-Is: Main.hs- GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-missing-signatures-- Build-Depends:- base >= 4 && < 5 ,- pipes >= 4.0.0 && < 4.2 ,- QuickCheck >= 2.4 && < 3 ,- mtl >= 2.0.1 && < 2.2 ,- test-framework >= 0.4 && < 1 ,- test-framework-quickcheck2 >= 0.2.0 && < 0.4 ,- transformers >= 0.2.0.0 && < 0.4--Benchmark lift-benchmarks- Default-Language: Haskell2010- Type: exitcode-stdio-1.0- HS-Source-Dirs: benchmarks- Main-Is: LiftBench.hs- GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind-- Build-Depends:- base >= 4 && < 5 ,- criterion >= 0.6.2.1 && < 0.9,- deepseq ,- mtl >= 2.0.1.0 && < 2.2,- pipes >= 4.0.0 && < 4.2,- transformers >= 0.2.0.0 && < 0.4+Name: pipes +Version: 4.1.1 +Cabal-Version: >= 1.10 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: 2012-2014 Gabriel Gonzalez +Author: Gabriel Gonzalez +Maintainer: Gabriel439@gmail.com +Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues +Synopsis: Compositional pipelines +Description: + `pipes` is a clean and powerful stream processing library that lets you build + and connect reusable streaming components + . + Advantages over traditional streaming libraries: + . + * /Concise API/: Use simple commands like 'for', ('>->'), 'await', and 'yield' + . + * /Blazing fast/: Implementation tuned for speed, including shortcut fusion + . + * /Lightweight Dependency/: @pipes@ is small and compiles very rapidly, + including dependencies + . + * /Elegant semantics/: Use practical category theory + . + * /ListT/: Correct implementation of 'ListT' that interconverts with pipes + . + * /Bidirectionality/: Implement duplex channels + . + * /Extensive Documentation/: Second to none! + . + Import "Pipes" to use the library. + . + Read "Pipes.Tutorial" for an extensive tutorial. +Category: Control, Pipes +Source-Repository head + Type: git + Location: https://github.com/Gabriel439/Haskell-Pipes-Library + +Library + Default-Language: Haskell2010 + + HS-Source-Dirs: src + Build-Depends: + base >= 4 && < 5 , + transformers >= 0.2.0.0 && < 0.4, + mmorph >= 1.0.0 && < 1.1, + mtl >= 2.0.1.0 && < 2.2 + + Exposed-Modules: + Pipes, + Pipes.Core, + Pipes.Internal, + Pipes.Lift, + Pipes.Prelude, + Pipes.Tutorial + GHC-Options: -O2 -Wall + +Benchmark prelude-benchmarks + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: PreludeBench.hs + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4 && < 5 , + criterion >= 0.6.2.1 && < 0.9, + mtl >= 2.0.1.0 && < 2.2, + pipes >= 4.0.0 && < 4.2 + +test-suite tests + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: tests + Main-Is: Main.hs + GHC-Options: -Wall -rtsopts -fno-warn-missing-signatures -fno-enable-rewrite-rules + + Build-Depends: + base >= 4 && < 5 , + pipes >= 4.0.0 && < 4.2 , + QuickCheck >= 2.4 && < 3 , + mtl >= 2.0.1 && < 2.2 , + test-framework >= 0.4 && < 1 , + test-framework-quickcheck2 >= 0.2.0 && < 0.4 , + transformers >= 0.2.0.0 && < 0.4 + +Benchmark lift-benchmarks + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: LiftBench.hs + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4 && < 5 , + criterion >= 0.6.2.1 && < 0.9, + deepseq , + mtl >= 2.0.1.0 && < 2.2, + pipes >= 4.0.0 && < 4.2, + transformers >= 0.2.0.0 && < 0.4
src/Pipes.hs view
@@ -1,498 +1,504 @@-{-# LANGUAGE- RankNTypes- , FlexibleInstances- , MultiParamTypeClasses- , UndecidableInstances- , Trustworthy- #-}--{-| This module is the recommended entry point to the @pipes@ library.-- Read "Pipes.Tutorial" if you want a tutorial explaining how to use this- library.--}--module Pipes (- -- * The Proxy Monad Transformer- Proxy- , X- , Effect- , Effect'- , runEffect-- -- ** Producers- -- $producers- , Producer- , Producer'- , yield- , for- , (~>)- , (<~)-- -- ** Consumers- -- $consumers- , Consumer- , Consumer'- , await- , (>~)- , (~<)-- -- ** Pipes- -- $pipes- , Pipe- , cat- , (>->)- , (<-<)-- -- * ListT- , ListT(..)- , Enumerable(..)-- -- * Utilities- , next- , each- , every- , discard-- -- * Re-exports- -- $reexports- , module Control.Monad.IO.Class- , module Control.Monad.Trans.Class- , module Control.Monad.Morph- , module Data.Foldable- ) where--import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))-import Control.Monad.Error (MonadError(..))-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad (MonadPlus(mzero, mplus))-import Control.Monad.Reader (MonadReader(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.Trans.Class (MonadTrans(lift))-import Control.Monad.Trans.Error (ErrorT(runErrorT))-import Control.Monad.Trans.Identity (IdentityT(runIdentityT))-import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))-import Control.Monad.Writer (MonadWriter(..))-import Data.Foldable (Foldable)-import Data.Monoid (Monoid(..))-import Pipes.Core-import Pipes.Internal (Proxy(..))-import qualified Data.Foldable as F---- Re-exports-import Control.Monad.Morph (MFunctor(hoist))--infixl 4 <~-infixr 4 ~>-infixl 5 ~<-infixr 5 >~-infixl 7 >->-infixr 7 <-<--{- $producers- Use 'yield' to produce output and ('~>') \/ 'for' to substitute 'yield's.-- 'yield' and ('~>') obey the 'Control.Category.Category' laws:--@-\-\- Substituting \'yield\' with \'f\' gives \'f\'-'yield' '~>' f = f--\-\- Substituting every \'yield\' with another \'yield\' does nothing-f '~>' 'yield' = f--\-\- \'yield\' substitution is associative-(f '~>' g) '~>' h = f '~>' (g '~>' h)-@-- These are equivalent to the following \"for loop laws\":--@-\-\- Looping over a single yield simplifies to function application-'for' ('yield' x) f = f x--\-\- Re-yielding every element of a stream returns the original stream-'for' s 'yield' = s--\-\- Nested for loops can become a sequential 'for' loops if the inner loop-\-\- body ignores the outer loop variable-'for' s (\\a -\> 'for' (f a) g) = 'for' ('for' s f) g = 'for' s (f '~>' g)-@---}--{-| Produce a value--@-'yield' :: 'Monad' m => a -> 'Pipe' x a m ()-@--}-yield :: Monad m => a -> Producer' a m ()-yield = respond-{-# INLINABLE yield #-}--{-| @(for p body)@ loops over @p@ replacing each 'yield' with @body@.--@-'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r-'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r-'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r-'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r-@--}-for :: Monad m- => Proxy x' x b' b m a'- -- ^- -> (b -> Proxy x' x c' c m b')- -- ^- -> Proxy x' x c' c m a'-for = (//>)-{-# INLINABLE for #-}--{-# RULES- "for (for p f) g" forall p f g . for (for p f) g = for p (\a -> for (f a) g)-- ; "for p yield" forall p . for p yield = p-- ; "for (yield x) f" forall x f . for (yield x) f = f x-- ; "for cat f" forall f .- for cat f =- let go = do- x <- await- f x- go- in go-- ; "f >~ (g >~ p)" forall f g p . f >~ (g >~ p) = (f >~ g) >~ p-- ; "await >~ p" forall p . await >~ p = p-- ; "p >~ await" forall p . p >~ await = p-- ; "m >~ cat" forall m .- m >~ cat =- let go = do- x <- m- yield x- go- in go-- ; "p1 >-> (p2 >-> p3)" forall p1 p2 p3 .- p1 >-> (p2 >-> p3) = (p1 >-> p2) >-> p3-- ; "p >-> cat" forall p . p >-> cat = p-- ; "cat >-> p" forall p . cat >-> p = p-- #-}--{-| Compose loop bodies--@-('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r)-('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r)-('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r)-('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r)-@--}-(~>)- :: Monad m- => (a -> Proxy x' x b' b m a')- -- ^- -> (b -> Proxy x' x c' c m b')- -- ^- -> (a -> Proxy x' x c' c m a')-(~>) = (/>/)-{-# INLINABLE (~>) #-}---- | ('~>') with the arguments flipped-(<~)- :: Monad m- => (b -> Proxy x' x c' c m b')- -- ^- -> (a -> Proxy x' x b' b m a')- -- ^- -> (a -> Proxy x' x c' c m a')-g <~ f = f ~> g-{-# INLINABLE (<~) #-}--{- $consumers- Use 'await' to request input and ('>~') to substitute 'await's.-- 'await' and ('>~') obey the 'Control.Category.Category' laws:--@-\-\- Substituting every \'await\' with another \'await\' does nothing-'await' '>~' f = f--\-\- Substituting \'await\' with \'f\' gives \'f\'-f '>~' 'await' = f--\-\- \'await\' substitution is associative-(f '>~' g) '>~' h = f '>~' (g '>~' h)-@---}--{-| Consume a value--@-'await' :: 'Monad' m => 'Pipe' a y m a-@--}-await :: Monad m => Consumer' a m a-await = request ()-{-# INLINABLE await #-}--{-| @(draw >~ p)@ loops over @p@ replacing each 'await' with @draw@--@-('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c-('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c-('>~') :: 'Monad' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c-('>~') :: 'Monad' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c-@--}-(>~)- :: Monad m- => Proxy a' a y' y m b- -- ^- -> Proxy () b y' y m c- -- ^- -> Proxy a' a y' y m c-p1 >~ p2 = (\() -> p1) >\\ p2-{-# INLINABLE (>~) #-}---- | ('>~') with the arguments flipped-(~<)- :: Monad m- => Proxy () b y' y m c- -- ^- -> Proxy a' a y' y m b- -- ^- -> Proxy a' a y' y m c-p2 ~< p1 = p1 >~ p2-{-# INLINABLE (~<) #-}--{- $pipes- Use 'await' and 'yield' to build 'Pipe's and ('>->') to connect 'Pipe's.-- 'cat' and ('>->') obey the 'Control.Category.Category' laws:--@-\-\- Useless use of cat-'cat' '>->' f = f--\-\- Redirecting output to cat does nothing-f '>->' 'cat' = f--\-\- The pipe operator is associative-(f '>->' g) '>->' h = f '>->' (g '>->' h)-@---}---- | The identity 'Pipe', analogous to the Unix @cat@ program-cat :: Monad m => Pipe a a m r-cat = pull ()-{-# INLINABLE cat #-}--{-| 'Pipe' composition, analogous to the Unix pipe operator--@-('>->') :: 'Monad' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r-('>->') :: 'Monad' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r-('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r-('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r-@--}-(>->)- :: Monad m- => Proxy a' a () b m r- -- ^- -> Proxy () b c' c m r- -- ^- -> Proxy a' a c' c m r-p1 >-> p2 = (\() -> p1) +>> p2-{-# INLINABLE (>->) #-}--{-| The list monad transformer, which extends a monad with non-determinism-- 'return' corresponds to 'yield', yielding a single value-- ('>>=') corresponds to 'for', calling the second computation once for each- time the first computation 'yield's.--}-newtype ListT m a = Select { enumerate :: Producer a m () }--instance (Monad m) => Functor (ListT m) where- fmap f p = Select (for (enumerate p) (\a -> yield (f a)))--instance (Monad m) => Applicative (ListT m) where- pure a = Select (yield a)- mf <*> mx = Select (- for (enumerate mf) (\f ->- for (enumerate mx) (\x ->- yield (f x) ) ) )--instance (Monad m) => Monad (ListT m) where- return a = Select (yield a)- m >>= f = Select (for (enumerate m) (\a -> enumerate (f a)))- fail _ = mzero--instance MonadTrans ListT where- lift m = Select (do- a <- lift m- yield a )--instance (MonadIO m) => MonadIO (ListT m) where- liftIO m = lift (liftIO m)--instance (Monad m) => Alternative (ListT m) where- empty = Select (return ())- p1 <|> p2 = Select (do- enumerate p1- enumerate p2 )--instance (Monad m) => MonadPlus (ListT m) where- mzero = empty- mplus = (<|>)--instance MFunctor ListT where- hoist morph = Select . hoist morph . enumerate--instance (Monad m) => Monoid (ListT m a) where- mempty = empty- mappend = (<|>)--instance (MonadState s m) => MonadState s (ListT m) where- get = lift get-- put s = lift (put s)-- state f = lift (state f)--instance (MonadWriter w m) => MonadWriter w (ListT m) where- writer = lift . writer-- tell w = lift (tell w)-- listen l = Select (go (enumerate l) mempty)- where- go p w = case p of- Request a' fa -> Request a' (\a -> go (fa a ) w)- Respond b fb' -> Respond (b, w) (\b' -> go (fb' b') w)- M m -> M (do- (p', w') <- listen m- return (go p' $! mappend w w') )- Pure r -> Pure r-- pass l = Select (go (enumerate l) mempty)- where- go p w = case p of- Request a' fa -> Request a' (\a -> go (fa a ) w)- Respond (b, f) fb' -> M (pass (return- (Respond b (\b' -> go (fb' b') (f w)), \_ -> f w) ))- M m -> M (do- (p', w') <- listen m- return (go p' $! mappend w w') )- Pure r -> Pure r--instance (MonadReader i m) => MonadReader i (ListT m) where- ask = lift ask-- local f l = Select (local f (enumerate l))-- reader f = lift (reader f)--instance (MonadError e m) => MonadError e (ListT m) where- throwError e = lift (throwError e)-- catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e)))--{-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful- containers to 'ListT's.--}-class Enumerable t where- toListT :: Monad m => t m a -> ListT m a--instance Enumerable ListT where- toListT = id--instance Enumerable IdentityT where- toListT m = Select $ do- a <- lift $ runIdentityT m- yield a--instance Enumerable MaybeT where- toListT m = Select $ do- x <- lift $ runMaybeT m- case x of- Nothing -> return ()- Just a -> yield a--instance Enumerable (ErrorT e) where- toListT m = Select $ do- x <- lift $ runErrorT m- case x of- Left _ -> return ()- Right a -> yield a--{-| Consume the first value from a 'Producer'-- 'next' either fails with a 'Left' if the 'Producer' terminates or succeeds- with a 'Right' providing the next value and the remainder of the 'Producer'.--}-next :: Monad m => Producer a m r -> m (Either r (a, Producer a m r))-next = go- where- go p = case p of- Request v _ -> closed v- Respond a fu -> return (Right (a, fu ()))- M m -> m >>= go- Pure r -> return (Left r)-{-# INLINABLE next #-}---- | Convert a 'F.Foldable' to a 'Producer'-each :: (Monad m, Foldable f) => f a -> Producer' a m ()-each = F.foldr (\a p -> yield a >> p) (return ())-{-# INLINABLE each #-}-{- The above code is the same as:--> each = Data.Foldable.mapM_ yield-- ... except writing it directly in terms of `Data.Foldable.foldr` improves- build/foldr fusion--}---- | Convert an 'Enumerable' to a 'Producer'-every :: (Monad m, Enumerable t) => t m a -> Producer' a m ()-every it = discard >\\ enumerate (toListT it)-{-# INLINABLE every #-}---- | Discards a value-discard :: Monad m => a -> m ()-discard _ = return ()-{-# INLINABLE discard #-}---- | ('>->') with the arguments flipped-(<-<)- :: Monad m- => Proxy () b c' c m r- -- ^- -> Proxy a' a () b m r- -- ^- -> Proxy a' a c' c m r-p2 <-< p1 = p1 >-> p2-{-# INLINABLE (<-<) #-}--{- $reexports- "Control.Monad.IO.Class" re-exports 'MonadIO'.-- "Control.Monad.Trans.Class" re-exports 'MonadTrans'.-- "Control.Monad.Morph" re-exports 'MFunctor'.-- "Data.Foldable" re-exports 'Foldable' (the class name only)--}+{-# LANGUAGE + RankNTypes + , FlexibleInstances + , MultiParamTypeClasses + , UndecidableInstances + , Trustworthy + #-} + +{-| This module is the recommended entry point to the @pipes@ library. + + Read "Pipes.Tutorial" if you want a tutorial explaining how to use this + library. +-} + +module Pipes ( + -- * The Proxy Monad Transformer + Proxy + , X + , Effect + , Effect' + , runEffect + + -- ** Producers + -- $producers + , Producer + , Producer' + , yield + , for + , (~>) + , (<~) + + -- ** Consumers + -- $consumers + , Consumer + , Consumer' + , await + , (>~) + , (~<) + + -- ** Pipes + -- $pipes + , Pipe + , cat + , (>->) + , (<-<) + + -- * ListT + , ListT(..) + , runListT + , Enumerable(..) + + -- * Utilities + , next + , each + , every + , discard + + -- * Re-exports + -- $reexports + , module Control.Monad.IO.Class + , module Control.Monad.Trans.Class + , module Control.Monad.Morph + , module Data.Foldable + ) where + +import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad (MonadPlus(mzero, mplus)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Error (ErrorT(runErrorT)) +import Control.Monad.Trans.Identity (IdentityT(runIdentityT)) +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Control.Monad.Writer (MonadWriter(..)) +import Data.Foldable (Foldable) +import Data.Monoid (Monoid(..)) +import Pipes.Core +import Pipes.Internal (Proxy(..)) +import qualified Data.Foldable as F + +-- Re-exports +import Control.Monad.Morph (MFunctor(hoist)) + +infixl 4 <~ +infixr 4 ~> +infixl 5 ~< +infixr 5 >~ +infixl 7 >-> +infixr 7 <-< + +{- $producers + Use 'yield' to produce output and ('~>') \/ 'for' to substitute 'yield's. + + 'yield' and ('~>') obey the 'Control.Category.Category' laws: + +@ +\-\- Substituting \'yield\' with \'f\' gives \'f\' +'yield' '~>' f = f + +\-\- Substituting every \'yield\' with another \'yield\' does nothing +f '~>' 'yield' = f + +\-\- \'yield\' substitution is associative +(f '~>' g) '~>' h = f '~>' (g '~>' h) +@ + + These are equivalent to the following \"for loop laws\": + +@ +\-\- Looping over a single yield simplifies to function application +'for' ('yield' x) f = f x + +\-\- Re-yielding every element of a stream returns the original stream +'for' s 'yield' = s + +\-\- Nested for loops can become a sequential 'for' loops if the inner loop +\-\- body ignores the outer loop variable +'for' s (\\a -\> 'for' (f a) g) = 'for' ('for' s f) g = 'for' s (f '~>' g) +@ + +-} + +{-| Produce a value + +@ +'yield' :: 'Monad' m => a -> 'Pipe' x a m () +@ +-} +yield :: Monad m => a -> Producer' a m () +yield = respond +{-# INLINABLE yield #-} + +{-| @(for p body)@ loops over @p@ replacing each 'yield' with @body@. + +@ +'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r +'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r +@ +-} +for :: Monad m + => Proxy x' x b' b m a' + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x c' c m a' +for = (//>) +{-# INLINABLE for #-} + +{-# RULES + "for (for p f) g" forall p f g . for (for p f) g = for p (\a -> for (f a) g) + + ; "for p yield" forall p . for p yield = p + + ; "for (yield x) f" forall x f . for (yield x) f = f x + + ; "for cat f" forall f . + for cat f = + let go = do + x <- await + f x + go + in go + + ; "f >~ (g >~ p)" forall f g p . f >~ (g >~ p) = (f >~ g) >~ p + + ; "await >~ p" forall p . await >~ p = p + + ; "p >~ await" forall p . p >~ await = p + + ; "m >~ cat" forall m . + m >~ cat = + let go = do + x <- m + yield x + go + in go + + ; "p1 >-> (p2 >-> p3)" forall p1 p2 p3 . + p1 >-> (p2 >-> p3) = (p1 >-> p2) >-> p3 + + ; "p >-> cat" forall p . p >-> cat = p + + ; "cat >-> p" forall p . cat >-> p = p + + #-} + +{-| Compose loop bodies + +@ +('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) +('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) +@ +-} +(~>) + :: Monad m + => (a -> Proxy x' x b' b m a') + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x c' c m a') +(~>) = (/>/) +{-# INLINABLE (~>) #-} + +-- | ('~>') with the arguments flipped +(<~) + :: Monad m + => (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x b' b m a') + -- ^ + -> (a -> Proxy x' x c' c m a') +g <~ f = f ~> g +{-# INLINABLE (<~) #-} + +{- $consumers + Use 'await' to request input and ('>~') to substitute 'await's. + + 'await' and ('>~') obey the 'Control.Category.Category' laws: + +@ +\-\- Substituting every \'await\' with another \'await\' does nothing +'await' '>~' f = f + +\-\- Substituting \'await\' with \'f\' gives \'f\' +f '>~' 'await' = f + +\-\- \'await\' substitution is associative +(f '>~' g) '>~' h = f '>~' (g '>~' h) +@ + +-} + +{-| Consume a value + +@ +'await' :: 'Monad' m => 'Pipe' a y m a +@ +-} +await :: Monad m => Consumer' a m a +await = request () +{-# INLINABLE await #-} + +{-| @(draw >~ p)@ loops over @p@ replacing each 'await' with @draw@ + +@ +('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +('>~') :: 'Monad' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c +('>~') :: 'Monad' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c +@ +-} +(>~) + :: Monad m + => Proxy a' a y' y m b + -- ^ + -> Proxy () b y' y m c + -- ^ + -> Proxy a' a y' y m c +p1 >~ p2 = (\() -> p1) >\\ p2 +{-# INLINABLE (>~) #-} + +-- | ('>~') with the arguments flipped +(~<) + :: Monad m + => Proxy () b y' y m c + -- ^ + -> Proxy a' a y' y m b + -- ^ + -> Proxy a' a y' y m c +p2 ~< p1 = p1 >~ p2 +{-# INLINABLE (~<) #-} + +{- $pipes + Use 'await' and 'yield' to build 'Pipe's and ('>->') to connect 'Pipe's. + + 'cat' and ('>->') obey the 'Control.Category.Category' laws: + +@ +\-\- Useless use of cat +'cat' '>->' f = f + +\-\- Redirecting output to cat does nothing +f '>->' 'cat' = f + +\-\- The pipe operator is associative +(f '>->' g) '>->' h = f '>->' (g '>->' h) +@ + +-} + +-- | The identity 'Pipe', analogous to the Unix @cat@ program +cat :: Monad m => Pipe a a m r +cat = pull () +{-# INLINABLE cat #-} + +{-| 'Pipe' composition, analogous to the Unix pipe operator + +@ +('>->') :: 'Monad' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r +('>->') :: 'Monad' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r +('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r +('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +@ +-} +(>->) + :: Monad m + => Proxy a' a () b m r + -- ^ + -> Proxy () b c' c m r + -- ^ + -> Proxy a' a c' c m r +p1 >-> p2 = (\() -> p1) +>> p2 +{-# INLINABLE (>->) #-} + +{-| The list monad transformer, which extends a monad with non-determinism + + 'return' corresponds to 'yield', yielding a single value + + ('>>=') corresponds to 'for', calling the second computation once for each + time the first computation 'yield's. +-} +newtype ListT m a = Select { enumerate :: Producer a m () } + +instance (Monad m) => Functor (ListT m) where + fmap f p = Select (for (enumerate p) (\a -> yield (f a))) + +instance (Monad m) => Applicative (ListT m) where + pure a = Select (yield a) + mf <*> mx = Select ( + for (enumerate mf) (\f -> + for (enumerate mx) (\x -> + yield (f x) ) ) ) + +instance (Monad m) => Monad (ListT m) where + return a = Select (yield a) + m >>= f = Select (for (enumerate m) (\a -> enumerate (f a))) + fail _ = mzero + +instance MonadTrans ListT where + lift m = Select (do + a <- lift m + yield a ) + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO m = lift (liftIO m) + +instance (Monad m) => Alternative (ListT m) where + empty = Select (return ()) + p1 <|> p2 = Select (do + enumerate p1 + enumerate p2 ) + +instance (Monad m) => MonadPlus (ListT m) where + mzero = empty + mplus = (<|>) + +instance MFunctor ListT where + hoist morph = Select . hoist morph . enumerate + +instance (Monad m) => Monoid (ListT m a) where + mempty = empty + mappend = (<|>) + +instance (MonadState s m) => MonadState s (ListT m) where + get = lift get + + put s = lift (put s) + + state f = lift (state f) + +instance (MonadWriter w m) => MonadWriter w (ListT m) where + writer = lift . writer + + tell w = lift (tell w) + + listen l = Select (go (enumerate l) mempty) + where + go p w = case p of + Request a' fa -> Request a' (\a -> go (fa a ) w) + Respond b fb' -> Respond (b, w) (\b' -> go (fb' b') w) + M m -> M (do + (p', w') <- listen m + return (go p' $! mappend w w') ) + Pure r -> Pure r + + pass l = Select (go (enumerate l) mempty) + where + go p w = case p of + Request a' fa -> Request a' (\a -> go (fa a ) w) + Respond (b, f) fb' -> M (pass (return + (Respond b (\b' -> go (fb' b') (f w)), \_ -> f w) )) + M m -> M (do + (p', w') <- listen m + return (go p' $! mappend w w') ) + Pure r -> Pure r + +instance (MonadReader i m) => MonadReader i (ListT m) where + ask = lift ask + + local f l = Select (local f (enumerate l)) + + reader f = lift (reader f) + +instance (MonadError e m) => MonadError e (ListT m) where + throwError e = lift (throwError e) + + catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e))) + +-- | Run a self-contained `ListT` computation +runListT :: Monad m => ListT m X -> m () +runListT l = runEffect (enumerate l) +{-# INLINABLE runListT #-} + +{-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful + containers to 'ListT's. +-} +class Enumerable t where + toListT :: Monad m => t m a -> ListT m a + +instance Enumerable ListT where + toListT = id + +instance Enumerable IdentityT where + toListT m = Select $ do + a <- lift $ runIdentityT m + yield a + +instance Enumerable MaybeT where + toListT m = Select $ do + x <- lift $ runMaybeT m + case x of + Nothing -> return () + Just a -> yield a + +instance Enumerable (ErrorT e) where + toListT m = Select $ do + x <- lift $ runErrorT m + case x of + Left _ -> return () + Right a -> yield a + +{-| Consume the first value from a 'Producer' + + 'next' either fails with a 'Left' if the 'Producer' terminates or succeeds + with a 'Right' providing the next value and the remainder of the 'Producer'. +-} +next :: Monad m => Producer a m r -> m (Either r (a, Producer a m r)) +next = go + where + go p = case p of + Request v _ -> closed v + Respond a fu -> return (Right (a, fu ())) + M m -> m >>= go + Pure r -> return (Left r) +{-# INLINABLE next #-} + +-- | Convert a 'F.Foldable' to a 'Producer' +each :: (Monad m, Foldable f) => f a -> Producer' a m () +each = F.foldr (\a p -> yield a >> p) (return ()) +{-# INLINABLE each #-} +{- The above code is the same as: + +> each = Data.Foldable.mapM_ yield + + ... except writing it directly in terms of `Data.Foldable.foldr` improves + build/foldr fusion +-} + +-- | Convert an 'Enumerable' to a 'Producer' +every :: (Monad m, Enumerable t) => t m a -> Producer' a m () +every it = discard >\\ enumerate (toListT it) +{-# INLINABLE every #-} + +-- | Discards a value +discard :: Monad m => a -> m () +discard _ = return () +{-# INLINABLE discard #-} + +-- | ('>->') with the arguments flipped +(<-<) + :: Monad m + => Proxy () b c' c m r + -- ^ + -> Proxy a' a () b m r + -- ^ + -> Proxy a' a c' c m r +p2 <-< p1 = p1 >-> p2 +{-# INLINABLE (<-<) #-} + +{- $reexports + "Control.Monad.IO.Class" re-exports 'MonadIO'. + + "Control.Monad.Trans.Class" re-exports 'MonadTrans'. + + "Control.Monad.Morph" re-exports 'MFunctor'. + + "Data.Foldable" re-exports 'Foldable' (the class name only) +-}
src/Pipes/Core.hs view
@@ -1,854 +1,854 @@-{-| The core functionality for the 'Proxy' monad transformer-- Read "Pipes.Tutorial" if you want a beginners tutorial explaining how to use- this library. The documentation in this module targets more advanced users- who want to understand the theory behind this library.-- This module is not exported by default, and I recommend you use the- unidirectional operations exported by the "Pipes" module if you can. You- should only use this module if you require advanced features like:-- * bidirectional communication, or:-- * push-based 'Pipe's.--}--{-# LANGUAGE RankNTypes, Trustworthy #-}--module Pipes.Core (- -- * Proxy Monad Transformer- -- $proxy- Proxy- , runEffect-- -- * Categories- -- $categories-- -- ** Respond- -- $respond- , respond- , (/>/)- , (//>)-- -- ** Request- -- $request- , request- , (\>\)- , (>\\)-- -- ** Push- -- $push- , push- , (>~>)- , (>>~)-- -- ** Pull- -- $pull- , pull- , (>+>)- , (+>>)-- -- ** Reflect- -- $reflect- , reflect-- -- * Concrete Type Synonyms- , X- , Effect- , Producer- , Pipe- , Consumer- , Client- , Server-- -- * Polymorphic Type Synonyms- , Effect'- , Producer'- , Consumer'- , Client'- , Server'-- -- * Flipped operators- , (\<\)- , (/</)- , (<~<)- , (~<<)- , (<+<)- , (<\\)- , (//<)- , (<<+)-- -- * Re-exports- , closed- ) where--import Pipes.Internal (Proxy(..), X, closed)--{- $proxy- Diagrammatically, you can think of a 'Proxy' as having the following shape:--@- Upstream | Downstream- +---------+- | |- a' <== <== b'- | |- a ==> ==> b- | | |- +----|----+- v- r-@-- You can connect proxies together in five different ways:-- * ('Pipes.>+>'): connect pull-based streams-- * ('Pipes.>~>'): connect push-based streams-- * ('Pipes.\>\'): chain folds-- * ('Pipes./>/'): chain unfolds-- * ('Control.Monad.>=>'): sequence proxies---}---- | Run a self-contained 'Effect', converting it back to the base monad-runEffect :: Monad m => Effect m r -> m r-runEffect = go- where- go p = case p of- Request v _ -> closed v- Respond v _ -> closed v- M m -> m >>= go- Pure r -> return r-{-# INLINABLE runEffect #-}--{- * Keep proxy composition lower in precedence than function composition, which- is 9 at the time of of this comment, so that users can write things like:---> lift . k >+> p->-> hoist f . k >+> p-- * Keep the priorities different so that users can mix composition operators- like:--> up \>\ p />/ dn->-> up >~> p >+> dn-- * Keep 'request' and 'respond' composition lower in precedence than 'pull'- and 'push' composition, so that users can do:--> read \>\ pull >+> writer-- * I arbitrarily choose a lower priority for downstream operators so that lazy- pull-based computations need not evaluate upstream stages unless absolutely- necessary.--}-infixl 3 //>-infixr 3 <\\ -- GHC will raise a parse error if either of these lines ends-infixr 4 />/, >\\ -- with '\', which is why this comment is here-infixl 4 \<\, //<-infixl 5 \>\ -- Same thing here-infixr 5 /</-infixl 6 <<+-infixr 6 +>>-infixl 7 >+>, >>~-infixr 7 <+<, ~<<-infixl 8 <~<-infixr 8 >~>--{- $categories- A 'Control.Category.Category' is a set of components that you can connect- with a composition operator, ('Control.Category..'), that has an identity,- 'Control.Category.id'. The ('Control.Category..') and 'Control.Category.id'- must satisfy the following three 'Control.Category.Category' laws:--@-\-\- Left identity-'Control.Category.id' 'Control.Category..' f = f--\-\- Right identity-f 'Control.Category..' 'Control.Category.id' = f--\-\- Associativity-(f 'Control.Category..' g) 'Control.Category..' h = f 'Control.Category..' (g 'Control.Category..' h)-@-- The 'Proxy' type sits at the intersection of five separate categories, four- of which are named after their identity:--@- Identity | Composition | Point-ful- +-------------+-------------+-------------+- respond category | 'respond' | '/>/' | '//>' |- request category | 'request' | '\>\' | '>\\' |- push category | 'push' | '>~>' | '>>~' |- pull category | 'pull' | '>+>' | '+>>' |- Kleisli category | 'return' | 'Control.Monad.>=>' | '>>=' |- +-------------+-------------+-------------+-@-- Each composition operator has a \"point-ful\" version, analogous to how- ('>>=') is the point-ful version of ('Control.Monad.>=>'). For example,- ('//>') is the point-ful version of ('/>/'). The convention is that the- odd character out faces the argument that is a function.--}--{- $respond- The 'respond' category closely corresponds to the generator design pattern.-- The 'respond' category obeys the category laws, where 'respond' is the- identity and ('/>/') is composition:--@-\-\- Left identity-'respond' '/>/' f = f--\-\- Right identity-f '/>/' 'respond' = f--\-\- Associativity-(f '/>/' g) '/>/' h = f '/>/' (g '/>/' h)-@-- The following diagrams show the flow of information:--@-'respond' :: 'Monad' m- => a -> 'Proxy' x' x a' a m a'--\ a- |- +----|----+- | | |- x' <== \\ /==== a'- | X |- x ==> / \\===> a- | | |- +----|----+- v - a'--('/>/') :: 'Monad' m- => (a -> 'Proxy' x' x b' b m a')- -> (b -> 'Proxy' x' x c' c m b')- -> (a -> 'Proxy' x' x b' b m a')--\ a /===> b a- | / | |- +----|----+ / +----|----+ +----|----+- | v | / | v | | v |- x' <== <== b' <==\\ / x'<== <== c' x' <== <== c'- | f | X | g | = | f '/>/' g |- x ==> ==> b ===/ \\ x ==> ==> c x ==> ==> c'- | | | \\ | | | | | |- +----|----+ \\ +----|----+ +----|----+- v \\ v v- a' \\==== b' a'-@---}--{-| Send a value of type @a@ downstream and block waiting for a reply of type- @a'@-- 'respond' is the identity of the respond category.--}-respond :: Monad m => a -> Proxy x' x a' a m a'-respond a = Respond a Pure-{-# INLINABLE respond #-}--{-| Compose two unfolds, creating a new unfold--@-(f '/>/' g) x = f x '//>' g-@-- ('/>/') is the composition operator of the respond category.--}-(/>/)- :: Monad m- => (a -> Proxy x' x b' b m a')- -- ^- -> (b -> Proxy x' x c' c m b')- -- ^- -> (a -> Proxy x' x c' c m a')- -- ^-(fa />/ fb) a = fa a //> fb-{-# INLINABLE (/>/) #-}--{-| @(p \/\/> f)@ replaces each 'respond' in @p@ with @f@.-- Point-ful version of ('/>/')--}-(//>)- :: Monad m- => Proxy x' x b' b m a'- -- ^- -> (b -> Proxy x' x c' c m b')- -- ^- -> Proxy x' x c' c m a'- -- ^-p0 //> fb = go p0- where- go p = case p of- Request x' fx -> Request x' (\x -> go (fx x))- Respond b fb' -> fb b >>= \b' -> go (fb' b')- M m -> M (m >>= \p' -> return (go p'))- Pure a -> Pure a-{-# INLINABLE (//>) #-}--{-# RULES- "(Request x' fx ) //> fb" forall x' fx fb .- (Request x' fx ) //> fb = Request x' (\x -> fx x //> fb);- "(Respond b fb') //> fb" forall b fb' fb .- (Respond b fb') //> fb = fb b >>= \b' -> fb' b' //> fb;- "(M m ) //> fb" forall m fb .- (M m ) //> fb = M (m >>= \p' -> return (p' //> fb));- "(Pure a ) //> fb" forall a fb .- (Pure a ) //> fb = Pure a;- #-}--{- $request- The 'request' category closely corresponds to the iteratee design pattern.-- The 'request' category obeys the category laws, where 'request' is the- identity and ('\>\') is composition:--@--- Left identity-'request' '\>\' f = f--\-\- Right identity-f '\>\' 'request' = f--\-\- Associativity-(f '\>\' g) '\>\' h = f '\>\' (g '\>\' h)-@-- The following diagrams show the flow of information:--@-'request' :: 'Monad' m- => a' -> 'Proxy' a' a y' y m a--\ a'- |- +----|----+- | | |- a' <=====/ <== y'- | |- a ======\\ ==> y- | | |- +----|----+- v- a--('\>\') :: 'Monad' m- => (b' -> 'Proxy' a' a y' y m b)- -> (c' -> 'Proxy' b' b y' y m c)- -> (c' -> 'Proxy' a' a y' y m c)--\ b'<=====\\ c' c'- | \\ | |- +----|----+ \\ +----|----+ +----|----+- | v | \\ | v | | v |- a' <== <== y' \\== b' <== <== y' a' <== <== y'- | f | | g | = | f '\>\' g |- a ==> ==> y /=> b ==> ==> y a ==> ==> y- | | | / | | | | | |- +----|----+ / +----|----+ +----|----+- v / v v- b ======/ c c-@--}--{-| Send a value of type @a'@ upstream and block waiting for a reply of type @a@-- 'request' is the identity of the request category.--}-request :: Monad m => a' -> Proxy a' a y' y m a-request a' = Request a' Pure-{-# INLINABLE request #-}--{-| Compose two folds, creating a new fold--@-(f '\>\' g) x = f '>\\' g x-@-- ('\>\') is the composition operator of the request category.--}-(\>\)- :: Monad m- => (b' -> Proxy a' a y' y m b)- -- ^- -> (c' -> Proxy b' b y' y m c)- -- ^- -> (c' -> Proxy a' a y' y m c)- -- ^-(fb' \>\ fc') c' = fb' >\\ fc' c'-{-# INLINABLE (\>\) #-}--{-| @(f >\\\\ p)@ replaces each 'request' in @p@ with @f@.-- Point-ful version of ('\>\')--}-(>\\)- :: Monad m- => (b' -> Proxy a' a y' y m b)- -- ^- -> Proxy b' b y' y m c- -- ^- -> Proxy a' a y' y m c- -- ^-fb' >\\ p0 = go p0- where- go p = case p of- Request b' fb -> fb' b' >>= \b -> go (fb b)- Respond x fx' -> Respond x (\x' -> go (fx' x'))- M m -> M (m >>= \p' -> return (go p'))- Pure a -> Pure a-{-# INLINABLE (>\\) #-}--{-# RULES- "fb' >\\ (Request b' fb )" forall fb' b' fb .- fb' >\\ (Request b' fb ) = fb' b' >>= \b -> fb' >\\ fb b;- "fb' >\\ (Respond x fx')" forall fb' x fx' .- fb' >\\ (Respond x fx') = Respond x (\x' -> fb' >\\ fx' x');- "fb' >\\ (M m )" forall fb' m .- fb' >\\ (M m ) = M (m >>= \p' -> return (fb' >\\ p'));- "fb' >\\ (Pure a )" forall fb' a .- fb' >\\ (Pure a ) = Pure a;- #-}--{- $push- The 'push' category closely corresponds to push-based Unix pipes.-- The 'push' category obeys the category laws, where 'push' is the identity- and ('>~>') is composition:--@-\-\- Left identity-'push' '>~>' f = f--\-\- Right identity-f '>~>' 'push' = f--\-\- Associativity-(f '>~>' g) '>~>' h = f '>~>' (g '>~>' h)-@-- The following diagram shows the flow of information:--@-'push' :: 'Monad' m- => a -> 'Proxy' a' a a' a m r--\ a- |- +----|----+- | v |- a' <============ a'- | |- a ============> a- | | |- +----|----+- v- r--('>~>') :: 'Monad' m- => (a -> 'Proxy' a' a b' b m r)- -> (b -> 'Proxy' b' b c' c m r)- -> (a -> 'Proxy' a' a c' c m r)--\ a b a- | | |- +----|----+ +----|----+ +----|----+- | v | | v | | v |- a' <== <== b' <== <== c' a' <== <== c'- | f | | g | = | f '>~>' g |- a ==> ==> b ==> ==> c a ==> ==> c- | | | | | | | | |- +----|----+ +----|----+ +----|----+- v v v- r r r-@---}--{-| Forward responses followed by requests--@-'push' = 'respond' 'Control.Monad.>=>' 'request' 'Control.Monad.>=>' 'push'-@-- 'push' is the identity of the push category.--}-push :: Monad m => a -> Proxy a' a a' a m r-push = go- where- go a = Respond a (\a' -> Request a' go)-{-# INLINABLE push #-}--{-| Compose two proxies blocked while 'request'ing data, creating a new proxy- blocked while 'request'ing data--@-(f '>~>' g) x = f x '>>~' g-@-- ('>~>') is the composition operator of the push category.--}-(>~>)- :: Monad m- => (_a -> Proxy a' a b' b m r)- -- ^- -> ( b -> Proxy b' b c' c m r)- -- ^- -> (_a -> Proxy a' a c' c m r)- -- ^-(fa >~> fb) a = fa a >>~ fb-{-# INLINABLE (>~>) #-}--{-| @(p >>~ f)@ pairs each 'respond' in @p@ with an 'request' in @f@.-- Point-ful version of ('>~>')--}-(>>~)- :: Monad m- => Proxy a' a b' b m r- -- ^- -> (b -> Proxy b' b c' c m r)- -- ^- -> Proxy a' a c' c m r- -- ^-p >>~ fb = case p of- Request a' fa -> Request a' (\a -> fa a >>~ fb)- Respond b fb' -> fb' +>> fb b- M m -> M (m >>= \p' -> return (p' >>~ fb))- Pure r -> Pure r-{-# INLINABLE (>>~) #-}--{- $pull- The 'pull' category closely corresponds to pull-based Unix pipes.-- The 'pull' category obeys the category laws, where 'pull' is the identity- and ('>+>') is composition:--@-\-\- Left identity-'pull' '>+>' f = f--\-\- Right identity-f '>+>' 'pull' = f--\-\- Associativity-(f '>+>' g) '>+>' h = f '>+>' (g '>+>' h)-@-- The following diagrams show the flow of information:--@-'pull' :: 'Monad' m- => a' -> 'Proxy' a' a a' a m r--\ a'- |- +----|----+- | v |- a' <============ a'- | |- a ============> a- | | |- +----|----+- v- r--('>+>') :: 'Monad' m- -> (b' -> 'Proxy' a' a b' b m r)- -> (c' -> 'Proxy' b' b c' c m r)- -> (c' -> 'Proxy' a' a c' c m r)--\ b' c' c'- | | |- +----|----+ +----|----+ +----|----+- | v | | v | | v |- a' <== <== b' <== <== c' a' <== <== c'- | f | | g | = | f >+> g |- a ==> ==> b ==> ==> c a ==> ==> c- | | | | | | | | |- +----|----+ +----|----+ +----|----+- v v v- r r r-@---}--{-| Forward requests followed by responses:--@-'pull' = 'request' 'Control.Monad.>=>' 'respond' 'Control.Monad.>=>' 'pull'-@-- 'pull' is the identity of the pull category.--}-pull :: Monad m => a' -> Proxy a' a a' a m r-pull = go- where- go a' = Request a' (\a -> Respond a go)-{-# INLINABLE pull #-}--{-| Compose two proxies blocked in the middle of 'respond'ing, creating a new- proxy blocked in the middle of 'respond'ing--@-(f '>+>' g) x = f '+>>' g x-@-- ('>+>') is the composition operator of the pull category.--}-(>+>)- :: Monad m- => ( b' -> Proxy a' a b' b m r)- -- ^- -> (_c' -> Proxy b' b c' c m r)- -- ^- -> (_c' -> Proxy a' a c' c m r)- -- ^-(fb' >+> fc') c' = fb' +>> fc' c'-{-# INLINABLE (>+>) #-}--{-| @(f +>> p)@ pairs each 'request' in @p@ with a 'respond' in @f@.-- Point-ful version of ('>+>')--}-(+>>)- :: Monad m- => (b' -> Proxy a' a b' b m r)- -- ^- -> Proxy b' b c' c m r- -- ^- -> Proxy a' a c' c m r- -- ^-fb' +>> p = case p of- Request b' fb -> fb' b' >>~ fb- Respond c fc' -> Respond c (\c' -> fb' +>> fc' c')- M m -> M (m >>= \p' -> return (fb' +>> p'))- Pure r -> Pure r-{-# INLINABLE (+>>) #-}--{- $reflect- @(reflect .)@ transforms each streaming category into its dual:-- * The request category is the dual of the respond category--@-'reflect' '.' 'respond' = 'request'--'reflect' '.' (f '/>/' g) = 'reflect' '.' f '/</' 'reflect' '.' g-@--@-'reflect' '.' 'request' = 'respond'--'reflect' '.' (f '\>\' g) = 'reflect' '.' f '\<\' 'reflect' '.' g-@-- * The pull category is the dual of the push category--@-'reflect' '.' 'push' = 'pull'--'reflect' '.' (f '>~>' g) = 'reflect' '.' f '<+<' 'reflect' '.' g-@--@-'reflect' '.' 'pull' = 'push'--'reflect' '.' (f '>+>' g) = 'reflect' '.' f '<~<' 'reflect' '.' g-@--}---- | Switch the upstream and downstream ends-reflect :: Monad m => Proxy a' a b' b m r -> Proxy b b' a a' m r-reflect = go- where- go p = case p of- Request a' fa -> Respond a' (\a -> go (fa a ))- Respond b fb' -> Request b (\b' -> go (fb' b'))- M m -> M (m >>= \p' -> return (go p'))- Pure r -> Pure r-{-# INLINABLE reflect #-}--{-| An effect in the base monad-- 'Effect's neither 'Pipes.await' nor 'Pipes.yield'--}-type Effect = Proxy X () () X---- | 'Producer's can only 'Pipes.yield'-type Producer b = Proxy X () () b---- | 'Pipe's can both 'Pipes.await' and 'Pipes.yield'-type Pipe a b = Proxy () a () b---- | 'Consumer's can only 'Pipes.await'-type Consumer a = Proxy () a () X--{-| @Client a' a@ sends requests of type @a'@ and receives responses of- type @a@.-- 'Client's only 'request' and never 'respond'.--}-type Client a' a = Proxy a' a () X--{-| @Server b' b@ receives requests of type @b'@ and sends responses of type- @b@.-- 'Server's only 'respond' and never 'request'.--}-type Server b' b = Proxy X () b' b---- | Like 'Effect', but with a polymorphic type-type Effect' m r = forall x' x y' y . Proxy x' x y' y m r---- | Like 'Producer', but with a polymorphic type-type Producer' b m r = forall x' x . Proxy x' x () b m r---- | Like 'Consumer', but with a polymorphic type-type Consumer' a m r = forall y' y . Proxy () a y' y m r---- | Like 'Server', but with a polymorphic type-type Server' b' b m r = forall x' x . Proxy x' x b' b m r---- | Like 'Client', but with a polymorphic type-type Client' a' a m r = forall y' y . Proxy a' a y' y m r---- | Equivalent to ('/>/') with the arguments flipped-(\<\)- :: Monad m- => (b -> Proxy x' x c' c m b')- -- ^- -> (a -> Proxy x' x b' b m a')- -- ^- -> (a -> Proxy x' x c' c m a')- -- ^-p1 \<\ p2 = p2 />/ p1-{-# INLINABLE (\<\) #-}---- | Equivalent to ('\>\') with the arguments flipped-(/</)- :: Monad m- => (c' -> Proxy b' b x' x m c)- -- ^- -> (b' -> Proxy a' a x' x m b)- -- ^- -> (c' -> Proxy a' a x' x m c)- -- ^-p1 /</ p2 = p2 \>\ p1-{-# INLINABLE (/</) #-}---- | Equivalent to ('>~>') with the arguments flipped-(<~<)- :: Monad m- => (b -> Proxy b' b c' c m r)- -- ^- -> (a -> Proxy a' a b' b m r)- -- ^- -> (a -> Proxy a' a c' c m r)- -- ^-p1 <~< p2 = p2 >~> p1-{-# INLINABLE (<~<) #-}---- | Equivalent to ('>+>') with the arguments flipped-(<+<)- :: Monad m- => (c' -> Proxy b' b c' c m r)- -- ^- -> (b' -> Proxy a' a b' b m r)- -- ^- -> (c' -> Proxy a' a c' c m r)- -- ^-p1 <+< p2 = p2 >+> p1-{-# INLINABLE (<+<) #-}---- | Equivalent to ('//>') with the arguments flipped-(<\\)- :: Monad m- => (b -> Proxy x' x c' c m b')- -- ^- -> Proxy x' x b' b m a'- -- ^- -> Proxy x' x c' c m a'- -- ^-f <\\ p = p //> f-{-# INLINABLE (<\\) #-}---- | Equivalent to ('>\\') with the arguments flipped-(//<)- :: Monad m- => Proxy b' b y' y m c- -- ^- -> (b' -> Proxy a' a y' y m b)- -- ^- -> Proxy a' a y' y m c- -- ^-p //< f = f >\\ p-{-# INLINABLE (//<) #-}---- | Equivalent to ('>>~') with the arguments flipped-(~<<)- :: Monad m- => (b -> Proxy b' b c' c m r)- -- ^- -> Proxy a' a b' b m r- -- ^- -> Proxy a' a c' c m r- -- ^-k ~<< p = p >>~ k-{-# INLINABLE (~<<) #-}---- | Equivalent to ('+>>') with the arguments flipped-(<<+)- :: Monad m- => Proxy b' b c' c m r- -- ^- -> (b' -> Proxy a' a b' b m r)- -- ^- -> Proxy a' a c' c m r- -- ^-k <<+ p = p +>> k-{-# INLINABLE (<<+) #-}--{-# RULES- "(p //> f) //> g" forall p f g . (p //> f) //> g = p //> (\x -> f x //> g)-- ; "p //> respond" forall p . p //> respond = p-- ; "respond x //> f" forall x f . respond x //> f = f x-- ; "f >\\ (g >\\ p)" forall f g p . f >\\ (g >\\ p) = (\x -> f >\\ g x) >\\ p-- ; "request >\\ p" forall p . request >\\ p = p-- ; "f >\\ request x" forall f x . f >\\ request x = f x-- ; "(p >>~ f) >>~ g" forall p f g . (p >>~ f) >>~ g = p >>~ (\x -> f x >>~ g)-- ; "p >>~ push" forall p . p >>~ push = p-- ; "push x >>~ f" forall x f . push x >>~ f = f x-- ; "f +>> (g +>> p)" forall f g p . f +>> (g +>> p) = (\x -> f +>> g x) +>> p-- ; "pull +>> p" forall p . pull +>> p = p-- ; "f +>> pull x" forall f x . f +>> pull x = f x-- #-}+{-| The core functionality for the 'Proxy' monad transformer + + Read "Pipes.Tutorial" if you want a beginners tutorial explaining how to use + this library. The documentation in this module targets more advanced users + who want to understand the theory behind this library. + + This module is not exported by default, and I recommend you use the + unidirectional operations exported by the "Pipes" module if you can. You + should only use this module if you require advanced features like: + + * bidirectional communication, or: + + * push-based 'Pipe's. +-} + +{-# LANGUAGE RankNTypes, Trustworthy #-} + +module Pipes.Core ( + -- * Proxy Monad Transformer + -- $proxy + Proxy + , runEffect + + -- * Categories + -- $categories + + -- ** Respond + -- $respond + , respond + , (/>/) + , (//>) + + -- ** Request + -- $request + , request + , (\>\) + , (>\\) + + -- ** Push + -- $push + , push + , (>~>) + , (>>~) + + -- ** Pull + -- $pull + , pull + , (>+>) + , (+>>) + + -- ** Reflect + -- $reflect + , reflect + + -- * Concrete Type Synonyms + , X + , Effect + , Producer + , Pipe + , Consumer + , Client + , Server + + -- * Polymorphic Type Synonyms + , Effect' + , Producer' + , Consumer' + , Client' + , Server' + + -- * Flipped operators + , (\<\) + , (/</) + , (<~<) + , (~<<) + , (<+<) + , (<\\) + , (//<) + , (<<+) + + -- * Re-exports + , closed + ) where + +import Pipes.Internal (Proxy(..), X, closed) + +{- $proxy + Diagrammatically, you can think of a 'Proxy' as having the following shape: + +@ + Upstream | Downstream + +---------+ + | | + a' <== <== b' + | | + a ==> ==> b + | | | + +----|----+ + v + r +@ + + You can connect proxies together in five different ways: + + * ('Pipes.>+>'): connect pull-based streams + + * ('Pipes.>~>'): connect push-based streams + + * ('Pipes.\>\'): chain folds + + * ('Pipes./>/'): chain unfolds + + * ('Control.Monad.>=>'): sequence proxies + +-} + +-- | Run a self-contained 'Effect', converting it back to the base monad +runEffect :: Monad m => Effect m r -> m r +runEffect = go + where + go p = case p of + Request v _ -> closed v + Respond v _ -> closed v + M m -> m >>= go + Pure r -> return r +{-# INLINABLE runEffect #-} + +{- * Keep proxy composition lower in precedence than function composition, which + is 9 at the time of of this comment, so that users can write things like: + + +> lift . k >+> p +> +> hoist f . k >+> p + + * Keep the priorities different so that users can mix composition operators + like: + +> up \>\ p />/ dn +> +> up >~> p >+> dn + + * Keep 'request' and 'respond' composition lower in precedence than 'pull' + and 'push' composition, so that users can do: + +> read \>\ pull >+> writer + + * I arbitrarily choose a lower priority for downstream operators so that lazy + pull-based computations need not evaluate upstream stages unless absolutely + necessary. +-} +infixl 3 //> +infixr 3 <\\ -- GHC will raise a parse error if either of these lines ends +infixr 4 />/, >\\ -- with '\', which is why this comment is here +infixl 4 \<\, //< +infixl 5 \>\ -- Same thing here +infixr 5 /</ +infixl 6 <<+ +infixr 6 +>> +infixl 7 >+>, >>~ +infixr 7 <+<, ~<< +infixl 8 <~< +infixr 8 >~> + +{- $categories + A 'Control.Category.Category' is a set of components that you can connect + with a composition operator, ('Control.Category..'), that has an identity, + 'Control.Category.id'. The ('Control.Category..') and 'Control.Category.id' + must satisfy the following three 'Control.Category.Category' laws: + +@ +\-\- Left identity +'Control.Category.id' 'Control.Category..' f = f + +\-\- Right identity +f 'Control.Category..' 'Control.Category.id' = f + +\-\- Associativity +(f 'Control.Category..' g) 'Control.Category..' h = f 'Control.Category..' (g 'Control.Category..' h) +@ + + The 'Proxy' type sits at the intersection of five separate categories, four + of which are named after their identity: + +@ + Identity | Composition | Point-ful + +-------------+-------------+-------------+ + respond category | 'respond' | '/>/' | '//>' | + request category | 'request' | '\>\' | '>\\' | + push category | 'push' | '>~>' | '>>~' | + pull category | 'pull' | '>+>' | '+>>' | + Kleisli category | 'return' | 'Control.Monad.>=>' | '>>=' | + +-------------+-------------+-------------+ +@ + + Each composition operator has a \"point-ful\" version, analogous to how + ('>>=') is the point-ful version of ('Control.Monad.>=>'). For example, + ('//>') is the point-ful version of ('/>/'). The convention is that the + odd character out faces the argument that is a function. +-} + +{- $respond + The 'respond' category closely corresponds to the generator design pattern. + + The 'respond' category obeys the category laws, where 'respond' is the + identity and ('/>/') is composition: + +@ +\-\- Left identity +'respond' '/>/' f = f + +\-\- Right identity +f '/>/' 'respond' = f + +\-\- Associativity +(f '/>/' g) '/>/' h = f '/>/' (g '/>/' h) +@ + + The following diagrams show the flow of information: + +@ +'respond' :: 'Monad' m + => a -> 'Proxy' x' x a' a m a' + +\ a + | + +----|----+ + | | | + x' <== \\ /==== a' + | X | + x ==> / \\===> a + | | | + +----|----+ + v + a' + +('/>/') :: 'Monad' m + => (a -> 'Proxy' x' x b' b m a') + -> (b -> 'Proxy' x' x c' c m b') + -> (a -> 'Proxy' x' x b' b m a') + +\ a /===> b a + | / | | + +----|----+ / +----|----+ +----|----+ + | v | / | v | | v | + x' <== <== b' <==\\ / x'<== <== c' x' <== <== c' + | f | X | g | = | f '/>/' g | + x ==> ==> b ===/ \\ x ==> ==> c x ==> ==> c' + | | | \\ | | | | | | + +----|----+ \\ +----|----+ +----|----+ + v \\ v v + a' \\==== b' a' +@ + +-} + +{-| Send a value of type @a@ downstream and block waiting for a reply of type + @a'@ + + 'respond' is the identity of the respond category. +-} +respond :: Monad m => a -> Proxy x' x a' a m a' +respond a = Respond a Pure +{-# INLINABLE respond #-} + +{-| Compose two unfolds, creating a new unfold + +@ +(f '/>/' g) x = f x '//>' g +@ + + ('/>/') is the composition operator of the respond category. +-} +(/>/) + :: Monad m + => (a -> Proxy x' x b' b m a') + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x c' c m a') + -- ^ +(fa />/ fb) a = fa a //> fb +{-# INLINABLE (/>/) #-} + +{-| @(p \/\/> f)@ replaces each 'respond' in @p@ with @f@. + + Point-ful version of ('/>/') +-} +(//>) + :: Monad m + => Proxy x' x b' b m a' + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x c' c m a' + -- ^ +p0 //> fb = go p0 + where + go p = case p of + Request x' fx -> Request x' (\x -> go (fx x)) + Respond b fb' -> fb b >>= \b' -> go (fb' b') + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a +{-# INLINABLE (//>) #-} + +{-# RULES + "(Request x' fx ) //> fb" forall x' fx fb . + (Request x' fx ) //> fb = Request x' (\x -> fx x //> fb); + "(Respond b fb') //> fb" forall b fb' fb . + (Respond b fb') //> fb = fb b >>= \b' -> fb' b' //> fb; + "(M m ) //> fb" forall m fb . + (M m ) //> fb = M (m >>= \p' -> return (p' //> fb)); + "(Pure a ) //> fb" forall a fb . + (Pure a ) //> fb = Pure a; + #-} + +{- $request + The 'request' category closely corresponds to the iteratee design pattern. + + The 'request' category obeys the category laws, where 'request' is the + identity and ('\>\') is composition: + +@ +-- Left identity +'request' '\>\' f = f + +\-\- Right identity +f '\>\' 'request' = f + +\-\- Associativity +(f '\>\' g) '\>\' h = f '\>\' (g '\>\' h) +@ + + The following diagrams show the flow of information: + +@ +'request' :: 'Monad' m + => a' -> 'Proxy' a' a y' y m a + +\ a' + | + +----|----+ + | | | + a' <=====/ <== y' + | | + a ======\\ ==> y + | | | + +----|----+ + v + a + +('\>\') :: 'Monad' m + => (b' -> 'Proxy' a' a y' y m b) + -> (c' -> 'Proxy' b' b y' y m c) + -> (c' -> 'Proxy' a' a y' y m c) + +\ b'<=====\\ c' c' + | \\ | | + +----|----+ \\ +----|----+ +----|----+ + | v | \\ | v | | v | + a' <== <== y' \\== b' <== <== y' a' <== <== y' + | f | | g | = | f '\>\' g | + a ==> ==> y /=> b ==> ==> y a ==> ==> y + | | | / | | | | | | + +----|----+ / +----|----+ +----|----+ + v / v v + b ======/ c c +@ +-} + +{-| Send a value of type @a'@ upstream and block waiting for a reply of type @a@ + + 'request' is the identity of the request category. +-} +request :: Monad m => a' -> Proxy a' a y' y m a +request a' = Request a' Pure +{-# INLINABLE request #-} + +{-| Compose two folds, creating a new fold + +@ +(f '\>\' g) x = f '>\\' g x +@ + + ('\>\') is the composition operator of the request category. +-} +(\>\) + :: Monad m + => (b' -> Proxy a' a y' y m b) + -- ^ + -> (c' -> Proxy b' b y' y m c) + -- ^ + -> (c' -> Proxy a' a y' y m c) + -- ^ +(fb' \>\ fc') c' = fb' >\\ fc' c' +{-# INLINABLE (\>\) #-} + +{-| @(f >\\\\ p)@ replaces each 'request' in @p@ with @f@. + + Point-ful version of ('\>\') +-} +(>\\) + :: Monad m + => (b' -> Proxy a' a y' y m b) + -- ^ + -> Proxy b' b y' y m c + -- ^ + -> Proxy a' a y' y m c + -- ^ +fb' >\\ p0 = go p0 + where + go p = case p of + Request b' fb -> fb' b' >>= \b -> go (fb b) + Respond x fx' -> Respond x (\x' -> go (fx' x')) + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a +{-# INLINABLE (>\\) #-} + +{-# RULES + "fb' >\\ (Request b' fb )" forall fb' b' fb . + fb' >\\ (Request b' fb ) = fb' b' >>= \b -> fb' >\\ fb b; + "fb' >\\ (Respond x fx')" forall fb' x fx' . + fb' >\\ (Respond x fx') = Respond x (\x' -> fb' >\\ fx' x'); + "fb' >\\ (M m )" forall fb' m . + fb' >\\ (M m ) = M (m >>= \p' -> return (fb' >\\ p')); + "fb' >\\ (Pure a )" forall fb' a . + fb' >\\ (Pure a ) = Pure a; + #-} + +{- $push + The 'push' category closely corresponds to push-based Unix pipes. + + The 'push' category obeys the category laws, where 'push' is the identity + and ('>~>') is composition: + +@ +\-\- Left identity +'push' '>~>' f = f + +\-\- Right identity +f '>~>' 'push' = f + +\-\- Associativity +(f '>~>' g) '>~>' h = f '>~>' (g '>~>' h) +@ + + The following diagram shows the flow of information: + +@ +'push' :: 'Monad' m + => a -> 'Proxy' a' a a' a m r + +\ a + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>~>') :: 'Monad' m + => (a -> 'Proxy' a' a b' b m r) + -> (b -> 'Proxy' b' b c' c m r) + -> (a -> 'Proxy' a' a c' c m r) + +\ a b a + | | | + +----|----+ +----|----+ +----|----+ + | v | | v | | v | + a' <== <== b' <== <== c' a' <== <== c' + | f | | g | = | f '>~>' g | + a ==> ==> b ==> ==> c a ==> ==> c + | | | | | | | | | + +----|----+ +----|----+ +----|----+ + v v v + r r r +@ + +-} + +{-| Forward responses followed by requests + +@ +'push' = 'respond' 'Control.Monad.>=>' 'request' 'Control.Monad.>=>' 'push' +@ + + 'push' is the identity of the push category. +-} +push :: Monad m => a -> Proxy a' a a' a m r +push = go + where + go a = Respond a (\a' -> Request a' go) +{-# INLINABLE push #-} + +{-| Compose two proxies blocked while 'request'ing data, creating a new proxy + blocked while 'request'ing data + +@ +(f '>~>' g) x = f x '>>~' g +@ + + ('>~>') is the composition operator of the push category. +-} +(>~>) + :: Monad m + => (_a -> Proxy a' a b' b m r) + -- ^ + -> ( b -> Proxy b' b c' c m r) + -- ^ + -> (_a -> Proxy a' a c' c m r) + -- ^ +(fa >~> fb) a = fa a >>~ fb +{-# INLINABLE (>~>) #-} + +{-| @(p >>~ f)@ pairs each 'respond' in @p@ with an 'request' in @f@. + + Point-ful version of ('>~>') +-} +(>>~) + :: Monad m + => Proxy a' a b' b m r + -- ^ + -> (b -> Proxy b' b c' c m r) + -- ^ + -> Proxy a' a c' c m r + -- ^ +p >>~ fb = case p of + Request a' fa -> Request a' (\a -> fa a >>~ fb) + Respond b fb' -> fb' +>> fb b + M m -> M (m >>= \p' -> return (p' >>~ fb)) + Pure r -> Pure r +{-# INLINABLE (>>~) #-} + +{- $pull + The 'pull' category closely corresponds to pull-based Unix pipes. + + The 'pull' category obeys the category laws, where 'pull' is the identity + and ('>+>') is composition: + +@ +\-\- Left identity +'pull' '>+>' f = f + +\-\- Right identity +f '>+>' 'pull' = f + +\-\- Associativity +(f '>+>' g) '>+>' h = f '>+>' (g '>+>' h) +@ + + The following diagrams show the flow of information: + +@ +'pull' :: 'Monad' m + => a' -> 'Proxy' a' a a' a m r + +\ a' + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>+>') :: 'Monad' m + -> (b' -> 'Proxy' a' a b' b m r) + -> (c' -> 'Proxy' b' b c' c m r) + -> (c' -> 'Proxy' a' a c' c m r) + +\ b' c' c' + | | | + +----|----+ +----|----+ +----|----+ + | v | | v | | v | + a' <== <== b' <== <== c' a' <== <== c' + | f | | g | = | f >+> g | + a ==> ==> b ==> ==> c a ==> ==> c + | | | | | | | | | + +----|----+ +----|----+ +----|----+ + v v v + r r r +@ + +-} + +{-| Forward requests followed by responses: + +@ +'pull' = 'request' 'Control.Monad.>=>' 'respond' 'Control.Monad.>=>' 'pull' +@ + + 'pull' is the identity of the pull category. +-} +pull :: Monad m => a' -> Proxy a' a a' a m r +pull = go + where + go a' = Request a' (\a -> Respond a go) +{-# INLINABLE pull #-} + +{-| Compose two proxies blocked in the middle of 'respond'ing, creating a new + proxy blocked in the middle of 'respond'ing + +@ +(f '>+>' g) x = f '+>>' g x +@ + + ('>+>') is the composition operator of the pull category. +-} +(>+>) + :: Monad m + => ( b' -> Proxy a' a b' b m r) + -- ^ + -> (_c' -> Proxy b' b c' c m r) + -- ^ + -> (_c' -> Proxy a' a c' c m r) + -- ^ +(fb' >+> fc') c' = fb' +>> fc' c' +{-# INLINABLE (>+>) #-} + +{-| @(f +>> p)@ pairs each 'request' in @p@ with a 'respond' in @f@. + + Point-ful version of ('>+>') +-} +(+>>) + :: Monad m + => (b' -> Proxy a' a b' b m r) + -- ^ + -> Proxy b' b c' c m r + -- ^ + -> Proxy a' a c' c m r + -- ^ +fb' +>> p = case p of + Request b' fb -> fb' b' >>~ fb + Respond c fc' -> Respond c (\c' -> fb' +>> fc' c') + M m -> M (m >>= \p' -> return (fb' +>> p')) + Pure r -> Pure r +{-# INLINABLE (+>>) #-} + +{- $reflect + @(reflect .)@ transforms each streaming category into its dual: + + * The request category is the dual of the respond category + +@ +'reflect' '.' 'respond' = 'request' + +'reflect' '.' (f '/>/' g) = 'reflect' '.' f '/</' 'reflect' '.' g +@ + +@ +'reflect' '.' 'request' = 'respond' + +'reflect' '.' (f '\>\' g) = 'reflect' '.' f '\<\' 'reflect' '.' g +@ + + * The pull category is the dual of the push category + +@ +'reflect' '.' 'push' = 'pull' + +'reflect' '.' (f '>~>' g) = 'reflect' '.' f '<+<' 'reflect' '.' g +@ + +@ +'reflect' '.' 'pull' = 'push' + +'reflect' '.' (f '>+>' g) = 'reflect' '.' f '<~<' 'reflect' '.' g +@ +-} + +-- | Switch the upstream and downstream ends +reflect :: Monad m => Proxy a' a b' b m r -> Proxy b b' a a' m r +reflect = go + where + go p = case p of + Request a' fa -> Respond a' (\a -> go (fa a )) + Respond b fb' -> Request b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure r +{-# INLINABLE reflect #-} + +{-| An effect in the base monad + + 'Effect's neither 'Pipes.await' nor 'Pipes.yield' +-} +type Effect = Proxy X () () X + +-- | 'Producer's can only 'Pipes.yield' +type Producer b = Proxy X () () b + +-- | 'Pipe's can both 'Pipes.await' and 'Pipes.yield' +type Pipe a b = Proxy () a () b + +-- | 'Consumer's can only 'Pipes.await' +type Consumer a = Proxy () a () X + +{-| @Client a' a@ sends requests of type @a'@ and receives responses of + type @a@. + + 'Client's only 'request' and never 'respond'. +-} +type Client a' a = Proxy a' a () X + +{-| @Server b' b@ receives requests of type @b'@ and sends responses of type + @b@. + + 'Server's only 'respond' and never 'request'. +-} +type Server b' b = Proxy X () b' b + +-- | Like 'Effect', but with a polymorphic type +type Effect' m r = forall x' x y' y . Proxy x' x y' y m r + +-- | Like 'Producer', but with a polymorphic type +type Producer' b m r = forall x' x . Proxy x' x () b m r + +-- | Like 'Consumer', but with a polymorphic type +type Consumer' a m r = forall y' y . Proxy () a y' y m r + +-- | Like 'Server', but with a polymorphic type +type Server' b' b m r = forall x' x . Proxy x' x b' b m r + +-- | Like 'Client', but with a polymorphic type +type Client' a' a m r = forall y' y . Proxy a' a y' y m r + +-- | Equivalent to ('/>/') with the arguments flipped +(\<\) + :: Monad m + => (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x b' b m a') + -- ^ + -> (a -> Proxy x' x c' c m a') + -- ^ +p1 \<\ p2 = p2 />/ p1 +{-# INLINABLE (\<\) #-} + +-- | Equivalent to ('\>\') with the arguments flipped +(/</) + :: Monad m + => (c' -> Proxy b' b x' x m c) + -- ^ + -> (b' -> Proxy a' a x' x m b) + -- ^ + -> (c' -> Proxy a' a x' x m c) + -- ^ +p1 /</ p2 = p2 \>\ p1 +{-# INLINABLE (/</) #-} + +-- | Equivalent to ('>~>') with the arguments flipped +(<~<) + :: Monad m + => (b -> Proxy b' b c' c m r) + -- ^ + -> (a -> Proxy a' a b' b m r) + -- ^ + -> (a -> Proxy a' a c' c m r) + -- ^ +p1 <~< p2 = p2 >~> p1 +{-# INLINABLE (<~<) #-} + +-- | Equivalent to ('>+>') with the arguments flipped +(<+<) + :: Monad m + => (c' -> Proxy b' b c' c m r) + -- ^ + -> (b' -> Proxy a' a b' b m r) + -- ^ + -> (c' -> Proxy a' a c' c m r) + -- ^ +p1 <+< p2 = p2 >+> p1 +{-# INLINABLE (<+<) #-} + +-- | Equivalent to ('//>') with the arguments flipped +(<\\) + :: Monad m + => (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x b' b m a' + -- ^ + -> Proxy x' x c' c m a' + -- ^ +f <\\ p = p //> f +{-# INLINABLE (<\\) #-} + +-- | Equivalent to ('>\\') with the arguments flipped +(//<) + :: Monad m + => Proxy b' b y' y m c + -- ^ + -> (b' -> Proxy a' a y' y m b) + -- ^ + -> Proxy a' a y' y m c + -- ^ +p //< f = f >\\ p +{-# INLINABLE (//<) #-} + +-- | Equivalent to ('>>~') with the arguments flipped +(~<<) + :: Monad m + => (b -> Proxy b' b c' c m r) + -- ^ + -> Proxy a' a b' b m r + -- ^ + -> Proxy a' a c' c m r + -- ^ +k ~<< p = p >>~ k +{-# INLINABLE (~<<) #-} + +-- | Equivalent to ('+>>') with the arguments flipped +(<<+) + :: Monad m + => Proxy b' b c' c m r + -- ^ + -> (b' -> Proxy a' a b' b m r) + -- ^ + -> Proxy a' a c' c m r + -- ^ +k <<+ p = p +>> k +{-# INLINABLE (<<+) #-} + +{-# RULES + "(p //> f) //> g" forall p f g . (p //> f) //> g = p //> (\x -> f x //> g) + + ; "p //> respond" forall p . p //> respond = p + + ; "respond x //> f" forall x f . respond x //> f = f x + + ; "f >\\ (g >\\ p)" forall f g p . f >\\ (g >\\ p) = (\x -> f >\\ g x) >\\ p + + ; "request >\\ p" forall p . request >\\ p = p + + ; "f >\\ request x" forall f x . f >\\ request x = f x + + ; "(p >>~ f) >>~ g" forall p f g . (p >>~ f) >>~ g = p >>~ (\x -> f x >>~ g) + + ; "p >>~ push" forall p . p >>~ push = p + + ; "push x >>~ f" forall x f . push x >>~ f = f x + + ; "f +>> (g +>> p)" forall f g p . f +>> (g +>> p) = (\x -> f +>> g x) +>> p + + ; "pull +>> p" forall p . pull +>> p = p + + ; "f +>> pull x" forall f x . f +>> pull x = f x + + #-}
src/Pipes/Internal.hs view
@@ -1,248 +1,258 @@-{-| This is an internal module, meaning that it is unsafe to import unless you- understand the risks.-- This module provides a fast implementation by weakening the monad- transformer laws. These laws do not hold if you can pattern match on the- constructors, as the following counter-example illustrates:--@-'lift' '.' 'return' = 'M' '.' 'return' '.' 'Pure'--'return' = 'Pure'--'lift' '.' 'return' /= 'return'-@-- You do not need to worry about this if you do not import this module, since- the other modules in this library do not export the constructors or export- any functions which can violate the monad transformer laws.--}--{-# LANGUAGE- FlexibleInstances- , MultiParamTypeClasses- , RankNTypes- , UndecidableInstances- , Trustworthy- #-}--module Pipes.Internal (- -- * Internal- Proxy(..)- , unsafeHoist- , observe- , X- , closed- ) where--import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))-import Control.Monad (MonadPlus(..))-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Trans.Class (MonadTrans(lift))-import Control.Monad.Morph (MFunctor(hoist))-import Control.Monad.Error (MonadError(..))-import Control.Monad.Reader (MonadReader(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.Writer (MonadWriter(..))-import Data.Monoid (mempty,mappend)--{-| A 'Proxy' is a monad transformer that receives and sends information on both- an upstream and downstream interface.-- The type variables signify:-- * @a'@ and @a@ - The upstream interface, where @(a')@s go out and @(a)@s- come in-- * @b'@ and @b@ - The downstream interface, where @(b)@s go out and @(b')@s- come in-- * @m @ - The base monad-- * @r @ - The return value--}-data Proxy a' a b' b m r- = Request a' (a -> Proxy a' a b' b m r )- | Respond b (b' -> Proxy a' a b' b m r )- | M (m (Proxy a' a b' b m r))- | Pure r--instance Monad m => Functor (Proxy a' a b' b m) where- fmap f p0 = go p0 where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (m >>= \p' -> return (go p'))- Pure r -> Pure (f r)--instance Monad m => Applicative (Proxy a' a b' b m) where- pure = Pure- pf <*> px = go pf where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (m >>= \p' -> return (go p'))- Pure f -> fmap f px--instance Monad m => Monad (Proxy a' a b' b m) where- return = Pure- (>>=) = _bind--_bind- :: Monad m- => Proxy a' a b' b m r- -> (r -> Proxy a' a b' b m r')- -> Proxy a' a b' b m r'-p0 `_bind` f = go p0 where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (m >>= \p' -> return (go p'))- Pure r -> f r--{-# RULES- "_bind (Request a' k) f" forall a' k f .- _bind (Request a' k) f = Request a' (\a -> _bind (k a) f);- "_bind (Respond b k) f" forall b k f .- _bind (Respond b k) f = Respond b (\b' -> _bind (k b') f);- "_bind (M m) f" forall m f .- _bind (M m) f = M (m >>= \p -> return (_bind p f));- "_bind (Pure r ) f" forall r f .- _bind (Pure r ) f = f r;- #-}--instance MonadTrans (Proxy a' a b' b) where- lift m = M (m >>= \r -> return (Pure r))--{-| 'unsafeHoist' is like 'hoist', but faster.-- This is labeled as unsafe because you will break the monad transformer laws- if you do not pass a monad morphism as the first argument. This function is- safe if you pass a monad morphism as the first argument.--}-unsafeHoist- :: Monad m- => (forall x . m x -> n x) -> Proxy a' a b' b m r -> Proxy a' a b' b n r-unsafeHoist nat = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (nat (m >>= \p' -> return (go p')))- Pure r -> Pure r-{-# INLINABLE unsafeHoist #-}--instance MFunctor (Proxy a' a b' b) where- hoist nat p0 = go (observe p0) where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (nat (m >>= \p' -> return (go p')))- Pure r -> Pure r--instance MonadIO m => MonadIO (Proxy a' a b' b m) where- liftIO m = M (liftIO (m >>= \r -> return (Pure r)))--instance MonadReader r m => MonadReader r (Proxy a' a b' b m) where- ask = lift ask- local f = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M (local f m >>= \r -> return (go r))- reader = lift . reader--instance MonadState s m => MonadState s (Proxy a' a b' b m) where- get = lift get- put = lift . put- state = lift . state--instance MonadWriter w m => MonadWriter w (Proxy a' a b' b m) where- writer = lift . writer- tell = lift . tell- listen p0 = go p0 mempty- where- go p w = case p of- Request a' fa -> Request a' (\a -> go (fa a ) w)- Respond b fb' -> Respond b (\b' -> go (fb' b') w)- M m -> M (do- (p', w') <- listen m- return (go p' $! mappend w w') )- Pure r -> Pure (r, w)-- pass p0 = go p0 mempty- where- go p w = case p of- Request a' fa -> Request a' (\a -> go (fa a ) w)- Respond b fb' -> Respond b (\b' -> go (fb' b') w)- M m -> M (do- (p', w') <- listen m- return (go p' $! mappend w w') )- Pure (r, f) -> M (pass (return (Pure r, \_ -> f w)))--instance MonadError e m => MonadError e (Proxy a' a b' b m) where- throwError = lift . throwError- catchError p0 f = go p0- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M ((do- p' <- m- return (go p') ) `catchError` (\e -> return (f e)) )--instance MonadPlus m => Alternative (Proxy a' a b' b m) where- empty = mzero- (<|>) = mplus--instance MonadPlus m => MonadPlus (Proxy a' a b' b m) where- mzero = lift mzero- mplus p0 p1 = go p0- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M ((do- p' <- m- return (go p') ) `mplus` return p1 )--{-| The monad transformer laws are correct when viewed through the 'observe'- function:--@-'observe' ('lift' ('return' r)) = 'observe' ('return' r)--'observe' ('lift' (m '>>=' f)) = 'observe' ('lift' m '>>=' 'lift' '.' f)-@-- This correctness comes at a small cost to performance, so use this function- sparingly.-- This function is a convenience for low-level @pipes@ implementers. You do- not need to use 'observe' if you stick to the safe API.--}-observe :: Monad m => Proxy a' a b' b m r -> Proxy a' a b' b m r-observe p0 = M (go p0) where- go p = case p of- Request a' fa -> return (Request a' (\a -> observe (fa a )))- Respond b fb' -> return (Respond b (\b' -> observe (fb' b')))- M m' -> m' >>= go- Pure r -> return (Pure r)-{-# INLINABLE observe #-}--{-| The empty type, used to close output ends-- When @Data.Void@ is merged into @base@, this will change to:--> type X = Void--}-newtype X = X X---- | Use 'closed' to \"handle\" impossible outputs-closed :: X -> a-closed (X x) = closed x-{-# INLINABLE closed #-}+{-| This is an internal module, meaning that it is unsafe to import unless you + understand the risks. + + This module provides a fast implementation by weakening the monad + transformer laws. These laws do not hold if you can pattern match on the + constructors, as the following counter-example illustrates: + +@ +'lift' '.' 'return' = 'M' '.' 'return' '.' 'Pure' + +'return' = 'Pure' + +'lift' '.' 'return' /= 'return' +@ + + You do not need to worry about this if you do not import this module, since + the other modules in this library do not export the constructors or export + any functions which can violate the monad transformer laws. +-} + +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , RankNTypes + , UndecidableInstances + , Trustworthy + #-} + +module Pipes.Internal ( + -- * Internal + Proxy(..) + , unsafeHoist + , observe + , X + , closed + ) where + +import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) +import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Writer (MonadWriter(..)) +import Data.Monoid (mempty,mappend) + +{-| A 'Proxy' is a monad transformer that receives and sends information on both + an upstream and downstream interface. + + The type variables signify: + + * @a'@ and @a@ - The upstream interface, where @(a')@s go out and @(a)@s + come in + + * @b'@ and @b@ - The downstream interface, where @(b)@s go out and @(b')@s + come in + + * @m @ - The base monad + + * @r @ - The return value +-} +data Proxy a' a b' b m r + = Request a' (a -> Proxy a' a b' b m r ) + | Respond b (b' -> Proxy a' a b' b m r ) + | M (m (Proxy a' a b' b m r)) + | Pure r + +instance Monad m => Functor (Proxy a' a b' b m) where + fmap f p0 = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure (f r) + +instance Monad m => Applicative (Proxy a' a b' b m) where + pure = Pure + pf <*> px = go pf where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure f -> fmap f px + +instance Monad m => Monad (Proxy a' a b' b m) where + return = Pure + (>>=) = _bind + +_bind + :: Monad m + => Proxy a' a b' b m r + -> (r -> Proxy a' a b' b m r') + -> Proxy a' a b' b m r' +p0 `_bind` f = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> f r + +{-# RULES + "_bind (Request a' k) f" forall a' k f . + _bind (Request a' k) f = Request a' (\a -> _bind (k a) f); + "_bind (Respond b k) f" forall b k f . + _bind (Respond b k) f = Respond b (\b' -> _bind (k b') f); + "_bind (M m) f" forall m f . + _bind (M m) f = M (m >>= \p -> return (_bind p f)); + "_bind (Pure r ) f" forall r f . + _bind (Pure r ) f = f r; + #-} + +instance MonadTrans (Proxy a' a b' b) where + lift m = M (m >>= \r -> return (Pure r)) + +{-| 'unsafeHoist' is like 'hoist', but faster. + + This is labeled as unsafe because you will break the monad transformer laws + if you do not pass a monad morphism as the first argument. This function is + safe if you pass a monad morphism as the first argument. +-} +unsafeHoist + :: Monad m + => (forall x . m x -> n x) -> Proxy a' a b' b m r -> Proxy a' a b' b n r +unsafeHoist nat = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (nat (m >>= \p' -> return (go p'))) + Pure r -> Pure r +{-# INLINABLE unsafeHoist #-} + +instance MFunctor (Proxy a' a b' b) where + hoist nat p0 = go (observe p0) + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (nat (m >>= \p' -> return (go p'))) + Pure r -> Pure r + +instance MMonad (Proxy a' a b' b) where + embed f = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> f m >>= go + Pure r -> Pure r + +instance MonadIO m => MonadIO (Proxy a' a b' b m) where + liftIO m = M (liftIO (m >>= \r -> return (Pure r))) + +instance MonadReader r m => MonadReader r (Proxy a' a b' b m) where + ask = lift ask + local f = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M (local f m >>= \r -> return (go r)) + reader = lift . reader + +instance MonadState s m => MonadState s (Proxy a' a b' b m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadWriter w m => MonadWriter w (Proxy a' a b' b m) where + writer = lift . writer + tell = lift . tell + listen p0 = go p0 mempty + where + go p w = case p of + Request a' fa -> Request a' (\a -> go (fa a ) w) + Respond b fb' -> Respond b (\b' -> go (fb' b') w) + M m -> M (do + (p', w') <- listen m + return (go p' $! mappend w w') ) + Pure r -> Pure (r, w) + + pass p0 = go p0 mempty + where + go p w = case p of + Request a' fa -> Request a' (\a -> go (fa a ) w) + Respond b fb' -> Respond b (\b' -> go (fb' b') w) + M m -> M (do + (p', w') <- listen m + return (go p' $! mappend w w') ) + Pure (r, f) -> M (pass (return (Pure r, \_ -> f w))) + +instance MonadError e m => MonadError e (Proxy a' a b' b m) where + throwError = lift . throwError + catchError p0 f = go p0 + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M ((do + p' <- m + return (go p') ) `catchError` (\e -> return (f e)) ) + +instance MonadPlus m => Alternative (Proxy a' a b' b m) where + empty = mzero + (<|>) = mplus + +instance MonadPlus m => MonadPlus (Proxy a' a b' b m) where + mzero = lift mzero + mplus p0 p1 = go p0 + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M ((do + p' <- m + return (go p') ) `mplus` return p1 ) + +{-| The monad transformer laws are correct when viewed through the 'observe' + function: + +@ +'observe' ('lift' ('return' r)) = 'observe' ('return' r) + +'observe' ('lift' (m '>>=' f)) = 'observe' ('lift' m '>>=' 'lift' '.' f) +@ + + This correctness comes at a small cost to performance, so use this function + sparingly. + + This function is a convenience for low-level @pipes@ implementers. You do + not need to use 'observe' if you stick to the safe API. +-} +observe :: Monad m => Proxy a' a b' b m r -> Proxy a' a b' b m r +observe p0 = M (go p0) where + go p = case p of + Request a' fa -> return (Request a' (\a -> observe (fa a ))) + Respond b fb' -> return (Respond b (\b' -> observe (fb' b'))) + M m' -> m' >>= go + Pure r -> return (Pure r) +{-# INLINABLE observe #-} + +{-| The empty type, used to close output ends + + When @Data.Void@ is merged into @base@, this will change to: + +> type X = Void +-} +newtype X = X X + +-- | Use 'closed' to \"handle\" impossible outputs +closed :: X -> a +closed (X x) = closed x +{-# INLINABLE closed #-}
src/Pipes/Lift.hs view
@@ -1,380 +1,380 @@-{-| Many actions in base monad transformers cannot be automatically- 'Control.Monad.Trans.Class.lift'ed. These functions lift these remaining- actions so that they work in the 'Proxy' monad transformer.-- See the mini-tutorial at the bottom of this module for example code and- typical use cases where this module will come in handy.--}--module Pipes.Lift (- -- * Utilities- distribute-- -- * ErrorT- , errorP- , runErrorP- , catchError- , liftCatchError-- -- * MaybeT- , maybeP- , runMaybeP-- -- * ReaderT- , readerP- , runReaderP-- -- * StateT- , stateP- , runStateP- , evalStateP- , execStateP-- -- * WriterT- -- $writert- , writerP- , runWriterP- , execWriterP-- -- * RWST- , rwsP- , runRWSP- , evalRWSP- , execRWSP-- -- * Tutorial- -- $tutorial- ) where--import Control.Monad.Trans.Class (lift, MonadTrans(..))-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 S-import qualified Control.Monad.Trans.Writer.Strict as W-import qualified Control.Monad.Trans.RWS.Strict as RWS-import Data.Monoid (Monoid)-import Pipes.Internal (Proxy(..), unsafeHoist)-import Control.Monad.Morph (hoist, MFunctor(..))-import Pipes.Core (runEffect, request, respond, (//>), (>\\))---- | Distribute 'Proxy' over a monad transformer-distribute- :: ( Monad m- , MonadTrans t- , MFunctor t- , Monad (t m)- , Monad (t (Proxy a' a b' b m))- )- => Proxy a' a b' b (t m) r- -- ^ - -> t (Proxy a' a b' b m) r- -- ^ -distribute p = runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond'- where- request' = lift . lift . request- respond' = lift . lift . respond-{-# INLINABLE distribute #-}---- | Wrap the base monad in 'E.ErrorT'-errorP- :: (Monad m, E.Error e)- => Proxy a' a b' b m (Either e r)- -> Proxy a' a b' b (E.ErrorT e m) r-errorP p = do- x <- unsafeHoist lift p- lift $ E.ErrorT (return x)-{-# INLINABLE errorP #-}---- | Run 'E.ErrorT' in the base monad-runErrorP- :: (Monad m, E.Error e)- => Proxy a' a b' b (E.ErrorT e m) r- -> Proxy a' a b' b m (Either e r)-runErrorP = E.runErrorT . distribute -{-# INLINABLE runErrorP #-}---- | Catch an error in the base monad-catchError- :: (Monad m, E.Error e) - => Proxy a' a b' b (E.ErrorT e m) r- -- ^- -> (e -> Proxy a' a b' b (E.ErrorT e m) r)- -- ^- -> Proxy a' a b' b (E.ErrorT e m) r-catchError e h = errorP . E.runErrorT $ - E.catchError (distribute e) (distribute . h)-{-# INLINABLE catchError #-}---- | Catch an error using a catch function for the base monad-liftCatchError- :: Monad m- => ( m (Proxy a' a b' b m r)- -> (e -> m (Proxy a' a b' b m r))- -> m (Proxy a' a b' b m r) )- -- ^- -> (Proxy a' a b' b m r- -> (e -> Proxy a' a b' b m r)- -> Proxy a' a b' b m r)- -- ^-liftCatchError c p0 f = go p0- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M ((do- p' <- m- return (go p') ) `c` (\e -> return (f e)) )-{-# INLINABLE liftCatchError #-}---- | Wrap the base monad in 'M.MaybeT'-maybeP- :: Monad m- => Proxy a' a b' b m (Maybe r) -> Proxy a' a b' b (M.MaybeT m) r-maybeP p = do- x <- unsafeHoist lift p- lift $ M.MaybeT (return x)-{-# INLINABLE maybeP #-}---- | Run 'M.MaybeT' in the base monad-runMaybeP- :: Monad m- => Proxy a' a b' b (M.MaybeT m) r- -> Proxy a' a b' b m (Maybe r)-runMaybeP p = M.runMaybeT $ distribute p-{-# INLINABLE runMaybeP #-}---- | Wrap the base monad in 'R.ReaderT'-readerP- :: Monad m- => (i -> Proxy a' a b' b m r) -> Proxy a' a b' b (R.ReaderT i m) r-readerP k = do- i <- lift R.ask- unsafeHoist lift (k i)-{-# INLINABLE readerP #-}---- | Run 'R.ReaderT' in the base monad-runReaderP- :: Monad m- => i- -> Proxy a' a b' b (R.ReaderT i m) r- -> Proxy a' a b' b m r-runReaderP r p = (`R.runReaderT` r) $ distribute p-{-# INLINABLE runReaderP #-}---- | Wrap the base monad in 'S.StateT'-stateP- :: Monad m- => (s -> Proxy a' a b' b m (r, s)) -> Proxy a' a b' b (S.StateT s m) r-stateP k = do- s <- lift S.get- (r, s') <- unsafeHoist lift (k s)- lift (S.put s')- return r-{-# INLINABLE stateP #-}---- | Run 'S.StateT' in the base monad-runStateP- :: Monad m- => s- -> Proxy a' a b' b (S.StateT s m) r- -> Proxy a' a b' b m (r, s)-runStateP s p = (`S.runStateT` s) $ distribute p-{-# INLINABLE runStateP #-}---- | Evaluate 'S.StateT' in the base monad-evalStateP- :: Monad m- => s- -> Proxy a' a b' b (S.StateT s m) r- -> Proxy a' a b' b m r-evalStateP s p = fmap fst $ runStateP s p-{-# INLINABLE evalStateP #-}---- | Execute 'S.StateT' in the base monad-execStateP- :: Monad m- => s- -> Proxy a' a b' b (S.StateT s m) r- -> Proxy a' a b' b m s-execStateP s p = fmap snd $ runStateP s p-{-# INLINABLE execStateP #-}--{- $writert- Note that 'runWriterP' and 'execWriterP' will keep the accumulator in- weak-head-normal form so that folds run in constant space when possible.-- This means that until @transformers@ adds a truly strict 'W.WriterT', you- should consider unwrapping 'W.WriterT' first using 'runWriterP' or- 'execWriterP' before running your 'Proxy'. You will get better performance- this way and eliminate space leaks if your accumulator doesn't have any lazy- fields.--}---- | Wrap the base monad in 'W.WriterT'-writerP- :: (Monad m, Monoid w)- => Proxy a' a b' b m (r, w) -> Proxy a' a b' b (W.WriterT w m) r-writerP p = do- (r, w) <- unsafeHoist lift p- lift $ W.tell w- return r-{-# INLINABLE writerP #-}---- | Run 'W.WriterT' in the base monad-runWriterP- :: (Monad m, Monoid w)- => Proxy a' a b' b (W.WriterT w m) r- -> Proxy a' a b' b m (r, w)-runWriterP p = W.runWriterT $ distribute p-{-# INLINABLE runWriterP #-}---- | Execute 'W.WriterT' in the base monad-execWriterP- :: (Monad m, Monoid w)- => Proxy a' a b' b (W.WriterT w m) r- -> Proxy a' a b' b m w-execWriterP p = fmap snd $ runWriterP p-{-# INLINABLE execWriterP #-}---- | Wrap the base monad in 'RWS.RWST'-rwsP- :: (Monad m, Monoid w)- => (i -> s -> Proxy a' a b' b m (r, s, w))- -> Proxy a' a b' b (RWS.RWST i w s m) r-rwsP k = do- i <- lift RWS.ask- s <- lift RWS.get- (r, s', w) <- unsafeHoist lift (k i s)- lift $ do- RWS.put s'- RWS.tell w- return r-{-# INLINABLE rwsP #-}---- | Run 'RWS.RWST' in the base monad-runRWSP- :: (Monad m, Monoid w)- => r- -> s- -> Proxy a' a b' b (RWS.RWST r w s m) d- -> Proxy a' a b' b m (d, s, w)-runRWSP i s p = (\b -> RWS.runRWST b i s) $ distribute p-{-# INLINABLE runRWSP #-}---- | Evaluate 'RWS.RWST' in the base monad-evalRWSP- :: (Monad m, Monoid w)- => r- -> s- -> Proxy a' a b' b (RWS.RWST r w s m) d- -> Proxy a' a b' b m (d, w)-evalRWSP i s p = fmap f $ runRWSP i s p- where- f x = let (r, _, w) = x in (r, w)-{-# INLINABLE evalRWSP #-}---- | Execute 'RWS.RWST' in the base monad-execRWSP- :: (Monad m, Monoid w)- => r- -> s- -> Proxy a' a b' b (RWS.RWST r w s m) d- -> Proxy a' a b' b m (s, w)-execRWSP i s p = fmap f $ runRWSP i s p- where- f x = let (_, s', w) = x in (s', w)-{-# INLINABLE execRWSP #-}--{- $tutorial- Probably the most useful functionality in this module is lifted error- handling. Suppose that you have a 'Pipes.Pipe' whose base monad can fail- using 'E.ErrorT':--> import Control.Monad.Trans.Error-> import Pipes->-> example :: Monad m => Pipe Int Int (ErrorT String m) r-> example = for cat $ \n ->-> if n == 0-> then lift $ throwError "Zero is forbidden"-> else yield n-- Without the tools in this module you cannot recover from any potential error- until after you compose and run the pipeline:-->>> import qualified Pipes.Prelude as P->>> runErrorT $ runEffect $ P.readLn >-> example >-> P.print-42<Enter>-42-1<Enter>-1-0<Enter>-Zero is forbidden->>>-- This module provides `catchError`, which lets you catch and recover from- errors inside the 'Pipe':--> import qualified Pipes.Lift as Lift-> -> caught :: Pipe Int Int (ErrorT String IO) r-> caught = example `Lift.catchError` \str -> do-> liftIO (putStrLn str)-> caught-- This lets you resume streaming in the face of errors raised within the base- monad:-->>> runErrorT $ runEffect $ P.readLn >-> caught >-> P.print-0<Enter>-Zero is forbidden-42<Enter>-42-0<Enter>-Zero is forbidden-1<Enter>-1-...-- Another common use case is running a base monad before running the pipeline.- For example, the following contrived 'Producer' uses 'S.StateT' gratuitously- to increment numbers:--> import Control.Monad (forever)-> import Control.Monad.Trans.State.Strict-> import Pipes-> -> numbers :: Monad m => Producer Int (StateT Int m) r-> numbers = forever $ do-> n <- lift get-> yield n-> lift $ put $! n + 1-- You can run the 'StateT' monad by supplying an initial state, before you- ever compose the 'Producer':--> import Pipes.Lift->-> naturals :: Monad m => Producer Int m r-> naturals = evalStateP 0 numbers-- This deletes 'StateT' from the base monad entirely, give you a completely- pure 'Pipes.Producer':-->>> Pipes.Prelude.toList naturals-[0,1,2,3,4,5,6...]-- Note that the convention for the 'S.StateT' run functions is backwards from- @transformers@ for convenience: the initial state is the first argument.-- All of these functions internally use 'distribute', which can pull out most- monad transformers from the base monad. For example, 'evalStateP' is- defined in terms of 'distribute':--> evalStateP s p = evalStateT (distribute p) s-- Therefore you can use 'distribute' to run other monad transformers, too, as- long as they implement the 'MFunctor' type class from the @mmorph@ library.--}+{-| Many actions in base monad transformers cannot be automatically + 'Control.Monad.Trans.Class.lift'ed. These functions lift these remaining + actions so that they work in the 'Proxy' monad transformer. + + See the mini-tutorial at the bottom of this module for example code and + typical use cases where this module will come in handy. +-} + +module Pipes.Lift ( + -- * Utilities + distribute + + -- * ErrorT + , errorP + , runErrorP + , catchError + , liftCatchError + + -- * MaybeT + , maybeP + , runMaybeP + + -- * ReaderT + , readerP + , runReaderP + + -- * StateT + , stateP + , runStateP + , evalStateP + , execStateP + + -- * WriterT + -- $writert + , writerP + , runWriterP + , execWriterP + + -- * RWST + , rwsP + , runRWSP + , evalRWSP + , execRWSP + + -- * Tutorial + -- $tutorial + ) where + +import Control.Monad.Trans.Class (lift, MonadTrans(..)) +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 S +import qualified Control.Monad.Trans.Writer.Strict as W +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Data.Monoid (Monoid) +import Pipes.Internal (Proxy(..), unsafeHoist) +import Control.Monad.Morph (hoist, MFunctor(..)) +import Pipes.Core (runEffect, request, respond, (//>), (>\\)) + +-- | Distribute 'Proxy' over a monad transformer +distribute + :: ( Monad m + , MonadTrans t + , MFunctor t + , Monad (t m) + , Monad (t (Proxy a' a b' b m)) + ) + => Proxy a' a b' b (t m) r + -- ^ + -> t (Proxy a' a b' b m) r + -- ^ +distribute p = runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond' + where + request' = lift . lift . request + respond' = lift . lift . respond +{-# INLINABLE distribute #-} + +-- | Wrap the base monad in 'E.ErrorT' +errorP + :: (Monad m, E.Error e) + => Proxy a' a b' b m (Either e r) + -> Proxy a' a b' b (E.ErrorT e m) r +errorP p = do + x <- unsafeHoist lift p + lift $ E.ErrorT (return x) +{-# INLINABLE errorP #-} + +-- | Run 'E.ErrorT' in the base monad +runErrorP + :: (Monad m, E.Error e) + => Proxy a' a b' b (E.ErrorT e m) r + -> Proxy a' a b' b m (Either e r) +runErrorP = E.runErrorT . distribute +{-# INLINABLE runErrorP #-} + +-- | Catch an error in the base monad +catchError + :: (Monad m, E.Error e) + => Proxy a' a b' b (E.ErrorT e m) r + -- ^ + -> (e -> Proxy a' a b' b (E.ErrorT e m) r) + -- ^ + -> Proxy a' a b' b (E.ErrorT e m) r +catchError e h = errorP . E.runErrorT $ + E.catchError (distribute e) (distribute . h) +{-# INLINABLE catchError #-} + +-- | Catch an error using a catch function for the base monad +liftCatchError + :: Monad m + => ( m (Proxy a' a b' b m r) + -> (e -> m (Proxy a' a b' b m r)) + -> m (Proxy a' a b' b m r) ) + -- ^ + -> (Proxy a' a b' b m r + -> (e -> Proxy a' a b' b m r) + -> Proxy a' a b' b m r) + -- ^ +liftCatchError c p0 f = go p0 + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M ((do + p' <- m + return (go p') ) `c` (\e -> return (f e)) ) +{-# INLINABLE liftCatchError #-} + +-- | Wrap the base monad in 'M.MaybeT' +maybeP + :: Monad m + => Proxy a' a b' b m (Maybe r) -> Proxy a' a b' b (M.MaybeT m) r +maybeP p = do + x <- unsafeHoist lift p + lift $ M.MaybeT (return x) +{-# INLINABLE maybeP #-} + +-- | Run 'M.MaybeT' in the base monad +runMaybeP + :: Monad m + => Proxy a' a b' b (M.MaybeT m) r + -> Proxy a' a b' b m (Maybe r) +runMaybeP p = M.runMaybeT $ distribute p +{-# INLINABLE runMaybeP #-} + +-- | Wrap the base monad in 'R.ReaderT' +readerP + :: Monad m + => (i -> Proxy a' a b' b m r) -> Proxy a' a b' b (R.ReaderT i m) r +readerP k = do + i <- lift R.ask + unsafeHoist lift (k i) +{-# INLINABLE readerP #-} + +-- | Run 'R.ReaderT' in the base monad +runReaderP + :: Monad m + => i + -> Proxy a' a b' b (R.ReaderT i m) r + -> Proxy a' a b' b m r +runReaderP r p = (`R.runReaderT` r) $ distribute p +{-# INLINABLE runReaderP #-} + +-- | Wrap the base monad in 'S.StateT' +stateP + :: Monad m + => (s -> Proxy a' a b' b m (r, s)) -> Proxy a' a b' b (S.StateT s m) r +stateP k = do + s <- lift S.get + (r, s') <- unsafeHoist lift (k s) + lift (S.put s') + return r +{-# INLINABLE stateP #-} + +-- | Run 'S.StateT' in the base monad +runStateP + :: Monad m + => s + -> Proxy a' a b' b (S.StateT s m) r + -> Proxy a' a b' b m (r, s) +runStateP s p = (`S.runStateT` s) $ distribute p +{-# INLINABLE runStateP #-} + +-- | Evaluate 'S.StateT' in the base monad +evalStateP + :: Monad m + => s + -> Proxy a' a b' b (S.StateT s m) r + -> Proxy a' a b' b m r +evalStateP s p = fmap fst $ runStateP s p +{-# INLINABLE evalStateP #-} + +-- | Execute 'S.StateT' in the base monad +execStateP + :: Monad m + => s + -> Proxy a' a b' b (S.StateT s m) r + -> Proxy a' a b' b m s +execStateP s p = fmap snd $ runStateP s p +{-# INLINABLE execStateP #-} + +{- $writert + Note that 'runWriterP' and 'execWriterP' will keep the accumulator in + weak-head-normal form so that folds run in constant space when possible. + + This means that until @transformers@ adds a truly strict 'W.WriterT', you + should consider unwrapping 'W.WriterT' first using 'runWriterP' or + 'execWriterP' before running your 'Proxy'. You will get better performance + this way and eliminate space leaks if your accumulator doesn't have any lazy + fields. +-} + +-- | Wrap the base monad in 'W.WriterT' +writerP + :: (Monad m, Monoid w) + => Proxy a' a b' b m (r, w) -> Proxy a' a b' b (W.WriterT w m) r +writerP p = do + (r, w) <- unsafeHoist lift p + lift $ W.tell w + return r +{-# INLINABLE writerP #-} + +-- | Run 'W.WriterT' in the base monad +runWriterP + :: (Monad m, Monoid w) + => Proxy a' a b' b (W.WriterT w m) r + -> Proxy a' a b' b m (r, w) +runWriterP p = W.runWriterT $ distribute p +{-# INLINABLE runWriterP #-} + +-- | Execute 'W.WriterT' in the base monad +execWriterP + :: (Monad m, Monoid w) + => Proxy a' a b' b (W.WriterT w m) r + -> Proxy a' a b' b m w +execWriterP p = fmap snd $ runWriterP p +{-# INLINABLE execWriterP #-} + +-- | Wrap the base monad in 'RWS.RWST' +rwsP + :: (Monad m, Monoid w) + => (i -> s -> Proxy a' a b' b m (r, s, w)) + -> Proxy a' a b' b (RWS.RWST i w s m) r +rwsP k = do + i <- lift RWS.ask + s <- lift RWS.get + (r, s', w) <- unsafeHoist lift (k i s) + lift $ do + RWS.put s' + RWS.tell w + return r +{-# INLINABLE rwsP #-} + +-- | Run 'RWS.RWST' in the base monad +runRWSP + :: (Monad m, Monoid w) + => r + -> s + -> Proxy a' a b' b (RWS.RWST r w s m) d + -> Proxy a' a b' b m (d, s, w) +runRWSP i s p = (\b -> RWS.runRWST b i s) $ distribute p +{-# INLINABLE runRWSP #-} + +-- | Evaluate 'RWS.RWST' in the base monad +evalRWSP + :: (Monad m, Monoid w) + => r + -> s + -> Proxy a' a b' b (RWS.RWST r w s m) d + -> Proxy a' a b' b m (d, w) +evalRWSP i s p = fmap f $ runRWSP i s p + where + f x = let (r, _, w) = x in (r, w) +{-# INLINABLE evalRWSP #-} + +-- | Execute 'RWS.RWST' in the base monad +execRWSP + :: (Monad m, Monoid w) + => r + -> s + -> Proxy a' a b' b (RWS.RWST r w s m) d + -> Proxy a' a b' b m (s, w) +execRWSP i s p = fmap f $ runRWSP i s p + where + f x = let (_, s', w) = x in (s', w) +{-# INLINABLE execRWSP #-} + +{- $tutorial + Probably the most useful functionality in this module is lifted error + handling. Suppose that you have a 'Pipes.Pipe' whose base monad can fail + using 'E.ErrorT': + +> import Control.Monad.Trans.Error +> import Pipes +> +> example :: Monad m => Pipe Int Int (ErrorT String m) r +> example = for cat $ \n -> +> if n == 0 +> then lift $ throwError "Zero is forbidden" +> else yield n + + Without the tools in this module you cannot recover from any potential error + until after you compose and run the pipeline: + +>>> import qualified Pipes.Prelude as P +>>> runErrorT $ runEffect $ P.readLn >-> example >-> P.print +42<Enter> +42 +1<Enter> +1 +0<Enter> +Zero is forbidden +>>> + + This module provides `catchError`, which lets you catch and recover from + errors inside the 'Pipe': + +> import qualified Pipes.Lift as Lift +> +> caught :: Pipe Int Int (ErrorT String IO) r +> caught = example `Lift.catchError` \str -> do +> liftIO (putStrLn str) +> caught + + This lets you resume streaming in the face of errors raised within the base + monad: + +>>> runErrorT $ runEffect $ P.readLn >-> caught >-> P.print +0<Enter> +Zero is forbidden +42<Enter> +42 +0<Enter> +Zero is forbidden +1<Enter> +1 +... + + Another common use case is running a base monad before running the pipeline. + For example, the following contrived 'Producer' uses 'S.StateT' gratuitously + to increment numbers: + +> import Control.Monad (forever) +> import Control.Monad.Trans.State.Strict +> import Pipes +> +> numbers :: Monad m => Producer Int (StateT Int m) r +> numbers = forever $ do +> n <- lift get +> yield n +> lift $ put $! n + 1 + + You can run the 'StateT' monad by supplying an initial state, before you + ever compose the 'Producer': + +> import Pipes.Lift +> +> naturals :: Monad m => Producer Int m r +> naturals = evalStateP 0 numbers + + This deletes 'StateT' from the base monad entirely, give you a completely + pure 'Pipes.Producer': + +>>> Pipes.Prelude.toList naturals +[0,1,2,3,4,5,6...] + + Note that the convention for the 'S.StateT' run functions is backwards from + @transformers@ for convenience: the initial state is the first argument. + + All of these functions internally use 'distribute', which can pull out most + monad transformers from the base monad. For example, 'evalStateP' is + defined in terms of 'distribute': + +> evalStateP s p = evalStateT (distribute p) s + + Therefore you can use 'distribute' to run other monad transformers, too, as + long as they implement the 'MFunctor' type class from the @mmorph@ library. +-}
src/Pipes/Prelude.hs view
@@ -1,725 +1,802 @@-{-| General purpose utilities-- The names in this module clash heavily with the Haskell Prelude, so I- recommend the following import scheme:--> import Pipes-> import qualified Pipes.Prelude as P -- or use any other qualifier you prefer-- Note that 'String'-based 'IO' is inefficient. The 'String'-based utilities- in this module exist only for simple demonstrations without incurring a- dependency on the @text@ package.-- Also, 'stdinLn' and 'stdoutLn' remove and add newlines, respectively. This- behavior is intended to simplify examples. The corresponding @stdin@ and- @stdout@ utilities from @pipes-bytestring@ and @pipes-text@ preserve- newlines.--}--{-# LANGUAGE RankNTypes, Trustworthy #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module Pipes.Prelude (- -- * Producers- -- $producers- stdinLn- , readLn- , fromHandle- , replicateM-- -- * Consumers- -- $consumers- , stdoutLn- , print- , toHandle- , drain-- -- * Pipes- -- $pipes- , map- , mapM- , sequence- , mapFoldable- , filter- , filterM- , take- , takeWhile- , drop- , dropWhile- , concat- , elemIndices- , findIndices- , scan- , scanM- , chain- , read- , show-- -- * Folds- -- $folds- , fold- , foldM- , all- , any- , and- , or- , elem- , notElem- , find- , findIndex- , head- , index- , last- , length- , maximum- , minimum- , null- , sum- , product- , toList- , toListM-- -- * Zips- , zip- , zipWith-- -- * Utilities- , tee- , generalize- ) where--import Control.Exception (throwIO, try)-import Control.Monad (liftM, replicateM_, when, unless)-import Control.Monad.Trans.State.Strict (get, put)-import Data.Functor.Identity (Identity, runIdentity)-import Foreign.C.Error (Errno(Errno), ePIPE)-import Pipes-import Pipes.Core-import Pipes.Internal-import Pipes.Lift (evalStateP)-import qualified GHC.IO.Exception as G-import qualified System.IO as IO-import qualified Prelude-import Prelude hiding (- all- , and- , any- , concat- , drop- , dropWhile- , elem- , filter- , head- , last- , length- , map- , mapM- , maximum- , minimum- , notElem- , null- , or- , print- , product- , read- , readLn- , sequence- , show- , sum- , take- , takeWhile- , zip- , zipWith- )--{- $producers- Use 'for' loops to iterate over 'Producer's whenever you want to perform the- same action for every element:--> -- Echo all lines from standard input to standard output-> runEffect $ for P.stdinLn $ \str -> do-> lift $ putStrLn str-- ... or more concisely:-->>> runEffect $ for P.stdinLn (lift . putStrLn)-Test<Enter>-Test-ABC<Enter>-ABC-...---}--{-| Read 'String's from 'IO.stdin' using 'getLine'-- Terminates on end of input--}-stdinLn :: MonadIO m => Producer' String m ()-stdinLn = fromHandle IO.stdin-{-# INLINABLE stdinLn #-}---- | 'read' values from 'IO.stdin', ignoring failed parses-readLn :: (MonadIO m, Read a) => Producer' a m ()-readLn = stdinLn >-> read-{-# INLINABLE readLn #-}--{-| Read 'String's from a 'IO.Handle' using 'IO.hGetLine'-- Terminates on end of input--}-fromHandle :: MonadIO m => IO.Handle -> Producer' String m ()-fromHandle h = go- where- go = do- eof <- liftIO $ IO.hIsEOF h- unless eof $ do- str <- liftIO $ IO.hGetLine h- yield str- go-{-# INLINABLE fromHandle #-}---- | Repeat a monadic action a fixed number of times, 'yield'ing each result-replicateM :: Monad m => Int -> m a -> Producer a m ()-replicateM n m = lift m >~ take n-{-# INLINABLE replicateM #-}--{- $consumers- Feed a 'Consumer' the same value repeatedly using ('>~'):-->>> runEffect $ lift getLine >~ P.stdoutLn-Test<Enter>-Test-ABC<Enter>-ABC-...---}--{-| Write 'String's to 'IO.stdout' using 'putStrLn'-- Unlike 'toHandle', 'stdoutLn' gracefully terminates on a broken output pipe--}-stdoutLn :: MonadIO m => Consumer' String m ()-stdoutLn = go- where- go = do- str <- await- x <- liftIO $ try (putStrLn str)- case x of- Left (G.IOError { G.ioe_type = G.ResourceVanished- , G.ioe_errno = Just ioe })- | Errno ioe == ePIPE- -> return ()- Left e -> liftIO (throwIO e)- Right () -> go-{-# INLINABLE stdoutLn #-}---- | 'print' values to 'IO.stdout'-print :: (MonadIO m, Show a) => Consumer' a m r-print = for cat (\a -> liftIO (Prelude.print a))-{-# INLINABLE print #-}--{-# RULES- "p >-> print" forall p .- p >-> print = for p (\a -> liftIO (Prelude.print a))- #-}---- | Write 'String's to a 'IO.Handle' using 'IO.hPutStrLn'-toHandle :: MonadIO m => IO.Handle -> Consumer' String m r-toHandle handle = for cat (\str -> liftIO (IO.hPutStrLn handle str))-{-# INLINABLE toHandle #-}--{-# RULES- "p >-> toHandle handle" forall p handle .- p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str))- #-}---- | 'discard' all incoming values-drain :: Monad m => Consumer' a m r-drain = for cat discard-{-# INLINABLE drain #-}--{-# RULES- "p >-> drain" forall p .- p >-> drain = for p discard- #-}--{- $pipes- Use ('>->') to connect 'Producer's, 'Pipe's, and 'Consumer's:-->>> runEffect $ P.stdinLn >-> P.takeWhile (/= "quit") >-> P.stdoutLn-Test<Enter>-Test-ABC<Enter>-ABC-quit<Enter>->>>---}---- | Apply a function to all values flowing downstream-map :: Monad m => (a -> b) -> Pipe a b m r-map f = for cat (\a -> yield (f a))-{-# INLINABLE map #-}--{-# RULES- "p >-> map f" forall p f . p >-> map f = for p (\a -> yield (f a))-- ; "map f >-> p" forall p f . map f >-> p = (do- a <- await- return (f a) ) >~ p- #-}---- | Apply a monadic function to all values flowing downstream-mapM :: Monad m => (a -> m b) -> Pipe a b m r-mapM f = for cat $ \a -> do- b <- lift (f a)- yield b-{-# INLINABLE mapM #-}--{-# RULES- "p >-> mapM f" forall p f . p >-> mapM f = for p (\a -> do- b <- lift (f a)- yield b )-- ; "mapM f >-> p" forall p f . mapM f >-> p = (do- a <- await- b <- lift (f a)- return b ) >~ p- #-}---- | Convert a stream of actions to a stream of values-sequence :: Monad m => Pipe (m a) a m r-sequence = mapM id-{-# INLINABLE sequence #-}--{- | Apply a function to all values flowing downstream, and- forward each element of the result.--}-mapFoldable :: (Monad m, Foldable t) => (a -> t b) -> Pipe a b m r-mapFoldable f = for cat (\a -> each (f a))-{-# INLINABLE mapFoldable #-}--{-# RULES- "p >-> mapFoldable f" forall p f .- p >-> mapFoldable f = for p (\a -> each (f a))- #-}---- | @(filter predicate)@ only forwards values that satisfy the predicate.-filter :: Monad m => (a -> Bool) -> Pipe a a m r-filter predicate = for cat $ \a -> when (predicate a) (yield a)-{-# INLINABLE filter #-}--{-# RULES- "p >-> filter predicate" forall p predicate.- p >-> filter predicate = for p (\a -> when (predicate a) (yield a))- #-}--{-| @(filterM predicate)@ only forwards values that satisfy the monadic- predicate--}-filterM :: Monad m => (a -> m Bool) -> Pipe a a m r-filterM predicate = for cat $ \a -> do- b <- lift (predicate a)- when b (yield a)-{-# INLINABLE filterM #-}--{-# RULES- "p >-> filterM predicate" forall p predicate .- p >-> filterM predicate = for p (\a -> do- b <- lift (predicate a)- when b (yield a) )- #-}---- | @(take n)@ only allows @n@ values to pass through-take :: Monad m => Int -> Pipe a a m ()-take n = replicateM_ n $ do- a <- await- yield a-{-# INLINABLE take #-}--{-| @(takeWhile p)@ allows values to pass downstream so long as they satisfy- the predicate @p@.--}-takeWhile :: Monad m => (a -> Bool) -> Pipe a a m ()-takeWhile predicate = go- where- go = do- a <- await- if (predicate a)- then do- yield a- go- else return ()-{-# INLINABLE takeWhile #-}---- | @(drop n)@ discards @n@ values going downstream-drop :: Monad m => Int -> Pipe a a m r-drop n = do- replicateM_ n await- cat-{-# INLINABLE drop #-}--{-| @(dropWhile p)@ discards values going downstream until one violates the- predicate @p@.--}-dropWhile :: Monad m => (a -> Bool) -> Pipe a a m r-dropWhile predicate = go- where- go = do- a <- await- if (predicate a)- then go- else do- yield a- cat-{-# INLINABLE dropWhile #-}---- | Flatten all 'Foldable' elements flowing downstream-concat :: (Monad m, Foldable f) => Pipe (f a) a m r-concat = for cat each-{-# INLINABLE concat #-}--{-# RULES- "p >-> concat" forall p . p >-> concat = for p each- #-}---- | Outputs the indices of all elements that match the given element-elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r-elemIndices a = findIndices (a ==)-{-# INLINABLE elemIndices #-}---- | Outputs the indices of all elements that satisfied the predicate-findIndices :: Monad m => (a -> Bool) -> Pipe a Int m r-findIndices predicate = loop 0- where- loop n = do- a <- await- when (predicate a) (yield n)- loop $! n + 1-{-# INLINABLE findIndices #-}---- | Strict left scan-scan :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r-scan step begin done = loop begin- where- loop x = do- yield (done x)- a <- await- let x' = step x a- loop $! x'-{-# INLINABLE scan #-}---- | Strict, monadic left scan-scanM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r-scanM step begin done = do- x <- lift begin- loop x- where- loop x = do- b <- lift (done x)- yield b- a <- await- x' <- lift (step x a)- loop $! x'-{-# INLINABLE scanM #-}---- | Apply an action to all values flowing downstream-chain :: Monad m => (a -> m ()) -> Pipe a a m r-chain f = for cat $ \a -> do- lift (f a)- yield a-{-# INLINABLE chain #-}--{-# RULES- "p >-> chain f" forall p f .- p >-> chain f = for p (\a -> do- lift (f a)- yield a )- ; "chain f >-> p" forall p f .- chain f >-> p = (do- a <- await- lift (f a)- return a ) >~ p- #-}---- | Parse 'Read'able values, only forwarding the value if the parse succeeds-read :: (Monad m, Read a) => Pipe String a m r-read = for cat $ \str -> case (reads str) of- [(a, "")] -> yield a- _ -> return ()-{-# INLINABLE read #-}--{-# RULES- "p >-> read" forall p .- p >-> read = for p (\str -> case (reads str) of- [(a, "")] -> yield a- _ -> return () )- #-}---- | Convert 'Show'able values to 'String's-show :: (Monad m, Show a) => Pipe a String m r-show = map Prelude.show-{-# INLINABLE show #-}--{- $folds- Use these to fold the output of a 'Producer'. Many of these folds will stop- drawing elements if they can compute their result early, like 'any':-->>> P.any null P.stdinLn-Test<Enter>-ABC<Enter>-<Enter>-True->>>---}---- | Strict fold of the elements of a 'Producer'-fold :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b-fold step begin done p0 = loop p0 begin- where- loop p x = case p of- Request v _ -> closed v- Respond a fu -> loop (fu ()) $! step x a- M m -> m >>= \p' -> loop p' x- Pure _ -> return (done x)-{-# INLINABLE fold #-}---- | Strict, monadic fold of the elements of a 'Producer'-foldM- :: Monad m- => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b-foldM step begin done p0 = do- x0 <- begin- loop p0 x0- where- loop p x = case p of- Request v _ -> closed v- Respond a fu -> do- x' <- step x a- loop (fu ()) $! x'- M m -> m >>= \p' -> loop p' x- Pure _ -> done x-{-# INLINABLE foldM #-}--{-| @(all predicate p)@ determines whether all the elements of @p@ satisfy the- predicate.--}-all :: Monad m => (a -> Bool) -> Producer a m () -> m Bool-all predicate p = null $ p >-> filter (\a -> not (predicate a))-{-# INLINABLE all #-}--{-| @(any predicate p)@ determines whether any element of @p@ satisfies the- predicate.--}-any :: Monad m => (a -> Bool) -> Producer a m () -> m Bool-any predicate p = liftM not $ null (p >-> filter predicate)-{-# INLINABLE any #-}---- | Determines whether all elements are 'True'-and :: Monad m => Producer Bool m () -> m Bool-and = all id-{-# INLINABLE and #-}---- | Determines whether any element is 'True'-or :: Monad m => Producer Bool m () -> m Bool-or = any id-{-# INLINABLE or #-}--{-| @(elem a p)@ returns 'True' if @p@ has an element equal to @a@, 'False'- otherwise--}-elem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool-elem a = any (a ==)-{-# INLINABLE elem #-}--{-| @(notElem a)@ returns 'False' if @p@ has an element equal to @a@, 'True'- otherwise--}-notElem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool-notElem a = all (a /=)-{-# INLINABLE notElem #-}---- | Find the first element of a 'Producer' that satisfies the predicate-find :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe a)-find predicate p = head (p >-> filter predicate)-{-# INLINABLE find #-}--{-| Find the index of the first element of a 'Producer' that satisfies the- predicate--}-findIndex :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe Int)-findIndex predicate p = head (p >-> findIndices predicate)-{-# INLINABLE findIndex #-}---- | Retrieve the first element from a 'Producer'-head :: Monad m => Producer a m () -> m (Maybe a)-head p = do- x <- next p- return $ case x of- Left _ -> Nothing- Right (a, _) -> Just a-{-# INLINABLE head #-}---- | Index into a 'Producer'-index :: Monad m => Int -> Producer a m () -> m (Maybe a)-index n p = head (p >-> drop n)-{-# INLINABLE index #-}---- | Retrieve the last element from a 'Producer'-last :: Monad m => Producer a m () -> m (Maybe a)-last p0 = do- x <- next p0- case x of- Left _ -> return Nothing- Right (a, p') -> loop a p'- where- loop a p = do- x <- next p- case x of- Left _ -> return (Just a)- Right (a', p') -> loop a' p'-{-# INLINABLE last #-}---- | Count the number of elements in a 'Producer'-length :: Monad m => Producer a m () -> m Int-length = fold (\n _ -> n + 1) 0 id-{-# INLINABLE length #-}---- | Find the maximum element of a 'Producer'-maximum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a)-maximum = fold step Nothing id- where- step x a = Just $ case x of- Nothing -> a- Just a' -> max a a'-{-# INLINABLE maximum #-}---- | Find the minimum element of a 'Producer'-minimum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a)-minimum = fold step Nothing id- where- step x a = Just $ case x of- Nothing -> a- Just a' -> min a a'-{-# INLINABLE minimum #-}---- | Determine if a 'Producer' is empty-null :: Monad m => Producer a m () -> m Bool-null p = do- x <- next p- return $ case x of- Left _ -> True- Right _ -> False-{-# INLINABLE null #-}---- | Compute the sum of the elements of a 'Producer'-sum :: (Monad m, Num a) => Producer a m () -> m a-sum = fold (+) 0 id-{-# INLINABLE sum #-}---- | Compute the product of the elements of a 'Producer'-product :: (Monad m, Num a) => Producer a m () -> m a-product = fold (*) 1 id-{-# INLINABLE product #-}---- | Convert a pure 'Producer' into a list-toList :: Producer a Identity () -> [a]-toList = loop- where- loop p = case p of- Request v _ -> closed v- Respond a fu -> a:loop (fu ())- M m -> loop (runIdentity m)- Pure _ -> []-{-# INLINABLE toList #-}--{-| Convert an effectful 'Producer' into a list-- Note: 'toListM' is not an idiomatic use of @pipes@, but I provide it for- simple testing purposes. Idiomatic @pipes@ style consumes the elements- immediately as they are generated instead of loading all elements into- memory.--}-toListM :: Monad m => Producer a m () -> m [a]-toListM = loop- where- loop p = case p of- Request v _ -> closed v- Respond a fu -> do- as <- loop (fu ())- return (a:as)- M m -> m >>= loop- Pure _ -> return []-{-# INLINABLE toListM #-}---- | Zip two 'Producer's-zip :: Monad m- => (Producer a m r)- -> (Producer b m r)- -> (Producer' (a, b) m r)-zip = zipWith (,)-{-# INLINABLE zip #-}---- | Zip two 'Producer's using the provided combining function-zipWith :: Monad m- => (a -> b -> c)- -> (Producer a m r)- -> (Producer b m r)- -> (Producer' c m r)-zipWith f = go- where- go p1 p2 = do- e1 <- lift $ next p1- case e1 of- Left r -> return r- Right (a, p1') -> do- e2 <- lift $ next p2- case e2 of- Left r -> return r- Right (b, p2') -> do- yield (f a b)- go p1' p2'-{-# INLINABLE zipWith #-}--{-| Transform a 'Consumer' to a 'Pipe' that reforwards all values further- downstream--}-tee :: Monad m => Consumer a m r -> Pipe a a m r-tee p = evalStateP Nothing $ do- r <- up >\\ (hoist lift p //> dn)- ma <- lift get- case ma of- Nothing -> return ()- Just a -> yield a- return r- where- up () = do- ma <- lift get- case ma of- Nothing -> return ()- Just a -> yield a- a <- await- lift $ put (Just a)- return a- dn v = closed v-{-# INLINABLE tee #-}--{-| Transform a unidirectional 'Pipe' to a bidirectional 'Proxy'--> generalize (f >-> g) = generalize f >+> generalize g->-> generalize cat = pull--}-generalize :: Monad m => Pipe a b m r -> x -> Proxy x a x b m r-generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn- where- up () = do- x <- lift get- request x- dn a = do- x <- respond a- lift $ put x-{-# INLINABLE generalize #-}+{-| General purpose utilities + + The names in this module clash heavily with the Haskell Prelude, so I + recommend the following import scheme: + +> import Pipes +> import qualified Pipes.Prelude as P -- or use any other qualifier you prefer + + Note that 'String'-based 'IO' is inefficient. The 'String'-based utilities + in this module exist only for simple demonstrations without incurring a + dependency on the @text@ package. + + Also, 'stdinLn' and 'stdoutLn' remove and add newlines, respectively. This + behavior is intended to simplify examples. The corresponding @stdin@ and + @stdout@ utilities from @pipes-bytestring@ and @pipes-text@ preserve + newlines. +-} + +{-# LANGUAGE RankNTypes, Trustworthy #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Pipes.Prelude ( + -- * Producers + -- $producers + stdinLn + , readLn + , fromHandle + , repeatM + , replicateM + + -- * Consumers + -- $consumers + , stdoutLn + , print + , toHandle + , drain + + -- * Pipes + -- $pipes + , map + , mapM + , sequence + , mapFoldable + , filter + , filterM + , take + , takeWhile + , drop + , dropWhile + , concat + , elemIndices + , findIndices + , scan + , scanM + , chain + , read + , show + + -- * Folds + -- $folds + , fold + , foldM + , all + , any + , and + , or + , elem + , notElem + , find + , findIndex + , head + , index + , last + , length + , maximum + , minimum + , null + , sum + , product + , toList + , toListM + + -- * Zips + , zip + , zipWith + + -- * Utilities + , tee + , generalize + ) where + +import Control.Exception (throwIO, try) +import Control.Monad (liftM, replicateM_, when, unless) +import Control.Monad.Trans.State.Strict (get, put) +import Data.Functor.Identity (Identity, runIdentity) +import Foreign.C.Error (Errno(Errno), ePIPE) +import Pipes +import Pipes.Core +import Pipes.Internal +import Pipes.Lift (evalStateP) +import qualified GHC.IO.Exception as G +import qualified System.IO as IO +import qualified Prelude +import Prelude hiding ( + all + , and + , any + , concat + , drop + , dropWhile + , elem + , filter + , head + , last + , length + , map + , mapM + , maximum + , minimum + , notElem + , null + , or + , print + , product + , read + , readLn + , sequence + , show + , sum + , take + , takeWhile + , zip + , zipWith + ) + +{- $producers + Use 'for' loops to iterate over 'Producer's whenever you want to perform the + same action for every element: + +> -- Echo all lines from standard input to standard output +> runEffect $ for P.stdinLn $ \str -> do +> lift $ putStrLn str + + ... or more concisely: + +>>> runEffect $ for P.stdinLn (lift . putStrLn) +Test<Enter> +Test +ABC<Enter> +ABC +... + +-} + +{-| Read 'String's from 'IO.stdin' using 'getLine' + + Terminates on end of input +-} +stdinLn :: MonadIO m => Producer' String m () +stdinLn = fromHandle IO.stdin +{-# INLINABLE stdinLn #-} + +-- | 'read' values from 'IO.stdin', ignoring failed parses +readLn :: (MonadIO m, Read a) => Producer' a m () +readLn = stdinLn >-> read +{-# INLINABLE readLn #-} + +{-| Read 'String's from a 'IO.Handle' using 'IO.hGetLine' + + Terminates on end of input +-} +fromHandle :: MonadIO m => IO.Handle -> Producer' String m () +fromHandle h = go + where + go = do + eof <- liftIO $ IO.hIsEOF h + unless eof $ do + str <- liftIO $ IO.hGetLine h + yield str + go +{-# INLINABLE fromHandle #-} + +-- | Repeat a monadic action indefinitely, 'yield'ing each result +repeatM :: Monad m => m a -> Producer' a m r +repeatM m = lift m >~ cat +{-# INLINABLE repeatM #-} + +{-# RULES + "repeatM m >-> p" forall m p . repeatM m >-> p = lift m >~ p + #-} + +{-| Repeat a monadic action a fixed number of times, 'yield'ing each result + +> replicateM 0 x = return () +> +> replicateM (m + n) x = replicateM m x >> replicateM n x -- 0 <= {m,n} + +> replicateM 1 = lift +> +> replicateM (m * n) = replicateM m >|> replicate n -- 0 <= {m,n} +-} +replicateM :: Monad m => Int -> m a -> Producer' a m () +replicateM n m = lift m >~ take n +{-# INLINABLE replicateM #-} + +{- $consumers + Feed a 'Consumer' the same value repeatedly using ('>~'): + +>>> runEffect $ lift getLine >~ P.stdoutLn +Test<Enter> +Test +ABC<Enter> +ABC +... + +-} + +{-| Write 'String's to 'IO.stdout' using 'putStrLn' + + Unlike 'toHandle', 'stdoutLn' gracefully terminates on a broken output pipe +-} +stdoutLn :: MonadIO m => Consumer' String m () +stdoutLn = go + where + go = do + str <- await + x <- liftIO $ try (putStrLn str) + case x of + Left (G.IOError { G.ioe_type = G.ResourceVanished + , G.ioe_errno = Just ioe }) + | Errno ioe == ePIPE + -> return () + Left e -> liftIO (throwIO e) + Right () -> go +{-# INLINABLE stdoutLn #-} + +-- | 'print' values to 'IO.stdout' +print :: (MonadIO m, Show a) => Consumer' a m r +print = for cat (\a -> liftIO (Prelude.print a)) +{-# INLINABLE print #-} + +{-# RULES + "p >-> print" forall p . + p >-> print = for p (\a -> liftIO (Prelude.print a)) + #-} + +-- | Write 'String's to a 'IO.Handle' using 'IO.hPutStrLn' +toHandle :: MonadIO m => IO.Handle -> Consumer' String m r +toHandle handle = for cat (\str -> liftIO (IO.hPutStrLn handle str)) +{-# INLINABLE toHandle #-} + +{-# RULES + "p >-> toHandle handle" forall p handle . + p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str)) + #-} + +-- | 'discard' all incoming values +drain :: Monad m => Consumer' a m r +drain = for cat discard +{-# INLINABLE drain #-} + +{-# RULES + "p >-> drain" forall p . + p >-> drain = for p discard + #-} + +{- $pipes + Use ('>->') to connect 'Producer's, 'Pipe's, and 'Consumer's: + +>>> runEffect $ P.stdinLn >-> P.takeWhile (/= "quit") >-> P.stdoutLn +Test<Enter> +Test +ABC<Enter> +ABC +quit<Enter> +>>> + +-} + +{-| Apply a function to all values flowing downstream + +> map id = cat +> +> map (g . f) = map f >-> map g +-} +map :: Monad m => (a -> b) -> Pipe a b m r +map f = for cat (\a -> yield (f a)) +{-# INLINABLE map #-} + +{-# RULES + "p >-> map f" forall p f . p >-> map f = for p (\a -> yield (f a)) + + ; "map f >-> p" forall p f . map f >-> p = (do + a <- await + return (f a) ) >~ p + #-} + +{-| Apply a monadic function to all values flowing downstream + +> mapM return = cat +> +> mapM (f >=> g) = mapM f >-> mapM g +-} +mapM :: Monad m => (a -> m b) -> Pipe a b m r +mapM f = for cat $ \a -> do + b <- lift (f a) + yield b +{-# INLINABLE mapM #-} + +{-# RULES + "p >-> mapM f" forall p f . p >-> mapM f = for p (\a -> do + b <- lift (f a) + yield b ) + + ; "mapM f >-> p" forall p f . mapM f >-> p = (do + a <- await + b <- lift (f a) + return b ) >~ p + #-} + +-- | Convert a stream of actions to a stream of values +sequence :: Monad m => Pipe (m a) a m r +sequence = mapM id +{-# INLINABLE sequence #-} + +{- | Apply a function to all values flowing downstream, and + forward each element of the result. +-} +mapFoldable :: (Monad m, Foldable t) => (a -> t b) -> Pipe a b m r +mapFoldable f = for cat (\a -> each (f a)) +{-# INLINABLE mapFoldable #-} + +{-# RULES + "p >-> mapFoldable f" forall p f . + p >-> mapFoldable f = for p (\a -> each (f a)) + #-} + +{-| @(filter predicate)@ only forwards values that satisfy the predicate. + +> filter (pure True) = cat +> +> filter (liftA2 (&&) p1 p2) = filter p1 >-> filter p2 +-} +filter :: Monad m => (a -> Bool) -> Pipe a a m r +filter predicate = for cat $ \a -> when (predicate a) (yield a) +{-# INLINABLE filter #-} + +{-# RULES + "p >-> filter predicate" forall p predicate. + p >-> filter predicate = for p (\a -> when (predicate a) (yield a)) + #-} + +{-| @(filterM predicate)@ only forwards values that satisfy the monadic + predicate + +> filterM (pure (pure True)) = cat +> +> filterM (liftA2 (liftA2 (&&)) p1 p2) = filterM p1 >-> filterM p2 +-} +filterM :: Monad m => (a -> m Bool) -> Pipe a a m r +filterM predicate = for cat $ \a -> do + b <- lift (predicate a) + when b (yield a) +{-# INLINABLE filterM #-} + +{-# RULES + "p >-> filterM predicate" forall p predicate . + p >-> filterM predicate = for p (\a -> do + b <- lift (predicate a) + when b (yield a) ) + #-} + +{-| @(take n)@ only allows @n@ values to pass through + +> take 0 = return () +> +> take (m + n) = take m >> take n + +> take <infinity> = cat +> +> take (min m n) = take m >-> take n +-} +take :: Monad m => Int -> Pipe a a m () +take n = replicateM_ n $ do + a <- await + yield a +{-# INLINABLE take #-} + +{-| @(takeWhile p)@ allows values to pass downstream so long as they satisfy + the predicate @p@. + +> takeWhile (pure True) = cat +> +> takeWhile (liftA2 (&&) p1 p2) = takeWhile p1 >-> takeWhile p2 +-} +takeWhile :: Monad m => (a -> Bool) -> Pipe a a m () +takeWhile predicate = go + where + go = do + a <- await + if (predicate a) + then do + yield a + go + else return () +{-# INLINABLE takeWhile #-} + +{-| @(drop n)@ discards @n@ values going downstream + +> drop 0 = cat +> +> drop (m + n) = drop m >-> drop n +-} +drop :: Monad m => Int -> Pipe a a m r +drop n = do + replicateM_ n await + cat +{-# INLINABLE drop #-} + +{-| @(dropWhile p)@ discards values going downstream until one violates the + predicate @p@. + +> dropWhile (pure False) = cat +> +> dropWhile (liftA2 (||) p1 p2) = dropWhile p1 >-> dropWhile p2 +-} +dropWhile :: Monad m => (a -> Bool) -> Pipe a a m r +dropWhile predicate = go + where + go = do + a <- await + if (predicate a) + then go + else do + yield a + cat +{-# INLINABLE dropWhile #-} + +-- | Flatten all 'Foldable' elements flowing downstream +concat :: (Monad m, Foldable f) => Pipe (f a) a m r +concat = for cat each +{-# INLINABLE concat #-} + +{-# RULES + "p >-> concat" forall p . p >-> concat = for p each + #-} + +-- | Outputs the indices of all elements that match the given element +elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r +elemIndices a = findIndices (a ==) +{-# INLINABLE elemIndices #-} + +-- | Outputs the indices of all elements that satisfied the predicate +findIndices :: Monad m => (a -> Bool) -> Pipe a Int m r +findIndices predicate = loop 0 + where + loop n = do + a <- await + when (predicate a) (yield n) + loop $! n + 1 +{-# INLINABLE findIndices #-} + +{-| Strict left scan + +> Control.Foldl.purely scan :: Monad m => Fold a b -> Pipe a b m r +-} +scan :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r +scan step begin done = loop begin + where + loop x = do + yield (done x) + a <- await + let x' = step x a + loop $! x' +{-# INLINABLE scan #-} + +{-| Strict, monadic left scan + +> Control.Foldl.impurely scan :: Monad m => FoldM a m b -> Pipe a b m r +-} +scanM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r +scanM step begin done = do + x <- lift begin + loop x + where + loop x = do + b <- lift (done x) + yield b + a <- await + x' <- lift (step x a) + loop $! x' +{-# INLINABLE scanM #-} + +{-| Apply an action to all values flowing downstream + +> chain (pure (return ())) = cat +> +> chain (liftA2 (>>) m1 m2) = chain m1 >-> chain m2 +-} +chain :: Monad m => (a -> m ()) -> Pipe a a m r +chain f = for cat $ \a -> do + lift (f a) + yield a +{-# INLINABLE chain #-} + +{-# RULES + "p >-> chain f" forall p f . + p >-> chain f = for p (\a -> do + lift (f a) + yield a ) + ; "chain f >-> p" forall p f . + chain f >-> p = (do + a <- await + lift (f a) + return a ) >~ p + #-} + +-- | Parse 'Read'able values, only forwarding the value if the parse succeeds +read :: (Monad m, Read a) => Pipe String a m r +read = for cat $ \str -> case (reads str) of + [(a, "")] -> yield a + _ -> return () +{-# INLINABLE read #-} + +{-# RULES + "p >-> read" forall p . + p >-> read = for p (\str -> case (reads str) of + [(a, "")] -> yield a + _ -> return () ) + #-} + +-- | Convert 'Show'able values to 'String's +show :: (Monad m, Show a) => Pipe a String m r +show = map Prelude.show +{-# INLINABLE show #-} + +{- $folds + Use these to fold the output of a 'Producer'. Many of these folds will stop + drawing elements if they can compute their result early, like 'any': + +>>> P.any null P.stdinLn +Test<Enter> +ABC<Enter> +<Enter> +True +>>> + +-} + +{-| Strict fold of the elements of a 'Producer' + +> Control.Foldl.purely fold :: Monad m => Fold a b -> Producer a m () -> m b +-} +fold :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b +fold step begin done p0 = loop p0 begin + where + loop p x = case p of + Request v _ -> closed v + Respond a fu -> loop (fu ()) $! step x a + M m -> m >>= \p' -> loop p' x + Pure _ -> return (done x) +{-# INLINABLE fold #-} + +{-| Strict, monadic fold of the elements of a 'Producer' + +> Control.Foldl.impurely foldM :: Monad m => FoldM a b -> Producer a m () -> m b +-} +foldM + :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b +foldM step begin done p0 = do + x0 <- begin + loop p0 x0 + where + loop p x = case p of + Request v _ -> closed v + Respond a fu -> do + x' <- step x a + loop (fu ()) $! x' + M m -> m >>= \p' -> loop p' x + Pure _ -> done x +{-# INLINABLE foldM #-} + +{-| @(all predicate p)@ determines whether all the elements of @p@ satisfy the + predicate. +-} +all :: Monad m => (a -> Bool) -> Producer a m () -> m Bool +all predicate p = null $ p >-> filter (\a -> not (predicate a)) +{-# INLINABLE all #-} + +{-| @(any predicate p)@ determines whether any element of @p@ satisfies the + predicate. +-} +any :: Monad m => (a -> Bool) -> Producer a m () -> m Bool +any predicate p = liftM not $ null (p >-> filter predicate) +{-# INLINABLE any #-} + +-- | Determines whether all elements are 'True' +and :: Monad m => Producer Bool m () -> m Bool +and = all id +{-# INLINABLE and #-} + +-- | Determines whether any element is 'True' +or :: Monad m => Producer Bool m () -> m Bool +or = any id +{-# INLINABLE or #-} + +{-| @(elem a p)@ returns 'True' if @p@ has an element equal to @a@, 'False' + otherwise +-} +elem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool +elem a = any (a ==) +{-# INLINABLE elem #-} + +{-| @(notElem a)@ returns 'False' if @p@ has an element equal to @a@, 'True' + otherwise +-} +notElem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool +notElem a = all (a /=) +{-# INLINABLE notElem #-} + +-- | Find the first element of a 'Producer' that satisfies the predicate +find :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe a) +find predicate p = head (p >-> filter predicate) +{-# INLINABLE find #-} + +{-| Find the index of the first element of a 'Producer' that satisfies the + predicate +-} +findIndex :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe Int) +findIndex predicate p = head (p >-> findIndices predicate) +{-# INLINABLE findIndex #-} + +-- | Retrieve the first element from a 'Producer' +head :: Monad m => Producer a m () -> m (Maybe a) +head p = do + x <- next p + return $ case x of + Left _ -> Nothing + Right (a, _) -> Just a +{-# INLINABLE head #-} + +-- | Index into a 'Producer' +index :: Monad m => Int -> Producer a m () -> m (Maybe a) +index n p = head (p >-> drop n) +{-# INLINABLE index #-} + +-- | Retrieve the last element from a 'Producer' +last :: Monad m => Producer a m () -> m (Maybe a) +last p0 = do + x <- next p0 + case x of + Left _ -> return Nothing + Right (a, p') -> loop a p' + where + loop a p = do + x <- next p + case x of + Left _ -> return (Just a) + Right (a', p') -> loop a' p' +{-# INLINABLE last #-} + +-- | Count the number of elements in a 'Producer' +length :: Monad m => Producer a m () -> m Int +length = fold (\n _ -> n + 1) 0 id +{-# INLINABLE length #-} + +-- | Find the maximum element of a 'Producer' +maximum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a) +maximum = fold step Nothing id + where + step x a = Just $ case x of + Nothing -> a + Just a' -> max a a' +{-# INLINABLE maximum #-} + +-- | Find the minimum element of a 'Producer' +minimum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a) +minimum = fold step Nothing id + where + step x a = Just $ case x of + Nothing -> a + Just a' -> min a a' +{-# INLINABLE minimum #-} + +-- | Determine if a 'Producer' is empty +null :: Monad m => Producer a m () -> m Bool +null p = do + x <- next p + return $ case x of + Left _ -> True + Right _ -> False +{-# INLINABLE null #-} + +-- | Compute the sum of the elements of a 'Producer' +sum :: (Monad m, Num a) => Producer a m () -> m a +sum = fold (+) 0 id +{-# INLINABLE sum #-} + +-- | Compute the product of the elements of a 'Producer' +product :: (Monad m, Num a) => Producer a m () -> m a +product = fold (*) 1 id +{-# INLINABLE product #-} + +-- | Convert a pure 'Producer' into a list +toList :: Producer a Identity () -> [a] +toList = loop + where + loop p = case p of + Request v _ -> closed v + Respond a fu -> a:loop (fu ()) + M m -> loop (runIdentity m) + Pure _ -> [] +{-# INLINABLE toList #-} + +{-| Convert an effectful 'Producer' into a list + + Note: 'toListM' is not an idiomatic use of @pipes@, but I provide it for + simple testing purposes. Idiomatic @pipes@ style consumes the elements + immediately as they are generated instead of loading all elements into + memory. +-} +toListM :: Monad m => Producer a m () -> m [a] +toListM = loop + where + loop p = case p of + Request v _ -> closed v + Respond a fu -> do + as <- loop (fu ()) + return (a:as) + M m -> m >>= loop + Pure _ -> return [] +{-# INLINABLE toListM #-} + +-- | Zip two 'Producer's +zip :: Monad m + => (Producer a m r) + -> (Producer b m r) + -> (Producer' (a, b) m r) +zip = zipWith (,) +{-# INLINABLE zip #-} + +-- | Zip two 'Producer's using the provided combining function +zipWith :: Monad m + => (a -> b -> c) + -> (Producer a m r) + -> (Producer b m r) + -> (Producer' c m r) +zipWith f = go + where + go p1 p2 = do + e1 <- lift $ next p1 + case e1 of + Left r -> return r + Right (a, p1') -> do + e2 <- lift $ next p2 + case e2 of + Left r -> return r + Right (b, p2') -> do + yield (f a b) + go p1' p2' +{-# INLINABLE zipWith #-} + +{-| Transform a 'Consumer' to a 'Pipe' that reforwards all values further + downstream +-} +tee :: Monad m => Consumer a m r -> Pipe a a m r +tee p = evalStateP Nothing $ do + r <- up >\\ (hoist lift p //> dn) + ma <- lift get + case ma of + Nothing -> return () + Just a -> yield a + return r + where + up () = do + ma <- lift get + case ma of + Nothing -> return () + Just a -> yield a + a <- await + lift $ put (Just a) + return a + dn v = closed v +{-# INLINABLE tee #-} + +{-| Transform a unidirectional 'Pipe' to a bidirectional 'Proxy' + +> generalize (f >-> g) = generalize f >+> generalize g +> +> generalize cat = pull +-} +generalize :: Monad m => Pipe a b m r -> x -> Proxy x a x b m r +generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn + where + up () = do + x <- lift get + request x + dn a = do + x <- respond a + lift $ put x +{-# INLINABLE generalize #-}
src/Pipes/Tutorial.hs view
@@ -1,1508 +1,1509 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--{-| Conventional Haskell stream programming forces you to choose only two of the- following three features:-- * Effects-- * Streaming-- * Composability-- If you sacrifice /Effects/ you get Haskell's pure and lazy lists, which you- can transform using composable functions in constant space, but without- interleaving effects.-- If you sacrifice /Streaming/ you get 'mapM', 'forM' and- \"ListT done wrong\", which are composable and effectful, but do not return- a single result until the whole list has first been processed and loaded- into memory.-- If you sacrifice /Composability/ you write a tightly coupled read,- transform, and write loop in 'IO', which is streaming and effectful, but is- not modular or separable.-- @pipes@ gives you all three features: effectful, streaming, and composable- programming. @pipes@ also provides a wide variety of stream programming- abstractions which are all subsets of a single unified machinery:-- * effectful 'Producer's (like generators),-- * effectful 'Consumer's (like iteratees),-- * effectful 'Pipe's (like Unix pipes), and:-- * 'ListT' done right.-- All of these are connectable and you can combine them together in clever and- unexpected ways because they all share the same underlying type.-- @pipes@ requires a basic understanding of monad transformers, which you can- learn about by reading either:-- * the paper \"Monad Transformers - Step by Step\",-- * chapter 18 of \"Real World Haskell\" on monad transformers, or:-- * the documentation of the @transformers@ library.-- If you want a Quick Start guide to @pipes@, read the documentation in- "Pipes.Prelude" from top to bottom.-- This tutorial is more extensive and explains the @pipes@ API in greater- detail and illustrates several idioms.--}--module Pipes.Tutorial (- -- * Introduction- -- $introduction-- -- * Producers- -- $producers-- -- * Composability- -- $composability-- -- * Consumers- -- $consumers-- -- * Pipes- -- $pipes-- -- * ListT- -- $listT-- -- * Tricks- -- $tricks-- -- * Conclusion- -- $conclusion-- -- * Appendix: Types- -- $types-- -- * Appendix: Time Complexity- -- $timecomplexity- ) where--import Control.Category-import Control.Monad-import Control.Monad.Trans.Error-import Control.Monad.Trans.Writer.Strict-import Pipes-import Pipes.Lift-import qualified Pipes.Prelude as P-import Prelude hiding ((.), id)--{- $introduction- The @pipes@ library decouples stream processing stages from each other so- that you can mix and match diverse stages to produce useful streaming- programs. If you are a library writer, @pipes@ lets you package up- streaming components into a reusable interface. If you are an application- writer, @pipes@ lets you connect pre-made streaming components with minimal- effort to produce a highly-efficient program that streams data in constant- memory.-- To enforce loose coupling, components can only communicate using two- commands:-- * 'yield': Send output data-- * 'await': Receive input data-- @pipes@ has four types of components built around these two commands:-- * 'Producer's can only 'yield' values and they model streaming sources-- * 'Consumer's can only 'await' values and they model streaming sinks-- * 'Pipe's can both 'yield' and 'await' values and they model stream- transformations-- * 'Effect's can neither 'yield' nor 'await' and they model non-streaming- components-- You can connect these components together in four separate ways which- parallel the four above types:-- * 'for' handles 'yield's-- * ('>~') handles 'await's-- * ('>->') handles both 'yield's and 'await's-- * ('>>=') handles return values-- As you connect components their types will change to reflect inputs and- outputs that you've fused away. You know that you're done connecting things- when you get an 'Effect', meaning that you have handled all inputs and- outputs. You run this final 'Effect' to begin streaming.--}--{- $producers- 'Producer's are effectful streams of input. Specifically, a 'Producer' is a- monad transformer that extends any base monad with a new 'yield' command.- This 'yield' command lets you send output downstream to an anonymous- handler, decoupling how you generate values from how you consume them.-- The following @stdinLn@ 'Producer' shows how to incrementally read in- 'String's from standard input and 'yield' them downstream, terminating- gracefully when reaching the end of the input:--> -- echo.hs->-> import Control.Monad (unless)-> import Pipes-> import System.IO (isEOF)->-> -- +--------+-- A 'Producer' that yields 'String's-> -- | |-> -- | | +-- Every monad transformer has a base monad.-> -- | | | This time the base monad is 'IO'.-> -- | | | -> -- | | | +-- Every monadic action has a return value.-> -- | | | | This action returns '()' when finished-> -- v v v v-> stdinLn :: Producer String IO ()-> stdinLn = do-> eof <- lift isEOF -- 'lift' an 'IO' action from the base monad-> unless eof $ do-> str <- lift getLine-> yield str -- 'yield' the 'String'-> stdinLn -- Loop-- 'yield' emits a value, suspending the current 'Producer' until the value is- consumed. If nobody consumes the value (which is possible) then 'yield'- never returns. You can think of 'yield' as having the following type:--@- 'yield' :: 'Monad' m => a -> 'Producer' a m ()-@-- The true type of 'yield' is actually more general and powerful. Throughout- the tutorial I will present type signatures like this that are simplified at- first and then later reveal more general versions. So read the above type- signature as simply saying: \"You can use 'yield' within a 'Producer', but- you may be able to use 'yield' in other contexts, too.\"-- Click the link to 'yield' to navigate to its documentation. There you will- see that 'yield' actually uses the 'Producer'' (with an apostrophe) type- synonym which hides a lot of polymorphism behind a simple veneer. The- documentation for 'yield' says that you can also use 'yield' within a- 'Pipe', too, because of this polymorphism:--@- 'yield' :: 'Monad' m => a -> 'Pipe' x a m ()-@-- Use simpler types like these to guide you until you understand the fully- general type.-- 'for' loops are the simplest way to consume a 'Producer' like @stdinLn@.- 'for' has the following type:--@- \-\- +-- Producer +-- The body of the +-- Result- \-\- | to loop | loop |- \-\- v over v v- \-\- -------------- ------------------ ----------- 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r-@-- @(for producer body)@ loops over @(producer)@, substituting each 'yield' in- @(producer)@ with @(body)@.-- You can also deduce that behavior purely from the type signature:-- * The body of the loop takes exactly one argument of type @(a)@, which is- the same as the output type of the 'Producer'. Therefore, the body of the- loop must get its input from that 'Producer' and nowhere else.-- * The return value of the input 'Producer' matches the return value of the- result, therefore 'for' must loop over the entire 'Producer' and not skip- anything.-- The above type signature is not the true type of 'for', which is actually- more general. Think of the above type signature as saying: \"If the first- argument of 'for' is a 'Producer' and the second argument returns an- 'Effect', then the final result must be an 'Effect'.\"-- Click the link to 'for' to navigate to its documentation. There you will- see the fully general type and underneath you will see equivalent simpler- types. One of these says that if the body of the loop is a 'Producer', then- the result is a 'Producer', too:--@- 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r-@-- The first type signature I showed for 'for' was a special case of this- slightly more general signature because a 'Producer' that never 'yield's is- also an 'Effect':--@- data 'X' -- The uninhabited type--\ type 'Effect' m r = 'Producer' 'X' m r-@-- This is why 'for' permits two different type signatures. The first type- signature is just a special case of the second one:--@- 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r--\ -- Specialize \'b\' to \'X\'- 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' 'X' m ()) -> 'Producer' 'X' m r--\ -- Producer X = Effect- 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r-@-- This is the same trick that all @pipes@ functions use to work with various- combinations of 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's. Each- function really has just one general type, which you can then simplify down- to multiple useful alternative types.-- Here's an example use of a 'for' @loop@, where the second argument (the- loop body) is an 'Effect':--> -- echo.hs->-> loop :: Effect IO ()-> loop = for stdinLn $ \str -> do -- Read this like: "for str in stdinLn"-> lift $ putStrLn str -- The body of the 'for' loop->-> -- more concise: loop = for stdinLn (lift . putStrLn)-- In this example, 'for' loops over @stdinLn@ and replaces every 'yield' in- @stdinLn@ with the body of the loop, printing each line. This is exactly- equivalent to the following code, which I've placed side-by-side with the- original definition of @stdinLn@ for comparison:--> loop = do | stdinLn = do-> eof <- lift isEOF | eof <- lift isEOF-> unless eof $ do | unless eof $ do-> str <- lift getLine | str <- lift getLine-> (lift . putStrLn) str | yield str-> loop | stdinLn-- You can think of 'yield' as creating a hole and a 'for' loop is one way to- fill that hole.-- Notice how the final @loop@ only 'lift's actions from the base monad and- does nothing else. This property is true for all 'Effect's, which are just- glorified wrappers around actions in the base monad. This means we can run- these 'Effect's to remove their 'lift's and lower them back to the- equivalent computation in the base monad:--@- 'runEffect' :: 'Monad' m => 'Effect' m r -> m r-@-- This is the real type signature of 'runEffect', which refuses to accept- anything other than an 'Effect'. This ensures that we handle all inputs and- outputs before streaming data:--> -- echo.hs->-> main :: IO ()-> main = runEffect loop-- ... or you could inline the entire @loop@ into the following one-liner:--> main = runEffect $ for stdinLn (lift . putStrLn)-- Our final program loops over standard input and echoes every line to- standard output until we hit @Ctrl-D@ to end the input stream:--> $ ghc -O2 echo.hs-> $ ./echo-> Test<Enter>-> Test-> ABC<Enter>-> ABC-> <Ctrl-D>-> $-- The final behavior is indistinguishable from just removing all the 'lift's- from @loop@:--> main = do | loop = do-> eof <- isEof | eof <- lift isEof-> unless eof $ do | unless eof $ do-> str <- getLine | str <- lift getLine-> putStrLn str | (lift . putStrLn) str-> main | loop-- This @main@ is what we might have written by hand if we were not using- @pipes@, but with @pipes@ we can decouple the input and output logic from- each other. When we connect them back together, we still produce streaming- code equivalent to what a sufficiently careful Haskell programmer would- have written.-- You can also use 'for' to loop over lists, too. To do so, convert the list- to a 'Producer' using 'each', which is exported by default from "Pipes":--> each :: Monad m => [a] -> Producer a m ()-> each as = mapM_ yield as-- Combine 'for' and 'each' to iterate over lists using a \"foreach\" loop:-->>> runEffect $ for (each [1..4]) (lift . print)-1-2-3-4-- 'each' is actually more general and works for any 'Foldable':--@- 'each' :: ('Monad' m, 'Foldable' f) => f a -> 'Producer' a m ()-@-- So you can loop over any 'Foldable' container or even a 'Maybe':-->>> runEffect $ for (each (Just 1)) (lift . print)-1---}--{- $composability- You might wonder why the body of a 'for' loop can be a 'Producer'. Let's- test out this feature by defining a new loop body that @duplicate@s every- value:--> -- nested.hs->-> import Pipes-> import qualified Pipes.Prelude as P -- Pipes.Prelude already has 'stdinLn'-> -> duplicate :: Monad m => a -> Producer a m ()-> duplicate x = do-> yield x-> yield x->-> loop :: Producer String IO ()-> loop = for P.stdinLn duplicate->-> -- This is the exact same as:-> ---> -- loop = for P.stdinLn $ \x -> do-> -- yield x-> -- yield x-- This time our @loop@ is a 'Producer' that outputs 'String's, specifically- two copies of each line that we read from standard input. Since @loop@ is a- 'Producer' we cannot run it because there is still unhandled output.- However, we can use yet another 'for' to handle this new duplicated stream:--> -- nested.hs->-> main = runEffect $ for loop (lift . putStrLn)-- This creates a program which echoes every line from standard input to- standard output twice:--> $ ./nested-> Test<Enter>-> Test-> Test-> ABC<Enter>-> ABC-> ABC-> <Ctrl-D>-> $-- But is this really necessary? Couldn't we have instead written this using a- nested for loop?--> main = runEffect $-> for P.stdinLn $ \str1 ->-> for (duplicate str1) $ \str2 ->-> lift $ putStrLn str2-- Yes, we could have! In fact, this is a special case of the following- equality, which always holds no matter what:--@- \-\- s :: Monad m => 'Producer' a m () -- i.e. \'P.stdinLn\'- \-\- f :: Monad m => a -> 'Producer' b m () -- i.e. \'duplicate\'- \-\- g :: Monad m => b -> 'Producer' c m () -- i.e. \'(lift . putStrLn)\'--\ for (for s f) g = for s (\\x -> for (f x) g)-@-- We can understand the rationale behind this equality if we first define the- following operator that is the point-free counterpart to 'for':--@- (~>) :: Monad m- => (a -> 'Producer' b m r)- -> (b -> 'Producer' c m r)- -> (a -> 'Producer' c m r)- (f ~> g) x = for (f x) g-@-- Using ('~>') (pronounced \"into\"), we can transform our original equality- into the following more symmetric equation:--@- f :: Monad m => a -> 'Producer' b m r- g :: Monad m => b -> 'Producer' c m r- h :: Monad m => c -> 'Producer' d m r--\ \-\- Associativity- (f ~> g) ~> h = f ~> (g ~> h)-@-- This looks just like an associativity law. In fact, ('~>') has another nice- property, which is that 'yield' is its left and right identity:--> -- Left Identity-> yield ~> f = f--> -- Right Identity-> f ~> yield = f-- In other words, 'yield' and ('~>') form a 'Category', specifically the- generator category, where ('~>') plays the role of the composition operator- and 'yield' is the identity. If you don't know what a 'Category' is, that's- okay, and category theory is not a prerequisite for using @pipes@. All you- really need to know is that @pipes@ uses some simple category theory to keep- the API intuitive and easy to use.-- Notice that if we translate the left identity law to use 'for' instead of- ('~>') we get:--> for (yield x) f = f x-- This just says that if you iterate over a pure single-element 'Producer',- then you could instead cut out the middle man and directly apply the body of- the loop to that single element.-- If we translate the right identity law to use 'for' instead of ('~>') we- get:--> for s yield = s-- This just says that if the only thing you do is re-'yield' every element of- a stream, you get back your original stream.-- These three \"for loop\" laws summarize our intuition for how 'for' loops- should behave and because these are 'Category' laws in disguise that means- that 'Producer's are composable in a rigorous sense of the word.-- In fact, we get more out of this than just a bunch of equations. We also- get a useful operator: ('~>'). We can use this operator to condense- our original code into the following more succinct form that composes two- transformations:--> main = runEffect $ for P.stdinLn (duplicate ~> lift . putStrLn)-- This means that we can also choose to program in a more functional style and- think of stream processing in terms of composing transformations using- ('~>') instead of nesting a bunch of 'for' loops.-- The above example is a microcosm of the design philosophy behind the @pipes@- library:-- * Define the API in terms of categories-- * Specify expected behavior in terms of category laws-- * Think compositionally instead of sequentially--}--{- $consumers- Sometimes you don't want to use a 'for' loop because you don't want to consume- every element of a 'Producer' or because you don't want to process every- value of a 'Producer' the exact same way.-- The most general solution is to externally iterate over the 'Producer' using- the 'next' command:--@- 'next' :: 'Monad' m => 'Producer' a m r -> m ('Either' r (a, 'Producer' a m r))-@-- Think of 'next' as pattern matching on the head of the 'Producer'. This- 'Either' returns a 'Left' if the 'Producer' is done or it returns a 'Right'- containing the next value, @a@, along with the remainder of the 'Producer'.-- However, sometimes we can get away with something a little more simple and- elegant, like a 'Consumer', which represents an effectful sink of values. A- 'Consumer' is a monad transformer that extends the base monad with a new- 'await' command. This 'await' command lets you receive input from an- anonymous upstream source.-- The following @stdoutLn@ 'Consumer' shows how to incrementally 'await'- 'String's and print them to standard output, terminating gracefully when- receiving a broken pipe error:--> import Control.Monad (unless)-> import Control.Exception (try, throwIO)-> import qualified GHC.IO.Exception as G-> import Pipes->-> -- +--------+-- A 'Consumer' that awaits 'String's-> -- | |-> -- v v-> stdoutLn :: Consumer String IO ()-> stdoutLn = do-> str <- await -- 'await' a 'String'-> x <- lift $ try $ putStrLn str-> case x of-> -- Gracefully terminate if we got a broken pipe error-> Left e@(G.IOError { G.ioe_type = t}) ->-> lift $ unless (t == G.ResourceVanished) $ throwIO e-> -- Otherwise loop-> Right () -> stdoutLn-- 'await' is the dual of 'yield': we suspend our 'Consumer' until we receive a- new value. If nobody provides a value (which is possible) then 'await'- never returns. You can think of 'await' as having the following type:--@- 'await' :: 'Monad' m => 'Consumer' a m a-@-- One way to feed a 'Consumer' is to repeatedly feed the same input using- using ('>~') (pronounced \"feed\"):--@- \-\- +- Feed +- Consumer to +- Returns new- \-\- | action | feed | Effect- \-\- v v v - \-\- ---------- -------------- ----------- ('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c-@-- @(draw >~ consumer)@ loops over @(consumer)@, substituting each 'await' in- @(consumer)@ with @(draw)@.-- So the following code replaces every 'await' in 'P.stdoutLn' with- @(lift getLine)@ and then removes all the 'lift's:-->>> runEffect $ lift getLine >~ stdoutLn-Test<Enter>-Test-ABC<Enter>-ABC-42<Enter>-42-...-- You might wonder why ('>~') uses an 'Effect' instead of a raw action in the- base monad. The reason why is that ('>~') actually permits the following- more general type:--@- ('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c-@-- ('>~') is the dual of ('~>'), composing 'Consumer's instead of 'Producer's.-- This means that you can feed a 'Consumer' with yet another 'Consumer' so- that you can 'await' while you 'await'. For example, we could define the- following intermediate 'Consumer' that requests two 'String's and returns- them concatenated:--> doubleUp :: Monad m => Consumer String m String-> doubleUp = do-> str1 <- await-> str2 <- await-> return (str1 ++ str2)->-> -- more concise: doubleUp = (++) <$> await <*> await-- We can now insert this in between @(lift getLine)@ and @stdoutLn@ and see- what happens:-->>> runEffect $ lift getLine >~ doubleUp >~ stdoutLn-Test<Enter>-ing<Enter>-Testing-ABC<Enter>-DEF<Enter>-ABCDEF-42<Enter>-000<Enter>-42000-...-- 'doubleUp' splits every request from 'stdoutLn' into two separate requests- and- returns back the concatenated result.-- We didn't need to parenthesize the above chain of ('>~') operators, because- ('>~') is associative:--> -- Associativity-> (f >~ g) >~ h = f >~ (g >~ h)-- ... so we can always omit the parentheses since the meaning is unambiguous:--> f >~ g >~ h-- Also, ('>~') has an identity, which is 'await'!--> -- Left identity-> await >~ f = f->-> -- Right Identity-> f >~ await = f-- In other words, ('>~') and 'await' form a 'Category', too, specifically the- iteratee category, and 'Consumer's are also composable.--}--{- $pipes- Our previous programs were unsatisfactory because they were biased either- towards the 'Producer' end or the 'Consumer' end. As a result, we had to- choose between gracefully handling end of input (using 'P.stdinLn') or- gracefully handling end of output (using 'P.stdoutLn'), but not both at the- same time.-- However, we don't need to restrict ourselves to using 'Producer's- exclusively or 'Consumer's exclusively. We can connect 'Producer's and- 'Consumer's directly together using ('>->') (pronounced \"pipe\"):--@- ('>->') :: 'Monad' m => 'Producer' a m r -> 'Consumer' a m r -> 'Effect' m r-@-- This returns an 'Effect' which we can run:--> -- echo2.hs->-> import Pipes-> import qualified Pipes.Prelude as P -- Pipes.Prelude also provides 'stdoutLn'->-> main = runEffect $ P.stdinLn >-> P.stdoutLn-- This program is more declarative of our intent: we want to stream values- from 'P.stdinLn' to 'P.stdoutLn'. The above \"pipeline\" not only echoes- standard input to standard output, but also handles both end of input and- broken pipe errors:--> $ ./echo2-> Test<Enter>-> Test-> ABC<Enter>-> ABC-> 42<Enter>-> 42-> <Ctrl-D>-> $-- ('>->') is \"pull-based\" meaning that control flow begins at the most- downstream component (i.e. 'P.stdoutLn' in the above example). Any time a- component 'await's a value it blocks and transfers control upstream and- every time a component 'yield's a value it blocks and restores control back- downstream, satisfying the 'await'. So in the above example, ('>->')- matches every 'await' from 'P.stdoutLn' with a 'yield' from 'P.stdinLn'.-- Streaming stops when either 'P.stdinLn' terminates (i.e. end of input) or- 'P.stdoutLn' terminates (i.e. broken pipe). This is why ('>->') requires- that both the 'Producer' and 'Consumer' share the same type of return value:- whichever one terminates first provides the return value for the entire- 'Effect'.-- Let's test this by modifying our 'Producer' and 'Consumer' to each return a- diagnostic 'String':--> -- echo3.hs->-> import Control.Applicative ((<$)) -- (<$) modifies return values-> import Pipes-> import qualified Pipes.Prelude as P-> import System.IO->-> main = do-> hSetBuffering stdout NoBuffering-> str <- runEffect $-> ("End of input!" <$ P.stdinLn) >-> ("Broken pipe!" <$ P.stdoutLn)-> hPutStrLn stderr str-- This lets us diagnose whether the 'Producer' or 'Consumer' terminated first:--> $ ./echo3-> Test<Enter>-> Test-> <Ctrl-D>-> End of input!-> $ ./echo3 | perl -e 'close STDIN'-> Test<Enter>-> Broken pipe!-> $-- You might wonder why ('>->') returns an 'Effect' that we have to run instead- of directly returning an action in the base monad. This is because you can- connect things other than 'Producer's and 'Consumer's, like 'Pipe's, which- are effectful stream transformations.-- A 'Pipe' is a monad transformer that is a mix between a 'Producer' and- 'Consumer', because a 'Pipe' can both 'await' and 'yield'. The following- example 'Pipe' is analagous to the Prelude's 'take', only allowing a fixed- number of values to flow through:--> -- take.hs->-> import Control.Monad (replicateM_)-> import Pipes-> import Prelude hiding (take)->-> -- +--------- A 'Pipe' that-> -- | +---- 'await's 'a's and-> -- | | +-- 'yield's 'a's-> -- | | |-> -- v v v-> take :: Int -> Pipe a a IO ()-> take n = do-> replicateM_ n $ do -- Repeat this block 'n' times-> x <- await -- 'await' a value of type 'a'-> yield x -- 'yield' a value of type 'a'-> lift $ putStrLn "You shall not pass!" -- Fly, you fools!-- You can use 'Pipe's to transform 'Producer's, 'Consumer's, or even other- 'Pipe's using the same ('>->') operator:--@- ('>->') :: 'Monad' m => 'Producer' a m r -> 'Pipe' a b m r -> 'Producer' b m r- ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r- ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r-@-- For example, you can compose 'P.take' after 'P.stdinLn' to limit the number- of lines drawn from standard input:--> maxInput :: Int -> Producer String IO ()-> maxInput n = P.stdinLn >-> take n-->>> runEffect $ maxInput 3 >-> P.stdoutLn-Test<Enter>-Test-ABC<Enter>-ABC-42<Enter>-42-You shall not pass!->>>-- ... or you can pre-compose 'P.take' before 'P.stdoutLn' to limit the number- of lines written to standard output:--> maxOutput :: Int -> Consumer String IO ()-> maxOutput n = take n >-> P.stdoutLn-->>> runEffect $ P.stdinLn >-> maxOutput 3-<Exact same behavior>-- Those both gave the same behavior because ('>->') is associative:--> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3)-- Therefore we can just leave out the parentheses:-->>> runEffect $ P.stdinLn >-> take 3 >-> P.stdoutLn-<Exact same behavior>-- ('>->') is designed to behave like the Unix pipe operator, except with less- quirks. In fact, we can continue the analogy to Unix by defining 'cat'- (named after the Unix @cat@ utility), which reforwards elements endlessly:--> cat :: Monad m => Pipe a a m r-> cat = forever $ do-> x <- await-> yield x-- 'cat' is the identity of ('>->'), meaning that 'cat' satisfies the- following two laws:--> -- Useless use of 'cat'-> cat >-> p = p->-> -- Forwarding output to 'cat' does nothing-> p >-> cat = p-- Therefore, ('>->') and 'cat' form a 'Category', specifically the category of- Unix pipes, and 'Pipe's are also composable.-- A lot of Unix tools have very simple definitions when written using @pipes@:--> -- unix.hs->-> import Control.Monad (forever)-> import Pipes-> import qualified Pipes.Prelude as P -- Pipes.Prelude provides 'take', too-> import Prelude hiding (head)->-> head :: Monad m => Int -> Pipe a a m ()-> head = P.take->-> yes :: Monad m => Producer String m r-> yes = forever $ yield "y"->-> main = runEffect $ yes >-> head 3 >-> P.stdoutLn-- This prints out 3 \'@y@\'s, just like the equivalent Unix pipeline:--> $ ./unix-> y-> y-> y-> $ yes | head -3-> y-> y-> y-> $-- This lets us write \"Haskell pipes\" instead of Unix pipes. These are much- easier to build than Unix pipes and we can connect them directly within- Haskell for interoperability with the Haskell language and ecosystem.--}--{- $listT- @pipes@ also provides a \"ListT done right\" implementation. This differs- from the implementation in @transformers@ because this 'ListT':-- * obeys the monad laws, and-- * streams data immediately instead of collecting all results into memory.-- The latter property is actually an elegant consequence of obeying the monad- laws.-- To bind a list within a 'ListT' computation, combine 'Select' and 'each':--> import Pipes-> -> pair :: ListT IO (Int, Int)-> pair = do-> x <- Select $ each [1, 2]-> lift $ putStrLn $ "x = " ++ show x-> y <- Select $ each [3, 4]-> lift $ putStrLn $ "y = " ++ show y-> return (x, y)-- You can then loop over a 'ListT' by using 'every':--@- 'every' :: 'Monad' m => 'ListT' m a -> 'Producer' a m ()-@-- So you can use your 'ListT' within a 'for' loop:-->>> runEffect $ for (every pair) (lift . print)-x = 1-y = 3-(1,3)-y = 4-(1,4)-x = 2-y = 3-(2,3)-y = 4-(2,4)-- ... or a pipeline:-->>> import qualified Pipes.Prelude as P->>> runEffect $ every pair >-> P.print-<Exact same behavior>-- Note that 'ListT' is lazy and only produces as many elements as we request:-->>> runEffect $ for (every pair >-> P.take 2) (lift . print)-x = 1-y = 3-(1,3)-y = 4-(1,4)-- You can also go the other way, binding 'Producer's directly within a- 'ListT'. In fact, this is actually what 'Select' was already doing:--@- 'Select' :: 'Producer' a m () -> 'ListT' m a-@-- This lets you write crazy code like:--> import Pipes-> import qualified Pipes.Prelude as P-> -> input :: Producer String IO ()-> input = P.stdinLn >-> P.takeWhile (/= "quit")-> -> name :: ListT IO String-> name = do-> firstName <- Select input-> lastName <- Select input-> return (firstName ++ " " ++ lastName)-- Here we're binding standard input non-deterministically (twice) as if it- were an effectful list:-->>> runEffect $ every name >-> P.stdoutLn-Daniel<Enter>-Fischer<Enter>-Daniel Fischer-Wagner<Enter>-Daniel Wagner-quit<Enter>-Donald<Enter>-Stewart<Enter>-Donald Stewart-Duck<Enter>-Donald Duck-quit<Enter>-quit<Enter>->>>-- Notice how this streams out values immediately as they are generated, rather- than building up a large intermediate result and then printing all the- values in one batch at the end.--}--{- $tricks- @pipes@ is more powerful than meets the eye so this section presents some- non-obvious tricks you may find useful.-- Many pipe combinators will work on unusual pipe types and the next few- examples will use the 'cat' pipe to demonstrate this.-- For example, you can loop over the output of a 'Pipe' using 'for', which is- how 'P.map' is defined:--> map :: Monad m => (a -> b) -> Pipe a b m r-> map f = for cat $ \x -> yield (f x)->-> -- Read this as: For all values flowing downstream, apply 'f'-- This is equivalent to:--> map f = forever $ do-> x <- await-> yield (f x)-- You can also feed a 'Pipe' input using ('>~'). This means we could have- instead defined the @yes@ pipe like this:--> yes :: Monad m => Producer String m r-> yes = return "y" >~ cat->-> -- Read this as: Keep feeding "y" downstream-- This is equivalent to:--> yes = forever $ yield "y"-- You can also sequence two 'Pipe's together. This is how 'P.drop' is- defined:--> drop :: Monad m => Int -> Pipe a a m r-> drop n = do-> replicateM_ n await-> cat-- This is equivalent to:--> drop n = do-> replicateM_ n await-> forever $ do-> x <- await-> yield x-- You can even compose pipes inside of another pipe:--> customerService :: Producer String IO ()-> customerService = do-> each [ "Hello, how can I help you?" -- Begin with a script-> , "Hold for one second."-> ]-> P.stdinLn >-> P.takeWhile (/= "Goodbye!") -- Now continue with a human-- Also, you can often use 'each' in conjunction with ('~>') to traverse nested- data structures. For example, you can print all non-'Nothing' elements- from a doubly-nested list:-->>> runEffect $ (each ~> each ~> each ~> lift . print) [[Just 1, Nothing], [Just 2, Just 3]]-1-2-3-- Another neat thing to know is that 'every' has a more general type:--@- 'every' :: ('Monad' m, 'Enumerable' t) => t m a -> 'Producer' a m ()-@-- 'Enumerable' generalizes 'Foldable' and if you have an effectful container- of your own that you want others to traverse using @pipes@, just have your- container implement the 'toListT' method of the 'Enumerable' class:--> class Enumerable t where-> toListT :: Monad m => t m a -> ListT m a-- You can even use 'Enumerable' to traverse effectful types that are not even- proper containers, like 'Control.Monad.Trans.Maybe.MaybeT':--> input :: MaybeT IO Int-> input = do-> str <- lift getLine-> guard (str /= "Fail")-->>> runEffect $ every input >-> P.stdoutLn-Test<Enter>-Test->>> runEffect $ every input >-> P.stdoutLn-Fail<Enter>->>>---}--{- $conclusion- This tutorial covers the concepts of connecting, building, and reading- @pipes@ code. However, this library is only the core component in an- ecosystem of streaming components. Derived libraries that build immediately- upon @pipes@ include:-- * @pipes-concurrency@: Concurrent reactive programming and message passing-- * @pipes-parse@: Minimal utilities for stream parsing-- * @pipes-safe@: Resource management and exception safety for @pipes@-- These libraries provide functionality specialized to common streaming- domains. Additionally, there are several libraries on Hackage that provide- even higher-level functionality, which you can find by searching under the- \"Pipes\" category or by looking for packages with a @pipes-@ prefix in- their name. Current examples include:-- * @pipes-network@/@pipes-network-tls@: Networking-- * @pipes-zlib@: Compression and decompression-- * @pipes-binary@: Binary serialization-- * @pipes-attoparsec@: High-performance parsing-- * @pipes-aeson@: JSON serialization and deserialization-- Even these derived packages still do not explore the full potential of- @pipes@ functionality, which actually permits bidirectional communication.- Advanced @pipes@ users can explore this library in greater detail by- studying the documentation in the "Pipes.Core" module to learn about the- symmetry of the underlying 'Proxy' type and operators.-- To learn more about @pipes@, ask questions, or follow @pipes@ development,- you can subscribe to the @haskell-pipes@ mailing list at:-- <https://groups.google.com/forum/#!forum/haskell-pipes>-- ... or you can mail the list directly at:-- <mailto:haskell-pipes@googlegroups.com>-- Additionally, for questions regarding types or type errors, you might find- the following appendix on types very useful.--}--{- $types- @pipes@ uses parametric polymorphism (i.e. generics) to overload all- operations. You've probably noticed this overloading already::-- * 'yield' works within both 'Producer's and 'Pipe's-- * 'await' works within both 'Consumer's and 'Pipe's-- * ('>->') connects 'Producer's, 'Consumer's, and 'Pipe's in varying ways-- This overloading is great when it works, but when connections fail they- produce type errors that appear intimidating at first. This section- explains the underlying types so that you can work through type errors- intelligently.-- 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's are all special cases of a- single underlying type: a 'Proxy'. This overarching type permits fully- bidirectional communication on both an upstream and downstream interface.- You can think of it as having the following shape:--> Proxy a' a b' b m r->-> Upstream | Downstream-> +---------+-> | |-> a' <== <== b' -- Information flowing upstream-> | |-> a ==> ==> b -- Information flowing downstream-> | | |-> +----|----+-> v-> r-- The four core types do not use the upstream flow of information. This means- that the @a'@ and @b'@ in the above diagram go unused unless you use the- more advanced features provided in "Pipes.Core".-- @pipes@ uses type synonyms to hide unused inputs or outputs and clean up- type signatures. These type synonyms come in two flavors:-- * Concrete type synonyms that explicitly close unused inputs and outputs of- the 'Proxy' type-- * Polymorphic type synonyms that don't explicitly close unused inputs or- outputs-- The concrete type synonyms use @()@ to close unused inputs and 'X' (the- uninhabited type) to close unused outputs:-- * 'Effect': explicitly closes both ends, forbidding 'await's and 'yield's--> type Effect = Proxy X () () X->-> Upstream | Downstream-> +---------+-> | |-> X <== <== ()-> | |-> () ==> ==> X-> | | |-> +----|----+-> v-> r-- * 'Producer': explicitly closes the upstream end, forbidding 'await's--> type Producer b = Proxy X () () b->-> Upstream | Downstream-> +---------+-> | |-> X <== <== ()-> | |-> () ==> ==> b-> | | |-> +----|----+-> v-> r-- * 'Consumer': explicitly closes the downstream end, forbidding 'yield's--> type Consumer a = Proxy () a () X->-> Upstream | Downstream-> +---------+-> | |-> () <== <== ()-> | |-> a ==> ==> X-> | | |-> +----|----+-> v-> r-- * 'Pipe': marks both ends open, allowing both 'await's and 'yield's--> type Pipe a b = Proxy () a () b->-> Upstream | Downstream-> +---------+-> | |-> () <== <== ()-> | |-> a ==> ==> b-> | | |-> +----|----+-> v-> r-- When you compose 'Proxy's using ('>->') all you are doing is placing them- side by side and fusing them laterally. For example, when you compose a- 'Producer', 'Pipe', and a 'Consumer', you can think of information flowing- like this:--> Producer Pipe Consumer-> +-----------+ +----------+ +------------+-> | | | | | |-> X <== <== () <== <== () <== <== ()-> | stdinLn | | take 3 | | stdoutLn |-> () ==> ==> String ==> ==> String ==> ==> X-> | | | | | | | | |-> +-----|-----+ +----|-----+ +------|-----+-> v v v-> () () ()-- Composition fuses away the intermediate interfaces, leaving behind an- 'Effect':--> Effect-> +-----------------------------------+-> | |-> X <== <== ()-> | stdinLn >-> take 3 >-> stdoutLn |-> () ==> ==> X-> | |-> +----------------|------------------+-> v-> ()-- @pipes@ also provides polymorphic type synonyms with apostrophes at the end- of their names. These use universal quantification to leave open any unused- input or output ends (which I mark using @*@):-- * 'Producer'': marks the upstream end unused but still open--> type Producer' b m r = forall x' x . Proxy x' x () b m r->-> Upstream | Downstream-> +---------+-> | |-> * <== <== ()-> | |-> * ==> ==> b-> | | |-> +----|----+-> v-> r-- * 'Consumer'': marks the downstream end unused but still open--> type Consumer' a m r = forall y' y . Proxy () a y' y m r->-> Upstream | Downstream-> +---------+-> | |-> () <== <== * -> | |-> a ==> ==> *-> | | |-> +----|----+-> v-> r-- * 'Effect'': marks both ends unused but still open--> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r->-> Upstream | Downstream-> +---------+-> | |-> * <== <== * -> | |-> * ==> ==> *-> | | |-> +----|----+-> v-> r-- Note that there is no polymorphic generalization of a 'Pipe'.-- Like before, if you compose a 'Producer'', a 'Pipe', and a 'Consumer'':--> Producer' Pipe Consumer'-> +-----------+ +----------+ +------------+-> | | | | | |-> * <== <== () <== <== () <== <== *-> | stdinLn | | take 3 | | stdoutLn |-> * ==> ==> String ==> ==> String ==> ==> *-> | | | | | | | | |-> +-----|-----+ +-----|----+ +------|-----+-> v v v-> () () ()-- ... they fuse into an 'Effect'':--> Effect'-> +-----------------------------------+-> | |-> * <== <== *-> | stdinLn >-> take 3 >-> stdoutLn |-> * ==> ==> *-> | |-> +----------------|------------------+-> v-> ()-- Polymorphic type synonyms come in handy when you want to keep the type as- general as possible. For example, the type signature for 'yield' uses- 'Producer'' to keep the type signature simple while still leaving the- upstream input end open:--@- 'yield' :: 'Monad' m => a -> 'Producer'' a m ()-@-- This type signature lets us use 'yield' within a 'Pipe', too, because the- 'Pipe' type synonym is a special case of the polymorphic 'Producer'' type - synonym:--@- type 'Producer'' b m r = forall x' x . 'Proxy' x' x () b m r- type 'Pipe' a b m r = 'Proxy' () a () b m r-@-- The same is true for 'await', which uses the polymorphic 'Consumer'' type- synonym:--@- 'await' :: 'Monad' m => 'Consumer'' a m a-@-- We can use 'await' within a 'Pipe' because a 'Pipe' is a special case of the- polymorphic 'Consumer'' type synonym:--@- type 'Consumer'' a m r = forall y' y . 'Proxy' () a y' y m r- type 'Pipe' a b m r = 'Proxy' () a () b m r-@-- However, polymorphic type synonyms cause problems in many other cases:-- * They usually give the wrong behavior when used as the argument of a- function (known as the \"negative\" or \"contravariant\" position) like- this:--> f :: Producer' a m r -> ... -- Wrong->-> f :: Producer a m r -> ... -- Right-- The former function only accepts polymorphic 'Producer's as arguments.- The latter function accepts both polymorphic and concrete 'Producer's,- which is probably what you want.-- * Even when you desire a polymorphic argument, this induces a higher-ranked- type, because it translates to a @forall@ which you cannot factor out to- the top-level to simplify the type signature:--> f :: (forall x' x y' . Proxy x' x y' m r) -> ...-- These kinds of type signatures require the @RankNTypes@ extension.-- * Even when you have polymorphic type synonyms as the result of a function- (i.e. the \"positive\" or \"covariant\" position), recent versions of- @ghc@ such still require the @RankNTypes@ extension. For example, the- 'Pipes.Prelude.fromHandle' function from "Pipes.Prelude" requires- @RankNTypes@ to compile correctly on @ghc-7.6.3@:--> fromHandle :: MonadIO m => Handle -> Producer' String m ()-- * You can't use polymorphic type synonyms inside other type constructors- without the @ImpredicativeTypes@ extension:--> io :: IO (Producer' a m r) -- Type error without ImpredicativeTypes-- * You can't partially apply polymorphic type synonyms:--> stack :: MaybeT (Producer' a m) r -- Type error-- In these scenarios you should fall back on the concrete type synonyms, which- are better behaved. If concrete type synonyms are unsatisfactory, then ask- @ghc@ to infer the most general type signature and use that.-- For the purposes of debugging type errors you can just remember that:--> Input --+ +-- Output-> | |-> v v-> Proxy a' a b' b m r-> ^ ^-> | |-> +----+-- Ignore these-- For example, let's say that you try to run the 'P.stdinLn' 'Producer'. This- produces the following type error:-->>> runEffect P.stdinLn-<interactive>:4:5:- Couldn't match expected type `X' with actual type `String'- Expected type: Effect m0 r0- Actual type: Proxy X () () String IO ()- In the first argument of `runEffect', namely `P.stdinLn'- In the expression: runEffect P.stdinLn-- 'runEffect' expects an 'Effect', which is equivalent to the following type:--> Effect IO () = Proxy X () () X IO ()-- ... but 'P.stdinLn' type-checks as a 'Producer', which has the following- type:--> Producer String IO () = Proxy X () () String IO ()-- The fourth type variable (the output) does not match. For an 'Effect' this- type variable should be closed (i.e. 'X'), but 'P.stdinLn' has a 'String'- output, thus the type error:--> Couldn't match expected type `X' with actual type `String'-- Any time you get type errors like these you can work through them by- expanding out the type synonyms and seeing which type variables do not- match.-- You may also consult this table of type synonyms to more easily compare- them:--> type Effect = Proxy X () () X-> type Producer b = Proxy X () () b-> type Consumer a = Proxy () a () X-> type Pipe a b = Proxy () a () b->-> type Server b' b = Proxy X () b' b -> type Client a' a = Proxy a' a () X->-> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r-> type Producer' b m r = forall x' x . Proxy x' x () b m r-> type Consumer' a m r = forall y' y . Proxy () a y' y m r->-> type Server' b' b m r = forall x' x . Proxy x' x b' b m r-> type Client' a' a m r = forall y' y . Proxy a' a y' y m r---}--{- $timecomplexity- There are three functions that give quadratic time complexity when used in- within @pipes@:-- * 'sequence'-- * 'replicateM'-- * 'mapM'-- For example, the time complexity of this code segment scales quadratically- with `n`:--> import Control.Monad (replicateM)-> import Pipes->-> quadratic :: Int -> Consumer a m [a]-> quadratic n = replicateM n await-- These three functions are generally bad practice to use, because all three- of them correspond to \"ListT done wrong\", building a list in memory- instead of streaming results.-- However, sometimes situations arise where one deliberately intends to build- a list in memory. The solution is to use the \"codensity transformation\"- to transform the code to run with linear time complexity. This involves:-- * wrapping the code in the @Codensity@ monad transformer (from- @Control.Monad.Codensity@ module of the @kan-extensions@ package) using- 'lift'-- * applying 'sequence' \/ 'replicateM' \/ 'mapM'-- * unwrapping the code using @lowerCodensity@-- To illustrate this, we'd transform the above example to:--> import Control.Monad.Codensity (lowerCodensity)-> -> linear :: Monad m => Int -> Consumer a m [a]-> linear n = lowerCodensity $ replicateM n $ lift await-- This will produce the exact same result, but in linear time.--}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-| Conventional Haskell stream programming forces you to choose only two of the + following three features: + + * Effects + + * Streaming + + * Composability + + If you sacrifice /Effects/ you get Haskell's pure and lazy lists, which you + can transform using composable functions in constant space, but without + interleaving effects. + + If you sacrifice /Streaming/ you get 'mapM', 'forM' and + \"ListT done wrong\", which are composable and effectful, but do not return + a single result until the whole list has first been processed and loaded + into memory. + + If you sacrifice /Composability/ you write a tightly coupled read, + transform, and write loop in 'IO', which is streaming and effectful, but is + not modular or separable. + + @pipes@ gives you all three features: effectful, streaming, and composable + programming. @pipes@ also provides a wide variety of stream programming + abstractions which are all subsets of a single unified machinery: + + * effectful 'Producer's (like generators), + + * effectful 'Consumer's (like iteratees), + + * effectful 'Pipe's (like Unix pipes), and: + + * 'ListT' done right. + + All of these are connectable and you can combine them together in clever and + unexpected ways because they all share the same underlying type. + + @pipes@ requires a basic understanding of monad transformers, which you can + learn about by reading either: + + * the paper \"Monad Transformers - Step by Step\", + + * chapter 18 of \"Real World Haskell\" on monad transformers, or: + + * the documentation of the @transformers@ library. + + If you want a Quick Start guide to @pipes@, read the documentation in + "Pipes.Prelude" from top to bottom. + + This tutorial is more extensive and explains the @pipes@ API in greater + detail and illustrates several idioms. +-} + +module Pipes.Tutorial ( + -- * Introduction + -- $introduction + + -- * Producers + -- $producers + + -- * Composability + -- $composability + + -- * Consumers + -- $consumers + + -- * Pipes + -- $pipes + + -- * ListT + -- $listT + + -- * Tricks + -- $tricks + + -- * Conclusion + -- $conclusion + + -- * Appendix: Types + -- $types + + -- * Appendix: Time Complexity + -- $timecomplexity + ) where + +import Control.Category +import Control.Monad +import Control.Monad.Trans.Error +import Control.Monad.Trans.Writer.Strict +import Pipes +import Pipes.Lift +import qualified Pipes.Prelude as P +import Prelude hiding ((.), id) + +{- $introduction + The @pipes@ library decouples stream processing stages from each other so + that you can mix and match diverse stages to produce useful streaming + programs. If you are a library writer, @pipes@ lets you package up + streaming components into a reusable interface. If you are an application + writer, @pipes@ lets you connect pre-made streaming components with minimal + effort to produce a highly-efficient program that streams data in constant + memory. + + To enforce loose coupling, components can only communicate using two + commands: + + * 'yield': Send output data + + * 'await': Receive input data + + @pipes@ has four types of components built around these two commands: + + * 'Producer's can only 'yield' values and they model streaming sources + + * 'Consumer's can only 'await' values and they model streaming sinks + + * 'Pipe's can both 'yield' and 'await' values and they model stream + transformations + + * 'Effect's can neither 'yield' nor 'await' and they model non-streaming + components + + You can connect these components together in four separate ways which + parallel the four above types: + + * 'for' handles 'yield's + + * ('>~') handles 'await's + + * ('>->') handles both 'yield's and 'await's + + * ('>>=') handles return values + + As you connect components their types will change to reflect inputs and + outputs that you've fused away. You know that you're done connecting things + when you get an 'Effect', meaning that you have handled all inputs and + outputs. You run this final 'Effect' to begin streaming. +-} + +{- $producers + 'Producer's are effectful streams of input. Specifically, a 'Producer' is a + monad transformer that extends any base monad with a new 'yield' command. + This 'yield' command lets you send output downstream to an anonymous + handler, decoupling how you generate values from how you consume them. + + The following @stdinLn@ 'Producer' shows how to incrementally read in + 'String's from standard input and 'yield' them downstream, terminating + gracefully when reaching the end of the input: + +> -- echo.hs +> +> import Control.Monad (unless) +> import Pipes +> import System.IO (isEOF) +> +> -- +--------+-- A 'Producer' that yields 'String's +> -- | | +> -- | | +-- Every monad transformer has a base monad. +> -- | | | This time the base monad is 'IO'. +> -- | | | +> -- | | | +-- Every monadic action has a return value. +> -- | | | | This action returns '()' when finished +> -- v v v v +> stdinLn :: Producer String IO () +> stdinLn = do +> eof <- lift isEOF -- 'lift' an 'IO' action from the base monad +> unless eof $ do +> str <- lift getLine +> yield str -- 'yield' the 'String' +> stdinLn -- Loop + + 'yield' emits a value, suspending the current 'Producer' until the value is + consumed. If nobody consumes the value (which is possible) then 'yield' + never returns. You can think of 'yield' as having the following type: + +@ + 'yield' :: 'Monad' m => a -> 'Producer' a m () +@ + + The true type of 'yield' is actually more general and powerful. Throughout + the tutorial I will present type signatures like this that are simplified at + first and then later reveal more general versions. So read the above type + signature as simply saying: \"You can use 'yield' within a 'Producer', but + you may be able to use 'yield' in other contexts, too.\" + + Click the link to 'yield' to navigate to its documentation. There you will + see that 'yield' actually uses the 'Producer'' (with an apostrophe) type + synonym which hides a lot of polymorphism behind a simple veneer. The + documentation for 'yield' says that you can also use 'yield' within a + 'Pipe', too, because of this polymorphism: + +@ + 'yield' :: 'Monad' m => a -> 'Pipe' x a m () +@ + + Use simpler types like these to guide you until you understand the fully + general type. + + 'for' loops are the simplest way to consume a 'Producer' like @stdinLn@. + 'for' has the following type: + +@ + \-\- +-- Producer +-- The body of the +-- Result + \-\- | to loop | loop | + \-\- v over v v + \-\- -------------- ------------------ ---------- + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r +@ + + @(for producer body)@ loops over @(producer)@, substituting each 'yield' in + @(producer)@ with @(body)@. + + You can also deduce that behavior purely from the type signature: + + * The body of the loop takes exactly one argument of type @(a)@, which is + the same as the output type of the 'Producer'. Therefore, the body of the + loop must get its input from that 'Producer' and nowhere else. + + * The return value of the input 'Producer' matches the return value of the + result, therefore 'for' must loop over the entire 'Producer' and not skip + anything. + + The above type signature is not the true type of 'for', which is actually + more general. Think of the above type signature as saying: \"If the first + argument of 'for' is a 'Producer' and the second argument returns an + 'Effect', then the final result must be an 'Effect'.\" + + Click the link to 'for' to navigate to its documentation. There you will + see the fully general type and underneath you will see equivalent simpler + types. One of these says that if the body of the loop is a 'Producer', then + the result is a 'Producer', too: + +@ + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r +@ + + The first type signature I showed for 'for' was a special case of this + slightly more general signature because a 'Producer' that never 'yield's is + also an 'Effect': + +@ + data 'X' -- The uninhabited type + +\ type 'Effect' m r = 'Producer' 'X' m r +@ + + This is why 'for' permits two different type signatures. The first type + signature is just a special case of the second one: + +@ + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r + +\ -- Specialize \'b\' to \'X\' + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' 'X' m ()) -> 'Producer' 'X' m r + +\ -- Producer X = Effect + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r +@ + + This is the same trick that all @pipes@ functions use to work with various + combinations of 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's. Each + function really has just one general type, which you can then simplify down + to multiple useful alternative types. + + Here's an example use of a 'for' @loop@, where the second argument (the + loop body) is an 'Effect': + +> -- echo.hs +> +> loop :: Effect IO () +> loop = for stdinLn $ \str -> do -- Read this like: "for str in stdinLn" +> lift $ putStrLn str -- The body of the 'for' loop +> +> -- more concise: loop = for stdinLn (lift . putStrLn) + + In this example, 'for' loops over @stdinLn@ and replaces every 'yield' in + @stdinLn@ with the body of the loop, printing each line. This is exactly + equivalent to the following code, which I've placed side-by-side with the + original definition of @stdinLn@ for comparison: + +> loop = do | stdinLn = do +> eof <- lift isEOF | eof <- lift isEOF +> unless eof $ do | unless eof $ do +> str <- lift getLine | str <- lift getLine +> (lift . putStrLn) str | yield str +> loop | stdinLn + + You can think of 'yield' as creating a hole and a 'for' loop is one way to + fill that hole. + + Notice how the final @loop@ only 'lift's actions from the base monad and + does nothing else. This property is true for all 'Effect's, which are just + glorified wrappers around actions in the base monad. This means we can run + these 'Effect's to remove their 'lift's and lower them back to the + equivalent computation in the base monad: + +@ + 'runEffect' :: 'Monad' m => 'Effect' m r -> m r +@ + + This is the real type signature of 'runEffect', which refuses to accept + anything other than an 'Effect'. This ensures that we handle all inputs and + outputs before streaming data: + +> -- echo.hs +> +> main :: IO () +> main = runEffect loop + + ... or you could inline the entire @loop@ into the following one-liner: + +> main = runEffect $ for stdinLn (lift . putStrLn) + + Our final program loops over standard input and echoes every line to + standard output until we hit @Ctrl-D@ to end the input stream: + +> $ ghc -O2 echo.hs +> $ ./echo +> Test<Enter> +> Test +> ABC<Enter> +> ABC +> <Ctrl-D> +> $ + + The final behavior is indistinguishable from just removing all the 'lift's + from @loop@: + +> main = do | loop = do +> eof <- isEof | eof <- lift isEof +> unless eof $ do | unless eof $ do +> str <- getLine | str <- lift getLine +> putStrLn str | (lift . putStrLn) str +> main | loop + + This @main@ is what we might have written by hand if we were not using + @pipes@, but with @pipes@ we can decouple the input and output logic from + each other. When we connect them back together, we still produce streaming + code equivalent to what a sufficiently careful Haskell programmer would + have written. + + You can also use 'for' to loop over lists, too. To do so, convert the list + to a 'Producer' using 'each', which is exported by default from "Pipes": + +> each :: Monad m => [a] -> Producer a m () +> each as = mapM_ yield as + + Combine 'for' and 'each' to iterate over lists using a \"foreach\" loop: + +>>> runEffect $ for (each [1..4]) (lift . print) +1 +2 +3 +4 + + 'each' is actually more general and works for any 'Foldable': + +@ + 'each' :: ('Monad' m, 'Foldable' f) => f a -> 'Producer' a m () +@ + + So you can loop over any 'Foldable' container or even a 'Maybe': + +>>> runEffect $ for (each (Just 1)) (lift . print) +1 + +-} + +{- $composability + You might wonder why the body of a 'for' loop can be a 'Producer'. Let's + test out this feature by defining a new loop body that @duplicate@s every + value: + +> -- nested.hs +> +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude already has 'stdinLn' +> +> duplicate :: Monad m => a -> Producer a m () +> duplicate x = do +> yield x +> yield x +> +> loop :: Producer String IO () +> loop = for P.stdinLn duplicate +> +> -- This is the exact same as: +> -- +> -- loop = for P.stdinLn $ \x -> do +> -- yield x +> -- yield x + + This time our @loop@ is a 'Producer' that outputs 'String's, specifically + two copies of each line that we read from standard input. Since @loop@ is a + 'Producer' we cannot run it because there is still unhandled output. + However, we can use yet another 'for' to handle this new duplicated stream: + +> -- nested.hs +> +> main = runEffect $ for loop (lift . putStrLn) + + This creates a program which echoes every line from standard input to + standard output twice: + +> $ ./nested +> Test<Enter> +> Test +> Test +> ABC<Enter> +> ABC +> ABC +> <Ctrl-D> +> $ + + But is this really necessary? Couldn't we have instead written this using a + nested for loop? + +> main = runEffect $ +> for P.stdinLn $ \str1 -> +> for (duplicate str1) $ \str2 -> +> lift $ putStrLn str2 + + Yes, we could have! In fact, this is a special case of the following + equality, which always holds no matter what: + +@ + \-\- s :: Monad m => 'Producer' a m () -- i.e. \'P.stdinLn\' + \-\- f :: Monad m => a -> 'Producer' b m () -- i.e. \'duplicate\' + \-\- g :: Monad m => b -> 'Producer' c m () -- i.e. \'(lift . putStrLn)\' + +\ for (for s f) g = for s (\\x -> for (f x) g) +@ + + We can understand the rationale behind this equality if we first define the + following operator that is the point-free counterpart to 'for': + +@ + (~>) :: Monad m + => (a -> 'Producer' b m r) + -> (b -> 'Producer' c m r) + -> (a -> 'Producer' c m r) + (f ~> g) x = for (f x) g +@ + + Using ('~>') (pronounced \"into\"), we can transform our original equality + into the following more symmetric equation: + +@ + f :: Monad m => a -> 'Producer' b m r + g :: Monad m => b -> 'Producer' c m r + h :: Monad m => c -> 'Producer' d m r + +\ \-\- Associativity + (f ~> g) ~> h = f ~> (g ~> h) +@ + + This looks just like an associativity law. In fact, ('~>') has another nice + property, which is that 'yield' is its left and right identity: + +> -- Left Identity +> yield ~> f = f + +> -- Right Identity +> f ~> yield = f + + In other words, 'yield' and ('~>') form a 'Category', specifically the + generator category, where ('~>') plays the role of the composition operator + and 'yield' is the identity. If you don't know what a 'Category' is, that's + okay, and category theory is not a prerequisite for using @pipes@. All you + really need to know is that @pipes@ uses some simple category theory to keep + the API intuitive and easy to use. + + Notice that if we translate the left identity law to use 'for' instead of + ('~>') we get: + +> for (yield x) f = f x + + This just says that if you iterate over a pure single-element 'Producer', + then you could instead cut out the middle man and directly apply the body of + the loop to that single element. + + If we translate the right identity law to use 'for' instead of ('~>') we + get: + +> for s yield = s + + This just says that if the only thing you do is re-'yield' every element of + a stream, you get back your original stream. + + These three \"for loop\" laws summarize our intuition for how 'for' loops + should behave and because these are 'Category' laws in disguise that means + that 'Producer's are composable in a rigorous sense of the word. + + In fact, we get more out of this than just a bunch of equations. We also + get a useful operator: ('~>'). We can use this operator to condense + our original code into the following more succinct form that composes two + transformations: + +> main = runEffect $ for P.stdinLn (duplicate ~> lift . putStrLn) + + This means that we can also choose to program in a more functional style and + think of stream processing in terms of composing transformations using + ('~>') instead of nesting a bunch of 'for' loops. + + The above example is a microcosm of the design philosophy behind the @pipes@ + library: + + * Define the API in terms of categories + + * Specify expected behavior in terms of category laws + + * Think compositionally instead of sequentially +-} + +{- $consumers + Sometimes you don't want to use a 'for' loop because you don't want to consume + every element of a 'Producer' or because you don't want to process every + value of a 'Producer' the exact same way. + + The most general solution is to externally iterate over the 'Producer' using + the 'next' command: + +@ + 'next' :: 'Monad' m => 'Producer' a m r -> m ('Either' r (a, 'Producer' a m r)) +@ + + Think of 'next' as pattern matching on the head of the 'Producer'. This + 'Either' returns a 'Left' if the 'Producer' is done or it returns a 'Right' + containing the next value, @a@, along with the remainder of the 'Producer'. + + However, sometimes we can get away with something a little more simple and + elegant, like a 'Consumer', which represents an effectful sink of values. A + 'Consumer' is a monad transformer that extends the base monad with a new + 'await' command. This 'await' command lets you receive input from an + anonymous upstream source. + + The following @stdoutLn@ 'Consumer' shows how to incrementally 'await' + 'String's and print them to standard output, terminating gracefully when + receiving a broken pipe error: + +> import Control.Monad (unless) +> import Control.Exception (try, throwIO) +> import qualified GHC.IO.Exception as G +> import Pipes +> +> -- +--------+-- A 'Consumer' that awaits 'String's +> -- | | +> -- v v +> stdoutLn :: Consumer String IO () +> stdoutLn = do +> str <- await -- 'await' a 'String' +> x <- lift $ try $ putStrLn str +> case x of +> -- Gracefully terminate if we got a broken pipe error +> Left e@(G.IOError { G.ioe_type = t}) -> +> lift $ unless (t == G.ResourceVanished) $ throwIO e +> -- Otherwise loop +> Right () -> stdoutLn + + 'await' is the dual of 'yield': we suspend our 'Consumer' until we receive a + new value. If nobody provides a value (which is possible) then 'await' + never returns. You can think of 'await' as having the following type: + +@ + 'await' :: 'Monad' m => 'Consumer' a m a +@ + + One way to feed a 'Consumer' is to repeatedly feed the same input using + using ('>~') (pronounced \"feed\"): + +@ + \-\- +- Feed +- Consumer to +- Returns new + \-\- | action | feed | Effect + \-\- v v v + \-\- ---------- -------------- ---------- + ('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +@ + + @(draw >~ consumer)@ loops over @(consumer)@, substituting each 'await' in + @(consumer)@ with @(draw)@. + + So the following code replaces every 'await' in 'P.stdoutLn' with + @(lift getLine)@ and then removes all the 'lift's: + +>>> runEffect $ lift getLine >~ stdoutLn +Test<Enter> +Test +ABC<Enter> +ABC +42<Enter> +42 +... + + You might wonder why ('>~') uses an 'Effect' instead of a raw action in the + base monad. The reason why is that ('>~') actually permits the following + more general type: + +@ + ('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +@ + + ('>~') is the dual of ('~>'), composing 'Consumer's instead of 'Producer's. + + This means that you can feed a 'Consumer' with yet another 'Consumer' so + that you can 'await' while you 'await'. For example, we could define the + following intermediate 'Consumer' that requests two 'String's and returns + them concatenated: + +> doubleUp :: Monad m => Consumer String m String +> doubleUp = do +> str1 <- await +> str2 <- await +> return (str1 ++ str2) +> +> -- more concise: doubleUp = (++) <$> await <*> await + + We can now insert this in between @(lift getLine)@ and @stdoutLn@ and see + what happens: + +>>> runEffect $ lift getLine >~ doubleUp >~ stdoutLn +Test<Enter> +ing<Enter> +Testing +ABC<Enter> +DEF<Enter> +ABCDEF +42<Enter> +000<Enter> +42000 +... + + 'doubleUp' splits every request from 'stdoutLn' into two separate requests + and + returns back the concatenated result. + + We didn't need to parenthesize the above chain of ('>~') operators, because + ('>~') is associative: + +> -- Associativity +> (f >~ g) >~ h = f >~ (g >~ h) + + ... so we can always omit the parentheses since the meaning is unambiguous: + +> f >~ g >~ h + + Also, ('>~') has an identity, which is 'await'! + +> -- Left identity +> await >~ f = f +> +> -- Right Identity +> f >~ await = f + + In other words, ('>~') and 'await' form a 'Category', too, specifically the + iteratee category, and 'Consumer's are also composable. +-} + +{- $pipes + Our previous programs were unsatisfactory because they were biased either + towards the 'Producer' end or the 'Consumer' end. As a result, we had to + choose between gracefully handling end of input (using 'P.stdinLn') or + gracefully handling end of output (using 'P.stdoutLn'), but not both at the + same time. + + However, we don't need to restrict ourselves to using 'Producer's + exclusively or 'Consumer's exclusively. We can connect 'Producer's and + 'Consumer's directly together using ('>->') (pronounced \"pipe\"): + +@ + ('>->') :: 'Monad' m => 'Producer' a m r -> 'Consumer' a m r -> 'Effect' m r +@ + + This returns an 'Effect' which we can run: + +> -- echo2.hs +> +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude also provides 'stdoutLn' +> +> main = runEffect $ P.stdinLn >-> P.stdoutLn + + This program is more declarative of our intent: we want to stream values + from 'P.stdinLn' to 'P.stdoutLn'. The above \"pipeline\" not only echoes + standard input to standard output, but also handles both end of input and + broken pipe errors: + +> $ ./echo2 +> Test<Enter> +> Test +> ABC<Enter> +> ABC +> 42<Enter> +> 42 +> <Ctrl-D> +> $ + + ('>->') is \"pull-based\" meaning that control flow begins at the most + downstream component (i.e. 'P.stdoutLn' in the above example). Any time a + component 'await's a value it blocks and transfers control upstream and + every time a component 'yield's a value it blocks and restores control back + downstream, satisfying the 'await'. So in the above example, ('>->') + matches every 'await' from 'P.stdoutLn' with a 'yield' from 'P.stdinLn'. + + Streaming stops when either 'P.stdinLn' terminates (i.e. end of input) or + 'P.stdoutLn' terminates (i.e. broken pipe). This is why ('>->') requires + that both the 'Producer' and 'Consumer' share the same type of return value: + whichever one terminates first provides the return value for the entire + 'Effect'. + + Let's test this by modifying our 'Producer' and 'Consumer' to each return a + diagnostic 'String': + +> -- echo3.hs +> +> import Control.Applicative ((<$)) -- (<$) modifies return values +> import Pipes +> import qualified Pipes.Prelude as P +> import System.IO +> +> main = do +> hSetBuffering stdout NoBuffering +> str <- runEffect $ +> ("End of input!" <$ P.stdinLn) >-> ("Broken pipe!" <$ P.stdoutLn) +> hPutStrLn stderr str + + This lets us diagnose whether the 'Producer' or 'Consumer' terminated first: + +> $ ./echo3 +> Test<Enter> +> Test +> <Ctrl-D> +> End of input! +> $ ./echo3 | perl -e 'close STDIN' +> Test<Enter> +> Broken pipe! +> $ + + You might wonder why ('>->') returns an 'Effect' that we have to run instead + of directly returning an action in the base monad. This is because you can + connect things other than 'Producer's and 'Consumer's, like 'Pipe's, which + are effectful stream transformations. + + A 'Pipe' is a monad transformer that is a mix between a 'Producer' and + 'Consumer', because a 'Pipe' can both 'await' and 'yield'. The following + example 'Pipe' is analagous to the Prelude's 'take', only allowing a fixed + number of values to flow through: + +> -- take.hs +> +> import Control.Monad (replicateM_) +> import Pipes +> import Prelude hiding (take) +> +> -- +--------- A 'Pipe' that +> -- | +---- 'await's 'a's and +> -- | | +-- 'yield's 'a's +> -- | | | +> -- v v v +> take :: Int -> Pipe a a IO () +> take n = do +> replicateM_ n $ do -- Repeat this block 'n' times +> x <- await -- 'await' a value of type 'a' +> yield x -- 'yield' a value of type 'a' +> lift $ putStrLn "You shall not pass!" -- Fly, you fools! + + You can use 'Pipe's to transform 'Producer's, 'Consumer's, or even other + 'Pipe's using the same ('>->') operator: + +@ + ('>->') :: 'Monad' m => 'Producer' a m r -> 'Pipe' a b m r -> 'Producer' b m r + ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r + ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +@ + + For example, you can compose 'P.take' after 'P.stdinLn' to limit the number + of lines drawn from standard input: + +> maxInput :: Int -> Producer String IO () +> maxInput n = P.stdinLn >-> take n + +>>> runEffect $ maxInput 3 >-> P.stdoutLn +Test<Enter> +Test +ABC<Enter> +ABC +42<Enter> +42 +You shall not pass! +>>> + + ... or you can pre-compose 'P.take' before 'P.stdoutLn' to limit the number + of lines written to standard output: + +> maxOutput :: Int -> Consumer String IO () +> maxOutput n = take n >-> P.stdoutLn + +>>> runEffect $ P.stdinLn >-> maxOutput 3 +<Exact same behavior> + + Those both gave the same behavior because ('>->') is associative: + +> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) + + Therefore we can just leave out the parentheses: + +>>> runEffect $ P.stdinLn >-> take 3 >-> P.stdoutLn +<Exact same behavior> + + ('>->') is designed to behave like the Unix pipe operator, except with less + quirks. In fact, we can continue the analogy to Unix by defining 'cat' + (named after the Unix @cat@ utility), which reforwards elements endlessly: + +> cat :: Monad m => Pipe a a m r +> cat = forever $ do +> x <- await +> yield x + + 'cat' is the identity of ('>->'), meaning that 'cat' satisfies the + following two laws: + +> -- Useless use of 'cat' +> cat >-> p = p +> +> -- Forwarding output to 'cat' does nothing +> p >-> cat = p + + Therefore, ('>->') and 'cat' form a 'Category', specifically the category of + Unix pipes, and 'Pipe's are also composable. + + A lot of Unix tools have very simple definitions when written using @pipes@: + +> -- unix.hs +> +> import Control.Monad (forever) +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude provides 'take', too +> import Prelude hiding (head) +> +> head :: Monad m => Int -> Pipe a a m () +> head = P.take +> +> yes :: Monad m => Producer String m r +> yes = forever $ yield "y" +> +> main = runEffect $ yes >-> head 3 >-> P.stdoutLn + + This prints out 3 \'@y@\'s, just like the equivalent Unix pipeline: + +> $ ./unix +> y +> y +> y +> $ yes | head -3 +> y +> y +> y +> $ + + This lets us write \"Haskell pipes\" instead of Unix pipes. These are much + easier to build than Unix pipes and we can connect them directly within + Haskell for interoperability with the Haskell language and ecosystem. +-} + +{- $listT + @pipes@ also provides a \"ListT done right\" implementation. This differs + from the implementation in @transformers@ because this 'ListT': + + * obeys the monad laws, and + + * streams data immediately instead of collecting all results into memory. + + The latter property is actually an elegant consequence of obeying the monad + laws. + + To bind a list within a 'ListT' computation, combine 'Select' and 'each': + +> import Pipes +> +> pair :: ListT IO (Int, Int) +> pair = do +> x <- Select $ each [1, 2] +> lift $ putStrLn $ "x = " ++ show x +> y <- Select $ each [3, 4] +> lift $ putStrLn $ "y = " ++ show y +> return (x, y) + + You can then loop over a 'ListT' by using 'every': + +@ + 'every' :: 'Monad' m => 'ListT' m a -> 'Producer' a m () +@ + + So you can use your 'ListT' within a 'for' loop: + +>>> runEffect $ for (every pair) (lift . print) +x = 1 +y = 3 +(1,3) +y = 4 +(1,4) +x = 2 +y = 3 +(2,3) +y = 4 +(2,4) + + ... or a pipeline: + +>>> import qualified Pipes.Prelude as P +>>> runEffect $ every pair >-> P.print +<Exact same behavior> + + Note that 'ListT' is lazy and only produces as many elements as we request: + +>>> runEffect $ for (every pair >-> P.take 2) (lift . print) +x = 1 +y = 3 +(1,3) +y = 4 +(1,4) + + You can also go the other way, binding 'Producer's directly within a + 'ListT'. In fact, this is actually what 'Select' was already doing: + +@ + 'Select' :: 'Producer' a m () -> 'ListT' m a +@ + + This lets you write crazy code like: + +> import Pipes +> import qualified Pipes.Prelude as P +> +> input :: Producer String IO () +> input = P.stdinLn >-> P.takeWhile (/= "quit") +> +> name :: ListT IO String +> name = do +> firstName <- Select input +> lastName <- Select input +> return (firstName ++ " " ++ lastName) + + Here we're binding standard input non-deterministically (twice) as if it + were an effectful list: + +>>> runEffect $ every name >-> P.stdoutLn +Daniel<Enter> +Fischer<Enter> +Daniel Fischer +Wagner<Enter> +Daniel Wagner +quit<Enter> +Donald<Enter> +Stewart<Enter> +Donald Stewart +Duck<Enter> +Donald Duck +quit<Enter> +quit<Enter> +>>> + + Notice how this streams out values immediately as they are generated, rather + than building up a large intermediate result and then printing all the + values in one batch at the end. +-} + +{- $tricks + @pipes@ is more powerful than meets the eye so this section presents some + non-obvious tricks you may find useful. + + Many pipe combinators will work on unusual pipe types and the next few + examples will use the 'cat' pipe to demonstrate this. + + For example, you can loop over the output of a 'Pipe' using 'for', which is + how 'P.map' is defined: + +> map :: Monad m => (a -> b) -> Pipe a b m r +> map f = for cat $ \x -> yield (f x) +> +> -- Read this as: For all values flowing downstream, apply 'f' + + This is equivalent to: + +> map f = forever $ do +> x <- await +> yield (f x) + + You can also feed a 'Pipe' input using ('>~'). This means we could have + instead defined the @yes@ pipe like this: + +> yes :: Monad m => Producer String m r +> yes = return "y" >~ cat +> +> -- Read this as: Keep feeding "y" downstream + + This is equivalent to: + +> yes = forever $ yield "y" + + You can also sequence two 'Pipe's together. This is how 'P.drop' is + defined: + +> drop :: Monad m => Int -> Pipe a a m r +> drop n = do +> replicateM_ n await +> cat + + This is equivalent to: + +> drop n = do +> replicateM_ n await +> forever $ do +> x <- await +> yield x + + You can even compose pipes inside of another pipe: + +> customerService :: Producer String IO () +> customerService = do +> each [ "Hello, how can I help you?" -- Begin with a script +> , "Hold for one second." +> ] +> P.stdinLn >-> P.takeWhile (/= "Goodbye!") -- Now continue with a human + + Also, you can often use 'each' in conjunction with ('~>') to traverse nested + data structures. For example, you can print all non-'Nothing' elements + from a doubly-nested list: + +>>> runEffect $ (each ~> each ~> each ~> lift . print) [[Just 1, Nothing], [Just 2, Just 3]] +1 +2 +3 + + Another neat thing to know is that 'every' has a more general type: + +@ + 'every' :: ('Monad' m, 'Enumerable' t) => t m a -> 'Producer' a m () +@ + + 'Enumerable' generalizes 'Foldable' and if you have an effectful container + of your own that you want others to traverse using @pipes@, just have your + container implement the 'toListT' method of the 'Enumerable' class: + +> class Enumerable t where +> toListT :: Monad m => t m a -> ListT m a + + You can even use 'Enumerable' to traverse effectful types that are not even + proper containers, like 'Control.Monad.Trans.Maybe.MaybeT': + +> input :: MaybeT IO String +> input = do +> str <- lift getLine +> guard (str /= "Fail") +> return str + +>>> runEffect $ every input >-> P.stdoutLn +Test<Enter> +Test +>>> runEffect $ every input >-> P.stdoutLn +Fail<Enter> +>>> + +-} + +{- $conclusion + This tutorial covers the concepts of connecting, building, and reading + @pipes@ code. However, this library is only the core component in an + ecosystem of streaming components. Derived libraries that build immediately + upon @pipes@ include: + + * @pipes-concurrency@: Concurrent reactive programming and message passing + + * @pipes-parse@: Minimal utilities for stream parsing + + * @pipes-safe@: Resource management and exception safety for @pipes@ + + These libraries provide functionality specialized to common streaming + domains. Additionally, there are several libraries on Hackage that provide + even higher-level functionality, which you can find by searching under the + \"Pipes\" category or by looking for packages with a @pipes-@ prefix in + their name. Current examples include: + + * @pipes-network@/@pipes-network-tls@: Networking + + * @pipes-zlib@: Compression and decompression + + * @pipes-binary@: Binary serialization + + * @pipes-attoparsec@: High-performance parsing + + * @pipes-aeson@: JSON serialization and deserialization + + Even these derived packages still do not explore the full potential of + @pipes@ functionality, which actually permits bidirectional communication. + Advanced @pipes@ users can explore this library in greater detail by + studying the documentation in the "Pipes.Core" module to learn about the + symmetry of the underlying 'Proxy' type and operators. + + To learn more about @pipes@, ask questions, or follow @pipes@ development, + you can subscribe to the @haskell-pipes@ mailing list at: + + <https://groups.google.com/forum/#!forum/haskell-pipes> + + ... or you can mail the list directly at: + + <mailto:haskell-pipes@googlegroups.com> + + Additionally, for questions regarding types or type errors, you might find + the following appendix on types very useful. +-} + +{- $types + @pipes@ uses parametric polymorphism (i.e. generics) to overload all + operations. You've probably noticed this overloading already:: + + * 'yield' works within both 'Producer's and 'Pipe's + + * 'await' works within both 'Consumer's and 'Pipe's + + * ('>->') connects 'Producer's, 'Consumer's, and 'Pipe's in varying ways + + This overloading is great when it works, but when connections fail they + produce type errors that appear intimidating at first. This section + explains the underlying types so that you can work through type errors + intelligently. + + 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's are all special cases of a + single underlying type: a 'Proxy'. This overarching type permits fully + bidirectional communication on both an upstream and downstream interface. + You can think of it as having the following shape: + +> Proxy a' a b' b m r +> +> Upstream | Downstream +> +---------+ +> | | +> a' <== <== b' -- Information flowing upstream +> | | +> a ==> ==> b -- Information flowing downstream +> | | | +> +----|----+ +> v +> r + + The four core types do not use the upstream flow of information. This means + that the @a'@ and @b'@ in the above diagram go unused unless you use the + more advanced features provided in "Pipes.Core". + + @pipes@ uses type synonyms to hide unused inputs or outputs and clean up + type signatures. These type synonyms come in two flavors: + + * Concrete type synonyms that explicitly close unused inputs and outputs of + the 'Proxy' type + + * Polymorphic type synonyms that don't explicitly close unused inputs or + outputs + + The concrete type synonyms use @()@ to close unused inputs and 'X' (the + uninhabited type) to close unused outputs: + + * 'Effect': explicitly closes both ends, forbidding 'await's and 'yield's + +> type Effect = Proxy X () () X +> +> Upstream | Downstream +> +---------+ +> | | +> X <== <== () +> | | +> () ==> ==> X +> | | | +> +----|----+ +> v +> r + + * 'Producer': explicitly closes the upstream end, forbidding 'await's + +> type Producer b = Proxy X () () b +> +> Upstream | Downstream +> +---------+ +> | | +> X <== <== () +> | | +> () ==> ==> b +> | | | +> +----|----+ +> v +> r + + * 'Consumer': explicitly closes the downstream end, forbidding 'yield's + +> type Consumer a = Proxy () a () X +> +> Upstream | Downstream +> +---------+ +> | | +> () <== <== () +> | | +> a ==> ==> X +> | | | +> +----|----+ +> v +> r + + * 'Pipe': marks both ends open, allowing both 'await's and 'yield's + +> type Pipe a b = Proxy () a () b +> +> Upstream | Downstream +> +---------+ +> | | +> () <== <== () +> | | +> a ==> ==> b +> | | | +> +----|----+ +> v +> r + + When you compose 'Proxy's using ('>->') all you are doing is placing them + side by side and fusing them laterally. For example, when you compose a + 'Producer', 'Pipe', and a 'Consumer', you can think of information flowing + like this: + +> Producer Pipe Consumer +> +-----------+ +----------+ +------------+ +> | | | | | | +> X <== <== () <== <== () <== <== () +> | stdinLn | | take 3 | | stdoutLn | +> () ==> ==> String ==> ==> String ==> ==> X +> | | | | | | | | | +> +-----|-----+ +----|-----+ +------|-----+ +> v v v +> () () () + + Composition fuses away the intermediate interfaces, leaving behind an + 'Effect': + +> Effect +> +-----------------------------------+ +> | | +> X <== <== () +> | stdinLn >-> take 3 >-> stdoutLn | +> () ==> ==> X +> | | +> +----------------|------------------+ +> v +> () + + @pipes@ also provides polymorphic type synonyms with apostrophes at the end + of their names. These use universal quantification to leave open any unused + input or output ends (which I mark using @*@): + + * 'Producer'': marks the upstream end unused but still open + +> type Producer' b m r = forall x' x . Proxy x' x () b m r +> +> Upstream | Downstream +> +---------+ +> | | +> * <== <== () +> | | +> * ==> ==> b +> | | | +> +----|----+ +> v +> r + + * 'Consumer'': marks the downstream end unused but still open + +> type Consumer' a m r = forall y' y . Proxy () a y' y m r +> +> Upstream | Downstream +> +---------+ +> | | +> () <== <== * +> | | +> a ==> ==> * +> | | | +> +----|----+ +> v +> r + + * 'Effect'': marks both ends unused but still open + +> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r +> +> Upstream | Downstream +> +---------+ +> | | +> * <== <== * +> | | +> * ==> ==> * +> | | | +> +----|----+ +> v +> r + + Note that there is no polymorphic generalization of a 'Pipe'. + + Like before, if you compose a 'Producer'', a 'Pipe', and a 'Consumer'': + +> Producer' Pipe Consumer' +> +-----------+ +----------+ +------------+ +> | | | | | | +> * <== <== () <== <== () <== <== * +> | stdinLn | | take 3 | | stdoutLn | +> * ==> ==> String ==> ==> String ==> ==> * +> | | | | | | | | | +> +-----|-----+ +-----|----+ +------|-----+ +> v v v +> () () () + + ... they fuse into an 'Effect'': + +> Effect' +> +-----------------------------------+ +> | | +> * <== <== * +> | stdinLn >-> take 3 >-> stdoutLn | +> * ==> ==> * +> | | +> +----------------|------------------+ +> v +> () + + Polymorphic type synonyms come in handy when you want to keep the type as + general as possible. For example, the type signature for 'yield' uses + 'Producer'' to keep the type signature simple while still leaving the + upstream input end open: + +@ + 'yield' :: 'Monad' m => a -> 'Producer'' a m () +@ + + This type signature lets us use 'yield' within a 'Pipe', too, because the + 'Pipe' type synonym is a special case of the polymorphic 'Producer'' type + synonym: + +@ + type 'Producer'' b m r = forall x' x . 'Proxy' x' x () b m r + type 'Pipe' a b m r = 'Proxy' () a () b m r +@ + + The same is true for 'await', which uses the polymorphic 'Consumer'' type + synonym: + +@ + 'await' :: 'Monad' m => 'Consumer'' a m a +@ + + We can use 'await' within a 'Pipe' because a 'Pipe' is a special case of the + polymorphic 'Consumer'' type synonym: + +@ + type 'Consumer'' a m r = forall y' y . 'Proxy' () a y' y m r + type 'Pipe' a b m r = 'Proxy' () a () b m r +@ + + However, polymorphic type synonyms cause problems in many other cases: + + * They usually give the wrong behavior when used as the argument of a + function (known as the \"negative\" or \"contravariant\" position) like + this: + +> f :: Producer' a m r -> ... -- Wrong +> +> f :: Producer a m r -> ... -- Right + + The former function only accepts polymorphic 'Producer's as arguments. + The latter function accepts both polymorphic and concrete 'Producer's, + which is probably what you want. + + * Even when you desire a polymorphic argument, this induces a higher-ranked + type, because it translates to a @forall@ which you cannot factor out to + the top-level to simplify the type signature: + +> f :: (forall x' x y' . Proxy x' x y' m r) -> ... + + These kinds of type signatures require the @RankNTypes@ extension. + + * Even when you have polymorphic type synonyms as the result of a function + (i.e. the \"positive\" or \"covariant\" position), recent versions of + @ghc@ such still require the @RankNTypes@ extension. For example, the + 'Pipes.Prelude.fromHandle' function from "Pipes.Prelude" requires + @RankNTypes@ to compile correctly on @ghc-7.6.3@: + +> fromHandle :: MonadIO m => Handle -> Producer' String m () + + * You can't use polymorphic type synonyms inside other type constructors + without the @ImpredicativeTypes@ extension: + +> io :: IO (Producer' a m r) -- Type error without ImpredicativeTypes + + * You can't partially apply polymorphic type synonyms: + +> stack :: MaybeT (Producer' a m) r -- Type error + + In these scenarios you should fall back on the concrete type synonyms, which + are better behaved. If concrete type synonyms are unsatisfactory, then ask + @ghc@ to infer the most general type signature and use that. + + For the purposes of debugging type errors you can just remember that: + +> Input --+ +-- Output +> | | +> v v +> Proxy a' a b' b m r +> ^ ^ +> | | +> +----+-- Ignore these + + For example, let's say that you try to run the 'P.stdinLn' 'Producer'. This + produces the following type error: + +>>> runEffect P.stdinLn +<interactive>:4:5: + Couldn't match expected type `X' with actual type `String' + Expected type: Effect m0 r0 + Actual type: Proxy X () () String IO () + In the first argument of `runEffect', namely `P.stdinLn' + In the expression: runEffect P.stdinLn + + 'runEffect' expects an 'Effect', which is equivalent to the following type: + +> Effect IO () = Proxy X () () X IO () + + ... but 'P.stdinLn' type-checks as a 'Producer', which has the following + type: + +> Producer String IO () = Proxy X () () String IO () + + The fourth type variable (the output) does not match. For an 'Effect' this + type variable should be closed (i.e. 'X'), but 'P.stdinLn' has a 'String' + output, thus the type error: + +> Couldn't match expected type `X' with actual type `String' + + Any time you get type errors like these you can work through them by + expanding out the type synonyms and seeing which type variables do not + match. + + You may also consult this table of type synonyms to more easily compare + them: + +> type Effect = Proxy X () () X +> type Producer b = Proxy X () () b +> type Consumer a = Proxy () a () X +> type Pipe a b = Proxy () a () b +> +> type Server b' b = Proxy X () b' b +> type Client a' a = Proxy a' a () X +> +> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r +> type Producer' b m r = forall x' x . Proxy x' x () b m r +> type Consumer' a m r = forall y' y . Proxy () a y' y m r +> +> type Server' b' b m r = forall x' x . Proxy x' x b' b m r +> type Client' a' a m r = forall y' y . Proxy a' a y' y m r + +-} + +{- $timecomplexity + There are three functions that give quadratic time complexity when used in + within @pipes@: + + * 'sequence' + + * 'replicateM' + + * 'mapM' + + For example, the time complexity of this code segment scales quadratically + with `n`: + +> import Control.Monad (replicateM) +> import Pipes +> +> quadratic :: Int -> Consumer a m [a] +> quadratic n = replicateM n await + + These three functions are generally bad practice to use, because all three + of them correspond to \"ListT done wrong\", building a list in memory + instead of streaming results. + + However, sometimes situations arise where one deliberately intends to build + a list in memory. The solution is to use the \"codensity transformation\" + to transform the code to run with linear time complexity. This involves: + + * wrapping the code in the @Codensity@ monad transformer (from + @Control.Monad.Codensity@ module of the @kan-extensions@ package) using + 'lift' + + * applying 'sequence' \/ 'replicateM' \/ 'mapM' + + * unwrapping the code using @lowerCodensity@ + + To illustrate this, we'd transform the above example to: + +> import Control.Monad.Codensity (lowerCodensity) +> +> linear :: Monad m => Int -> Consumer a m [a] +> linear n = lowerCodensity $ replicateM n $ lift await + + This will produce the exact same result, but in linear time. +-}
tests/Main.hs view
@@ -1,272 +1,272 @@-module Main (main) where--import Data.Function (on)-import Data.List (intercalate)-import Control.Monad ((>=>))-import Control.Monad.Trans.Writer (Writer, runWriter, tell)-import Test.QuickCheck (Gen, Arbitrary(..), choose)-import Test.Framework (defaultMain, testGroup, Test)-import Test.Framework.Providers.QuickCheck2 (testProperty)--import Pipes-import Pipes.Core-import Prelude hiding (log)---main :: IO ()-main = defaultMain tests--tests :: [Test]-tests =- [ testGroup "Kleisli Category" $ testCategory (>=>) return- , testGroup "Respond Category" $ testCategory (/>/) respond- ++ [ testProperty "Distributivity" prop_respond_Distributivity- ]- , testGroup "Request Category" $ testCategory (\>\) request- ++ [ testProperty "Distributivity" prop_request_Distributivity- , testProperty "Zero Law" prop_request_ZeroLaw- ]- , testGroup "Pull Category" $ testCategory (>+>) pull- , testGroup "Push Category" $ testCategory (>~>) push- , testGroup "Push/Pull"- [ testProperty "Associativity" prop_pushPull_Associativity- ]- , testGroup "Duals"- [ testGroup "Request"- [ testProperty "Composition" prop_dual_RequestComposition- , testProperty "Identity" prop_dual_RequestIdentity- ]- , testGroup "Respond"- [ testProperty "Composition" prop_dual_RespondComposition- , testProperty "Identity" prop_dual_RespondIdentity- ]- , testProperty "Distributivity" prop_dual_ReflectDistributivity- , testProperty "Zero Law" prop_dual_ReflectZeroLaw- , testProperty "Involution" prop_dual_Involution- ]- , testGroup "Functor Laws"- [ testProperty "Identity" prop_FunctorIdentity- ]- ]--arbitraryBoundedEnum' :: (Bounded a, Enum a) => Gen a-arbitraryBoundedEnum' =- do let mn = minBound- mx = maxBound `asTypeOf` mn- n <- choose (fromEnum mn, fromEnum mx)- return (toEnum n `asTypeOf` mn)--data ClientStep- = ClientRequest- | ClientLog- | ClientInc- deriving (Enum, Bounded)--instance Arbitrary ClientStep where- arbitrary = arbitraryBoundedEnum'- shrink _ = []--instance Show ClientStep where- show x = case x of- ClientRequest -> "request"- ClientLog -> "log"- ClientInc -> "inc"--data ServerStep- = ServerRespond- | ServerLog- | ServerInc- deriving (Enum, Bounded)--instance Arbitrary ServerStep where- arbitrary = arbitraryBoundedEnum'- shrink _ = []--instance Show ServerStep where- show x = case x of- ServerRespond -> "respond"- ServerLog -> "log"- ServerInc -> "inc"--data ProxyStep- = ProxyRequest- | ProxyRespond- | ProxyLog- | ProxyInc deriving (Enum, Bounded)--instance Arbitrary ProxyStep where- arbitrary = arbitraryBoundedEnum'- shrink _ = []--instance Show ProxyStep where- show x = case x of- ProxyRequest -> "request"- ProxyRespond -> "respond"- ProxyLog -> "log"- ProxyInc -> "inc"--log :: Int -> Proxy a' a b' b (Writer [Int]) Int-log n = do- lift (tell [n])- return n--inc :: (Monad m) => Int -> Proxy a' a b' b m Int-inc n = return (n + 1)--correct :: String -> String-correct str = case str of- [] -> "return"- _ -> str--newtype AClient = AClient { unAClient :: [ClientStep] }--instance Arbitrary AClient where- arbitrary = fmap AClient arbitrary- shrink = map AClient . shrink . unAClient--instance Show AClient where- show = correct . intercalate " >=> " . map show . unAClient--aClient :: AClient -> Int -> Client Int Int (Writer [Int]) Int-aClient = foldr (>=>) return . map f . unAClient- where- f x = case x of- ClientRequest -> request- ClientLog -> log- ClientInc -> inc--newtype AServer = AServer { unAServer :: [ServerStep] }--instance Arbitrary AServer where- arbitrary = fmap AServer arbitrary- shrink = map AServer . shrink . unAServer--instance Show AServer where- show = correct . intercalate " >=> " . map show . unAServer--aServer :: AServer -> Int -> Server Int Int (Writer [Int]) Int-aServer = foldr (>=>) return . map f . unAServer- where- f x = case x of- ServerRespond -> respond- ServerLog -> log- ServerInc -> inc--newtype AProxy = AProxy { unAProxy :: [ProxyStep] }--instance Arbitrary AProxy where- arbitrary = fmap AProxy arbitrary- shrink = map AProxy . shrink . unAProxy--instance Show AProxy where- show = correct . intercalate " >=> " . map show . unAProxy--aProxy :: AProxy -> Int -> Proxy Int Int Int Int (Writer [Int]) Int-aProxy = foldr (>=>) return . map f . unAProxy- where- f x = case x of- ProxyRequest -> request- ProxyRespond -> respond- ProxyLog -> log- ProxyInc -> inc--type ProxyK = Int -> Proxy Int Int Int Int (Writer [Int]) Int-type Operation = ProxyK -> ProxyK -> ProxyK--infix 0 ===--(===) :: ProxyK -> ProxyK -> AServer -> AClient -> Bool-(===) pl pr p0 p1 =- let sv = aServer p0- cl = aClient p1- f p = runWriter (runEffect (p 0))- in on (==) f (sv >+> pl >+> cl) (sv >+> pr >+> cl)--gen_prop_RightIdentity, gen_prop_LeftIdentity- :: Operation- -> ProxyK -- right/left identity element- -> AProxy -> AServer -> AClient -> Bool-gen_prop_RightIdentity (>>>) idt f' =- let f = aProxy f'- in (f >>> idt) === f--gen_prop_LeftIdentity (>>>) idt f' =- let f = aProxy f'- in (idt >>> f) === f--gen_prop_Associativity- :: Operation- -> AProxy -> AProxy -> AProxy -> AServer -> AClient -> Bool-gen_prop_Associativity (>>>) f' g' h' =- let f = aProxy f'- g = aProxy g'- h = aProxy h'- in f >>> (g >>> h) === (f >>> g) >>> h--testCategory :: Operation -> ProxyK -> [Test]-testCategory op idt =- [ testProperty "Left Identity" $ gen_prop_LeftIdentity op idt- , testProperty "Right Identity" $ gen_prop_RightIdentity op idt- , testProperty "Associativity" $ gen_prop_Associativity op- ]---- Respond Category--prop_respond_Distributivity f' g' h' =- let f = aProxy f'- g = aProxy g'- h = aProxy h'- in (f >=> g) />/ h === (f />/ h) >=> (g />/ h)---- Request Category--prop_request_Distributivity f' g' h' =- let f = aProxy f'- g = aProxy g'- h = aProxy h'- in f \>\ (g >=> h) === (f \>\ g) >=> (f \>\ h)--prop_request_ZeroLaw f' =- let f = aProxy f'- in (f \>\ return) === return---- Push/Pull--prop_pushPull_Associativity f' g' h' =- let f = aProxy f'- g = aProxy g'- h = aProxy h'- in (f >+> g) >~> h === f >+> (g >~> h)---- Duals--prop_dual_RequestComposition f' g' =- let f = aProxy f'- g = aProxy g'- in reflect . (f \>\ g) === reflect . g />/ reflect . f--prop_dual_RequestIdentity = reflect . request === respond--prop_dual_RespondComposition f' g' =- let f = aProxy f'- g = aProxy g'- in reflect . (f />/ g) === reflect . g \>\ reflect . f--prop_dual_RespondIdentity = reflect . respond === request--prop_dual_ReflectDistributivity f' g' =- let f = aProxy f'- g = aProxy g'- in reflect . (f >=> g) === reflect . f >=> reflect . g--prop_dual_ReflectZeroLaw = reflect . return === return--prop_dual_Involution f' =- let f = aProxy f'- in (reflect . reflect) . f >=> return === f---- Functor Laws--prop_FunctorIdentity p' =- let p = aProxy p'- in fmap id p === id p+module Main (main) where + +import Data.Function (on) +import Data.List (intercalate) +import Control.Monad ((>=>)) +import Control.Monad.Trans.Writer (Writer, runWriter, tell) +import Test.QuickCheck (Gen, Arbitrary(..), choose) +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Pipes +import Pipes.Core +import Prelude hiding (log) + + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Kleisli Category" $ testCategory (>=>) return + , testGroup "Respond Category" $ testCategory (/>/) respond + ++ [ testProperty "Distributivity" prop_respond_Distributivity + ] + , testGroup "Request Category" $ testCategory (\>\) request + ++ [ testProperty "Distributivity" prop_request_Distributivity + , testProperty "Zero Law" prop_request_ZeroLaw + ] + , testGroup "Pull Category" $ testCategory (>+>) pull + , testGroup "Push Category" $ testCategory (>~>) push + , testGroup "Push/Pull" + [ testProperty "Associativity" prop_pushPull_Associativity + ] + , testGroup "Duals" + [ testGroup "Request" + [ testProperty "Composition" prop_dual_RequestComposition + , testProperty "Identity" prop_dual_RequestIdentity + ] + , testGroup "Respond" + [ testProperty "Composition" prop_dual_RespondComposition + , testProperty "Identity" prop_dual_RespondIdentity + ] + , testProperty "Distributivity" prop_dual_ReflectDistributivity + , testProperty "Zero Law" prop_dual_ReflectZeroLaw + , testProperty "Involution" prop_dual_Involution + ] + , testGroup "Functor Laws" + [ testProperty "Identity" prop_FunctorIdentity + ] + ] + +arbitraryBoundedEnum' :: (Bounded a, Enum a) => Gen a +arbitraryBoundedEnum' = + do let mn = minBound + mx = maxBound `asTypeOf` mn + n <- choose (fromEnum mn, fromEnum mx) + return (toEnum n `asTypeOf` mn) + +data ClientStep + = ClientRequest + | ClientLog + | ClientInc + deriving (Enum, Bounded) + +instance Arbitrary ClientStep where + arbitrary = arbitraryBoundedEnum' + shrink _ = [] + +instance Show ClientStep where + show x = case x of + ClientRequest -> "request" + ClientLog -> "log" + ClientInc -> "inc" + +data ServerStep + = ServerRespond + | ServerLog + | ServerInc + deriving (Enum, Bounded) + +instance Arbitrary ServerStep where + arbitrary = arbitraryBoundedEnum' + shrink _ = [] + +instance Show ServerStep where + show x = case x of + ServerRespond -> "respond" + ServerLog -> "log" + ServerInc -> "inc" + +data ProxyStep + = ProxyRequest + | ProxyRespond + | ProxyLog + | ProxyInc deriving (Enum, Bounded) + +instance Arbitrary ProxyStep where + arbitrary = arbitraryBoundedEnum' + shrink _ = [] + +instance Show ProxyStep where + show x = case x of + ProxyRequest -> "request" + ProxyRespond -> "respond" + ProxyLog -> "log" + ProxyInc -> "inc" + +log :: Int -> Proxy a' a b' b (Writer [Int]) Int +log n = do + lift (tell [n]) + return n + +inc :: (Monad m) => Int -> Proxy a' a b' b m Int +inc n = return (n + 1) + +correct :: String -> String +correct str = case str of + [] -> "return" + _ -> str + +newtype AClient = AClient { unAClient :: [ClientStep] } + +instance Arbitrary AClient where + arbitrary = fmap AClient arbitrary + shrink = map AClient . shrink . unAClient + +instance Show AClient where + show = correct . intercalate " >=> " . map show . unAClient + +aClient :: AClient -> Int -> Client Int Int (Writer [Int]) Int +aClient = foldr (>=>) return . map f . unAClient + where + f x = case x of + ClientRequest -> request + ClientLog -> log + ClientInc -> inc + +newtype AServer = AServer { unAServer :: [ServerStep] } + +instance Arbitrary AServer where + arbitrary = fmap AServer arbitrary + shrink = map AServer . shrink . unAServer + +instance Show AServer where + show = correct . intercalate " >=> " . map show . unAServer + +aServer :: AServer -> Int -> Server Int Int (Writer [Int]) Int +aServer = foldr (>=>) return . map f . unAServer + where + f x = case x of + ServerRespond -> respond + ServerLog -> log + ServerInc -> inc + +newtype AProxy = AProxy { unAProxy :: [ProxyStep] } + +instance Arbitrary AProxy where + arbitrary = fmap AProxy arbitrary + shrink = map AProxy . shrink . unAProxy + +instance Show AProxy where + show = correct . intercalate " >=> " . map show . unAProxy + +aProxy :: AProxy -> Int -> Proxy Int Int Int Int (Writer [Int]) Int +aProxy = foldr (>=>) return . map f . unAProxy + where + f x = case x of + ProxyRequest -> request + ProxyRespond -> respond + ProxyLog -> log + ProxyInc -> inc + +type ProxyK = Int -> Proxy Int Int Int Int (Writer [Int]) Int +type Operation = ProxyK -> ProxyK -> ProxyK + +infix 0 === + +(===) :: ProxyK -> ProxyK -> AServer -> AClient -> Bool +(===) pl pr p0 p1 = + let sv = aServer p0 + cl = aClient p1 + f p = runWriter (runEffect (p 0)) + in on (==) f (sv >+> pl >+> cl) (sv >+> pr >+> cl) + +gen_prop_RightIdentity, gen_prop_LeftIdentity + :: Operation + -> ProxyK -- right/left identity element + -> AProxy -> AServer -> AClient -> Bool +gen_prop_RightIdentity (>>>) idt f' = + let f = aProxy f' + in (f >>> idt) === f + +gen_prop_LeftIdentity (>>>) idt f' = + let f = aProxy f' + in (idt >>> f) === f + +gen_prop_Associativity + :: Operation + -> AProxy -> AProxy -> AProxy -> AServer -> AClient -> Bool +gen_prop_Associativity (>>>) f' g' h' = + let f = aProxy f' + g = aProxy g' + h = aProxy h' + in f >>> (g >>> h) === (f >>> g) >>> h + +testCategory :: Operation -> ProxyK -> [Test] +testCategory op idt = + [ testProperty "Left Identity" $ gen_prop_LeftIdentity op idt + , testProperty "Right Identity" $ gen_prop_RightIdentity op idt + , testProperty "Associativity" $ gen_prop_Associativity op + ] + +-- Respond Category + +prop_respond_Distributivity f' g' h' = + let f = aProxy f' + g = aProxy g' + h = aProxy h' + in (f >=> g) />/ h === (f />/ h) >=> (g />/ h) + +-- Request Category + +prop_request_Distributivity f' g' h' = + let f = aProxy f' + g = aProxy g' + h = aProxy h' + in f \>\ (g >=> h) === (f \>\ g) >=> (f \>\ h) + +prop_request_ZeroLaw f' = + let f = aProxy f' + in (f \>\ return) === return + +-- Push/Pull + +prop_pushPull_Associativity f' g' h' = + let f = aProxy f' + g = aProxy g' + h = aProxy h' + in (f >+> g) >~> h === f >+> (g >~> h) + +-- Duals + +prop_dual_RequestComposition f' g' = + let f = aProxy f' + g = aProxy g' + in reflect . (f \>\ g) === reflect . g />/ reflect . f + +prop_dual_RequestIdentity = reflect . request === respond + +prop_dual_RespondComposition f' g' = + let f = aProxy f' + g = aProxy g' + in reflect . (f />/ g) === reflect . g \>\ reflect . f + +prop_dual_RespondIdentity = reflect . respond === request + +prop_dual_ReflectDistributivity f' g' = + let f = aProxy f' + g = aProxy g' + in reflect . (f >=> g) === reflect . f >=> reflect . g + +prop_dual_ReflectZeroLaw = reflect . return === return + +prop_dual_Involution f' = + let f = aProxy f' + in (reflect . reflect) . f >=> return === f + +-- Functor Laws + +prop_FunctorIdentity p' = + let p = aProxy p' + in fmap id p === id p