diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/LiftBench.hs b/benchmarks/LiftBench.hs --- a/benchmarks/LiftBench.hs +++ b/benchmarks/LiftBench.hs @@ -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) + ] + ] diff --git a/benchmarks/PreludeBench.hs b/benchmarks/PreludeBench.hs --- a/benchmarks/PreludeBench.hs +++ b/benchmarks/PreludeBench.hs @@ -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] + ] + ] diff --git a/pipes.cabal b/pipes.cabal --- a/pipes.cabal +++ b/pipes.cabal @@ -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 diff --git a/src/Pipes.hs b/src/Pipes.hs --- a/src/Pipes.hs +++ b/src/Pipes.hs @@ -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) +-} diff --git a/src/Pipes/Core.hs b/src/Pipes/Core.hs --- a/src/Pipes/Core.hs +++ b/src/Pipes/Core.hs @@ -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 - , (\<\) - , (/ ==> 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 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 '/\' 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 -(/ (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 /\ p1 -{-# INLINABLE (/~>') 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 + , (\<\) + , (/ ==> 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 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 '/\' 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 +(/ (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 /\ p1 +{-# INLINABLE (/~>') 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 + + #-} diff --git a/src/Pipes/Internal.hs b/src/Pipes/Internal.hs --- a/src/Pipes/Internal.hs +++ b/src/Pipes/Internal.hs @@ -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 #-} diff --git a/src/Pipes/Lift.hs b/src/Pipes/Lift.hs --- a/src/Pipes/Lift.hs +++ b/src/Pipes/Lift.hs @@ -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 -42 -1 -1 -0 -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 -Zero is forbidden -42 -42 -0 -Zero is forbidden -1 -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 +42 +1 +1 +0 +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 +Zero is forbidden +42 +42 +0 +Zero is forbidden +1 +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. +-} diff --git a/src/Pipes/Prelude.hs b/src/Pipes/Prelude.hs --- a/src/Pipes/Prelude.hs +++ b/src/Pipes/Prelude.hs @@ -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 -Test -ABC -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 -Test -ABC -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 -Test -ABC -ABC -quit ->>> - --} - --- | 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 -ABC - -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 +Test +ABC +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 +Test +ABC +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 +Test +ABC +ABC +quit +>>> + +-} + +{-| 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 = 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 +ABC + +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 #-} diff --git a/src/Pipes/Tutorial.hs b/src/Pipes/Tutorial.hs --- a/src/Pipes/Tutorial.hs +++ b/src/Pipes/Tutorial.hs @@ -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 -> Test -> ABC -> ABC -> -> $ - - 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 -> Test -> Test -> ABC -> ABC -> ABC -> -> $ - - 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 -Test -ABC -ABC -42 -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 -ing -Testing -ABC -DEF -ABCDEF -42 -000 -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 -> Test -> ABC -> ABC -> 42 -> 42 -> -> $ - - ('>->') 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 -> Test -> -> End of input! -> $ ./echo3 | perl -e 'close STDIN' -> Test -> 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 -Test -ABC -ABC -42 -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 - - - 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 - - - ('>->') 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 - - - 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 -Fischer -Daniel Fischer -Wagner -Daniel Wagner -quit -Donald -Stewart -Donald Stewart -Duck -Donald Duck -quit -quit ->>> - - 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 -Test ->>> runEffect $ every input >-> P.stdoutLn -Fail ->>> - --} - -{- $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: - - - - ... or you can mail the list directly at: - - - - 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 -: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 +> Test +> ABC +> ABC +> +> $ + + 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 +> Test +> Test +> ABC +> ABC +> ABC +> +> $ + + 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 +Test +ABC +ABC +42 +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 +ing +Testing +ABC +DEF +ABCDEF +42 +000 +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 +> Test +> ABC +> ABC +> 42 +> 42 +> +> $ + + ('>->') 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 +> Test +> +> End of input! +> $ ./echo3 | perl -e 'close STDIN' +> Test +> 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 +Test +ABC +ABC +42 +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 + + + 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 + + + ('>->') 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 + + + 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 +Fischer +Daniel Fischer +Wagner +Daniel Wagner +quit +Donald +Stewart +Donald Stewart +Duck +Donald Duck +quit +quit +>>> + + 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 +Test +>>> runEffect $ every input >-> P.stdoutLn +Fail +>>> + +-} + +{- $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: + + + + ... or you can mail the list directly at: + + + + 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 +: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. +-} diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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