diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,173 @@ +4.3.16 + +* Fix example code for `every` +* Improved documentation for `ListT` + +4.3.15 + +* Build against `ghc-9.0` + +4.3.14 + +* Add `mapMaybe` and `wither`, and more laws for `filter` and `filterM`. + +4.3.13 + +* Add `MonadFail` instance for `Proxy` + +4.3.12 + +* Fix space leak introduced in version 4.3.10 + * This leak primarily affects the use of `forever` + +4.3.11 + +* Fix documentation for `scanM` + +4.3.10 + +* Relax `Monad` constraints to `Functor` +* Support GHC 8.8 + +4.3.9 + +* Increase upper bound on `exceptions` + +4.3.8 + +* Increase upper bound on `exceptions` + +4.3.7 + +* Documentation fix + +4.3.6 + +* Fix implementation of `pass` in `MonadWriter` instance for `Proxy` + +4.3.5 + +* Support `Semigroup` being a super-class of `Monoid` + +4.3.4 + +* Increase upper bound on `mmorph` + +4.3.3 + +* Make `X` a synonym for `Data.Void.Void` + +4.3.2 + +* BUG FIX: Fix `MMonad` instance for `ListT` + * The old instance was an infinite loop + +4.3.1 + +* Support building against `ghc-7.4` + +4.3.0 + +* BREAKING CHANGE: Remove `Alternative`/`MonadPlus` instances for `Proxy` + * See commit 08e7302f43dbf2a40bd367c5ee73ee3367e17768 which explains why +* Add `Traversable` instance for `ListT` +* New `MonadThrow`/`MonadCatch`/`MMonad`/`Semigroup`/`MonadZip` instances for + `ListT` +* New `MonadThrow`/`MonadCatch` instances for `Proxy` +* Fix lower bound on `mtl` +* Increase upper bound on `optparse-applicative` + +4.2.0 + +* BREAKING CHANGE: Switch from `ErrorT` to `ExceptT` +* Add `Foldable` instance for `ListT` +* Fix all warnings +* Enable foldr/build fusion for `toList` + +4.1.9 + +* Increase lower bound on `criterion` +* Increase upper bound on `transformers` for tests/benchmarks +* Optimize code by delaying `INLINABLE` annotations + +4.1.8 + +* Increase upper bound on `transformers` +* Prepare for MRP (Monad of no Return Proposal) + +4.1.7 + +* Increase lower bound on `deepseq` +* Add `unfoldr` +* Add `loop` +* Add `toListM'` +* Improve efficiency of `drop` +* License tutorial under Creative Commons license + +4.1.6 + +* Increase lower bound on `base` +* Add diagrams to `Pipes.Core` documentation +* Add `mapM_` +* Add `takeWhile'` +* Add `seq` +* Improve efficiency of `toListM` + +4.1.5 + +* Increase upper bound on `criterion` + +4.1.4 + +* Increase upper bound on `criterion` +* Add `Monoid` instance for `Proxy` + +4.1.3 + +* Increase lower bound on `mtl` +* Re-export `void` +* Add `fold'` +* Add `foldM'` + +4.1.2 + +* Increase upper bounds on `transformers` and `mtl` + +4.1.1 + +* Add `runListT` +* Add `MMonad` instance for `Proxy` +* Add `repeatM` +* Add laws to documentation of `Pipes.Prelude` utilities + +4.1.0 + +* Remove Haskell98 support +* Use internal `X` type instead of `Data.Void` +* Document `Pipes.Lift` module:w +* Add `drain` +* Add `sequence` + +4.0.2 + +* Improve performance of `each` +* Add tutorial appendix explaining how to work around quadratic time complexity + +4.0.1 + +* Remove `WriterT` and `RWST` benchmarks +* Add `Enumerable` instance for `ErrorT` +* Add cabal flag for Haskell98 compilation +* Add several rewrite rules +* Add `mtl` instances for `ListT` +* Fix implementation of `pass`, which did not satisfy `Writer` laws +* Implement `fail` for `ListT` +* Add type synonym table to tutorial appendix +* Add QuickCheck tests for `pipes` laws +* Add `mapFoldable` +* Add `Monoid` instance for `ListT` +* Add manual proofs of `pipes` laws in `laws.md` + +4.0.0 + +Major upgrade of `pipes` to no longer use `Proxy` type class diff --git a/Control/MFunctor.hs b/Control/MFunctor.hs deleted file mode 100644 --- a/Control/MFunctor.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | This module temporarily holds this class until it can find a better home. - -{-# LANGUAGE Rank2Types #-} - -module Control.MFunctor ( - -- * Functors over Monads - MFunctor(..), - raise - ) where - -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.Identity (IdentityT, mapIdentityT) -import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) -import Control.Monad.Trans.Reader (ReaderT, mapReaderT) -import Control.Monad.Trans.RWS (RWST, mapRWST) -import qualified Control.Monad.Trans.State.Strict as StateStrict -import qualified Control.Monad.Trans.State.Lazy as StateLazy -import qualified Control.Monad.Trans.Writer.Strict as WriterStrict -import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy - --- | A functor in the category of monads -class MFunctor t where - {-| Lift a monad morphism from @m@ to @n@ into a monad morphism from - @(t m)@ to @(t n)@ -} - hoist :: (Monad m) => (forall a . m a -> n a) -> t m b -> t n b - -instance MFunctor IdentityT where - hoist nat = mapIdentityT nat - -instance MFunctor MaybeT where - hoist nat = mapMaybeT nat - -instance MFunctor (ReaderT r) where - hoist nat = mapReaderT nat - -instance MFunctor (RWST r w s) where - hoist nat = mapRWST nat - -instance MFunctor (StateStrict.StateT s) where - hoist nat = StateStrict.mapStateT nat - -instance MFunctor (StateLazy.StateT s) where - hoist nat = StateLazy.mapStateT nat - -instance MFunctor (WriterStrict.WriterT w) where - hoist nat = WriterStrict.mapWriterT nat - -instance MFunctor (WriterLazy.WriterT w) where - hoist nat = WriterLazy.mapWriterT nat - -{-| Lift the base monad - -> raise = hoist lift --} -raise :: (Monad m, MFunctor t1, MonadTrans t2) => t1 m r -> t1 (t2 m) r -raise = hoist lift diff --git a/Control/PFunctor.hs b/Control/PFunctor.hs deleted file mode 100644 --- a/Control/PFunctor.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | This module defines functors in the category of proxies - -{-# LANGUAGE KindSignatures, Rank2Types #-} - -module Control.PFunctor ( - -- * Functors over Proxies - PFunctor(..), - raiseP - ) where - -import Control.Proxy.Class (Proxy) -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | A functor in the category of monads -class PFunctor ( - t :: (* -> * -> * -> * -> (* -> *) -> * -> *) - -> * -> * -> * -> * -> (* -> *) -> * -> * ) where - {-| Lift a proxy morphism from @p@ to @q@ into a proxy morphism from - @(t p)@ to @(t q)@ -} - hoistP - :: (Monad m, Proxy p) - => (forall a' a b' b r1 . p a' a b' b m r1 -> q a' a b' b m r1) - -> (t p a' a b' b m r2 -> t q a' a b' b m r2) - -{-| Lift the base proxy - -> raiseP = hoistP liftP --} -raiseP - :: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2) - => t1 p a' a b' b m r -> t1 (t2 p) a' a b' b m r -raiseP = hoistP liftP diff --git a/Control/Pipe.hs b/Control/Pipe.hs deleted file mode 100644 --- a/Control/Pipe.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-| This module remains as a wistful reminder of this library's humble origins. - This library now builds upon the more general 'Proxy' type, but still keeps - the @pipes@ name. Read "Control.Proxy.Tutorial" to learn about this new - implementation. - - The 'Pipe' type is a monad transformer that enriches the base monad with the - ability to 'await' or 'yield' data to and from other 'Pipe's. -} - -module Control.Pipe ( - -- * Types - -- $types - Pipe(..), - Producer, - Consumer, - Pipeline, - -- * Create Pipes - -- $create - await, - yield, - pipe, - -- * Compose Pipes - -- $category - (<+<), - (>+>), - idP, - PipeC(..), - -- * Run Pipes - runPipe - ) where - -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Category (Category((.), id), (<<<), (>>>)) -import Control.Monad (forever) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Synonym (C) -import Prelude hiding ((.), id) - -{- $types - The 'Pipe' type is strongly inspired by Mario Blazevic's @Coroutine@ type in - his concurrency article from Issue 19 of The Monad Reader. --} - -{-| - The base type for pipes - - * @a@ - The type of input received from upstream pipes - - * @b@ - The type of output delivered to downstream pipes - - * @m@ - The base monad - - * @r@ - The type of the return value --} -data Pipe a b m r - = Await (a -> Pipe a b m r) - | Yield b (Pipe a b m r) - | M (m (Pipe a b m r)) - | Pure r -{- -Technically, the correct implementation that satisfies the monad transformer -laws is: - -type PipeF a b x = Await (a -> x) | Yield b x deriving (Functor) - -type Pipe a b = FreeT (PipeF a b) --} - -instance (Monad m) => Functor (Pipe a b m) where - fmap f pr = go pr where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure r -> Pure (f r) - -instance (Monad m) => Applicative (Pipe a b m) where - pure = Pure - pf <*> px = go pf where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure f -> fmap f px - -instance (Monad m) => Monad (Pipe a b m) where - return = Pure - pm >>= f = go pm where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure r -> f r - -instance MonadTrans (Pipe a b) where - lift m = M (m >>= \r -> return (Pure r)) - --- | A pipe that produces values -type Producer b m r = Pipe () b m r - --- | A pipe that consumes values -type Consumer a m r = Pipe a C m r - --- | A self-contained pipeline that is ready to be run -type Pipeline m r = Pipe () C m r - -{- $create - 'yield' and 'await' are the only two primitives you need to create pipes. - Since @Pipe a b m@ is a monad, you can assemble 'yield' and 'await' - statements using ordinary @do@ notation. Since @Pipe a b@ is also a monad - transformer, you can use 'lift' to invoke the base monad. For example, you - could write a pipe stage that requests permission before forwarding any - output: - -> check :: (Show a) => Pipe a a IO r -> check = forever $ do -> x <- await -> lift $ putStrLn $ "Can '" ++ (show x) ++ "' pass?" -> ok <- read <$> lift getLine -> when ok (yield x) --} - -{-| - Wait for input from upstream. - - 'await' blocks until input is available from upstream. --} -await :: Pipe a b m a -await = Await Pure - -{-| - Deliver output downstream. - - 'yield' restores control back upstream and binds its value to 'await'. --} -yield :: b -> Pipe a b m () -yield b = Yield b (Pure ()) - -{-| - Convert a pure function into a pipe - -> pipe f = forever $ do -> x <- await -> yield (f x) --} -pipe :: (Monad m) => (a -> b) -> Pipe a b m r -pipe f = go where - go = Await (\a -> Yield (f a) go) - -{- $category - 'Pipe's form a 'Category', meaning that you can compose 'Pipe's using - ('>+>') and also define an identity 'Pipe': 'idP'. These satisfy the - category laws: - -> idP >+> p = p -> -> p >+> idP = p -> -> (p1 >+> p2) >+> p3 = p1 >+> (p2 >+> p3) - - @(p1 >+> p2)@ satisfies all 'await's in @p2@ with 'yield's in @p1@. If any - 'Pipe' terminates the entire 'Pipeline' terminates. --} - --- | 'Pipe's form a 'Category' instance when you rearrange the type variables -newtype PipeC m r a b = PipeC { unPipeC :: Pipe a b m r} - -instance (Monad m) => Category (PipeC m r) where - id = PipeC idP - PipeC p1 . PipeC p2 = PipeC $ p1 <+< p2 - --- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<+<) :: (Monad m) => Pipe b c m r -> Pipe a b m r -> Pipe a c m r -(Yield b p1) <+< p2 = Yield b (p1 <+< p2) -(M m ) <+< p2 = M (m >>= \p1 -> return (p1 <+< p2)) -(Pure r ) <+< _ = Pure r -(Await k ) <+< (Yield b p2) = k b <+< p2 -p1 <+< (Await k) = Await (\a -> p1 <+< k a) -p1 <+< (M m) = M (m >>= \p2 -> return (p1 <+< p2)) -_ <+< (Pure r) = Pure r - --- | Corresponds to ('>>>') from @Control.Category@ -(>+>) :: (Monad m) => Pipe a b m r -> Pipe b c m r -> Pipe a c m r -p2 >+> p1 = p1 <+< p2 - -infixr 8 <+< -infixl 8 >+> - --- | Corresponds to 'id' from @Control.Category@ -idP :: (Monad m) => Pipe a a m r -idP = go where - go = Await (\a -> Yield a go) - --- | Run the 'Pipe' monad transformer, converting it back into the base monad -runPipe :: (Monad m) => Pipe () b m r -> m r -runPipe pl = go pl where - go p = case p of - Yield _ p' -> go p' - Await k -> go (k ()) - M m -> m >>= go - Pure r -> return r diff --git a/Control/Proxy.hs b/Control/Proxy.hs deleted file mode 100644 --- a/Control/Proxy.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| Recommended entry import for this library - - Read "Control.Proxy.Tutorial" for an extended proxy tutorial. -} - -module Control.Proxy ( - -- * Modules - -- $default - module Control.Proxy.Core, - module Control.Proxy.Core.Fast - ) where - -import Control.Proxy.Core -import Control.Proxy.Core.Fast hiding (Request, Respond, M, Pure) - -{- $default - "Control.Proxy.Core" exports everything except 'runProxy'. - - This library provides two base proxy implementations, each of which export - their own 'runProxy' function: - - * "Control.Proxy.Core.Fast": This runs faster for code that is not - 'IO'-bound, but it only obeys the monad transformer laws modulo safe - observation functions. - - * "Control.Proxy.Core.Correct": This trades speed on pure code segments, but - strictly preserves the monad transformer laws. - - This module selects the currently recommended implementation (Fast). - - You can switch to the correct implementation by importing - "Control.Proxy.Core" and "Control.Proxy.Core.Correct". - - You can lock in the fast implementation (in case I change the recommended - default) by importing "Control.Proxy.Core" and "Control.Proxy.Core.Fast". --} diff --git a/Control/Proxy/Class.hs b/Control/Proxy/Class.hs deleted file mode 100644 --- a/Control/Proxy/Class.hs +++ /dev/null @@ -1,452 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - -{-| The 'Proxy' class defines the library's core API. Everything else in this - library builds exclusively on top of the 'Proxy' type class so that all - proxy implementations and extensions can share the same standard library. - - Several of these type classes duplicate methods from familiar type-classes - (such as ('?>=') duplicating ('>>=')). You do NOT need to use these - duplicate methods. Instead, read the \"Polymorphic proxies\" section below - which explains their purpose and how they help clean up type signatures. -} - -module Control.Proxy.Class ( - -- * Core proxy class - Proxy(..), - idT, - coidT, - (<-<), - (<~<), - - -- * request/respond substitution - Interact(..), - (/ lift . k >-> p -> -> hoist f . k >-> p --} -infixr 7 <-< -infixl 7 >-> -infixr 8 /\ -infixl 8 \<\ -infixr 8 />/ -infixl 1 ?>= -- This should match the fixity of >>= - -{-| The core API for the @pipes@ library - - You should only use 'request', 'respond', and ('>->') - - I only provide ('>~>') for theoretical symmetry, and the remaining methods - just implement internal type class plumbing. --} -class Proxy p where - {-| 'request' input from upstream, passing an argument with the request - - @request a'@ passes @a'@ as a parameter to upstream that upstream may - use to decide what response to return. 'request' binds the upstream's - response of type @a@ to its own return value. -} - request :: (Monad m) => a' -> p a' a b' b m a - - {-| 'respond' with an output for downstream and bind downstream's next - 'request' - - @respond b@ satisfies a downstream 'request' by supplying the value @b@. - 'respond' blocks until downstream 'request's a new value and binds the - argument of type @b'@ from the next 'request' as its return value. -} - respond :: (Monad m) => b -> p a' a b' b m b' - - {-| Compose two proxies blocked on a 'respond', generating a new proxy - blocked on a 'respond' - - Begins from the downstream end and satisfies every 'request' with a - 'respond' -} - (>->) - :: (Monad m) - => (b' -> p a' a b' b m r) - -> (c' -> p b' b c' c m r) - -> (c' -> p a' a c' c m r) - - {-| Compose two proxies blocked on a 'request', generating a new proxy - blocked on a 'request' - - Begins from the upstream end and satisfies every 'respond' with a - 'request' -} - (>~>) - :: (Monad m) - => (a -> p a' a b' b m r) - -> (b -> p b' b c' c m r) - -> (a -> p a' a c' c m r) - - {-| 'return_P' is identical to 'return', except with a more polymorphic - constraint. -} - return_P :: (Monad m) => r -> p a' a b' b m r - - {-| ('?>=') is identical to ('>>='), except with a more polymorphic - constraint. -} - (?>=) - :: (Monad m) - => p a' a b' b m r -> (r -> p a' a b' b m r') -> p a' a b' b m r' - - {-| 'lift_P' is identical to 'lift', except with a more polymorphic - constraint. -} - lift_P :: (Monad m) => m r -> p a' a b' b m r - - {-| 'hoist_P' is identical to 'hoist', except with a more polymorphic - constraint. -} - hoist_P - :: (Monad m) - => (forall r . m r -> n r) -> (p a' a b' b m r' -> p a' a b' b n r') - -{-| 'idT' forwards requests followed by responses - -> idT = request >=> respond >=> idT --} -idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r -idT = go where - go a' = - request a' ?>= \a -> - respond a ?>= \a'2 -> - go a'2 --- idT = foreverK $ request >=> respond - -{-| 'coidT' forwards responses followed by requests - -> coidT = respond >=> request >=> coidT --} -coidT :: (Monad m, Proxy p) => a -> p a' a a' a m r -coidT = go where - go a = - respond a ?>= \a' -> - request a' ?>= \a2 -> - go a2 --- coidT = foreverK $ respond >=> request - -{-| Compose two proxies blocked on a 'respond', generating a new proxy blocked - on a 'respond' - - Begins from the downstream end and satisfies every 'request' with a - 'respond' -} -(<-<) - :: (Monad m, Proxy p) - => (c' -> p b' b c' c m r) - -> (b' -> p a' a b' b m r) - -> (c' -> p a' a c' c m r) -p1 <-< p2 = p2 >-> p1 - -{-| Compose two proxies blocked on a 'request', generating a new proxy blocked - on a 'request' - - Begins from the upstream end and satisfies every 'respond' with a 'request' - - You don't need to use this. I include it only for symmetry. -} -(<~<) - :: (Monad m, Proxy p) - => (b -> p b' b c' c m r) - -> (a -> p a' a b' b m r) - -> (a -> p a' a c' c m r) -p1 <~< p2 = p2 >~> p1 - --- | Two extra Proxy categories of theoretical interest -class Interact p where - -- | @f \\>\\ g@ replaces all 'request's in 'g' with 'f'. - (\>\) :: (Monad m) - => (b' -> p a' a x' x m b) - -> (c' -> p b' b x' x m c) - -> (c' -> p a' a x' x m c) - - -- | @f \/>\/ g@ replaces all 'respond's in 'f' with 'g'. - (/>/) :: (Monad m) - => (a -> p x' x b' b m a') - -> (b -> p x' x c' c m b') - -> (a -> p x' x c' c m a') - --- | @f \/<\/ g@ replaces all 'request's in 'f' with 'g'. -(/ (c' -> p b' b x' x m c) - -> (b' -> p a' a x' x m b) - -> (c' -> p a' a x' x m c) -p1 /\ p1 - --- | @f \\<\\ g@ replaces all 'respond's in 'g' with 'f'. -(\<\) :: (Monad m, Interact p) - => (b -> p x' x c' c m b') - -> (a -> p x' x b' b m a') - -> (a -> p x' x c' c m a') -p1 \<\ p2 = p2 />/ p1 - -{- $laws - The 'Proxy' class defines an interface to all core proxy capabilities that - all proxy-like types must implement. - - First, all proxies must support a bidirectional flow of information, defined - by: - - * ('>->') - - * ('>~>') - - * 'request' - - * 'respond' - - Intuitively, both @p1 >-> p2@ and @p1 >~> p2@ pair each 'request' in @p2@ - with a 'respond' in @p1@. ('>->') accepts proxies blocked on 'respond' and - begins from the downstream end, whereas ('>~>') accepts proxies blocked on - 'request' and begins from the upstream end. - - Second, all proxies are monads, defined by: - - * 'return_P' - - * ('?>=') - - These must satify the monad laws using @(>>=) = (?>=)@ and - @return = return_P@. - - Third, all proxies are monad transformers, defined by: - - * 'lift_P' - - This must satisfy the monad transformer laws, using @lift = lift_P@. - - Fourth, all proxies are functors in the category of monads, defined by: - - * 'hoist_P' - - This must satisfy the functor laws, using @hoist = hoist_P@. - - All 'Proxy' instances must satisfy these additional laws: - - * ('>->') and 'idT' form a category: - -> Define: idT = request >=> respond >=> idT -> -> idT >-> p = p -> -> p >-> idT = p -> -> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) - - * ('>~>') and 'coidT' form a category: - -> Define: coidT = respond >=> request >=> coidT -> -> coidT >~> p = p -> -> p >~> coidT = p -> -> (p1 >~> p2) >~> p3 = p1 >~> (p2 >~> p3) - - * @(hoistK f)@ defines a functor between proxy categories: - -> Define: hoistK f = (hoist f .) -> -> hoistK f (p1 >-> p2) = hoistK f p1 >-> hoistK p2 -> -> hoistK f idT = idT -> -> hoistK f (p1 >~> p2) = hoistK f p1 >~> hoistK p2 -> -> hoistK f coidT = coidT - - Also, all proxies must satisfy the following 'Proxy' laws: - -> -- Define: liftK = (lift .) -> -> p1 >-> liftK f = liftK f -> -> p1 >-> (liftK f >=> respond >=> p2) = liftK f >=> respond >=> (p1 >-> p2) -> -> (liftK g >=> respond >=> p1) >-> (liftK f >=> request >=> liftK h >=> p2) -> = liftK (f >=> g >=> h) >=> (p1 >-> p2) -> -> (liftK g >=> request >=> p1) >-> (liftK f >=> request >=> p2) -> = liftK (f >=> g) >=> request >=> (p1 >~> p2) -> -> liftK f >~> p2 = liftK f -> -> (liftK f >=> request >=> p1) >~> p2 = liftK f >=> request >=> (p1 >~> p2) -> -> (liftK f >=> respond >=> liftK h >=> p1) >~> (liftK g >=> request >=> p2) -> = liftK (f >=> g >=> h) >=> (p1 >~> p2) -> -> (liftK f >=> respond >=> p1) >~> (liftK g >=> respond >=> p2) -> = liftK (f >=> g) >=> (p1 >-> p2) - - The 'Interact' class exists primarily for theoretical interest and to - justify some of the functor laws for the 'ProxyTrans' type class. You will - probably never use it. - - The 'Interact' class defines the ability to: - - * Replace existing 'request' commands using ('\>\') - - * Replace existing 'respond' commands using ('/>/') - - Laws: - - * ('\>\') and 'request' form a category: - -> request \>\ f = f -> -> f \>\ request = f -> -> (f \>\ g) \>\ h = f \>\ (g \>\ h) - - * ('/>/') and 'respond' form a category: - -> respond />/ f = f -> -> f />/ respond = f -> -> (f />/ g) />/ h = f />/ (g />/ h) - - Additionally, ('\>\') and ('/>/') distribute in one direction over Kleisli - composition: - -> a \>\ (b >=> c) = (a \>\ b) >=> (a \>\ c) -> -> a \>\ return = return - -> (b >=> c) />/ a = (b />/ a) >=> (c />/ a) -> -> return />/ a = return --} - -{- $poly - Many of these type classes contain methods which copy methods from more - familiar type classes. These duplicate methods serve two purposes. - - First, this library requires type class instances that would otherwise be - impossible to define without providing higher-kinded constraints. Rather - than use the following illegal polymorphic constraint: - -> instance (forall a' a b' b . MonadTrans (p a' a b' b)) => ... - - ... the instance can instead use the following Haskell98 constraint: - -> instance (MonadTransP p) => ... - - Second, these type classes don't require the @FlexibleContexts@ extension - to use and substantially clean up constraints in type signatures. They - convert messy constraints like this: - -> p :: (MonadP (p a' a b' b m), MonadTrans (p a' a b' b)) => ... - - .. into cleaner and more general constraints like this: - -> P :: (Proxy p) => ... - - These type classes exist solely for internal plumbing and you should never - directly use the duplicate methods from them. Instead, you can use all the - original type classes as long as you embed your proxy code within at least - one proxy transformer (or 'IdentityP' if don't use any transformers). The - type-class machinery will then automatically convert the messier and less - polymorphic constraints to the simpler and more general constraints. - - For example, consider the following almost-correct definition for @mapMD@ - (from "Control.Proxy.Prelude.Base"): - -> import Control.Monad.Trans.Class -> import Control.Proxy -> -> mapMD f = foreverK $ \a' -> do -> a <- request a' -> b <- lift (f a) -> respond b - - The compiler infers the following messy constraint: - -> mapMD -> :: (Monad m, Monad (p x a x b m), MonadTrans (p x a x b), Proxy p) -> => (a -> m b) -> x -> p x a x b m r - - Instead, you can embed the code in the @IdentityP@ proxy transformer by - wrapping it in 'runIdentityK': - -> -- |difference| -> mapMD f = runIdentityK $ foreverK $ \a' -> do -> a <- request a' -> b <- lift (f a) -> respond b - - ... and now the compiler collapses all the constraints into the 'Proxy' - constraint: - -> mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r - - You do not incur any performance penalty for writing polymorphic code or - embedding it in 'IdentityP'. This library employs several rewrite @RULES@ - which transform your polymorphic code into the equivalent type-specialized - hand-tuned code. These rewrite rules fire very robustly and they do not - require any assistance on your part from compiler pragmas like @INLINE@, - @NOINLINE@ or @SPECIALIZE@. - - If you nest proxies within proxies: - -> example () = do -> request () -> lift $ request () -> lift $ lift $ request () - - ... then you can still keep the nice constraints using: - -> example () = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ do -> request () -> lift $ request () -> lift $ lift $ request () - - You don't need to use 'runIdentityP' \/ 'runIdentityK' if you use any other - proxy transformers (In fact you can't, it's a type error). The following - code example illustrates this, where the 'throw' command (from the 'EitherP' - proxy transformer) suffices to guide the compiler to the cleaner type - signature: - -> import Control.Monad -> import Control.Proxy -> import qualified Control.Proxy.Trans.Either as E -> -> example :: (Monad m, Proxy p) => () -> Producer (EitherP String p) Char m () -> example () = do -> c <- request () -> when (c == ' ') $ E.throw "Error: received space" -> respond c --} - -{-| The @(MonadPlusP p)@ constraint is equivalent to the following constraint: - -> (forall a' a b' b m . (Monad m) => MonadPlus (p a' a b' b m)) => ... --} -class (Proxy p) => MonadPlusP p where - mzero_P :: (Monad m) => p a' a b' b m r - mplus_P - :: (Monad m) => p a' a b' b m r -> p a' a b' b m r -> p a' a b' b m r - -{-| The @(MonadIOP p)@ constraint is equivalent to the following constraint: - -> (forall a' a b' b m . (MonadIO m) => MonadIO (p a' a b' b m)) => ... --} -class (Proxy p) => MonadIOP p where - liftIO_P :: (MonadIO m) => IO r -> p a' a b' b m r diff --git a/Control/Proxy/Core.hs b/Control/Proxy/Core.hs deleted file mode 100644 --- a/Control/Proxy/Core.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | Default imports for the "Control.Proxy" hierarchy - -module Control.Proxy.Core ( - -- * Modules - -- $modules - module Control.Proxy.Class, - module Control.Proxy.Synonym, - module Control.Proxy.Prelude, - module Control.Proxy.Trans, - module Control.Proxy.Trans.Identity, - module Control.Monad, - module Control.Monad.Trans.Class, - module Control.MFunctor - ) where - -import Control.MFunctor (MFunctor(hoist)) -import Control.Monad (forever, (>=>), (<=<)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class -import Control.Proxy.Synonym -import Control.Proxy.Trans -import Control.Proxy.Trans.Identity -import Control.Proxy.Prelude - -{- $modules - "Control.Proxy.Class" defines the 'Proxy' type class that lets you program - generically over proxy implementations and their transformers. - - "Control.Proxy.Synonym" defines type synonyms for proxies that don't use all - of their inputs or outputs, such as 'Pipe's, 'Producer's, and 'Server's. - - "Control.Proxy.Prelude" provides a standard library of proxies. - - "Control.Proxy.Trans" defines the 'ProxyTrans' type class that lets you - write your own proxy extensions. - - "Control.Proxy.Trans.Identity" exports 'runIdentityP', which substantially - eases writing completely polymorphic proxies. - - "Control.Monad" exports 'forever', ('>=>'), and ('<=<'). - - "Control.Monad.Trans.Class" exports 'lift'. - - "Control.MFunctor" exports 'hoist'. --} diff --git a/Control/Proxy/Core/Correct.hs b/Control/Proxy/Core/Correct.hs deleted file mode 100644 --- a/Control/Proxy/Core/Correct.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-| This module provides the correct proxy implementation which strictly - enforces the monad transformer laws. You can safely import this module - without violating any laws or invariants. - - However, I advise that you stick to the 'Proxy' type class API rather than - import this module so that your code works with both 'Proxy' implementations - and also works with all proxy transformers. -} - -module Control.Proxy.Core.Correct ( - -- * Types - ProxyCorrect(..), - ProxyF(..), - - -- * Run Sessions - -- $run - runProxy, - runProxyK, - runPipe - ) where - -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.Proxy.Class -import Control.Proxy.Synonym (C) - -{-| A 'ProxyCorrect' communicates with an upstream interface and a downstream - interface. - - The type variables of @ProxyCorrect req_a' resp_a req_b' resp_b m r@ - signify: - - * @req_a'@ - The request supplied to the upstream interface - - * @resp_a@ - The response provided by the upstream interface - - * @req_b'@ - The request supplied by the downstream interface - - * @resp_b@ - The response provided to the downstream interface - - * @m @ - The base monad - - * @r @ - The final return value -} -data ProxyCorrect a' a b' b m r = - Proxy { unProxy :: m (ProxyF a' a b' b r (ProxyCorrect a' a b' b m r)) } - --- | The base functor for the 'ProxyCorrect' type -data ProxyF a' a b' b r x - = Request a' (a -> x) - | Respond b (b' -> x) - | Pure r - -instance (Monad m) => Functor (ProxyCorrect a' a b' b m) where - fmap f p0 = go p0 where - go p = Proxy (do - x <- unProxy p - return (case x of - Request a' fa -> Request a' (\a -> go (fa a )) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - Pure r -> Pure (f r) ) ) - -instance (Monad m) => Applicative (ProxyCorrect a' a b' b m) where - pure r = Proxy (return (Pure r)) - pf <*> px = go pf where - go p = Proxy (do - x <- unProxy p - case x of - Request a' fa -> return (Request a' (\a -> go (fa a ))) - Respond b fb' -> return (Respond b (\b' -> go (fb' b'))) - Pure f -> unProxy (fmap f px) ) - -instance (Monad m) => Monad (ProxyCorrect a' a b' b m) where - return = \r -> Proxy (return (Pure r)) - p0 >>= f = go p0 where - go p = Proxy (do - x <- unProxy p - case x of - Request a' fa -> return (Request a' (\a -> go (fa a ))) - Respond b fb' -> return (Respond b (\b' -> go (fb' b'))) - Pure r -> unProxy (f r) ) - -instance MonadTrans (ProxyCorrect a' a b' b) where - lift = lift_P - -instance (MonadIO m) => MonadIO (ProxyCorrect a' a b' b m) where - liftIO m = Proxy (liftIO (m >>= \r -> return (Pure r))) - -- liftIO = Proxy . liftIO . liftM Pure - -instance MonadIOP ProxyCorrect where - liftIO_P = liftIO - -instance Proxy ProxyCorrect where - fb'_0 >-> fc' = \c' -> fb'_0 >-| fc' c' where - fb' >-| p1 = Proxy (do - x <- unProxy p1 - case x of - Request b' fb -> unProxy (fb' b' |-> fb) - Respond c fc' -> return (Respond c (\c' -> fb' >-| fc' c')) - Pure r -> return (Pure r) ) - p2 |-> fb = Proxy (do - x <- unProxy p2 - case x of - Request a' fa -> return (Request a' (\a -> fa a |-> fb)) - Respond b fb' -> unProxy (fb' >-| fb b) - Pure r -> return (Pure r) ) - - fa_0 >~> fb_0 = \a -> fa_0 a |-> fb_0 where - fb' >-| p1 = Proxy (do - x <- unProxy p1 - case x of - Request b' fb -> unProxy (fb' b' |-> fb) - Respond c fc' -> return (Respond c (\c' -> fb' >-| fc' c')) - Pure r -> return (Pure r) ) - p2 |-> fb = Proxy (do - x <- unProxy p2 - case x of - Request a' fa -> return (Request a' (\a -> fa a |-> fb)) - Respond b fb' -> unProxy (fb' >-| fb b) - Pure r -> return (Pure r) ) - - request a' = Proxy (return (Request a' (\a -> Proxy (return (Pure a ))))) - respond b = Proxy (return (Respond b (\b' -> Proxy (return (Pure b'))))) - - return_P = return - (?>=) = (>>=) - - lift_P m = Proxy (m >>= \r -> return (Pure r)) - - hoist_P = hoist - -instance Interact ProxyCorrect where - k2 \>\ k1 = \a' -> go (k1 a') where - go p = Proxy (do - x <- unProxy p - case x of - Request b' fb -> unProxy (k2 b' >>= \b -> go (fb b)) - Respond x fx' -> return (Respond x (\x' -> go (fx' x'))) - Pure a -> return (Pure a) ) - k2 />/ k1 = \a' -> go (k2 a') where - go p = Proxy (do - x <- unProxy p - case x of - Request x' fx -> return (Request x' (\x -> go (fx x))) - Respond b fb' -> unProxy (k1 b >>= \b' -> go (fb' b')) - Pure a -> return (Pure a) ) - -instance MFunctor (ProxyCorrect a' a b' b) where - hoist nat p0 = go p0 where - go p = Proxy (nat (do - x <- unProxy p - return (case x of - Request a' fa -> Request a' (\a -> go (fa a )) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - Pure r -> Pure r ))) - -{- $run - The following commands run self-sufficient proxies, converting them back to - the base monad. - - These are the only functions specific to the 'ProxyCorrect' type. - Everything else programs generically over the 'Proxy' type class. - - Use 'runProxyK' if you are running proxies nested within proxies. It - provides a Kleisli arrow as its result that you can pass to another - 'runProxy' / 'runProxyK' command. -} - -{-| Run a self-sufficient 'ProxyCorrect' Kleisli arrow, converting it back to - the base monad -} -runProxy :: (Monad m) => (() -> ProxyCorrect a' () () b m r) -> m r -runProxy k = go (k ()) where - go p = do - x <- unProxy p - case x of - Request _ fa -> go (fa ()) - Respond _ fb' -> go (fb' ()) - Pure r -> return r - -{-| Run a self-sufficient 'ProxyCorrect' Kleisli arrow, converting it back to a - Kleisli arrow in the base monad -} -runProxyK :: (Monad m) => (() -> ProxyCorrect a' () () b m r) -> (() -> m r) -runProxyK p = \() -> runProxy p - --- | Run the 'Pipe' monad transformer, converting it back to the base monad -runPipe :: (Monad m) => ProxyCorrect a' () () b m r -> m r -runPipe p = runProxy (\_ -> p) diff --git a/Control/Proxy/Core/Fast.hs b/Control/Proxy/Core/Fast.hs deleted file mode 100644 --- a/Control/Proxy/Core/Fast.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-| This is an internal module, meaning that it is unsafe to import unless you - understand the risks. - - This module provides the fast proxy implementation, which achieves its speed - 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 - - These laws only hold when viewed through certain safe observation functions, - like 'runProxy' and 'observe'. - - Also, you really should not use the constructors anyway, let alone the - concrete type and instead you should stick to the 'Proxy' type class API. - This not only ensures that your code does not violate the monad transformer - laws, but also guarantees that it works with the other proxy implementations - and with any proxy transformers. -} - -module Control.Proxy.Core.Fast ( - -- * Types - ProxyFast(..), - - -- * Run Sessions - -- $run - runProxy, - runProxyK, - runPipe, - - -- * Safety - observe - ) where - -import Control.Applicative (Applicative(pure, (<*>))) --- import Control.Monad (ap, forever, liftM, (>=>)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.Proxy.Class -import Control.Proxy.Synonym (C) - -{-| A 'ProxyFast' communicates with an upstream interface and a downstream - interface. - - The type variables of @ProxyFast req_a' resp_a req_b' resp_b m r@ signify: - - * @req_a'@ - The request supplied to the upstream interface - - * @resp_a@ - The response provided by the upstream interface - - * @req_b'@ - The request supplied by the downstream interface - - * @resp_b@ - The response provided to the downstream interface - - * @m @ - The base monad - - * @r @ - The final return value -} -data ProxyFast a' a b' b m r - = Request a' (a -> ProxyFast a' a b' b m r ) - | Respond b (b' -> ProxyFast a' a b' b m r ) - | M (m (ProxyFast a' a b' b m r)) - | Pure r - -instance (Monad m) => Functor (ProxyFast 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 (ProxyFast 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 (ProxyFast a' a b' b m) where - return = Pure - (>>=) = _bind - -_bind - :: (Monad m) - => ProxyFast a' a b' b m r - -> (r -> ProxyFast a' a b' b m r') - -> ProxyFast 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 - --- | Only satisfies laws modulo 'observe' -instance MonadTrans (ProxyFast a' a b' b) where - lift = _lift - -_lift :: (Monad m) => m r -> ProxyFast a' a b' b m r -_lift m = M (m >>= \r -> return (Pure r)) --- _lift = M . liftM Pure - -{- These never fire, for some reason, but keep them until I figure out how to - get them to work. -} -{-# RULES - "_lift m ?>= f" forall m f . - _bind (_lift m) f = M (m >>= \r -> return (f r)) - #-} - -instance (MonadIO m) => MonadIO (ProxyFast a' a b' b m) where - liftIO m = M (liftIO (m >>= \r -> return (Pure r))) - -- liftIO = M . liftIO . liftM Pure - -instance MonadIOP ProxyFast where - liftIO_P = liftIO - -instance Proxy ProxyFast where - fb'_0 >-> fc'_0 = \c' -> fb'_0 >-| fc'_0 c' where - p1 |-> fb = case p1 of - Request a' fa -> Request a' (\a -> fa a |-> fb) - Respond b fb' -> fb' >-| fb b - M m -> M (m >>= \p1' -> return (p1' |-> fb)) - Pure r -> Pure r - fb' >-| p2 = case p2 of - Request b' fb -> fb' b' |-> fb - Respond c fc' -> Respond c (\c' -> fb' >-| fc' c') - M m -> M (m >>= \p2' -> return (fb' >-| p2')) - Pure r -> Pure r - - fa_0 >~> fb_0 = \a -> fa_0 a |-> fb_0 where - p1 |-> fb = case p1 of - Request a' fa -> Request a' (\a -> fa a |-> fb) - Respond b fb' -> fb' >-| fb b - M m -> M (m >>= \p1' -> return (p1' |-> fb)) - Pure r -> Pure r - fb' >-| p2 = case p2 of - Request b' fb -> fb' b' |-> fb - Respond c fc' -> Respond c (\c' -> fb' >-| fc' c') - M m -> M (m >>= \p2' -> return (fb' >-| p2')) - Pure r -> Pure r - - request a' = Request a' Pure - respond b = Respond b Pure - - return_P = return - (?>=) = _bind - - lift_P = _lift - - hoist_P = hoist - -{-# RULES - "_bind (Request a' Pure) f" forall a' f . - _bind (Request a' Pure) f = Request a' f; - "_bind (Respond b Pure) f" forall b f . - _bind (Respond b Pure) f = Respond b f - #-} - -instance Interact ProxyFast where - k2 \>\ k1 = \a' -> go (k1 a') where - go p = case p of - Request b' fb -> k2 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 - k2 />/ k1 = \a' -> go (k2 a') where - go p = case p of - Request x' fx -> Request x' (\x -> go (fx x)) - Respond b fb' -> k1 b >>= \b' -> go (fb' b') - M m -> M (m >>= \p' -> return (go p')) - Pure a -> Pure a - -instance MFunctor (ProxyFast 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 - -{- $run - The following commands run self-sufficient proxies, converting them back to - the base monad. - - These are the only functions specific to the 'ProxyFast' type. Everything - else programs generically over the 'Proxy' type class. - - Use 'runProxyK' if you are running proxies nested within proxies. It - provides a Kleisli arrow as its result that you can pass to another - 'runProxy' / 'runProxyK' command. -} - -{-| Run a self-sufficient 'ProxyFast' Kleisli arrow, converting it back to the - base monad -} -runProxy :: (Monad m) => (() -> ProxyFast a' () () b m r) -> m r -runProxy k = go (k ()) where - go p = case p of - Request _ fa -> go (fa ()) - Respond _ fb' -> go (fb' ()) - M m -> m >>= go - Pure r -> return r - -{-| Run a self-sufficient 'ProxyFast' Kleisli arrow, converting it back to a - Kleisli arrow in the base monad -} -runProxyK :: (Monad m) => (() -> ProxyFast a' () () b m r) -> (() -> m r) -runProxyK p = \() -> runProxy p - --- | Run the 'Pipe' monad transformer, converting it back to the base monad -runPipe :: (Monad m) => ProxyFast a' () () b m r -> m r -runPipe p = runProxy (\_ -> p) - -{-| 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 moderate cost to performance, so use this - function sparingly or else you would be better off using - "Control.Proxy.Core.Correct". - - You do not need to use this function if you use the safe API exported from - "Control.Proxy", which does not export any functions or constructors that - can violate the monad transformer laws. --} -observe :: (Monad m) => ProxyFast a' a b' b m r -> ProxyFast a' a b' b m r -observe p = M (go p) where - go p = case p of - M m' -> m' >>= go - Pure r -> return (Pure r) - Request a' fa -> return (Request a' (\a -> observe (fa a ))) - Respond b fb' -> return (Respond b (\b' -> observe (fb' b'))) diff --git a/Control/Proxy/Pipe.hs b/Control/Proxy/Pipe.hs deleted file mode 100644 --- a/Control/Proxy/Pipe.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE KindSignatures #-} - -{-| This module provides an API similar to "Control.Pipe" for those who prefer - the classic 'Pipe' API. - - This module differs slightly from "Control.Pipe" in order to promote - seamless interoperability with both pipes and proxies. See the \"Upgrade - Pipes to Proxies\" section below for details. -} -module Control.Proxy.Pipe ( - -- * Create Pipes - await, - yield, - pipe, - - -- * Compose Pipes - (<+<), - (>+>), - idP, - - -- * Synonyms - Pipeline, - - -- * Run Pipes - -- $run - - -- * Upgrade Pipes to Proxies - -- $upgrade - ) where - -import Control.Monad (forever) -import Control.Proxy.Class (Proxy(request, respond, (>->), (?>=))) -import Control.Proxy.Synonym (Pipe, Consumer, Producer, C) -import Control.Proxy.Trans.Identity (runIdentityP) - -{-| Wait for input from upstream - - 'await' blocks until input is available from upstream. -} -await :: (Monad m, Proxy p) => Pipe p a b m a -await = request () - -{-| Deliver output downstream - - 'yield' restores control back downstream and binds its value to 'await'. -} -yield :: (Monad m, Proxy p) => b -> p a' a b' b m () -yield b = runIdentityP $ do - respond b - return () - --- | Convert a pure function into a pipe -pipe :: (Monad m, Proxy p) => (a -> b) -> Pipe p a b m r -pipe f = runIdentityP $ forever $ do - a <- request () - respond (f a) - -infixr 9 <+< -infixl 9 >+> - --- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<+<) - :: (Monad m, Proxy p) => Pipe p b c m r -> Pipe p a b m r -> Pipe p a c m r -p1 <+< p2 = p2 >+> p1 - --- | Corresponds to ('>>>') from @Control.Category@ -(>+>) - :: (Monad m, Proxy p) => Pipe p a b m r -> Pipe p b c m r -> Pipe p a c m r -p1 >+> p2 = ((\() -> p1) >-> (\() -> p2)) () - --- | Corresponds to 'id' from @Control.Category@ -idP :: (Monad m, Proxy p) => Pipe p a a m r -idP = runIdentityP $ forever $ do - a <- request () - respond a - -{-| A self-contained 'Pipeline' that is ready to be run - - 'Pipeline's never 'request' nor 'respond'. -} -type Pipeline (p :: * -> * -> * -> * -> (* -> *) -> * -> *) = p C () () C - -{- $run - The "Control.Proxy.Core.Fast" and "Control.Proxy.Core.Correct" modules - provide their corresponding 'runPipe' functions, specialized to their own - 'Proxy' implementations. - - Each implementation must supply its own 'runPipe' function since it is - the only non-polymorphic 'Pipe' function and the compiler uses it to - select which underlying proxy implementation to use. -} - -{- $upgrade - You can upgrade classic 'Pipe' code to work with the proxy ecosystem in - steps. Each change enables greater interoperability with proxy utilities - and transformers and if time permits you should implement the entire upgrade - for your libraries if you want to take advantage of proxy standard - libraries. - - First, import "Control.Proxy" and "Control.Proxy.Pipe" instead of - "Control.Pipe". Then, add 'ProxyFast' after every 'Pipe', 'Producer', or - 'Consumer' in any type signature. For example, you would convert this: - -> import Control.Pipe -> -> fromList :: (Monad m) => [b] -> Producer b m () -> fromList xs = mapM_ yield xs - - ... to this: - -> import Control.Proxy -> import Control.Proxy.Pipe -- transition import -> -> fromList :: (Monad m) => [b] -> Producer ProxyFast b m () -> fromList xs = mapM_ yield xs - - The change ensures that all your code now works in the 'ProxyFast' monad, - which is the faster of the two proxy implementations. - - Second, modify all your 'Pipe's to take an empty '()' as their final - argument, and translate the following functions: - - * ('<+<') to ('<-<') - - * 'runPipe' to 'runProxy' - - For example, you would convert this: - -> import Control.Proxy -> import Control.Proxy.Pipe -> -> fromList :: (Monad m) => [b] -> Producer ProxyFast b m () -> fromList xs = mapM_ yield xs - - ... to this: - -> import Control.Proxy -> import Control.Proxy.Pipe -> -> fromList :: (Monad m) => [b] -> () -> Producer ProxyFast b m () -> fromList xs () = mapM_ yield xs - - Now when you call these within a @do@ block you must supplying an - additional @()@ argument: - -> examplePipe () = do -> a <- request () -> fromList [1..a] () - - This change lets you switch from pipe composition, ('<+<'), to proxy - composition, ('<-<'), so that you can mix proxy utilities with pipes. - - Third, wrap your pipe's implementation in 'runIdentityP' (which - "Control.Proxy" exports): - -> import Control.Proxy -> import Control.Proxy.Pipe -> -> fromList xs () = runIdentityP $ mapM_ yield xs - - Then replace the 'ProxyFast' in the type signature with a type variable @p@ - constrained by the 'Proxy' type class: - -> fromList :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () - - This change upgrades your 'Pipe' to work natively within proxies and proxy - transformers, without any manual conversion or lifting. You can now compose - or sequence your 'Pipe' within any feature set transparently. - - Finally, replace each 'await' with @request ()@ and each 'yield' with - 'respond'. Also, replace every 'Pipeline' with 'Session'. This lets you - drop the "Control.Proxy.Pipe" import: - -> import Control.Proxy -> -> fromList :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () -> fromList xs () = runIdentityP $ mapM_ respond xs - - Also, I encourage you to continue using the 'Pipe', 'Consumer' and - 'Producer' type synonyms to simplify type signatures. The following - examples show how they cleanly mix with proxies and their extensions: - -> import Control.Proxy -> import Control.Proxy.Trans.Either as E -> import Control.Proxy.Trans.State -> -> -- A Producer enriched with pipe-local state -> example1 :: (Monad m, Proxy p) => () -> Producer (StateP Int p) Int m r -> example1 () = forever $ do -> n <- get -> respond n -> put (n + 1) -> -> -- A Consumer enriched with error-handling -> example2 :: (Proxy p) => () -> Consumer (EitherP String p) Int IO () -> example2 () = do -> n <- request () -> if (n == 0) -> then E.throw "Error: received 0" -> else lift $ print n - --} diff --git a/Control/Proxy/Prelude.hs b/Control/Proxy/Prelude.hs deleted file mode 100644 --- a/Control/Proxy/Prelude.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Entry point for the Control.Proxy.Prelude hierarchy - -module Control.Proxy.Prelude ( - -- * Modules - -- $modules - module Control.Proxy.Prelude.Base, - module Control.Proxy.Prelude.IO, - module Control.Proxy.Prelude.Kleisli - ) where - -import Control.Proxy.Prelude.Base -import Control.Proxy.Prelude.IO -import Control.Proxy.Prelude.Kleisli - -{- $modules - "Control.Proxy.Prelude.Base" provides pure utility proxies. - - "Control.Proxy.Prelude.IO" provides proxies for simple 'IO'. - - "Control.Proxy.Prelude.Kleisli" provides convenience functions for working - with Kleisli arrows. -} diff --git a/Control/Proxy/Prelude/Base.hs b/Control/Proxy/Prelude/Base.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/Base.hs +++ /dev/null @@ -1,804 +0,0 @@ --- | General purpose proxies - -module Control.Proxy.Prelude.Base ( - -- * Maps - mapD, - mapU, - mapB, - mapMD, - mapMU, - mapMB, - useD, - useU, - useB, - execD, - execU, - execB, - - -- * Filters - takeB, - takeB_, - takeWhileD, - takeWhileU, - dropD, - dropU, - dropWhileD, - dropWhileU, - filterD, - filterU, - - -- * Lists - fromListS, - fromListC, - - -- * Enumerations - enumFromS, - enumFromC, - enumFromToS, - enumFromToC, - - -- * Folds - foldD, - foldU, - allD, - allU, - allD_, - allU_, - anyD, - anyU, - anyD_, - anyU_, - sumD, - sumU, - productD, - productU, - lengthD, - lengthU, - headD, - headD_, - headU, - headU_, - lastD, - lastU, - toListD, - toListU, - foldrD, - foldrU, - foldlD', - foldlU', - - -- * Zips and Merges - zipD, - mergeD, - - -- * Closed Adapters - -- $open - unitD, - unitU, - - -- * Modules - -- $modules - module Control.Monad.Trans.State.Strict, - module Control.Monad.Trans.Writer.Strict, - module Data.Monoid - ) where - -import Control.MFunctor (hoist) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Writer.Strict ( - WriterT(runWriterT), execWriterT, runWriter, tell ) -import Control.Monad.Trans.State.Strict ( - StateT(runStateT), execStateT, runState, execState, get, put ) -import Control.Proxy.Class -import Control.Proxy.Synonym -import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK) -import Data.Monoid ( - Monoid, - Endo(Endo, appEndo), - All(All, getAll), - Any(Any, getAny), - Sum(Sum, getSum), - Product(Product, getProduct), - First(First, getFirst), - Last(Last, getLast) ) - -{-| @(mapD f)@ applies @f@ to all values going \'@D@\'ownstream. - -> mapD f1 >-> mapD f2 = mapD (f2 . f1) -> -> mapD id = idT --} -mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r -mapD f = runIdentityK go where - go x = do - a <- request x - x2 <- respond (f a) - go x2 --- mapD f = foreverK $ request >=> respond . f - -{-| @(mapU g)@ applies @g@ to all values going \'@U@\'pstream. - -> mapU g1 >-> mapU g2 = mapU (g1 . g2) -> -> mapU id = idT --} -mapU :: (Monad m, Proxy p) => (b' -> a') -> b' -> p a' x b' x m r -mapU g = runIdentityK go where - go b' = do - x <- request (g b') - b'2 <- respond x - go b'2 --- mapU g = foreverK $ (request . g) >=> respond - -{-| @(mapB f g)@ applies @f@ to all values going downstream and @g@ to all - values going upstream. - - Mnemonic: map \'@B@\'idirectional - -> mapB f1 g1 >-> mapB f2 g2 = mapB (f2 . f1) (g1 . g2) -> -> mapB id id = idT --} -mapB :: (Monad m, Proxy p) => (a -> b) -> (b' -> a') -> b' -> p a' a b' b m r -mapB f g = runIdentityK go where - go b' = do - a <- request (g b') - b'2 <- respond (f a ) - go b'2 --- mapB f g = foreverK $ request . g >=> respond . f - -{-| @(mapMD f)@ applies the monadic function @f@ to all values going downstream - -> mapMD f1 >-> mapMD f2 = mapMD (f1 >=> f2) -> -> mapMD return = idT --} -mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r -mapMD f = runIdentityK go where - go x = do - a <- request x - b <- lift (f a) - x2 <- respond b - go x2 --- mapMD f = foreverK $ request >=> lift . f >=> respond - -{-| @(mapMU g)@ applies the monadic function @g@ to all values going upstream - -> mapMU g1 >-> mapMU g2 = mapMU (g2 >=> g1) -> -> mapMU return = idT --} -mapMU :: (Monad m, Proxy p) => (b' -> m a') -> b' -> p a' x b' x m r -mapMU g = runIdentityK go where - go b' = do - a' <- lift (g b') - x <- request a' - b'2 <- respond x - go b'2 --- mapMU g = foreverK $ lift . g >=> request >=> respond - -{-| @(mapMB f g)@ applies the monadic function @f@ to all values going - downstream and the monadic function @g@ to all values going upstream. - -> mapMB f1 g1 >-> mapMB f2 g2 = mapMB (f1 >=> f2) (g2 >=> g1) -> -> mapMB return return = idT --} -mapMB - :: (Monad m, Proxy p) => (a -> m b) -> (b' -> m a') -> b' -> p a' a b' b m r -mapMB f g = runIdentityK go where - go b' = do - a' <- lift (g b') - a <- request a' - b <- lift (f a ) - b'2 <- respond b - go b'2 --- mapMB f g = foreverK $ lift . g >=> request >=> lift . f >=> respond - -{-| @(useD f)@ executes the monadic function @f@ on all values flowing - \'@D@\'ownstream - -> useD f1 >-> useD f2 = useD (\a -> f1 a >> f2 a) -> -> useD (\_ -> return ()) = idT --} -useD :: (Monad m, Proxy p) => (a -> m r1) -> x -> p x a x a m r -useD f = runIdentityK go where - go x = do - a <- request x - lift $ f a - x2 <- respond a - go x2 - -{-| @(useU g)@ executes the monadic function @g@ on all values flowing - \'@U@\'pstream - -> useU g1 >-> useU g2 = useU (\a' -> g2 a' >> g1 a') -> -> useU (\_ -> return ()) = idT --} -useU :: (Monad m, Proxy p) => (a' -> m r2) -> a' -> p a' x a' x m r -useU g = runIdentityK go where - go a' = do - lift $ g a' - x <- request a' - a'2 <- respond x - go a'2 - -{-| @(useB f g)@ executes the monadic function @f@ on all values flowing - downstream and the monadic function @g@ on all values flowing upstream - -> useB f1 g1 >-> useB f2 g2 = useB (\a -> f1 a >> f2 a) (\a' -> g2 a' >> g1 a') -> -> useB (\_ -> return ()) (\_ -> return ()) = idT --} -useB - :: (Monad m, Proxy p) => (a -> m r1) -> (a' -> m r2) -> a' -> p a' a a' a m r -useB f g = runIdentityK go where - go a' = do - lift $ g a' - a <- request a' - lift $ f a - a'2 <- respond a - go a'2 - -{-| @(execD md)@ executes @md@ every time values flow downstream through it. - -> execD md1 >-> execD md2 = execD (md1 >> md2) -> -> execD (return ()) = idT --} -execD :: (Monad m, Proxy p) => m r1 -> a' -> p a' a a' a m r -execD md = runIdentityK go where - go a' = do - a <- request a' - lift md - a'2 <- respond a - go a'2 -{- execD md = foreverK $ \a' -> do - a <- request a' - lift md - respond a -} - -{-| @(execU mu)@ executes @mu@ every time values flow upstream through it. - -> execU mu1 >-> execU mu2 = execU (mu2 >> mu1) -> -> execU (return ()) = idT --} -execU :: (Monad m, Proxy p) => m r2 -> a' -> p a' a a' a m r -execU mu = runIdentityK go where - go a' = do - lift mu - a <- request a' - a'2 <- respond a - go a'2 -{- execU mu = foreverK $ \a' -> do - lift mu - a <- request a' - respond a -} - -{-| @(execB md mu)@ executes @mu@ every time values flow upstream through it, - and executes @md@ every time values flow downstream through it. - -> execB md1 mu1 >-> execB md2 mu2 = execB (md1 >> md2) (mu2 >> mu1) -> -> execB (return ()) = idT --} -execB :: (Monad m, Proxy p) => m r1 -> m r2 -> a' -> p a' a a' a m r -execB md mu = runIdentityK go where - go a' = do - lift mu - a <- request a' - lift md - a'2 <- respond a - go a'2 -{- execB md mu = foreverK $ \a' -> do - lift mu - a <- request a' - lift md - respond a -} - -{-| @(takeB n)@ allows @n@ upstream/downstream roundtrips to pass through - -> takeB n1 >=> takeB n2 = takeB (n1 + n2) -- n1 >= 0 && n2 >= 0 -> -> takeB 0 = return --} -takeB :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m a' -takeB n0 = runIdentityK (go n0) where - go n - | n <= 0 = return - | otherwise = \a' -> do - a <- request a' - a'2 <- respond a - go (n - 1) a'2 --- takeB n = replicateK n $ request >=> respond - --- | 'takeB_' is 'takeB' with a @()@ return value, convenient for composing -takeB_ :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m () -takeB_ n0 = runIdentityK (go n0) where - go n - | n <= 0 = \_ -> return () - | otherwise = \a' -> do - a <- request a' - a'2 <- respond a - go (n - 1) a'2 --- takeB_ n = fmap void (takeB n) - -{-| @(takeWhileD p)@ allows values to pass downstream so long as they satisfy - the predicate @p@. - -> -- Using the "All" monoid over functions: -> mempty = \_ -> True -> (p1 <> p2) a = p1 a && p2 a -> -> takeWhileD p1 >-> takeWhileD p2 = takeWhileD (p1 <> p2) -> -> takeWhileD mempty = idT --} -takeWhileD :: (Monad m, Proxy p) => (a -> Bool) -> a' -> p a' a a' a m () -takeWhileD p = runIdentityK go where - go a' = do - a <- request a' - if (p a) - then do - a'2 <- respond a - go a'2 - else return () - -{-| @(takeWhileU p)@ allows values to pass upstream so long as they satisfy the - predicate @p@. - -> takeWhileU p1 >-> takeWhileU p2 = takeWhileU (p1 <> p2) -> -> takeWhileD mempty = idT --} -takeWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' a a' a m () -takeWhileU p = runIdentityK go where - go a' = - if (p a') - then do - a <- request a' - a'2 <- respond a - go a'2 - else return_P () - -{-| @(dropD n)@ discards @n@ values going downstream - -> dropD n1 >-> dropD n2 = dropD (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropD 0 = idT --} -dropD :: (Monad m, Proxy p) => Int -> () -> Pipe p a a m r -dropD n0 = \() -> runIdentityP (go n0) where - go n - | n <= 0 = idT () - | otherwise = do - request () - go (n - 1) -{- dropD n () = do - replicateM_ n $ request () - idT () -} - -{-| @(dropU n)@ discards @n@ values going upstream - -> dropU n1 >-> dropU n2 = dropU (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropU 0 = idT --} -dropU :: (Monad m, Proxy p) => Int -> a' -> CoPipe p a' a' m r -dropU n0 = runIdentityK (go n0) where - go n - | n <= 0 = idT - | otherwise = \_ -> do - a' <- respond () - go (n - 1) a' - -{-| @(dropWhileD p)@ discards values going downstream until one violates the - predicate @p@. - -> -- Using the "Any" monoid over functions: -> mempty = \_ -> False -> (p1 <> p2) a = p1 a || p2 a -> -> dropWhileD p1 >-> dropWhileD p2 = dropWhileD (p1 <> p2) -> -> dropWhileD mempty = idT --} -dropWhileD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r -dropWhileD p () = runIdentityP go where - go = do - a <- request () - if (p a) - then go - else do - x <- respond a - idT x - -{-| @(dropWhileU p)@ discards values going upstream until one violates the - predicate @p@. - -> dropWhileU p1 >-> dropWhileU p2 = dropWhileU (p1 <> p2) -> -> dropWhileU mempty = idT --} -dropWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r -dropWhileU p = runIdentityK go where - go a' = - if (p a') - then do - a2 <- respond () - go a2 - else idT a' - -{-| @(filterD p)@ discards values going downstream if they fail the predicate - @p@ - -> -- Using the "All" monoid over functions: -> mempty = \_ -> True -> (p1 <> p2) a = p1 a && p2 a -> -> filterD p1 >-> filterD p2 = filterD (p1 <> p2) -> -> filterD mempty = idT --} -filterD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r -filterD p = \() -> runIdentityP go where - go = do - a <- request () - if (p a) - then do - respond a - go - else go - -{-| @(filterU p)@ discards values going upstream if they fail the predicate @p@ - -> filterU p1 >-> filterU p2 = filterU (p1 <> p2) -> -> filterU mempty = idT --} -filterU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r -filterU p = runIdentityK go where - go a' = - if (p a') - then do - request a' - a'2 <- respond () - go a'2 - else do - a'2 <- respond () - go a'2 - -{-| Convert a list into a 'Producer' - -> fromListS xs >=> fromListS ys = fromListS (xs ++ ys) -> -> fromListS [] = return --} -fromListS :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () -fromListS xs = \_ -> foldr (\e a -> respond e ?>= \_ -> a) (return_P ()) xs --- fromListS xs _ = mapM_ respond xs - -{-| Convert a list into a 'CoProducer' - -> fromListC xs >=> fromListC ys = fromListC (xs ++ ys) -> -> fromListC [] = return --} -fromListC :: (Monad m, Proxy p) => [a'] -> () -> CoProducer p a' m () -fromListC xs = \_ -> foldr (\e a -> request e ?>= \_ -> a) (return_P ()) xs --- fromListC xs _ = mapM_ request xs - --- | 'Producer' version of 'enumFrom' -enumFromS :: (Enum b, Monad m, Proxy p) => b -> () -> Producer p b m r -enumFromS b0 = \_ -> runIdentityP (go b0) where - go b = do - respond b - go (succ b) - --- | 'CoProducer' version of 'enumFrom' -enumFromC :: (Enum a', Monad m, Proxy p) => a' -> () -> CoProducer p a' m r -enumFromC a'0 = \_ -> runIdentityP (go a'0) where - go a' = do - request a' - go (succ a') - --- | 'Producer' version of 'enumFromTo' -enumFromToS - :: (Enum b, Ord b, Monad m, Proxy p) => b -> b -> () -> Producer p b m () -enumFromToS b1 b2 _ = runIdentityP (go b1) where - go b - | b > b2 = return () - | otherwise = do - respond b - go (succ b) - --- | 'CoProducer' version of 'enumFromTo' -enumFromToC - :: (Enum a', Ord a', Monad m, Proxy p) - => a' -> a' -> () -> CoProducer p a' m () -enumFromToC a1 a2 _ = runIdentityP (go a1) where - go n - | n > a2 = return () - | otherwise = do - request n - go (succ n) - -{-| Fold values flowing \'@D@\'ownstream - -> foldD f >-> foldD g = foldD (f <> g) -> -> foldD mempty = idT --} -foldD - :: (Monad m, Proxy p, Monoid w) => (a -> w) -> x -> p x a x a (WriterT w m) r -foldD f = runIdentityK go where - go x = do - a <- request x - lift $ tell $ f a - x2 <- respond a - go x2 - -{-| Fold values flowing \'@U@\'pstream - -> foldU f >-> foldU g = foldU (g <> f) -> -> foldU mempty = idT --} -foldU - :: (Monad m, Proxy p, Monoid w) - => (a' -> w) -> a' -> p a' x a' x (WriterT w m) r -foldU f = runIdentityK go where - go a' = do - lift $ tell $ f a' - x <- request a' - a'2 <- respond x - go a'2 - -{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the - predicate -} -allD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) r -allD pred = foldD (All . pred) - -{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the - predicate -} -allU - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) r -allU pred = foldU (All . pred) - -{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the - predicate - - 'allD_' terminates on the first value that fails the predicate -} -allD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) () -allD_ pred = runIdentityK go where - go x = do - a <- request x - if (pred a) - then do - x2 <- respond a - go x2 - else lift $ tell $ All False - -{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the - predicate - - 'allU_' terminates on the first value that fails the predicate -} -allU_ - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) () -allU_ pred = runIdentityK go where - go a' = - if (pred a') - then do - x <- request a' - a'2 <- respond x - go a'2 - else lift $ tell $ All False - -{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies - the predicate -} -anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r -anyD pred = foldD (Any . pred) - -{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies - the predicate -} -anyU - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) r -anyU pred = foldU (Any . pred) - -{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies the - predicate - - 'anyD_' terminates on the first value that satisfies the predicate -} -anyD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) () -anyD_ pred = runIdentityK go where - go x = do - a <- request x - if (pred a) - then lift $ tell $ Any True - else do - x2 <- respond a - go x2 - -{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies the - predicate - - 'anyU_' terminates on the first value that satisfies the predicate -} -anyU_ - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) () -anyU_ pred = runIdentityK go where - go a' = - if (pred a') - then lift $ tell $ Any True - else do - x <- request a' - a'2 <- respond x - go a'2 - --- | Compute the 'Sum' of all values that flow \'@D@\'ownstream -sumD :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Sum a) m) r -sumD = foldD Sum - --- | Compute the 'Sum' of all values that flow \'@U@\'pstream -sumU :: (Monad m, Proxy p, Num a') => a' -> p a' x a' x (WriterT (Sum a') m) r -sumU = foldU Sum - --- | Compute the 'Product' of all values that flow \'@D@\'ownstream -productD - :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Product a) m) r -productD = foldD Product - --- | Compute the 'Product' of all values that flow \'@U@\'pstream -productU - :: (Monad m, Proxy p, Num a') => a' -> p a' x a' x (WriterT (Product a') m) r -productU = foldU Product - --- | Count how many values flow \'@D@\'ownstream -lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r -lengthD = foldD (\_ -> Sum 1) - --- | Count how many values flow \'@U@\'pstream -lengthU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Sum Int) m) r -lengthU = foldU (\_ -> Sum 1) - --- | Retrieve the first value going \'@D@\'ownstream -headD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) r -headD = foldD (First . Just) - -{-| Retrieve the first value going \'@D@\'ownstream - - 'headD_' terminates on the first value it receives -} -headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () -headD_ x = runIdentityP $ do - a <- request x - lift $ tell $ First (Just a) - --- | Retrieve the first value going \'@U@\'pstream -headU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) r -headU = foldU (First . Just) - -{-| Retrieve the first value going \'@U@\'pstream - - 'headU_' terminates on the first value it receives -} -headU_ :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) () -headU_ a' = runIdentityP $ lift $ tell $ First (Just a') - --- | Retrieve the last value going \'@D@\'ownstream -lastD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Last a) m) r -lastD = foldD (Last . Just) - --- | Retrieve the last value going \'@U@\'pstream -lastU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Last a') m) r -lastU = foldU (Last . Just) - --- | Fold the values flowing \'@D@\'ownstream into a list -toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r -toListD = foldD (\x -> [x]) - --- | Fold the values flowing \'@U@\'pstream into a list -toListU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT [a'] m) r -toListU = foldU (\x -> [x]) - -{-| Fold equivalent to 'foldr' - - To see why, consider this isomorphic type for 'foldr': - -> foldr :: (a -> b -> b) -> [a] -> Endo b --} -foldrD - :: (Monad m, Proxy p) => (a -> b -> b) -> x -> p x a x a (WriterT (Endo b) m) r -foldrD step = foldD (Endo . step) - --- | Fold equivalent to 'foldr' -foldrU - :: (Monad m, Proxy p) - => (a' -> b -> b) -> a' -> p a' x a' x (WriterT (Endo b) m) r -foldrU step = foldU (Endo . step) - --- | Left strict fold over \'@D@\'ownstream values -foldlD' - :: (Monad m, Proxy p) => (b -> a -> b) -> x -> p x a x a (StateT b m) r -foldlD' f = runIdentityK go where - go x = do - a <- request x - lift $ do - b <- get - put $! f b a - x2 <- respond a - go x2 - --- | Left strict fold over \'@U@\'pstream values -foldlU' - :: (Monad m, Proxy p) => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r -foldlU' f = runIdentityK go where - go a' = do - lift $ do - b <- get - put $! f b a' - x <- request a' - a'2 <- respond x - go a'2 - --- | Zip values flowing downstream -zipD - :: (Monad m, Proxy p1, Proxy p2, Proxy p3) - => () -> Consumer p1 a (Consumer p2 b (Producer p3 (a, b) m)) r -zipD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where - go = do - a <- request () - lift $ do - b <- request () - lift $ respond (a, b) - go - --- | Interleave values flowing downstream using simple alternation -mergeD - :: (Monad m, Proxy p1, Proxy p2, Proxy p3) - => () -> Consumer p1 a (Consumer p2 a (Producer p3 a m)) r -mergeD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where - go = do - a1 <- request () - lift $ do - lift $ respond a1 - a2 <- request () - lift $ respond a2 - go - -{- $open - Use the @unit@ functions when you need to embed a proxy with a closed end - within an open proxy. For example, the following code will not type-check - because @fromListS [1..]@ is a 'Producer' and has a closed upstream end, - which conflicts with the 'request' statement preceding it: - -> p () = do -> request () -> fromList [1..] () - - You fix this by composing 'unitD' upstream of it, which replaces its closed - upstream end with an open polymorphic end: - -> p () = do -> request () -> (fromList [1..] <-< unitD) () - --} - --- | Compose 'unitD' with a closed upstream end to create a polymorphic end -unitD :: (Monad m, Proxy p) => y' -> p x' x y' () m r -unitD _ = runIdentityP go where - go = do - respond () - go - --- | Compose 'unitU' with a closed downstream end to create a polymorphic end -unitU :: (Monad m, Proxy p) => y' -> p () x y' y m r -unitU _ = runIdentityP go where - go = do - request () - go - -{- $modules - These modules help you build, run, and extract folds --} diff --git a/Control/Proxy/Prelude/IO.hs b/Control/Proxy/Prelude/IO.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/IO.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-| 'String'-based 'IO' operations. - - Note that 'String's are very inefficient, and I will release future separate - packages with 'ByteString' and 'Text' operations. I only provide these to - allow users to test simple I/O without requiring additional library - dependencies. -} - -module Control.Proxy.Prelude.IO ( - -- * Standard I/O - -- ** Input - getLineS, - getLineC, - readLnS, - readLnC, - -- ** Output - printB, - printD, - printU, - putStrLnB, - putStrLnD, - putStrLnU, - -- ** Interaction - promptS, - promptC, - -- * Handle I/O - -- ** Input - hGetLineS, - hGetLineC, - -- ** Output - hPrintB, - hPrintD, - hPrintU, - hPutStrLnB, - hPutStrLnD, - hPutStrLnU, - ) where - -import Control.Monad (forever) -import Control.Monad.Trans.Class (lift) -import Control.Proxy.Prelude.Kleisli (foreverK) -import Control.Proxy.Class (Proxy(request, respond)) -import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK) -import Control.Proxy.Synonym (Client, Server, Producer, CoProducer) -import qualified System.IO as IO - --- | A 'Producer' that sends lines from 'stdin' downstream -getLineS :: (Proxy p) => () -> Producer p String IO r -getLineS () = runIdentityP $ forever $ do - str <- lift getLine - respond str - --- | A 'CoProducer' that sends lines from 'stdin' upstream -getLineC :: (Proxy p) => () -> CoProducer p String IO r -getLineC () = runIdentityP $ forever $ do - str <- lift getLine - request str - --- | 'read' input from 'stdin' one line at a time and send \'@D@\'ownstream -readLnS :: (Read b, Proxy p) => () -> Producer p b IO r -readLnS () = runIdentityP $ forever $ do - a <- lift readLn - respond a - --- | 'read' input from 'stdin' one line at a time and send \'@U@\'pstream -readLnC :: (Read a', Proxy p) => () -> CoProducer p a' IO r -readLnC () = runIdentityP $ forever $ do - a <- lift readLn - request a - -{-| 'print's all values flowing through it to 'stdout' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -printB :: (Show a', Show a, Proxy p) => a' -> p a' a a' a IO r -printB = runIdentityK $ foreverK $ \a' -> do - lift $ do - putStr "U: " - print a' - a <- request a' - lift $ do - putStr "D: " - print a - respond a - --- | 'print's all values flowing \'@D@\'ownstream to 'stdout' -printD :: (Show a, Proxy p) => x -> p x a x a IO r -printD = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ print a - respond a - --- | 'print's all values flowing \'@U@\'pstream to 'stdout' -printU :: (Show a', Proxy p) => a' -> p a' x a' x IO r -printU = runIdentityK $ foreverK $ \a' -> do - lift $ print a' - x <- request a' - respond x - -{-| 'putStrLn's all values flowing through it to 'stdout' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -putStrLnB :: (Proxy p) => String -> p String String String String IO r -putStrLnB = runIdentityK $ foreverK $ \a' -> do - lift $ do - putStr "U: " - putStrLn a' - a <- request a' - lift $ do - putStr "D: " - putStrLn a - respond a - --- | 'putStrLn's all values flowing \'@D@\'ownstream to 'stdout' -putStrLnD :: (Proxy p) => x -> p x String x String IO r -putStrLnD = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ putStrLn a - respond a - --- | 'putStrLn's all values flowing \'@U@\'pstream to 'stdout' -putStrLnU :: (Proxy p) => String -> p String x String x IO r -putStrLnU = runIdentityK $ foreverK $ \a' -> do - lift $ putStrLn a' - x <- request a' - respond x - --- | Convert 'stdin'/'stdout' into a line-based 'Server' -promptS :: (Proxy p) => String -> Server p String String IO r -promptS = runIdentityK $ foreverK $ \send -> do - recv <- lift $ do - putStrLn send - getLine - respond recv - --- | Convert 'stdin'/'stdout' into a line-based 'Client' -promptC :: (Proxy p) => () -> Client p String String IO r -promptC () = runIdentityP $ forever $ do - send <- lift getLine - recv <- request send - lift $ putStrLn recv - --- | A 'Producer' that sends lines from a handle downstream -hGetLineS :: (Proxy p) => IO.Handle -> () -> Producer p String IO () -hGetLineS h () = runIdentityP go where - go = do - eof <- lift $ IO.hIsEOF h - if eof - then return () - else do - str <- lift $ IO.hGetLine h - respond str - go - --- | A 'CoProducer' that sends lines from a 'Handle' upstream -hGetLineC :: (Proxy p) => IO.Handle -> () -> CoProducer p String IO () -hGetLineC h () = runIdentityP go where - go = do - eof <- lift $ IO.hIsEOF h - if eof - then return () - else do - str <- lift $ IO.hGetLine h - request str - go - -{-| 'print's all values flowing through it to a 'Handle' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -hPrintB :: (Show a, Show a', Proxy p) => IO.Handle -> a' -> p a' a a' a IO r -hPrintB h = runIdentityK $ foreverK $ \a' -> do - lift $ do - IO.hPutStr h "U: " - IO.hPrint h a' - a <- request a' - lift $ do - IO.hPutStr h "D: " - IO.hPrint h a - respond a - --- | 'print's all values flowing \'@D@\'ownstream to a 'Handle' -hPrintD :: (Show a, Proxy p) => IO.Handle -> x -> p x a x a IO r -hPrintD h = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ IO.hPrint h a - respond a - --- | 'print's all values flowing \'@U@\'pstream to a 'Handle' -hPrintU :: (Show a', Proxy p) => IO.Handle -> a' -> p a' x a' x IO r -hPrintU h = runIdentityK $ foreverK $ \a' -> do - lift $ IO.hPrint h a' - x <- request a' - respond x - -{-| 'putStrLn's all values flowing through it to a 'Handle' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -hPutStrLnB - :: (Proxy p) => IO.Handle -> String -> p String String String String IO r -hPutStrLnB h = runIdentityK $ foreverK $ \a' -> do - lift $ do - IO.hPutStr h "U: " - IO.hPutStrLn h a' - a <- request a' - lift $ do - IO.hPutStr h "D: " - IO.hPutStrLn h a - respond a - --- | 'putStrLn's all values flowing \'@D@\'ownstream to a 'Handle' -hPutStrLnD :: (Proxy p) => IO.Handle -> x -> p x String x String IO r -hPutStrLnD h = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ IO.hPutStrLn h a - respond a - --- | 'putStrLn's all values flowing \'@U@\'pstream to a 'Handle' -hPutStrLnU :: (Proxy p) => IO.Handle -> String -> p String x String x IO r -hPutStrLnU h = runIdentityK $ foreverK $ \a' -> do - lift $ IO.hPutStrLn h a' - x <- request a' - respond x diff --git a/Control/Proxy/Prelude/Kleisli.hs b/Control/Proxy/Prelude/Kleisli.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/Kleisli.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE Rank2Types #-} - --- | Utility functions for Kleisli arrows - -module Control.Proxy.Prelude.Kleisli ( - -- * Core utility functions - foreverK, - replicateK, - liftK, - hoistK, - raiseK, - ) where - -import Control.MFunctor (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) - -{-| Compose a \'@K@\'leisli arrow with itself forever - - Use 'foreverK' to abstract away the following common recursion pattern: - -> p a = do -> ... -> a' <- respond b -> p a' - - Using 'foreverK', you can instead write: - -> p = foreverK $ \a -> do -> ... -> respond b --} -foreverK :: (Monad m) => (a -> m a) -> (a -> m b) -foreverK k = let r = \a -> k a >>= r in r -{- foreverK uses 'let' to avoid a space leak. - See: http://hackage.haskell.org/trac/ghc/ticket/5205 -} - --- | Repeat a \'@K@\'leisli arrow multiple times -replicateK :: (Monad m) => Int -> (a -> m a) -> (a -> m a) -replicateK n0 k = go n0 where - go n - | n < 1 = return - | n == 1 = k - | otherwise = \a -> k a >>= go (n - 1) - -{-| Convenience function equivalent to @(lift .)@ - -> liftK f >=> liftK g = liftK (f >=> g) -> -> liftK return = return --} -liftK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b) -liftK k a = lift (k a) --- liftK = (lift .) - -{-| Convenience function equivalent to @(hoist f .)@ - -> hoistK f p1 >-> hoistK f p2 = hoistK f (p1 >-> p2) -> -> hoistK f idT = idT - -> hoistK f p1 >=> hoistK f p2 = hoistK f (p1 >=> p2) -> -> hoistK f return = return - -> hoistK f . hoistK g = hoistK (f . g) -> -> hoistK id = id --} -hoistK - :: (Monad m, MFunctor t) - => (forall a . m a -> n a) -> ((b' -> t m b) -> (b' -> t n b)) -hoistK k p a' = hoist k (p a') --- hoistK k = (hoist k .) - -{-| Convenience function equivalent to @(hoist lift .)@ - -> raiseK p1 >-> raiseK p2 = raiseK (p1 >-> p2) -> -> raiseK idT = idT - -> raiseK p1 >=> raiseK p2 = raiseK (p1 >=> p2) -> -> raiseK return = return --} -raiseK - :: (Monad m, MFunctor t1, MonadTrans t2) => (q -> t1 m r) -> (q -> t1 (t2 m) r) -raiseK = (hoist lift .) diff --git a/Control/Proxy/Synonym.hs b/Control/Proxy/Synonym.hs deleted file mode 100644 --- a/Control/Proxy/Synonym.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE KindSignatures #-} - -{-| These type synonyms simplify type signatures when proxies do not use all - their type variables. -} - -module Control.Proxy.Synonym ( - -- * Synonyms - Pipe, - Producer, - Consumer, - CoPipe, - CoProducer, - CoConsumer, - Client, - Server, - Session, - - -- * Closed - C - ) where - --- | A unidirectional 'Proxy'. -type Pipe (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a b = p () a () b - -{-| A 'Pipe' that produces values - - 'Producer's never 'request'. -} -type Producer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b = p C () () b - -{-| A 'Pipe' that consumes values - - 'Consumer's never 'respond'. -} -type Consumer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a = p () a () C - --- | A 'Pipe' where everything flows upstream -type CoPipe (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' b' = p a' () b' () - -{-| A 'CoPipe' that produces values flowing upstream - - 'CoProducer's never 'respond'. -} -type CoProducer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' = p a' () () C - -{-| A 'CoConsumer' that consumes values flowing upstream - - 'CoConsumer's never 'request'. -} -type CoConsumer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b' = p C () b' () - -{-| @Server b' b@ receives requests of type @b'@ and sends responses of type - @b@. - - 'Server's never 'request'. -} -type Server (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b' b = p C () b' b - -{-| @Client a' a@ sends requests of type @a'@ and receives responses of - type @a@. - - 'Client's never 'respond'. -} -type Client (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' a = p a' a () C - -{-| A self-contained 'Session', ready to be run by 'runSession' - - 'Session's never 'request' or 'respond'. -} -type Session (p :: * -> * -> * -> * -> (* -> *) -> * -> *) = p C () () C - --- | The empty type, denoting a \'@C@\'losed end -data C = C -- Constructor not exported, but I include it to avoid EmptyDataDecls diff --git a/Control/Proxy/Trans.hs b/Control/Proxy/Trans.hs deleted file mode 100644 --- a/Control/Proxy/Trans.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-| You can define your own proxy extensions by writing your own \"proxy - transformers\". Proxy transformers are monad transformers that also - correctly lift all proxy operations from the base proxy type to the - extended proxy type. Stack multiple proxy transformers to chain features - together. --} - -module Control.Proxy.Trans ( - -- * Proxy Transformers - ProxyTrans(..), - mapP - - -- * Laws - -- $laws - ) where - -import Control.Proxy.Class - --- | Uniform interface to lifting proxies -class ProxyTrans t where - liftP :: (Monad m, Proxy p) => p a' a b' b m r -> t p a' a b' b m r - -{-| Lift a 'Proxy' Kleisli arrow - -> mapP = (lift .) --} -mapP :: (Monad m, Proxy p, ProxyTrans t) - => (q -> p a' a b' b m r) -> (q -> t p a' a b' b m r) -mapP = (liftP .) - -{- $laws - 'mapP' defines a functor that preserves five categories: - - * Kleisli category - - * The two Proxy categories - - * \"request\" category - - * \"respond\" category - - Laws: - - * Functor between 'Proxy' categories - -> mapP (f >-> g) = mapP f >-> mapP g -> -> mapP idT = idT - -> mapP (f >~> g) = mapP f >~> mapP g -> -> mapP idPush = idPush - - * Functor between Kleisli categories - -> mapP (f <=< g) = mapP f <=< mapP g -> -> mapP return = return - - * Functor between \"request\" categories - -> mapP (f / -> mapP request = request - - * Functor between \"respond\" categories - -> mapP (f \<\ g) = mapP f \<\ mapP g -- when \<\ is defined -> -> mapP respond = respond --} diff --git a/Control/Proxy/Trans/Either.hs b/Control/Proxy/Trans/Either.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Either.hs +++ /dev/null @@ -1,181 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'EitherT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Either ( - -- * EitherP - EitherP(..), - runEitherK, - -- * Either operations - left, - right, - -- * Symmetric monad - -- $symmetry - throw, - catch, - handle - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) -import Prelude hiding (catch) - --- | The 'Either' proxy transformer -newtype EitherP e p a' a b' b (m :: * -> *) r - = EitherP { runEitherP :: p a' a b' b m (Either e r) } - -instance (Proxy p, Monad m) - => Functor (EitherP e p a' a b' b m) where - fmap f p = EitherP ( - runEitherP p ?>= \e -> - return_P (case e of - Left l -> Left l - Right r -> Right (f r) ) ) - -- fmap f = EitherP . liftM (fmap f) . runEitherP - -instance (Proxy p, Monad m) - => Applicative (EitherP e p a' a b' b m) where - pure = return - fp <*> xp = EitherP ( - runEitherP fp ?>= \e1 -> - case e1 of - Left l -> return_P (Left l) - Right f -> - runEitherP xp ?>= \e2 -> - return_P (case e2 of - Left l -> Left l - Right x -> Right (f x) ) ) - -- fp <*> xp = EitherP ((<*>) <$> (runEitherP fp) <*> (runEitherP xp)) - -instance (Proxy p, Monad m) - => Monad (EitherP e p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (MonadPlusP p, Monad m) - => Alternative (EitherP e p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlusP p ) - => MonadPlusP (EitherP e p) where - mzero_P = EitherP mzero_P - mplus_P m1 m2 = EitherP (mplus_P (runEitherP m1) (runEitherP m2)) - -instance (MonadPlusP p, Monad m) - => MonadPlus (EitherP e p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (EitherP e p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (EitherP e p) where - liftIO_P m = EitherP (liftIO_P (m >>= \x -> return (Right x))) - -- liftIO = EitherP . liftIO . liftM Right - -instance (MonadIOP p, MonadIO m) - => MonadIO (EitherP e p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (EitherP e p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (EitherP e p) where - p1 >-> p2 = \c'1 -> EitherP ( - ((\b' -> runEitherP (p1 b')) >-> (\c'2 -> runEitherP (p2 c'2))) c'1 ) - -- p1 >-> p2 = (EitherP .) $ runEitherP . p1 >-> runEitherP . p2 - - p1 >~> p2 = \c'1 -> EitherP ( - ((\b' -> runEitherP (p1 b')) >~> (\c'2 -> runEitherP (p2 c'2))) c'1 ) - -- p1 >~> p2 = (EitherP .) $ runEitherP . p1 >~> runEitherP . p2 - - request = \a' -> EitherP (request a' ?>= \a -> return_P (Right a )) - respond = \b -> EitherP (respond b ?>= \b' -> return_P (Right b')) - - return_P = right - m ?>= f = EitherP ( - runEitherP m ?>= \e -> - runEitherP (case e of - Left l -> left l - Right r -> f r ) ) - - lift_P m = EitherP (lift_P (m >>= \x -> return (Right x))) - -- lift = EitherP . lift . liftM Right - - hoist_P nat p = EitherP (hoist_P nat (runEitherP p)) - -- hoist nat = EitherP . hoist nat . runEitherP - -instance ProxyTrans (EitherP e) where - liftP p = EitherP (p ?>= \x -> return_P (Right x)) - -- liftP = EitherP . liftM Right - -instance PFunctor (EitherP e) where - hoistP nat = EitherP . nat . runEitherP - --- | Run an 'EitherP' \'@K@\'leisi arrow, returning either a 'Left' or 'Right' -runEitherK - :: (q -> EitherP e p a' a b' b m r) -> (q -> p a' a b' b m (Either e r)) -runEitherK p q = runEitherP (p q) --- runEitherK = (runEitherP .) - --- | Abort the computation and return a 'Left' result -left :: (Monad m, Proxy p) => e -> EitherP e p a' a b' b m r -left e = EitherP (return_P (Left e)) --- left = EitherP . return . Left - --- | Synonym for 'return' -right :: (Monad m, Proxy p) => r -> EitherP e p a' a b' b m r -right r = EitherP (return_P (Right r)) --- right = EitherP . return . Right - -{- $symmetry - 'EitherP' forms a second symmetric monad over the left type variable. - - 'throw' is symmetric to 'return' - - 'catch' is symmetric to ('>>=') - - These two functions obey the monad laws: - -> catch m throw = m -> -> catch (throw e) f = f e -> -> catch (catch m f) g = catch m (\e -> catch (f e) g) --} - --- | Synonym for 'left' -throw :: (Monad m, Proxy p) => e -> EitherP e p a' a b' b m r -throw = left - --- | Resume from an aborted operation -catch - :: (Monad m, Proxy p) - => EitherP e p a' a b' b m r -- ^ Original computation - -> (e -> EitherP f p a' a b' b m r) -- ^ Handler - -> EitherP f p a' a b' b m r -- ^ Handled computation -catch m f = EitherP ( - runEitherP m ?>= \e -> - runEitherP (case e of - Left l -> f l - Right r -> right r )) - --- | 'catch' with the arguments flipped -handle - :: (Monad m, Proxy p) - => (e -> EitherP f p a' a b' b m r) -- ^ Handler - -> EitherP e p a' a b' b m r -- ^ Original computation - -> EitherP f p a' a b' b m r -- ^ Handled computation -handle f m = catch m f --- handle = flip catch diff --git a/Control/Proxy/Trans/Identity.hs b/Control/Proxy/Trans/Identity.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Identity.hs +++ /dev/null @@ -1,136 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'IdentityT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Identity ( - -- * Identity Proxy Transformer - IdentityP(..), - identityK, - runIdentityK - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | The 'Identity' proxy transformer -newtype IdentityP p a' a b' b (m :: * -> *) r = - IdentityP { runIdentityP :: p a' a b' b m r } - -instance (Proxy p, Monad m) - => Functor (IdentityP p a' a b' b m) where - fmap f p = IdentityP ( - runIdentityP p ?>= \x -> - return_P (f x) ) - -- fmap = liftM - -instance (Proxy p, Monad m) - => Applicative (IdentityP p a' a b' b m) where - pure = return - - fp <*> xp = IdentityP ( - runIdentityP fp ?>= \f -> - runIdentityP xp ?>= \x -> - return_P (f x) ) - -- fp <*> xp = ap - -instance (Proxy p, Monad m) - => Monad (IdentityP p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (MonadPlusP p, Monad m) - => Alternative (IdentityP p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlusP p ) - => MonadPlusP (IdentityP p) where - mzero_P = IdentityP mzero_P - mplus_P m1 m2 = IdentityP (mplus_P (runIdentityP m1) (runIdentityP m2)) - -instance (MonadPlusP p, Monad m) - => MonadPlus (IdentityP p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (IdentityP p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (IdentityP p) where - liftIO_P m = IdentityP (liftIO_P m) - -- liftIO = IdentityP . liftIO - -instance (MonadIOP p, MonadIO m) - => MonadIO (IdentityP p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (IdentityP p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (IdentityP p) where - p1 >-> p2 = \c'1 -> IdentityP ( - ((\c'2 -> runIdentityP (p1 c'2)) - >-> (\b' -> runIdentityP (p2 b' )) ) c'1 ) - -- p1 >-> p2 = (IdentityP .) $ runIdentityP . p1 >-> runIdentityP . p2 - - p1 >~> p2 = \c'1 -> IdentityP ( - ((\c'2 -> runIdentityP (p1 c'2)) - >~> (\b' -> runIdentityP (p2 b' )) ) c'1 ) - -- p1 >~> p2 = (IdentityP .) $ runIdentityP . p1 >~> runIdentityP . p2 - - request = \a' -> IdentityP (request a') - -- request = P . request - - respond = \b -> IdentityP (respond b) - -- respond = P . respond - - return_P = \r -> IdentityP (return_P r) - -- return = P . return - - m ?>= f = IdentityP ( - runIdentityP m ?>= \x -> - runIdentityP (f x) ) - - lift_P m = IdentityP (lift_P m) - -- lift = P . lift - - hoist_P nat p = IdentityP (hoist_P nat (runIdentityP p)) - -- hoist nat = IdentityP . hoist nat . runIdentityP - -instance (Interact p ) - => Interact (IdentityP p) where - p1 \>\ p2 = \c'1 -> IdentityP ( - ((\b' -> runIdentityP (p1 b' )) - \>\ (\c'2 -> runIdentityP (p2 c'2)) ) c'1 ) - -- p1 \>\ p2 = (IdentityP .) $ runIdentityP . p1 \>\ runIdentityP . p2 - - p1 />/ p2 = \a1 -> IdentityP ( - ((\a2 -> runIdentityP (p1 a2)) - />/ (\b -> runIdentityP (p2 b )) ) a1 ) - -- p1 />/ p2 = (IdentityP .) $ runIdentityP . p1 />/ runIdentityP . p2 - -instance ProxyTrans IdentityP where - liftP = IdentityP - -instance PFunctor IdentityP where - hoistP nat = IdentityP . nat . runIdentityP - --- | Wrap a \'@K@\'leisli arrow in 'IdentityP' -identityK :: (q -> p a' a b' b m r) -> (q -> IdentityP p a' a b' b m r) -identityK k q = IdentityP (k q) --- identityK = (IdentityP .) - --- | Run an 'P' \'@K@\'leisli arrow -runIdentityK :: (q -> IdentityP p a' a b' b m r) -> (q -> p a' a b' b m r) -runIdentityK k q = runIdentityP (k q) --- runIdentityK = (runIdentityP .) diff --git a/Control/Proxy/Trans/Maybe.hs b/Control/Proxy/Trans/Maybe.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Maybe.hs +++ /dev/null @@ -1,136 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'MaybeT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Maybe ( - -- * MaybeP - MaybeP(..), - runMaybeK, - -- * Maybe operations - nothing, - just - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | The 'Maybe' proxy transformer -newtype MaybeP p a' a b' b (m :: * -> *) r - = MaybeP { runMaybeP :: p a' a b' b m (Maybe r) } - -instance (Proxy p, Monad m) - => Functor (MaybeP p a' a b' b m) where - fmap f p = MaybeP ( - runMaybeP p ?>= \m -> - return_P (case m of - Nothing -> Nothing - Just x -> Just (f x) ) ) - -- fmap f = MaybeP . fmap (fmap f) . runMaybeP - -instance (Proxy p, Monad m) - => Applicative (MaybeP p a' a b' b m) where - pure = return - - fp <*> xp = MaybeP ( - runMaybeP fp ?>= \m1 -> - case m1 of - Nothing -> return_P Nothing - Just f -> - runMaybeP xp ?>= \m2 -> - case m2 of - Nothing -> return_P Nothing - Just x -> return_P (Just (f x)) ) - -- fp <*> xp = MaybeP ((<*>) <$> (runMaybeP fp) <*> (runMaybeP xp)) - -instance (Proxy p, Monad m) - => Monad (MaybeP p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p, Monad m) - => Alternative (MaybeP p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Proxy p ) - => MonadPlusP (MaybeP p) where - mzero_P = nothing - mplus_P m1 m2 = MaybeP ( - runMaybeP m1 ?>= \ma -> - runMaybeP (case ma of - Nothing -> m2 - Just a -> just a ) ) - -instance (Proxy p, Monad m) - => MonadPlus (MaybeP p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (MaybeP p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (MaybeP p) where - liftIO_P m = MaybeP (liftIO_P (m >>= \x -> return (Just x))) - -- liftIO = MaybeP . liftIO . liftM Just - -instance (MonadIOP p, MonadIO m) - => MonadIO (MaybeP p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (MaybeP p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (MaybeP p) where - p1 >-> p2 = \c'1 -> MaybeP ( - ((\b' -> runMaybeP (p1 b')) >-> (\c'2 -> runMaybeP (p2 c'2))) c'1 ) - -- p1 >-> p2 = (MaybeP .) $ runMaybeP . p1 >-> runMaybeP . p2 - - p1 >~> p2 = \c'1 -> MaybeP ( - ((\b' -> runMaybeP (p1 b')) >~> (\c'2 -> runMaybeP (p2 c'2))) c'1 ) - -- p1 >~> p2 = (MaybeP .) $ runMaybeP . p1 >~> runMaybeP . p2 - - request = \a' -> MaybeP (request a' ?>= \a -> return_P (Just a )) - respond = \b -> MaybeP (respond b ?>= \b' -> return_P (Just b')) - - return_P = just - m ?>= f = MaybeP ( - runMaybeP m ?>= \ma -> - runMaybeP (case ma of - Nothing -> nothing - Just a -> f a ) ) - - lift_P m = MaybeP (lift_P (m >>= \x -> return (Just x))) - -- lift = MaybeP . lift . liftM Just - - hoist_P nat p = MaybeP (hoist_P nat (runMaybeP p)) - -- hoist nat = MaybeP . hoist nat . runMaybeP - -instance ProxyTrans MaybeP where - liftP p = MaybeP (p ?>= \x -> return_P (Just x)) - -- liftP = MaybeP . liftM Just - -instance PFunctor MaybeP where - hoistP nat = MaybeP . nat . runMaybeP - --- | Run a 'MaybeP' \'@K@\'leisli arrow, returning the result or 'Nothing' -runMaybeK :: (q -> MaybeP p a' a b' b m r) -> (q -> p a' a b' b m (Maybe r)) -runMaybeK p q = runMaybeP (p q) --- runMaybeK = (runMaybeP .) - --- | A synonym for 'mzero' -nothing :: (Monad m, Proxy p) => MaybeP p a' a b' b m r -nothing = MaybeP (return_P Nothing) - --- | A synonym for 'return' -just :: (Monad m, Proxy p) => r -> MaybeP p a' a b' b m r -just r = MaybeP (return_P (Just r)) diff --git a/Control/Proxy/Trans/Reader.hs b/Control/Proxy/Trans/Reader.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Reader.hs +++ /dev/null @@ -1,153 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'ReaderT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Reader ( - -- * ReaderP - ReaderP(..), - runReaderP, - runReaderK, - withReaderP, - -- * Reader operations - ask, - local, - asks, - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | The 'Reader' proxy transformer -newtype ReaderP i p a' a b' b (m :: * -> *) r - = ReaderP { unReaderP :: i -> p a' a b' b m r } - -instance (Proxy p, Monad m) - => Functor (ReaderP i p a' a b' b m) where - fmap f p = ReaderP (\i -> - unReaderP p i ?>= \x -> - return_P (f x) ) - -instance (Proxy p, Monad m) - => Applicative (ReaderP i p a' a b' b m) where - pure = return - p1 <*> p2 = ReaderP (\i -> - unReaderP p1 i ?>= \f -> - unReaderP p2 i ?>= \x -> - return_P (f x) ) - -instance (Proxy p, Monad m) - => Monad (ReaderP i p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (MonadPlusP p, Monad m) - => Alternative (ReaderP i p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlusP p ) - => MonadPlusP (ReaderP i p) where - mzero_P = ReaderP (\_ -> mzero_P) - mplus_P m1 m2 = ReaderP (\i -> mplus_P (unReaderP m1 i) (unReaderP m2 i)) - -instance (MonadPlusP p, Monad m) - => MonadPlus (ReaderP i p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (ReaderP i p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (ReaderP i p) where - liftIO_P m = ReaderP (\_ -> liftIO_P m) - -instance (MonadIOP p, MonadIO m) - => MonadIO (ReaderP i p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (ReaderP i p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (ReaderP i p) where - p1 >-> p2 = \c'1 -> ReaderP (\i -> - ((\b' -> unReaderP (p1 b' ) i) - >-> (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) - {- p1 >-> p2 = \c' -> ReaderP $ \i -> - ((`unReaderP` i) . p1 >-> (`unReaderP` i) . p2) c' -} - - p1 >~> p2 = \c'1 -> ReaderP (\i -> - ((\b' -> unReaderP (p1 b' ) i) - >~> (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) - {- p1 >~> p2 = \c' -> ReaderP $ \i -> - ((`unReaderP` i) . p1 >~> (`unReaderP` i) . p2) c' -} - - return_P = \r -> ReaderP (\_ -> return_P r) - m ?>= f = ReaderP (\i -> - unReaderP m i ?>= \a -> - unReaderP (f a) i ) - - request = \a -> ReaderP (\_ -> request a) - respond = \a -> ReaderP (\_ -> respond a) - - lift_P m = ReaderP (\_ -> lift_P m) - - hoist_P nat p = ReaderP (\i -> hoist_P nat (unReaderP p i)) - -- hoist_P nat = ReaderP . fmap (hoist_P nat) . unReaderP - -instance (Interact p) - => Interact (ReaderP i p) where - p1 \>\ p2 = \c'1 -> ReaderP (\i -> - ((\b' -> unReaderP (p1 b' ) i) - \>\ (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) - {- p1 \>\ p2 = \c' -> ReaderP $ \i -> - ((`unReaderP` i) . p1 \>\ (`unReaderP` i) . p2) c' -} - - p1 />/ p2 = \a1 -> ReaderP (\i -> - ((\b -> unReaderP (p1 b ) i) - />/ (\a2 -> unReaderP (p2 a2) i) ) a1 ) - {- p1 />/ p2 = \a -> ReaderP $ \i -> - ((`unReaderP` i) . p1 />/ (`unReaderP` i) . p2) a -} - -instance ProxyTrans (ReaderP i) where - liftP m = ReaderP (\_ -> m) - -instance PFunctor (ReaderP i) where - hoistP nat = ReaderP . (nat .) . unReaderP - --- | Run a 'ReaderP' computation, supplying the environment -runReaderP :: i -> ReaderP i p a' a b' b m r -> p a' a b' b m r -runReaderP i m = unReaderP m i - --- | Run a 'ReaderP' \'@K@\'leisli arrow, supplying the environment -runReaderK :: i -> (q -> ReaderP i p a' a b' b m r) -> (q -> p a' a b' b m r) -runReaderK i p q = runReaderP i (p q) --- runReaderK i = (runReaderP i .) - --- | Modify a computation's environment (a more general version of 'local') -withReaderP - :: (j -> i) -> ReaderP i p a' a b' b m r -> ReaderP j p a' a b' b m r -withReaderP f p = ReaderP (\i -> unReaderP p (f i)) --- withReaderP f p = ReaderP $ unReaderP p . f - --- | Get the environment -ask :: (Proxy p, Monad m) => ReaderP i p a' a b' b m i -ask = ReaderP return_P - --- | Get a function of the environment -asks :: (Proxy p, Monad m) => (i -> r) -> ReaderP i p a' a b' b m r -asks f = ReaderP (\i -> return_P (f i)) - --- | Modify a computation's environment (a specialization of 'withReaderP') -local - :: (i -> i) -> ReaderP i p a' a b' b m r -> ReaderP i p a' a b' b m r -local = withReaderP diff --git a/Control/Proxy/Trans/State.hs b/Control/Proxy/Trans/State.hs deleted file mode 100644 --- a/Control/Proxy/Trans/State.hs +++ /dev/null @@ -1,166 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'StateT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.State ( - -- * StateP - StateP(..), - runStateP, - runStateK, - evalStateP, - evalStateK, - execStateP, - execStateK, - -- * State operations - get, - put, - modify, - gets - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | The 'State' proxy transformer -newtype StateP s p a' a b' b (m :: * -> *) r - = StateP { unStateP :: s -> p a' a b' b m (r, s) } - -instance (Proxy p, Monad m) - => Functor (StateP s p a' a b' b m) where - fmap f p = StateP (\s0 -> - unStateP p s0 ?>= \(x, s1) -> - return_P (f x, s1) ) - -{- As far as I can tell, there is no way to write this using an Applicative - context -} -instance (Proxy p, Monad m) - => Applicative (StateP s p a' a b' b m) where - pure = return - p1 <*> p2 = StateP (\s0 -> - unStateP p1 s0 ?>= \(f, s1) -> - unStateP p2 s1 ?>= \(x, s2) -> - return_P (f x, s2) ) - -instance (Proxy p, Monad m) - => Monad (StateP s p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (MonadPlusP p, Monad m) - => Alternative (StateP s p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlusP p ) - => MonadPlusP (StateP s p) where - mzero_P = StateP (\_ -> mzero_P) - mplus_P m1 m2 = StateP (\s -> mplus_P (unStateP m1 s) (unStateP m2 s)) - -instance (MonadPlusP p, Monad m) - => MonadPlus (StateP s p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (StateP s p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (StateP s p) where - liftIO_P m = StateP (\s -> liftIO_P (m >>= \r -> return (r, s))) - -instance (MonadIOP p, MonadIO m) - => MonadIO (StateP s p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (StateP s p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (StateP s p) where - p1 >-> p2 = \c'1 -> StateP (\s -> - ((\b' -> unStateP (p1 b') s) >-> (\c'2 -> unStateP (p2 c'2) s)) c'1 ) - {- (p1 >-> p2) = \c' -> StateP $ \s -> - ((`unStateP` s) . p1 >-> (`unStateP` s) . p2) c' -} - - p1 >~> p2 = \c'1 -> StateP (\s -> - ((\b' -> unStateP (p1 b') s) >~> (\c'2 -> unStateP (p2 c'2) s)) c'1 ) - {- (p1 >~> p2) = \c' -> StateP $ \s -> - ((`unStateP` s) . p1 >~> (`unStateP` s) . p2) c' -} - - request = \a' -> StateP (\s -> request a' ?>= \a -> return_P (a , s)) - respond = \b -> StateP (\s -> respond b ?>= \b' -> return_P (b', s)) - - return_P = \r -> StateP (\s -> return_P (r, s)) - m ?>= f = StateP (\s -> - unStateP m s ?>= \(a, s') -> - unStateP (f a) s' ) - - lift_P m = StateP (\s -> lift_P (m >>= \r -> return (r, s))) - - hoist_P nat p = StateP (\s -> hoist_P nat (unStateP p s)) - -- hoist nat = StateP . fmap (hoist nat) . unStateP - -instance ProxyTrans (StateP s) where - liftP m = StateP (\s -> m ?>= \r -> return_P (r, s)) - -instance PFunctor (StateP s) where - hoistP nat = StateP . (nat .) . unStateP - --- | Run a 'StateP' computation, producing the final result and state -runStateP :: s -> StateP s p a' a b' b m r -> p a' a b' b m (r, s) -runStateP s m = unStateP m s - --- | Run a 'StateP' \'@K@\'leisli arrow, procuding the final result and state -runStateK :: s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m (r, s)) -runStateK s k q = unStateP (k q) s --- runStateK s = (runStateP s .) - --- | Evaluate a 'StateP' computation, but discard the final state -evalStateP - :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m r -evalStateP s p = unStateP p s ?>= \x -> return_P (fst x) --- evalStateP s = liftM fst . runStateP s - --- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final state -evalStateK - :: (Proxy p, Monad m) - => s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m r) -evalStateK s k q = evalStateP s (k q) --- evalStateK s = (evalStateP s .) - --- | Evaluate a 'StateP' computation, but discard the final result -execStateP - :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m s -execStateP s p = unStateP p s ?>= \x -> return_P (snd x) --- execStateP s = liftM snd . runStateP s - --- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final result -execStateK - :: (Proxy p, Monad m) - => s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m s) -execStateK s k q = execStateP s (k q) --- execStateK s = (execStateP s .) - --- | Get the current state -get :: (Proxy p, Monad m) => StateP s p a' a b' b m s -get = StateP (\s -> return_P (s, s)) - --- | Set the current state -put :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m () -put s = StateP (\_ -> return_P ((), s)) - --- | Modify the current state using a function -modify :: (Proxy p, Monad m) => (s -> s) -> StateP s p a' a b' b m () -modify f = StateP (\s -> return_P ((), f s)) - --- | Get the state filtered through a function -gets :: (Proxy p, Monad m) => (s -> r) -> StateP s p a' a b' b m r -gets f = StateP (\s -> return_P (f s, s)) diff --git a/Control/Proxy/Trans/Writer.hs b/Control/Proxy/Trans/Writer.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Writer.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-| This module provides the proxy transformer equivalent of 'WriterT'. - - This module is even stricter than @Control.Monad.Trans.Writer.Strict@ by - being strict in the accumulated monoid. - - The underlying implementation uses the state monad to avoid quadratic blowup - from left-associative binds. -} - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Writer ( - -- * WriterP - WriterP(..), - runWriterP, - runWriterK, - execWriterP, - execWriterK, - -- * Writer operations - tell, - censor - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(hoist)) -import Control.PFunctor (PFunctor(hoistP)) -import Control.Proxy.Class -import Control.Proxy.Trans (ProxyTrans(liftP)) -import Data.Monoid (Monoid(mempty, mappend)) - --- | The strict 'Writer' proxy transformer -newtype WriterP w p a' a b' b (m :: * -> *) r - = WriterP { unWriterP :: w -> p a' a b' b m (r, w) } - -instance (Proxy p, Monad m) - => Functor (WriterP w p a' a b' b m) where - fmap f p = WriterP (\w0 -> - unWriterP p w0 ?>= \(x, w1) -> - return_P (f x, w1) ) - -instance (Proxy p, Monad m) - => Applicative (WriterP w p a' a b' b m) where - pure = return - fp <*> xp = WriterP (\w0 -> - unWriterP fp w0 ?>= \(f, w1) -> - unWriterP xp w1 ?>= \(x, w2) -> - return_P (f x, w2) ) - -- (<*>) = ap - -instance (Proxy p, Monad m) - => Monad (WriterP w p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (MonadPlusP p, Monad m) - => Alternative (WriterP w p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (MonadPlusP p ) - => MonadPlusP (WriterP w p) where - mzero_P = WriterP (\_ -> mzero_P) - mplus_P m1 m2 = WriterP (\w -> mplus_P (unWriterP m1 w) (unWriterP m2 w)) - -instance (MonadPlusP p, Monad m) - => MonadPlus (WriterP w p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p ) - => MonadTrans (WriterP w p a' a b' b) where - lift = lift_P - -instance (MonadIOP p ) - => MonadIOP (WriterP w p) where - liftIO_P m = WriterP (\w -> liftIO_P (m >>= \r -> return (r, w))) - -instance (MonadIOP p, MonadIO m) - => MonadIO (WriterP w p a' a b' b m) where - liftIO = liftIO_P - -instance (Proxy p ) - => MFunctor (WriterP w p a' a b' b) where - hoist = hoist_P - -instance (Proxy p ) - => Proxy (WriterP w p) where - p1 >-> p2 = \c'1 -> WriterP (\w -> - ((\b' -> unWriterP (p1 b') w) >-> (\c'2 -> unWriterP (p2 c'2) w)) c'1 ) - {- p1 >-> p2 = \c' -> WriterP $ \w -> - ((`unWriterP` w) . p1 >-> (`unWriterP` w) . p2) c' -} - - p1 >~> p2 = \c'1 -> WriterP (\w -> - ((\b' -> unWriterP (p1 b') w) >~> (\c'2 -> unWriterP (p2 c'2) w)) c'1 ) - {- p1 >~> p2 = \c' -> WriterP $ \w -> - ((`unWriterP` w) . p1 >~> (`unWriterP` w) . p2) c' -} - - request = \a' -> WriterP (\w -> request a' ?>= \a -> return_P (a, w)) - respond = \b -> WriterP (\w -> respond b ?>= \b' -> return_P (b', w)) - - return_P = \r -> WriterP (\w -> return_P (r, w)) - m ?>= f = WriterP (\w -> - unWriterP m w ?>= \(a, w') -> - unWriterP (f a) w' ) - - lift_P m = WriterP (\w -> lift_P (m >>= \r -> return (r, w))) - - hoist_P nat p = WriterP (\w -> hoist_P nat (unWriterP p w)) - -- hoist_P nat = WriterP . fmap (hoist_P nat) . unWriterP - -instance ProxyTrans (WriterP w) where - liftP m = WriterP (\w -> m ?>= \r -> return_P (r, w)) - -instance PFunctor (WriterP w) where - hoistP nat = WriterP . (nat .) . unWriterP - --- | Run a 'WriterP' computation, producing the final result and monoid -runWriterP :: (Monoid w) => WriterP w p a' a b' b m r -> p a' a b' b m (r, w) -runWriterP p = unWriterP p mempty - --- | Run a 'WriterP' \'@K@\'leisli arrow, producing the final result and monoid -runWriterK - :: (Monoid w) - => (q -> WriterP w p a' a b' b m r) -> (q -> p a' a b' b m (r, w)) -runWriterK k q = runWriterP (k q) --- runWriterK = (runWriterP . ) - --- | Evaluate a 'WriterP' computation, but discard the final result -execWriterP - :: (Proxy p, Monad m, Monoid w) - => WriterP w p a' a b' b m r -> p a' a b' b m w -execWriterP m = runWriterP m ?>= \(_, w) -> return_P w --- execWriterP m = liftM snd $ runWriterP m - --- | Evaluate a 'WriterP' \'@K@\'leisli arrow, but discard the final result -execWriterK - :: (Proxy p, Monad m, Monoid w) - => (q -> WriterP w p a' a b' b m r) -> (q -> p a' a b' b m w) -execWriterK k q= execWriterP (k q) - --- | Add a value to the monoid -tell :: (Proxy p, Monad m, Monoid w) => w -> WriterP w p a' a b' b m () -tell w' = WriterP (\w -> let w'' = mappend w w' in w'' `seq` return_P ((), w'')) - --- | Modify the result of a writer computation -censor - :: (Proxy p, Monad m, Monoid w) - => (w -> w) -> WriterP w p a' a b' b m r -> WriterP w p a' a b' b m r -censor f p = WriterP (\w0 -> - unWriterP p w0 ?>= \(r, w1) -> - return_P (r, f w1) ) --- censor f = WriterP . fmap (liftM (\(r, w) -> (r, f w))) . unWriterP diff --git a/Control/Proxy/Tutorial.hs b/Control/Proxy/Tutorial.hs deleted file mode 100644 --- a/Control/Proxy/Tutorial.hs +++ /dev/null @@ -1,1890 +0,0 @@ -{-| This module provides a brief introductory tutorial in the \"Introduction\" - section followed by a lengthy discussion of the library's design and idioms. --} - -module Control.Proxy.Tutorial ( - -- * Introduction - -- $intro - - -- * Bidirectionality - -- $bidir - - -- * Type Synonyms - -- $synonyms - - -- * Request and Respond - -- $interact - - -- * Composition - -- $composition - - -- * The Proxy Class - -- $class - - -- * Interleaving Effects - -- $interleave - - -- * Mixing Base Monads - -- $hoist - - -- * Utilities - -- $utilities - - -- * Mix Monads and Composition - -- $mixmonadcomp - - -- * Folds - -- $folds - - -- * Resource Management - -- $resource - - -- * Extensions - -- $extend - - -- * Error handling - -- $error - - -- * Local state - -- $state - - -- * Branching, zips, and merges - -- $branch - - -- * Proxy Transformers - -- $proxytrans - - -- * Conclusion - -- $conclusion - ) where - --- For documentation -import Control.Category -import Control.Monad.Trans.Class -import Control.MFunctor -import Control.PFunctor -import Control.Proxy -import Control.Proxy.Core.Correct (ProxyCorrect) -import Control.Proxy.Trans.Either -import Prelude hiding (catch) - -{- $intro - The @pipes@ library replaces lazy 'IO' with a safe, elegant, and - theoretically principled alternative. Use this library if you: - - * want to write high-performance streaming programs - - * believe that lazy 'IO' was a bad idea - - * enjoy composing modular and reusable components - - * love theory and elegant code - - This library unifies many kinds of streaming abstractions, all of which are - special cases of \"proxies\" (The @pipes@ name is a legacy of one such - abstraction). - - Let's begin with the simplest 'Proxy': a 'Producer'. The following - 'Producer' lazily streams lines from a 'Handle' - -> import Control.Monad -> import Control.Proxy -> import System.IO -> -> -- Produces Strings ---+----------+ -> -- | | -> -- v v -> lines' :: (Proxy p) => Handle -> () -> Producer p String IO r -> lines' h () = runIdentityP loop where -> loop = do -> eof <- lift $ hIsEOF h -> if eof -> then return () -> else do -> str <- lift $ hGetLine h -> respond str -- Produce the string -> loop -> -> -- Ignore the 'runIdentityP' and '()' for now - - But why limit ourselves to streaming lines from some file? Why not lazily - generate values from an industrious user? - -> -- Uses 'IO' as the base monad --+ -> -- | -> -- v -> promptInt :: (Proxy p) => () -> Producer p Int IO r -> promptInt () = runIdentityP $ forever $ do -> lift $ putStrLn "Enter an Integer:" -> n <- lift readLn -- 'lift' invokes an action in the base monad -> respond n - - Now we need to hook our 'Producer's up to a 'Consumer'. The following - 'Consumer' endlessly 'request's a stream of 'Show'able values and 'print's - them: - -> -- Consumes 'a's ---+----------+ +-- Never terminates, so -> -- | | | the return value is -> -- v v v polymorphic -> printer :: (Proxy p, Show a) => () -> Consumer p a IO r -> printer () = runIdentityP $ forever $ do -> a <- request () -- Consume a value -> lift $ putStrLn "Received a value:" -> lift $ print a - - You can compose a 'Producer' and a 'Consumer' using ('>->'), which produces - a runnable 'Session': - -> -- Self-contained session ---+ +--+-- These must match -> -- | | | each component -> -- v v v -> promptInt >-> printer :: (Proxy p) => () -> Session p IO r -> -> lines' h >-> printer :: (Proxy p) => () -> Session p IO () - - ('>->') connects each 'request' in @printer@ with a 'respond' in - @lines'@ or @promptInt@. - - Finally, you use 'runProxy' to run the 'Session' and convert it back to the - base monad. First we'll try our @lines'@ 'Producer', which will stream - lines from the following file: - -> $ cat test.txt -> Line 1 -> Line 2 -> Line 3 - - The following program never brings more than a single line into memory (not - that it matters for such a small file): - ->>> withFile "test.txt" $ \h -> runProxy $ lines' h >-> printer -Received a value: -"Line 1" -Received a value: -"Line 2" -Received a value: -"Line 3" - - Similarly, we can lazily stream user input, requesting values from the user - only when we need them: - ->>> runProxy $ promptInt >-> printer :: IO r -Enter an Integer: -1 -Received a value: -1 -Enter an Integer: -5 -Received a value: -5 -... - - The last example proceeds endlessly until we hit @Ctrl-C@ to interrupt it. - - We would like to limit the number of iterations, so lets define an - intermediate 'Proxy' that behaves like a verbose 'take'. I will call it a - 'Pipe' (this library's namesake) since values flow through it: - -> 'a's flow in ---+ +--- 'a's flow out -> | | -> v v -> take' :: (Proxy p) => Int -> () -> Pipe p a a IO () -> take' n () = runIdentityP $ do -> replicateM_ n $ do -> a <- request () -> respond a -> lift $ putStrLn "You shall not pass!" - - This 'Pipe' forwards the first @n@ values it receives undisturbed, then it - outputs a cute message. You can compose it between the 'Producer' and - 'Consumer' using ('>->'): - ->>> runProxy $ promptInt >-> take' 2 >-> printer :: IO () -Enter an Integer: -9 -Received a value: -9 -Enter an Integer: -2 -Received a value: -2 -You shall not pass! - - When @take' 2@ terminates, it brings down every 'Proxy' composed with it. - - Notice how @promptInt@ behaves lazily and only 'respond's with as many - values as we 'request'. We 'request'ed exactly two values, so it only - prompts the user twice. - - We can already spot several improvements upon traditional lazy 'IO': - - * You can define your own lazy components that have nothing to do with files - - * @pipes@ never uses 'unsafePerformIO' or violates referential transparency. - - * You don't need strictness hacks to ensure the proper ordering of effects - - * You can interleave effects in downstream stages, too - - However, this library can offer even more than that! --} - -{- $bidir - So far we've only defined proxies that send information downstream in the - direction of the ('>->') arrow. However, we don't need to limit ourselves - to unidirectional communication and we can enhance these proxies with the - ability to send information upstream with each 'request' that determines - how upstream stages 'respond'. - - For example, 'Client's generalize 'Consumer's because they can supply an - argument other than @()@ with each 'request'. The following 'Client' - sends three 'request's upstream, each of which provides an 'Int' @argument@ - and expects a 'Bool' @result@: - -> Sends out 'Int's ---+ +-- Receives back 'Bool's -> | | -> v v -> threeReqs :: (Proxy p) => () -> Client p Int Bool IO () -> threeReqs () = runIdentityP $ forM_ [1, 3, 1] $ \argument -> do -> lift $ putStrLn $ "Client Sends: " ++ show (argument :: Int) -> result <- request argument -> lift $ putStrLn $ "Client Receives:" ++ show (result :: Bool) -> lift $ putStrLn "*" - - Notice how 'Client's use \"@request argument@\" instead of - \"@request ()@\". This sends \"@argument@\" upstream to parametrize the - 'request'. - - 'Server's similarly generalize 'Producer's because they receive arguments - other than @()@. The following 'Server' receives 'Int' 'request's and - 'respond's with 'Bool' values: - -> Receives 'Int's ---+ +--- Replies with 'Bool's -> | | -> v v -> comparer :: (Proxy p) => Int -> Server p Int Bool IO r -> comparer = runIdentityK loop where -> loop argument = do -> lift $ putStrLn $ "Server Receives:" ++ show (argument :: Int) -> let result = argument > 2 -> lift $ putStrLn $ "Server Sends: " ++ show (result :: Bool) -> nextArgument <- respond result -> loop nextArgument - - Notice how 'Server's receive their first argument as a parameter and bind - each subsequent argument using 'respond'. This library provides a - combinator which abstracts away this common pattern: - -> foreverK :: (Monad m) => (a -> m a) -> a -> m b -> foreverK f = loop where -> loop argument = do -> nextArgument <- f argument -> loop nextArgument -> -> -- or: foreverK f = f >=> foreverK f -> -- = f >=> f >=> f >=> f >=> ... - - We can use this to simplify the @comparer@ 'Server': - -> comparer = runIdentityK $ foreverK $ \argument -> do -> lift $ putStrLn $ "Server Receives:" ++ show argument -> let result = argument > 2 -> lift $ putStrLn $ "Server Sends: " ++ show result -> respond result - - ... which looks just like the way you might write a server's main loop in - another programming language. - - You can compose a 'Server' and 'Client' using ('>->'), and this also returns - a runnable 'Session': - -> comparer >-> threeReqs :: (Proxy p) => () -> Session p IO () - - Running this executes the client-server session: - ->>> runProxy $ comparer >-> threeReqs :: IO () -Client Sends: 1 -Server Receives: 1 -Server Sends: False -Client Receives: False -* -Client Sends: 3 -Server Receives: 3 -Server Sends: True -Client Receives: True -* -Client Sends: 1 -Server Receives: 1 -Server Sends: False -Client Receives: False -* - - 'Proxy's generalize 'Pipe's because they allow information to flow upstream. - The following 'Proxy' caches 'request's to reduce the load on the 'Server' - if the request matches a previous one: - -> import qualified Data.Map as M -> -> -- 'p' is the Proxy, as the (Proxy p) constraint indicates -> -> cache :: (Proxy p, Ord key) => key -> p key val key val IO r -> cache = runIdentityK (loop M.empty) where -> loop _map key = case M.lookup key _map of -> Nothing -> do -> val <- request key -> key2 <- respond val -> loop (M.insert key val _map) key2 -> Just val -> do -> lift $ putStrLn "Used cache!" -> key2 <- respond val -> loop _map key2 - - You can compose the @cache@ 'Proxy' between the 'Server' and 'Client' using - ('>->'): - ->>> runProxy $ comparer >-> cache >-> threeReqs -Client Sends: 1 -Server Receives: 1 -Server Sends: False -Client Receives: False -* -Client Sends: 3 -Server Receives: 3 -Server Sends: True -Client Receives: True -* -Client Sends: 1 -Used cache! -Client Receives: False -* - - This bidirectional flow of information separates @pipes@ from other - streaming libraries which are unable to model 'Client's, 'Server's, or - 'Proxy's. Using @pipes@ you can define interfaces to RPC interfaces, REST - architectures, message buses, chat clients, web servers, network protocols - ... you name it! --} - -{- $synonyms - You might wonder why ('>->') accepts 'Producer's, 'Consumer's, 'Pipe's, - 'Client's, 'Server's, and 'Proxy's. It turns out that these type-check - because they are all type synonyms that expand to the following central - type: - -> (Proxy p) => p a' a b' b m r - - Like the name suggests, a 'Proxy' exposes two interfaces: an upstream - interface and a downstream interface. Each interface can both send and - receive values: - -> Upstream | Downstream -> +---------+ -> | | -> a' <== <== b' -> | Proxy | -> a ==> ==> b -> | | -> +---------+ - - Proxies are monad transformers that enrich the base monad with the ability - to send or receive values upstream or downstream: - -> | Sends | Receives | Receives | Sends | Base | Return -> | Upstream | Upstream | Downstream | Downstream | Monad | Value -> p a' a b' b m r - - We can selectively close certain inputs or outputs to generate specialized - proxies. - - For example, a 'Producer' is a 'Proxy' that can only output values to its - downstream interface: - -> Upstream | Downstream -> +----------+ -> | | -> C <== <== () -> | Producer | -> () ==> ==> b -> | | -> +----------+ -> -> type Producer p b m r = p C () () b m r -> -> -- The 'C' type is uninhabited, so it 'C'loses an output end - - A 'Consumer' is a 'Proxy' that can only receive values on its upstream - interface: - -> Upstream | Downstream -> +----------+ -> | | -> () <== <== () -> | Consumer | -> a ==> ==> C -> | | -> +----------+ -> -> type Consumer p a m r = p () a () C m r - - A 'Pipe' is a 'Proxy' that can only receive values on its upstream interface - and send values on its downstream interface: - -> Upstream | Downstream -> +--------+ -> | | -> () <== <== () -> | Pipe | -> a ==> ==> b -> | | -> +--------+ -> -> type Pipe p a b m r = p () a () b m r - - When we compose proxies, the type system ensures sure that their input and - output types match: - -> promptInt >-> take' 2 >-> printer -> -> +-----------+ +---------+ +---------+ -> | | | | | | -> C <== <== () <== <== () <== <== () -> | | | | | | -> | promptInt | | take' 2 | | printer | -> | | | | | | -> () ==> ==> Int ==> ==> Int ==> ==> C -> | | | | | | -> +-----------+ +---------+ +---------+ - - Composition fuses these into a new 'Proxy' that has both ends closed, which - is a 'Session': - -> +-----------------------------------+ -> | | -> C <== <== () -> | | -> | promptInt >-> take' 2 >-> printer | -> | | -> () ==> ==> C -> | | -> +-----------------------------------+ -> -> type Session p m r = p C () () C m r - - A 'Client' is a 'Proxy' that only uses its upstream interface: - -> Upstream | Downstream -> +----------+ -> | | -> a' <== <== () -> | Client | -> a ==> ==> C -> | | -> +----------+ -> -> type Client p a' a m r = p a' a () C m r - - A 'Server' is a 'Proxy' that only uses its downstream interface: - - -> Upstream | Downstream -> +----------+ -> | | -> C <== <== b' -> | Server | -> () ==> ==> b -> | | -> +----------+ -> -> type Server p b' b m r = p C () b' b m r - - The compiler ensures that the types match when we compose 'Server's, - 'Proxy's, and 'Client's. - -> comparer >-> cache >-> threeReqs -> -> +----------+ +-------+ +-----------+ -> | | | | | | -> C <== <== Int <== <== Int <== <== () -> | | | | | | -> | comparer | | cache | | threeReqs | -> | | | | | | -> () ==> ==> Bool ==> ==> Bool ==> ==> C -> | | | | | | -> +----------+ +-------+ +-----------+ - - This similarly fuses into a 'Session': - -> +----------------------------------+ -> | | -> C <== <== () -> | | -> | comparer >-> cache >-> threeReqs | -> | | -> () ==> ==> C -> | | -> +----------------------------------+ - - @pipes@ encourages substantial code reuse by implementing all abstractions - as type synonyms on top of a single type class: 'Proxy'. This makes your - life easier because: - - * You only use one composition operator: ('>->') - - * You can mix multiple abstractions together as long as the types match --} - -{- $interact - There are only two ways to interact with other proxies: 'request' and - 'respond'. Let's examine their type signatures to understand how they - work: - -> request :: (Monad m, Proxy p) => a' -> p a' a b' b m a -> ^ ^ -> | | -> Argument --+ Result --+ - - 'request' sends an argument of type @a'@ upstream, and binds a result of - type @a@. Whenever you 'request', you block until upstream 'respond's with - a value. - - -> respond :: (Monad m, Proxy p) => b -> p a' a b' b m b' -> ^ ^ -> | | -> Result --+ Next Argument --+ - - 'respond' replies with a result of type @b@, and then binds the /next/ - argument of type @b'@. Whenever you 'respond', you block until downstream - 'request's a new value. - - Wait, if 'respond' always binds the /next/ argument, where does the /first/ - argument come from? Well, it turns out that every 'Proxy' receives this - initial argument as an ordinary parameter, as if they all began blocked on - a 'respond' statement. - - We can see this if we take all the previous proxies we defined and fully - expand every type synonym. The initial argument of each 'Proxy' matches - the type parameter corresponding to the return value of 'respond': - -> These -> +-- Columns ---+ -> | Match | -> v v -> promptInt :: (Proxy p) => () -> p C () () Int IO r -> printer :: (Proxy p, Show a) => () -> p () a () C IO r -> take' :: (Proxy p) => Int -> () -> p () a () a IO () -> comparer :: (Proxy p) => Int -> p C () Int Bool IO r -> cache :: (Proxy p, Ord key) => key -> p key val key val IO r - - You can also study the type of composition, which follows this same pattern. - Composition requires two 'Proxy's blocked on a 'respond', and produces a new - 'Proxy' similarly blocked on a 'respond': - -> (>->) :: (Monad m, Proxy p) -> => (b' -> p a' a b' b m r) -> -> (c' -> p b' b c' c m r) -> -> (c' -> p a' a c' c m r) -> ^ ^ -> | These | -> +---Match----+ - - This is why 'Producer's, 'Consumer's, and 'Client's all take @()@ as their - initial argument, because their corresponding 'respond' commands all have a - return value of @()@. - - This library also provides ('>~>'), which is the dual of the ('>->') - composition operator. ('>~>') composes two 'Proxy's blocked on a 'request' - and returns a new 'Proxy' blocked on a 'request': - -> (>~>) -> :: (Monad m, Proxy p) -> => (a -> p a' a b' b m r) -> -> (b -> p b' b c' c m r) -> -> (a -> p a' a c' c m r) - - Conceptually, ('>->') composes pull-based systems and ('>~>') composes - push-based systems. - - In fact, if you went back through the previous code and systematically - replaced every: - - * ('>->') with ('>~>'), - - * 'respond' with 'request', and - - * 'request' with 'respond' - - ... then everything would still work and produce identical behavior, except - the compiler would now infer the symmetric types with all interfaces - reversed. We can therefore conclude the obvious: pull-based systems are - symmetric to push-based systems. - - Since these two composition operators are perfectly symmetric, I arbitrarily - standardize on using ('>->') and I provide all standard library proxies - blocked on 'respond' so that they work with ('>->'). This gives behavior - more familiar to Haskell programmers that work with lazy pull-based - functions. I only include the ('>~>') composition operator for theoretical - completeness. --} - -{- $composition - When we compose @(p1 >-> p2)@, composition ensures that @p1@'s downstream - interface matches @p2@'s upstream interface. This follows from the type of - ('>->'): - -> (>->) :: (Monad m, Proxy p) -> => (b' -> p a' a b' b m r) -> -> (c' -> p b' b c' c m r) -> -> (c' -> p a' a c' c m r) - - Diagramatically, this looks like: - -> p1 >-> p2 -> -> +--------+ +--------+ -> | | | | -> a' <== <== b' <== <== c' -> | p1 | | p2 | -> a ==> ==> b ==> ==> c -> | | | | -> +--------+ +--------+ - - @p1@'s downstream @(b', b)@ interface matches @p2@'s upstream @(b', b)@ - interface, so composition connects them on this shared interface. This - fuses away the @(b', b)@ interface, leaving behind @p1@'s upstream @(a', a)@ - interface and @p2@'s downstream @(c', c)@ interface: - -> +-----------------+ -> | | -> a' <== <== c' -> | p1 >-> p2 | -> a ==> ==> c -> | | -> +-----------------+ - - Proxy composition has the very nice property that it is associative, meaning - that it behaves the exact same way no matter how you group composition: - -> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) - - ... so you can safely elide the parentheses: - -> p1 >-> p2 >-> p3 - - Also, we can define a \'@T@\'ransparent 'Proxy' that auto-forwards values - both ways: - -> idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r -> idT = runIdentityK loop where -> loop a' = do -> a <- request a' -> a'2 <- respond a -> loop a'2 -> -> -- or: idT = runIdentityK $ foreverK $ request >=> respond -> -- = runIdentityK $ request >=> respond >=> request >=> respond ... - - Diagramatically, this looks like: - -> +-----+ -> | | -> a' <======== a' <- All values pass -> | idT | straight through -> a ========> a <- immediately -> | | -> +-----+ - - Transparency means that: - -> idT >-> p = p -> -> p >-> idT = p - - In other words, 'idT' is an identity of composition. - - This means that proxies form a true 'Category' where ('>->') is composition - and 'idT' is the identity. The associativity law and the two - identity laws are just the 'Category' laws. The objects of the category are - the 'Proxy' interfaces. - - These 'Category' laws guarantee the following important properties: - - * You can reason about each proxy's behavior independently of other proxies - - * You don't encounter weird behavior at the interface between two components - - * You don't encounter corner cases at the 'Server' or 'Client' ends of a - 'Session' --} - -{- $class - All the proxy code we wrote was generic over the 'Proxy' type class, which - defines the three central operations of this library's API: - - * ('>->'): Proxy composition - - * 'request': Request input from upstream - - * 'respond': Respond with output to downstream - - @pipes@ defines everything in terms of these three operations, which is - why all the library's utilities are polymorphic over the 'Proxy' type class. - - Let's look at some example instances of the 'Proxy' type class: - -> instance Proxy ProxyFast -- Fastest implementation -> instance Proxy ProxyCorrect -- Strict monad transformer laws - - These two types provide the two alternative base implementations: - - * 'ProxyFast': This runs significantly faster on pure code segments and - employs several rewrite rules to optimize your code into the equivalent - hand-tuned code. - - * 'ProxyCorrect': This uses a monad transformer implementation that is - correct by construction, but runs about 8x slower on pure code segments. - However, for 'IO'-bound code, the performance gap is small. - - These two implementations differ only in the 'runProxy' function that they - export, which is how the compiler selects which 'Proxy' implementation to - use. - - "Control.Proxy" automatically selects the fast implementation for you, but - you can always choose the correct implementation instead by replacing - "Control.Proxy" with the following two imports: - -> import Control.Proxy.Core -- Everything except the base implementation -> import Control.Proxy.Core.Correct -- The alternative base implementation - - These are not the only instances of the 'Proxy' type class! This library - also provides several \"proxy transformers\", which are like monad - transformers except that they also correctly lift the 'Proxy' type class: - -> instance (Proxy p) => Proxy (IdentityP p) -> instance (Proxy p) => Proxy (EitherP e p) -> instance (Proxy p) => Proxy (MaybeP p) -> instance (Proxy p) => Proxy (ReaderP i p) -> instance (Proxy p) => Proxy (StateP s p) -> instance (Proxy p) => Proxy (WriterP w p) - - All of the 'Proxy' code we wrote so far also works seamlessly with all of - these proxy transformers. The 'Proxy' class abstracts over the - implementation details and extensions so that you can reuse the same library - code for any feature set. - - This polymorphism comes at a price: you must embed your 'Proxy' code in at - least one proxy transformer if you want clean type class constraints. If - you don't use extensions then you embed your code in the identity proxy - transformer: 'IdentityP'. This is why all the examples use 'runIdentityP' - or 'runIdentityK' to embed their code in 'IdentityP'. "Control.Proxy.Class" - provides a longer discussion on this subject. - - Without this 'IdentityP' embedding, the compiler infers uglier constraints, - which are also significantly less polymorphic. We can show this by - removing the 'runIdentityP' call from @promptInt@ and see what type the - compiler infers: - -> promptInt () = forever $ do -> lift $ putStrLn "Enter an Integer:" -> n <- lift readLn -> respond n - ->>> :t promptInt -- I've substantially cleaned up the inferred type -promptInt - :: (Monad (Producer p Int IO), MonadTrans (Producer p Int), Proxy p) => - () -> Producer p Int IO r - - All 'Proxy' instances are already monads and monad transformers, but the - compiler cannot infer that without the 'IdentityP' embedding. When we embed - @promptInt@ in 'IdentityP', the compiler collapses the 'Monad' and - 'MonadTrans' constraints into the 'Proxy' constraint. - - Fortunately, you do not pay any performance price for this 'IdentityP' - embedding or the type class polymorphism. Your polymorphic code will still - run very rapidly, as fast as if you had specialized it to a concrete - 'Proxy' instance without the 'IdentityP' embedding. I've taken great care - to ensure that all optimizations and rewrite rules always see through these - abstractions without any assistance on your part. --} - -{- $interleave - When you compose two proxies, you interleave their effects in the base - monad. The following two proxies demonstrate this interleaving of effects: - -> downstream :: (Proxy p) => Consumer p () IO () -> downstream () = runIdentityP $ do -> lift $ print 1 -> request () -- Switch to upstream -> lift $ print 3 -> request () -- Switch to upstream -> -> upstream :: (Proxy p) => Producer p () IO () -> upstream () = runIdentityP $ do -> lift $ print 2 -> respond () -- Switch to downstraem -> lift $ print 4 - - "Control.Proxy.Class" enumerates the 'Proxy' laws, which equationally - define how all 'Proxy' instances must behave. These laws require that - @(upstream >-> downstream)@ must reduce to the following: - -> upstream >-> downstream -- This is true no matter what feature -> = -- set or 'Proxy' instance you select -> \() -> lift $ do -> print 1 -> print 2 -> print 3 -> print 4 - - Conceptually, 'runProxy' just applies this to @()@ and removes the 'lift': - -> runProxy $ upstream >-> downstream -> = -> do print 1 -> print 2 -> print 3 -> print 4 - - Let's test this: - ->>> runProxy $ upstream >-> downstream -1 -2 -3 -4 - - The 'Proxy' laws let you reason about how proxies interleave effects without - knowing any specifics about the underlying implementation. Intuitively, the - 'Proxy' laws say that: - - * 'request' blocks until upstream 'respond's - - * 'respond' blocks until downstream 'request's - - * If a 'Proxy' terminates, it terminates every 'Proxy' composed with it - - Several of the utilities in "Control.Proxy.Prelude.Base" use these - equational laws to rigorously prove things about their behavior. For - example, consider the 'mapD' proxy, which applies a function @f@ to all - values flowing downstream: - -> mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r -> mapD f = runIdentityK loop where -> loop x = do -> a <- request x -> x2 <- respond (f a) -> loop x2 -> -> -- or: mapD f = runIdentityK $ foreverK $ request >=> respond . f - - We can use the 'Proxy' laws to prove that: - -> mapD f >-> mapD g = mapD (g . f) -> -> mapD id = idT - - ... which is what we expect. We can fuse two consecutive 'mapD's into one - by composing their functions, and mapping 'id' does nothing at all, just - like the identity proxy: 'idT'. - - In fact, these are just the functor laws in disguise, where 'mapD' defines a - functor between the category of Haskell function composition and the - category of 'Proxy' composition. "Control.Proxy.Prelude.Base" is full of - utilities like this that are simultaneously practical and theoretically - elegant. --} - -{- $hoist - Composition can't interleave two proxies if their base monads do not - match. For instance, I might try to modify @promptInt@ to use - @EitherT String@ to report the error instead of using exceptions: - -> import Control.Monad.Trans.Either -- from the "either" package -> import Safe (readMay) -> -> promptInt2 :: (Proxy p) => () -> Producer p Int (EitherT String IO) r -> promptInt2 () = runIdentityP $ forever $ do -> str <- lift $ lift $ do -> putStrLn "Enter an Integer:" -> getLine -> case readMay str of -> Nothing -> lift $ left "Could not read Integer" -> Just n -> respond n - - However, if I try to compose it with @printer@, I receive a type error: - ->>> runEitherT $ runProxy $ promptInt2 >-> printer -:2:40: - Couldn't match expected type `EitherT String IO' - with actual type `IO' - ... - - The type error says that @promptInt2@ uses @(EitherT String IO)@ for its - base monad, but @printer@ uses 'IO' for its base monad, so composition can't - interleave their effects. - - You can easily fix this using the 'hoist' function from the 'MFunctor' type - class in "Control.MFunctor", which transforms the base monad of any monad - transformer, including the 'Proxy' monad transformer. "Control.MFunctor" - really belongs in the @transformers@ package, however it currently resides - here because it requires the @Rank2Types@ extension. - - You will commonly use 'hoist' to 'lift' one proxy's base monad to match - another proxy's base monad, like so: - ->>> runEitherT $ runProxy $ promptInt2 >-> (hoist lift . printer) -Enter an Integer: -Hello -Left "Could not read Integer" - - This library provides three syntactic conveniences for making this easier to - write. - - First, ('.') has higher precedence than ('>->'), so you can drop the - parentheses: - ->>> runEitherT $ runProxy $ promptInt2 >-> hoist lift . printer -... - - Second, "lift" is such a common argument to 'hoist' that "Control.MFunctor" - provides the 'raise' function: - -> raise = hoist lift - ->>> runEitherT $ runProxy $ promptInt2 >-> raise . printer -... - - Third, "Control.Proxy.Prelude.Kleisli" provides the 'hoistK' and 'raiseK' - functions in case you think composition looks ugly: - -> hoistK f = (hoist f .) -> -> raiseK = (raise .) - ->>> runEitherT $ runProxy $ promptInt2 >-> raiseK printer -... - - Note that "Control.MFunctor" also provides 'MFunctor' instances for all the - monad transformers in the @transformers@ package. This means that you can - fix any incompatibility between two monad transformer stacks just using - various combinations of 'hoist' and 'lift'. - - To see how, consider the following contrived pathological example where I - want to mix two very different monad transformer stacks: - -> m1 :: StateT s (ReaderT i IO) r -> m2 :: MaybeT (WriterT w IO) r - - I can interleave their transformers through judicious use of 'hoist' and - 'lift' - -> mBoth :: StateT s (MaybeT (ReaderT i (WriterT w IO))) r -> mBoth = do -> hoist (lift . hoist lift) m1 -> lift (hoist lift m2) --} - -{- $utilities - The "Control.Proxy.Prelude" heirarchy provides several utility functions - for common tasks. We can redefine the previous example functions just by - composing these utilities. - - For example, 'readLnS' reads values from user input, so we can read 'Int's - just by specializing its type: - -> readLnS :: (Proxy p, Read a) => () -> Producer p a IO r -> -> readIntS :: (Proxy p) => () -> Producer p Int IO r -> readIntS = readLnS - - The @S@ suffix indicates that it belongs in the \'@S@\'erver position. - - @(takeB_ n)@ allows at most @n@ value to pass through it in \'@B@\'oth - directions: - -> takeB_ :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m () - - 'takeB_' has a more general type than @take'@ because it allows any type of - value to flow upstream. - - 'printD' prints all values flowing \'@D@\'ownstream: - -> printD :: (Proxy p, Show a) => x -> p x a x a IO r - - 'printD' has a more general type than our original @printer@ because it - forwards all values further downstream after 'print'ing them. This means - that you could use it as an intermediate stage as well. However, 'printD' - still type-checks as the most downstream stage, too, since 'runProxy' just - discards any unused outbound values. - - These utilities do not clash with the Prelude namespace or common libraries - because they all end with a capital letter suffix that indicates their - directionality: - - * \'@D@\' suffix: interacts with values flowing \'@D@\'ownstream - - * \'@U@\' suffix: interacts with values flowing \'@U@\'pstream - - * \'@B@\' suffix: interacts with values flowing \'@B@\'oth ways (or: - \'@B@\'idirectional) - - * \'@S@\' suffix: belongs furthest upstream in the \'@S@\'erver position - - * \'@C@\' suffix: belongs furthest downstream in the \'@C@\'lient position - - We can assemble these functions into a silent version of our previous - 'Session': - ->>> runProxy $ readIntS >-> takeB_ 2 >-> printD -4 -4 -39 -39 - - Fortunately, we don't have to give up our previous useful diagnostics. - We can use 'execU', which executes an action each time values flow upstream - through it, and 'execD', which executes an action each time values flow - downstream through it: - -> promptInt :: (Proxy p) => () -> Producer p Int IO r -> promptInt = readLnS >-> execU (putStrLn "Enter an Integer:") -> -> printer :: (Proxy p, Show a) => x -> p x a x a IO r -> printer = execD (putStrLn "Received a value:") >-> printD - - Similarly, we can build our old @take'@ on top of 'takeB_': - -> take' :: (Proxy p) => Int -> a' -> p a' a a' a m () -> take' n a' = runIdentityP $ do -- Remember, we need 'runIdentityP' if -> takeB_ n a' -- we use 'do' notation or 'lift' -> lift $ putStrLn "You shall not pass!" - ->>> runProxy $ promptInt >-> take' 2 >-> printer - - - Or perhaps I want to skip user input for testing and mock @promptInt@ by - replacing it with a predefined set of values: - ->>> runProxy $ fromListS [4, 37, 1] >-> take'2 >-> printer -Received a value: -4 -Received a value: -37 - - What about our original @lines@ function? That's just 'hGetLineS': - -> hGetLineS :: (Proxy p) => Handle -> () -> Producer p String IO () - - You could hand-write loops that accomplish these same tasks, but proxies let - you: - - * Rapidly swap in and out components for testing, debugging, and fast - prototyping - - * Factor out common patterns into modular components - - * Mix and match simple stages to build sophisticated programs - - This compositional programming style emphasizes building a library of - reusable components and connecting them like Unix pipes to assemble the - desired streaming program. --} - -{- $mixmonadcomp - Composition isn't the only way to assemble proxies. You can also sequence - predefined proxies using @do@ notation to generate more elaborate behaviors. - - Most commonly, you will sequence two sources to combine their outputs, very - similar to how the Unix @cat@ utility behaves: - -> threeSources () = do -> source1 () -> source2 () -> source3 () -> -> -- or: threeSources = source1 >=> source2 >=> source3 - - As a concrete example, we could create a 'Producer' where our first source - presets the first few values and then we let the user take over to generate - the remaining values: - -> source1 :: (Proxy p) => () -> Producer p Int IO r -> source1 () = runIdentityP $ do -> fromListS [4, 4] () -- Source 1 -> readLnS () -- Source 2 -> -> -- or: source1 = runIdentityK (fromListS [4, 4] >=> readLnS) - ->>> runProxy $ source1 >-> printD -4 -4 -70 -70 -34 -34 -... - - What if we only want the user to provide three values? We can - selectively throttle it with 'takeB_': - -> source2 :: (Proxy p) => () -> Producer p Int IO () -> source2 () = runIdentityP $ do -> fromListS [4, 4] () -> (readLnS >-> takeB_ 3) () -- You can compose inside a do block! -> -> -- or: source2 = runIdentityK (fromListS [4, 4] >=> (readLnS >-> takeB_ 3)) - - Notice that composition works inside of a @do@ block! This is a very handy - trick! - ->>> runProxy $ source2 >-> printD -4 -4 -56 -56 -41 -41 -80 -80 - - You can also concatenate sinks, too: - -> sink1 :: (Proxy p) => () -> Consumer p Int IO () -> sink1 () = do -> (takeB_ 3 >-> printD) () -- Sink 1 -> (takeWhileD (< 4) >-> printD) () -- Sink 2 -> -> -- or: sink1 = (takeB_ 3 >-> printD) >=> (takeWhileD (< 4) >-> printD) - ->>> runProxy $ source2 >-> sink1 -4 -- The first sink -4 -- handles these -68 -- -68 -1 -- The second sink -1 -- handles these -5 -- - - ... but the above example is gratuitous because you can simply concatenate - the intermediate stages: - -> sink2 :: (Proxy p) => () -> Consumer p Int IO () -> sink2 () = intermediate >-> printD where -> intermediate () = do -> takeB_ 3 () -- Intermediate stage 1 -> takeWhileD (< 4) -- Intermediate stage 2 -> -> -- or: sink2 = (takeB_ 3 >=> takeWhileD (< 4)) >-> printD - ->>> runProxy $ source2 >-> sink2 - - - These examples demonstrate the two principal ways to combine proxies: - - * \"Vertical\" composition, using ('>=>') from the Kleisli category - - * \"Horizontal\" composition: using ('>->') from the Proxy category - - You assemble most proxies simply by composing them in one or both of these - two categories. --} - -{- $folds - You can fold a stream of values in two ways, both of which use the base - monad: - - * Use 'WriterT' in the base monad and 'tell' the values to fold - - * Use 'StateT' in the base monad and 'put' strict values - - 'WriterT' is more elegant in principle but leaks space for a large number of - values to fold. 'StateT' does not leak space if you keep the accumulator - strict, but is less elegant and doesn't guarantee write-only behavior. To - remedy this, I am currently working on a stricter 'WriterT' implementation - that does not leak space to add to the @transformers@ package. - - "Control.Proxy.Prelude.Base" provides several common folds using 'WriterT' - as the base monad, such as: - - * 'lengthD': Count how many values flow downstream - -> lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r - - * 'toListD': Fold the values flowing downstream into a list. - -> toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r - - * 'anyD': Determine whether any values satisfy the predicate - -> anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r - - These 'WriterT' versions demonstrate how the elegant approach should work in - principle and they should be okay for folding a medium number of values - until I release the fixed 'WriterT'. If space leaks cause problems, you can - temporarily rewrite the 'WriterT' folds using the following two strict - 'StateT' folds: - - * 'foldlD'': Strictly fold values flowing downstream - -> foldlD' -> :: (Monad m, Proxy p) => (b -> a -> b) -> x -> p x a x a (StateT b m) r - - * 'foldlU'': Strictly fold values flowing upstream - -> foldU' -> :: (Monad m, Proxy p) => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r - - Now, let's try these folds out and see if we can build a list from user - input: - ->>> runWriterT $ runProxy $ raiseK promptInt >-> takeB_ 3 >-> toListD -Enter an Integer: -1 -Enter an Integer: -66 -Enter an Integer: -5 -((), [1, 66, 5]) - - Notice that @promptInt@ uses 'IO' as its base monad, but 'toListD' uses - @(WriterT [Int] m)@ as its base monad, so I use 'raiseK' to get the base - monads to match. - - You can insert these folds anywhere in the middle of a pipeline and they - still work: - ->>> runWriterT $ runProxy $ fromListS [5, 7, 4] >-> lengthD >-> raiseK printD -5 -7 -4 -((), Sum 3) - - You can also run multiple folds at the same time just by adding more - 'WriterT' layers to your base monad: - ->>> runWriterT $ runWriterT $ fromListS [9, 10] >-> anyD even >-> raiseK sumD -(((), Any {getAny = True},Sum {getSum = 19}) - - I designed certain special folds to terminate the 'Session' early if they - can compute their result prematurely, in order to draw as little input as - possible. These folds end with an underscore, such as 'headD_', which - terminates the stream once it receives an input: - -> headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () - ->>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD_ -3 -((), First {getFirst = Just 3}) - - Compare this to 'headD' without underscore, which folds the entire input: - ->>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD -3 -4 -9 -((), First {getFirst = Just 3}) - - Use the versions that don't prematurely terminate if you are running - multiple folds or if you want to continue to use the rest of the input when - the fold is done. Use the versions that do prematurely terminate if - collecting that single fold is the entire purpose of the session. --} - -{- $resource - This core library provides utilities for lazily streaming from resources, - but does not provide utilities for lazily managing resource allocation and - deallocation. To frame the problem, let's assume that we try to be clever - and write a streaming utility that lazily opens a file only in response to - a 'request', such as the following 'Producer': - -> readFile' :: FilePath -> () -> Producer p String IO -> readFile' file () = runIdentityP $ do -> h <- lift $ openFile file ReadMode -> lift $ putStrLn "Opening file" -> hGetLineS h () -> lift $ putStrLn "Closing file" -> lift $ hClose h - - This works well if we fully demand the file: - ->>> runProxy $ readFile' "test.txt" >-> printD -Opening file -"Line 1" -"Line 2" -"Line 3" -Closing file - - This also works well if we never demand the file at all, in which case we - never open it: - ->>> runProxy $ readFile' "test.txt" >-> return --- Outputs nothing - - But it gives exactly the wrong behavior if we partially demand the file: - ->>> runProxy $ readFile' "test.txt" >-> takeB_ 1 >-> printD -Opening file -"Line 1" - - Notice that this does not close the file, because once @takeB_ 1@ terminates - it terminates the entire 'Session' and @readFile'@ does not get a chance to - finalize the file. - - I will release a separate library in the near future that offers lazy - resource management, too, but in the meantime I advise that you use one of - the following two strategies to guarantee deterministic resource - deallocation. - - The first approach opens all resources before running the session and close - them all afterward. For example, if I wanted to emulate the Unix @cp@ - command, streaming one line at a time, I would write: - -> import System.IO -> -> cp :: FilePath -> FilePath -> IO () -> cp inFile outFile = -> withFile file1 ReadMode $ \hIn -> -> withFile file2 WriteMode $ \hOut -> -> runProxy $ hGetLineS hIn >-> hPutLineS hOut2 - - The advantage of this approach is that it: - - * is straightforward, - - * requires no special integration with existing libraries, and - - * is exception safe. - - The disadvantage is that this does not lazily allocate resources, nor does - this promptly deallocate them. - - The second approach is to use something like 'ResourceT' (from the - @resourceT@ package) to register finalizers and ensure they get released - deterministically. You may prefer this approach if you have previously used - the @conduit@ library, which uses 'ResourceT' in its base monad to offer - resource determinism. You can use 'ResourceT' with @pipes@, too, just by - including it in the base monad. - - I plan to release a lazy resource management library very soon built on top - of @pipes@ that behaves similarly to 'ResourceT'. The main advantages of - this upcoming implementation will be that it: - - * uses a simpler and pure implementation - - * obeys several useful theoretical laws - - * requires no dependencies other than @pipes@ - - However, if you don't need this extra power, then just stick to the former - simpler approach. I plan to release all standard libraries to be agnostic - of the finalization approach to let you use which one you prefer. --} - -{- $extend - This library provides several extensions that add features on top of the - base 'Proxy' API. These extensions behave like monad transformers, except - that they also lift the 'Proxy' class through the extension so that the - extended proxy can still 'request', 'respond', compose with other proxies: - -> instance (Proxy p) => Proxy (IdentityP p) -- Equivalent to IdentityT -> instance (Proxy p) => Proxy (EitherP e p) -- Equivalent to EitherT -> instance (Proxy p) => Proxy (MaybeP p) -- Equivalent to MaybeT -> instance (Proxy p) => Proxy (StateP s p) -- Equivalent to StateT -> instance (Proxy p) => Proxy (WriterP w p) -- Equivalent to WriterT - - Each of these proxy transformers provides the same API as the equivalent - monad transformer (sometimes even more). The following sections show some - common problems that these proxy transformers solve. --} - -{- $error - - Our previous @promptInt@ example suffered from one major flaw: - -> promptInt2 :: (Proxy p) => () -> Producer p Int (EitherT String IO) r -> promptInt2 () = runIdentityP $ forever $ do -> str <- lift $ lift $ do -> putStrLn "Enter an Integer:" -> getLine -> case readMay str of -> Nothing -> lift $ left "Could not read Integer" -> Just n -> respond n - - There is no way to recover from the error and resume streaming data. You - can only handle 'Left' value after using 'runProxy', but by then it is too - late. - - We can solve this by switching the order of the two monad transformers, but - using 'EitherP' this time instead of 'EitherT': - -> import qualified Control.Proxy.Trans.Either as E -> -> -- Proxy transformers play -> -- nice with type synonyms --+ -> -- | -> -- v -> promptInt3 :: (Proxy p) => () -> Producer (E.EitherP String p) Int IO r -> -- i.e. (Proxy p) => () -> EitherP String p C () () Int IO r -> -> promptInt3 () = forever $ do -> str <- lift $ do -> putStrLn "Enter an Integer:" -> getLine -> case readMay str of -> Nothing -> E.throw "Could not read Integer" -> Just n' -> respond n - - This example does not need 'runIdentityP' (nor would that type-check) - because the 'EitherP' proxy transformer gives the compiler enough - information to generalize the constraints. - - We've swapped the order of the transformers, so now we use 'runEitherK' - first to unwrap the 'EitherP' followed by 'runProxy'. - -> runEitherK -> :: (q -> EitherP p a' a b' b m r) -> (q -> p a' a b' b m (Either e r)) - ->>> runProxy $ runEitherK $ promptInt3 >-> printer :: IO (Either String r) -Enter an Integer: -Hello -Left "Could not read Integer" - - Notice how we can directly compose @printer@ with @promptInt@. - This works because @printer@'s base proxy type is completely polymorphic - over the 'Proxy' type class and doesn't use any features specific to any - proxy transformers: - -> 'p' type-checks as anything --+ -> that implements 'Proxy' | -> v -> printer :: (Proxy p, Show a) => () -> Consumer p a IO r - - This means that you can compose @printer@ with anything that implements the - 'Proxy' type class, including 'EitherP', without any lifting. - - 'EitherP' lets us catch and handle errors locally without disturbing other - proxies. For example, I can define a heartbeat function that just restarts - a given proxy each time it raises an error: - -> heartbeat -> :: (Proxy p) -> => E.EitherP String p a' a b' b IO r -> -> E.EitherP String p a' a b' b IO r -> heartbeat p = p `E.catch` \err -> do -> lift $ putStrLn err -- Print the error -> heartbeat p -- Restart 'p' - - This uses the 'catch' function from "Control.Proxy.Trans.Either", which - lets you catch and handle errors locally without disturbing other proxies. - ->>> runProxy $ E.runEitherK $ (heartbeat . promptInt3) >-> takeB_ 2 >-> printer -Enter an Integer: -Hello -Could not read Integer -Enter an Integer -8 -Received a value: -8 -Enter an Integer -0 -Received a value: -0 - - It's very easy to prove that 'EitherP' has only a local effect. In fact, - we can run it entirely locally like so: - ->>> runProxy $ (E.runEitherK $ heartbeat . promptInt3) >-> takeB_ 2 >-> printer - - Proxy transformers do not use the base monad at all, so you can use them to - isolate effects from other proxies, as the next section demonstrates. --} - -{- $state - The 'StateP' proxy lets you embed local state into any 'Proxy' computation. - For example, we might want to gratuitously use state to generate successive - numbers: - -> import qualified Control.Proxy.Trans.State as S -> -> increment :: (Monad m, Proxy p) => () -> Producer (S.StateP Int p) Int m r -> increment () = forever $ do -> n <- S.get -> respond n -> S.put (n + 1) - - We could then embed it locally into any 'Proxy', such as the following one: - -> numbers :: (Monad m, Proxy p) => () -> Producer p Int m () -> numbers () = runIdentityP $ do -> (takeB_ 5 <-< S.evalStateK 10 increment) () -> S.evalStateK 1 (takeB_ 3 <-< increment) () -- This works, too! - ->>> runProxy $ numbers >-> printD -10 -11 -12 -13 -14 -1 -2 -3 - - We can also prove the effect is local even when you directly compose two - 'StateP' proxies before running them. Let's define a stateful consumer: - -> increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r -> increment2 () = forever $ do -> nOurs <- S.get -> nTheirs <- request () -> lift $ print (nTheirs, nOurs) -> S.put (nOurs + 2) - - .. and hook it up directly to @increment@: - ->>> runProxy $ S.evalStateK 0 $ increment >-> takeB_ 3 >-> increment2 -(0, 0) -(1, 2) -(2, 4) - - They each share the same initial state, but they isolate their own side - effects completely from each other. --} - -{- $branch - So far we've only considered linear chains of proxies, but @pipes@ allows - you to branch these chains and generate more sophisticated topologies. The - trick is to simply nest the 'Proxy' monad transformer within itself. - - For example, if I want to zip two inputs, I can just define the following - triply nested proxy: - -> zipD -> :: (Monad m, Proxy p1, Proxy p2, Proxy p3) -> => () -> Consumer p1 a (Consumer p2 b (Consumer p3 (a, b) m)) r -> zipD = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do -> -- Yes, this 'runIdentityP' mess is necessary. Sorry! -> -> a <- request () -- Request from the outer 'Consumer' -> b <- lift $ request () -- Request from the inner 'Consumer' -> lift $ lift $ respond (a, b) -- Respond to the 'Producer' - - 'zipD' behaves analogously to a curried function. We partially apply it to - each layer using composition and 'runProxyK' or 'runProxy': - -> -- 1st application -> p1 = runProxyK $ zipD <-< fromListS [1..3] -> -> -- 2nd application -> p2 = runProxyK $ p1 <-< fromListS [4..] -> -> -- 3rd application -> p3 = runProxy $ printD <-< p2 - ->>> p3 -(1, 4) -(2, 5) -(3, 6) - - You can use this trick to fork output, too: - -> fork -> :: (Monad m, Proxy p1, Proxy p2, Proxy p3) -> => () -> Consumer p1 a (Producer p2 a (Producer p3 a m)) r -> fork () = -> runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do -> a <- request () -- Request output from the 'Consumer' -> lift $ respond a -- Send output to the outer 'Producer' -> lift $ lift $ respond a -- Send output to the inner 'Producer' - - Again, we just keep partially applying it until it is fully applied: - -> -- 1st application -> p1 = runProxyK $ fork <-< fromListS [1..3] -> -> -- 2nd application -> p2 = runProxyK $ raiseK printD <-< mapD (> 2) <-< p1 -> -> -- 3rd application -> p3 = runProxy $ printD <-< mapD show <-< p2 - ->>> p3 -False -"1" -False -"2" -True -"3" - - You can even merge or fork proxies that use entirely different feature sets: - -> p1 = runProxyK $ S.evalStateK 0 $ fork <-< increment -> -> p2 = runProxyK $ raiseK printD <-< mapD (+ 10) <-< p1 -> -> p3 = runProxy $ E.runEitherK $ printD <-< (takeB_ 3 >=> E.throw) <-< p2 - ->>> p3 -10 -0 -11 -1 -12 -2 -Left () - - We just forked a @(StateP p1)@ proxy and read out the result in both a - generic @p2@ proxy and an @(EitherP p3)@ proxy. That's pretty crazy, but it - gives you a sense of how versatile and robust proxies can be. - - You can implement arbitrary branching topologies using this trick. However, - I want to mention a few caveats: - - * The intermediate partially applied type signatures will be ugly as sin. - I warned you. - - * You cannot implement cyclic topologies (and cyclic topologies do not make - sense for proxies anyway) - - * You cannot use this trick to implement a polymorphic zip function of the - following form: - -> zip' -- You can't define this -> :: (Monad m, Proxy p) -> => (() -> Producer p a m r) -> -> (() -> Producer p b m r) -> -> (() -> Producer p (a, b) m r) - - Partial application requires selecting a 'Proxy' instance, which is why you - cannot define @zip'@. You /can/ define a @zip'@ specialized to a concrete - 'Proxy' instance, but I don't really recommend doing that since you should - always strive to write polymorphic proxies to avoid locking your user into - a particular feature set. - - With those caveats out of the way, this approach affords many indispensable - features that other approaches do not allow: - - * It does not require extending the 'Proxy' type class - - * It handles almost every branching scenario, including more complicated - situations like concurrent interleavings - - * You can branch and merge mixtures of 'Server's, 'Client's, and 'Proxy's - - * You can branch and merge heterogeneous feature sets - - * It is completely polymorphic over the 'Proxy' class and uses no - implementation-specific details --} - -{- $proxytrans - There is one last scenario that you will eventually encounter: mixing - proxies that have incompatible proxy transformer stacks. You solve this the - exact same way you mix different monad transformer stacks, except that - instead of using 'lift' and 'hoist' you use 'liftP' and 'hoistP'. - - For example, we might want to mix @promptInt3@ and @increment2@: - -> promptInt3 :: (Proxy p) => () -> Producer (E.EitherP String p) Int IO r -> -> increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r - - Unfortunately, they use two different feature sets so neither one is fully - polymorphic over the 'Proxy' class and we cannot directly compose them. - - Fortunately, all proxy transformers implement the 'ProxyTrans' class, - analogous to the 'MonadTrans' class for transformers: - -> class ProxyTrans t where -> liftP -> :: (Monad m, Proxy p) -> => p a' a b' b m r -> t p a' a b' b m r -> -> -- mapP is slightly more elegant -> mapP -> :: (Monad m, Proxy p) -> => (q -> p a' a b' b m r) -> (q -> t p a' a b' b m r) -> mapP = (liftP . ) - - It's very easy to use. Just use 'mapP' (equivalent to @(liftP .)@ to lift - one proxy transformer to match another one. For example, we can 'mapP' - @increment2@ to match @promptInt3@: - -> promptInt3 >-> mapP increment2 -> :: (Proxy p) => () -> Session (EitherP String (StateP Int p)) IO r - ->>> runProxy $ S.evalStateK 0 $ E.runEitherK $ promptInt3 >-> mapP increment2 -Enter an Integer: -4 -(4, 0) -Enter an Integer: -5 -(5, 2) -Enter an Integer: -Hello -Left "Could not read Integer" - - ... or we could instead 'mapP' @promptInt3@ to match @increment2@ and switch - the order of the two proxy transformers: - -> mapP promptInt3 >-> increment2 -> :: (Proxy p) => () -> Session (StateP Int (EitherP String p)) IO r - ->>> runProxy $ E.runEitherK $ S.evalStateK 0 $ mapP promptInt3 >-> increment2 -Enter an Integer: -4 -(4, 0) -Enter an Integer: -5 -(5, 2) -Enter an Integer: -Hello -Left "Could not read Integer" - - Like monad transformers, proxy transformers lift a base 'Monad' instance - to an extended 'Monad' instance. 'liftP' exactly mirrors the 'lift' - function from 'MonadTrans'. 'liftP' takes some base proxy, @p@, that - implements 'Monad' and \"lift\"s it to an extended proxy, @(t p)@, that also - implements 'Monad'. - - So for example, I could do something like: - -> do liftP $ actionInBaseProxy -> actionInExtendedProxy - - Monad transformers impose certain laws to ensure that this lifting is - correct. These are known as the monad transformer laws; - -> (lift .) (f >=> g) = (lift .) f >=> (lift .) g -> -> (lift .) return = return - - If you convert these laws to @do@ notation, they just say: - -> do x <- lift m = lift $ do x <- m -> lift (f x) f x -> -> lift (return r) = return r - - Proxy transformers require the exact same laws to ensure that they lift the - base monad to the extended monad correctly. Just replace 'lift' with - 'liftP': - -> (liftP .) (f >=> g) = (liftP .) f >=> (liftP .) g -> -> (liftP .) return = return - - The only difference is that I also include 'mapP' in the 'ProxyTrans' type - class for convenience, which sweetens these laws a little bit: - -> mapP = (lift .) -> -> mapP (f >=> g) = mapP f >=> mapP g -- These are functor laws! -> -> mapP return = return - - However, proxy transformers do one extra thing above and beyond ordinary - monad transformers. Proxy transformers lift the 'Proxy' type class, meaning - that if the base type implements 'Proxy', so does the extended type. - - This means that we need a set of laws that guarantee that the proxy - transformer lifts the 'Proxy' instance correctly. I call these laws the - \"proxy transformer laws\": - -> mapP (f >-> g) = mapP f >-> mapP g -- These are functor laws, too! -> -> mapP idT = idT - - In other words, a proxy transformer defines a functor from the base - composition to the extended composition! Neat! - - But we're not even done, because proxies actually form three other - categories, only one of which I have mentioned so far, and proxy - transformers lift these three other categories, too: - -> -- The push-based category -> -> mapP (f >~> g) = mapP f >~> mapP g -> -> mapP coidT = coidT - -> -- The "request" category -> -> mapP (f \>\ g) = mapP f \>\ mapP g -> -> mapP request = request - -> -- The "respond" category -> -> mapP (f />/ g) = mapP f />/ mapP g -> -> mapP respond = respond - - I never even mentioned those last two categories because they are more - exotic and you probably never need to use them. However, even if we never - use those categories they still guarantee two really important laws that we - should remember: - -> mapP request = request -> -> mapP respond = respond - - We can translate those to 'liftP' to get: - -> liftP $ request a' = request a' -> -> liftP $ respond b = respond b - - In other words, 'request' and 'respond' in the extended proxy must behave - exactly the same as lifting 'request' and 'respond' from the base proxy. - - All the proxy transformers in this library obey the proxy transformer laws, - which ensure that 'liftP' / 'mapP' always do \"the right thing\". - - Proxy transformers also implement 'hoistP' from the 'PFunctor' class in - "Control.PFunctor". This exactly parallels 'hoist' for monad transformers. - - Just like monad transformers, we can mix two completely exotic proxy - transformer stacks using a combination of 'liftP' and 'hoistP'. Here's the - proxy transformer equivalent of the previous example I gave: - -> p1 :: (Proxy p) => a' -> StateP s (ReaderP i p) a' a a' a m r -> p2 :: (Proxy p) => a' -> MaybeP (WriterP w p) a' a a' a m r - - As before, I can interleave their proxy transformers through judicious use - of 'hoistP' and 'liftP' - -> pSequence -> :: (Proxy p) => StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a r -> pSequence a' = do -> hoistP (liftP . hoistP liftP) (p1 a') -> liftP (hoistP liftP (p2 a')) - - ... but unlike ordinary monad transformers I could instead mix them by - composition, too! - -> pCompose -> :: (Proxy p) => StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a r -> pCompose = -> hoistP (liftP . hoistP liftP) . p1 -> >-> liftP . hoistP liftP . p2 --} - -{- $conclusion - The @pipes@ library emphasizes the reuse of a small set of core abstractions - grounded in theory to implement all functionality: - - * Monads - - * Proxies: ('>->'), 'request', and 'respond' - - * Monad Transformers and Functors on Monads: 'lift' and 'hoist' - - * Proxy Transformers and Functors on Proxies: 'liftP' and 'hoistP' - - However, I don't expect everybody to immediately understand how so few - primitives can implement such a wide variety of features. This tutorial - gives a taste of how many interesting ways you can combine these few - abstractions, but these examples barely scratch the surface, despite this - tutorial's length. So if you don't know how to implement something using - @pipes@, just ask me and I will be happy to help. --} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, Gabriel Gonzalez +Copyright (c) 2012-2016 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/benchmarks/Common.hs b/benchmarks/Common.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Common.hs @@ -0,0 +1,20 @@ +module Common (commonMain) where + +import Criterion.Main (Benchmark, runMode) +import Criterion.Main.Options as Criterion +import Data.Maybe (fromMaybe) +import Data.Monoid +import Options.Applicative + +commonMain :: Int -- ^ default maximum data size + -> (Int -> [Benchmark]) -- ^ the benchmarks to run + -> IO () +commonMain mdMax bench = do + (maybeNewMax, critMode) <- execParser $ info (helper <*> options) mempty + runMode critMode $ bench (fromMaybe mdMax maybeNewMax) + +options :: Parser (Maybe Int, Criterion.Mode) +options = + (,) <$> optional (option auto (help "benchmark maximum data size" + <> metavar "N" <> short 'i' <> long "imax")) + <*> Criterion.parseWith Criterion.defaultConfig diff --git a/benchmarks/LiftBench.hs b/benchmarks/LiftBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/LiftBench.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE RankNTypes #-} +module Main (main) where + +import Common (commonMain) +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 + +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 new file mode 100644 --- /dev/null +++ b/benchmarks/PreludeBench.hs @@ -0,0 +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] + ] + ] diff --git a/pipes.cabal b/pipes.cabal --- a/pipes.cabal +++ b/pipes.cabal @@ -1,69 +1,115 @@ Name: pipes -Version: 3.0.0 -Cabal-Version: >=1.14.0 +Version: 4.3.16 +Cabal-Version: >= 1.10 Build-Type: Simple +Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 License: BSD3 License-File: LICENSE -Copyright: 2012 Gabriel Gonzalez +Copyright: 2012-2016 Gabriel Gonzalez Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues Synopsis: Compositional pipelines Description: - \"Coroutines done right\". This library generalizes - iteratees\/enumerators\/enumeratees simply and elegantly. + `pipes` is a clean and powerful stream processing library that lets you build + and connect reusable streaming components . - Advantages over traditional iteratee\/coroutine implementations: + Advantages over traditional streaming libraries: . - * /Concise API/: Use three simple commands: ('>->'), 'request', and 'respond' + * /Concise API/: Use simple commands like 'for', ('>->'), 'await', and 'yield' . - * /Bidirectionality/: Implement duplex channels + * /Blazing fast/: Implementation tuned for speed, including shortcut fusion . - * /Blazing fast/: Implementation tuned for speed + * /Lightweight Dependency/: @pipes@ is small and compiles very rapidly, + including dependencies . * /Elegant semantics/: Use practical category theory . - * /Extension Framework/: Mix and match extensions and create your own + * /ListT/: Correct implementation of 'ListT' that interconverts with pipes . - * /Lightweight Dependency/: @pipes@ depends only on @transformers@ and - compiles rapidly + * /Bidirectionality/: Implement duplex channels . * /Extensive Documentation/: Second to none! . - Import "Control.Proxy" to use the library. + Import "Pipes" to use the library. . - Read "Control.Proxy.Tutorial" for a really extensive tutorial. -Category: Control, Pipes, Proxies -Tested-With: GHC ==7.4.1 + Read "Pipes.Tutorial" for an extensive tutorial. +Category: Control, Pipes +Extra-Source-Files: + CHANGELOG.md 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 + base >= 4.8 && < 5 , + transformers >= 0.2.0.0 && < 0.6 , + exceptions >= 0.4 && < 0.11, + mmorph >= 1.0.4 && < 1.2 , + mtl >= 2.2.1 && < 2.3 , + void >= 0.4 && < 0.8 + + if impl(ghc < 8.0) + Build-depends: + fail == 4.9.* , + semigroups >= 0.17 && < 0.20 + Exposed-Modules: - Control.MFunctor, - Control.PFunctor, - Control.Pipe, - Control.Proxy, - Control.Proxy.Class, - Control.Proxy.Core, - Control.Proxy.Core.Fast, - Control.Proxy.Core.Correct, - Control.Proxy.Pipe, - Control.Proxy.Synonym, - Control.Proxy.Trans, - Control.Proxy.Trans.Either, - Control.Proxy.Trans.Identity, - Control.Proxy.Trans.Maybe, - Control.Proxy.Trans.Reader, - Control.Proxy.Trans.State, - Control.Proxy.Trans.Writer, - Control.Proxy.Tutorial, - Control.Proxy.Prelude, - Control.Proxy.Prelude.Base, - Control.Proxy.Prelude.IO, - Control.Proxy.Prelude.Kleisli - Default-Language: Haskell98 + 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 + Other-Modules: Common + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4.4 && < 5 , + criterion >= 1.1.1.0 && < 1.6, + optparse-applicative >= 0.12 && < 0.17, + mtl >= 2.1 && < 2.3, + pipes + +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.4 && < 5 , + pipes , + QuickCheck >= 2.4 && < 3 , + mtl >= 2.1 && < 2.3 , + test-framework >= 0.4 && < 1 , + test-framework-quickcheck2 >= 0.2.0 && < 0.4 , + transformers >= 0.2.0.0 && < 0.6 + +Benchmark lift-benchmarks + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: LiftBench.hs + Other-Modules: Common + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4.4 && < 5 , + criterion >= 1.1.1.0 && < 1.6 , + optparse-applicative >= 0.12 && < 0.17, + mtl >= 2.1 && < 2.3 , + pipes , + transformers >= 0.2.0.0 && < 0.6 diff --git a/src/Pipes.hs b/src/Pipes.hs new file mode 100644 --- /dev/null +++ b/src/Pipes.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE 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 + , module Control.Monad.IO.Class + , module Control.Monad.Trans.Class + , module Control.Monad.Morph + , Foldable + ) where + +import Control.Monad (void, MonadPlus(mzero, mplus)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Except (MonadError(..)) +import Control.Monad.Fail (MonadFail(..)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Trans.Identity (IdentityT(runIdentityT)) +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Control.Monad.Writer (MonadWriter(..)) +import Control.Monad.Zip (MonadZip(..)) +import Pipes.Core +import Pipes.Internal (Proxy(..)) +import qualified Data.Foldable as F + +#if MIN_VERSION_base(4,8,0) +import Control.Applicative (Alternative(..)) +#else +import Control.Applicative +import Data.Foldable (Foldable) +import Data.Traversable (Traversable(..)) +#endif +import Data.Semigroup + +-- Re-exports +import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) + +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 -> 'Producer' a m () +'yield' :: 'Monad' m => a -> 'Pipe' x a m () +@ +-} +yield :: Functor m => a -> Proxy x' x () a m () +yield = respond +{-# INLINABLE [1] yield #-} + +{-| @(for p body)@ loops over @p@ replacing each 'yield' with @body@. + +@ +'for' :: 'Functor' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r +'for' :: 'Functor' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r +'for' :: 'Functor' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r +'for' :: 'Functor' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r +@ + + The following diagrams show the flow of information: + +@ + .---> b + / | + +-----------+ / +-----|-----+ +---------------+ + | | / | v | | | + | | / | | | | +x ==> p ==> b ---' x ==> body ==> c = x ==> 'for' p body ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +-------|-------+ + v v v + r () r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#respond-diagram". +-} +for :: Functor m + => Proxy x' x b' b m a' + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x c' c m a' +for = (//>) +-- There are a number of useful rewrites which can be performed on various uses +-- of this combinator; to ensure that they fire we defer inlining until quite +-- late. +{-# INLINABLE [0] 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 + +@ +('~>') :: 'Functor' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) +('~>') :: 'Functor' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r) +('~>') :: 'Functor' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) +('~>') :: 'Functor' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) +@ + + The following diagrams show the flow of information: + +@ + a .---> b a + | / | | + +-----|-----+ / +-----|-----+ +------|------+ + | v | / | v | | v | + | | / | | | | +x ==> f ==> b ---' x ==> g ==> c = x ==> f '~>' g ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +------|------+ + v v v + r () r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#respond-diagram". +-} +(~>) + :: Functor 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 +(<~) + :: Functor 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' :: 'Functor' m => 'Pipe' a y m a +@ +-} +await :: Functor m => Consumer' a m a +await = request () +{-# INLINABLE [1] await #-} + +{-| @(draw >~ p)@ loops over @p@ replacing each 'await' with @draw@ + +@ +('>~') :: 'Functor' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +('>~') :: 'Functor' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +('>~') :: 'Functor' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c +('>~') :: 'Functor' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c +@ + + The following diagrams show the flow of information: + +@ + +-----------+ +-----------+ +-------------+ + | | | | | | + | | | | | | +a ==> f ==> y .---> b ==> g ==> y = a ==> f '>~' g ==> y + | | / | | | | + | | | / | | | | | | + +-----|-----+ / +-----|-----+ +------|------+ + v / v v + b ----' c c +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#request-diagram". +-} +(>~) + :: Functor 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 [1] (>~) #-} + +-- | ('>~') with the arguments flipped +(~<) + :: Functor 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 :: Functor m => Pipe a a m r +cat = pull () +{-# INLINABLE [1] cat #-} + +{-| 'Pipe' composition, analogous to the Unix pipe operator + +@ +('>->') :: 'Functor' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r +('>->') :: 'Functor' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r +('>->') :: 'Functor' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r +('>->') :: 'Functor' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +@ + + The following diagrams show the flow of information: + +@ + +-----------+ +-----------+ +-------------+ + | | | | | | + | | | | | | +a ==> f ==> b ==> g ==> c = a ==> f '>->' g ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +------|------+ + v v v + r r r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#pull-diagram". +-} +(>->) + :: Functor 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 [1] (>->) #-} + +{-| The list monad transformer, which extends a monad with non-determinism + + The type variables signify: + + * @m@ - The base monad + * @a@ - The values that the computation 'yield's throughout its execution + + For basic construction and composition of 'ListT' computations, much can be + accomplished using common typeclass methods. + + * 'return' corresponds to 'yield', yielding a single value. + * ('>>=') corresponds to 'for', calling the second computation once + for each time the first computation 'yield's. + * 'mempty' neither 'yield's any values nor produces any effects in the + base monad. + * ('<>') sequences two computations, 'yield'ing all the values of the + first followed by all the values of the second. + * 'lift' converts an action in the base monad into a ListT computation + which performs the action and 'yield's a single value. + + 'ListT' is a newtype wrapper for 'Producer'. You will likely need to use + 'Select' and 'enumerate' to convert back and forth between these two types + to take advantage of all the 'Producer'-related utilities that + "Pipes.Prelude" has to offer. + + * To lift a plain list into a 'ListT' computation, first apply 'each' + to turn the list into a 'Producer'. Then apply the 'Select' + constructor to convert from 'Producer' to 'ListT'. + * For other ways to construct 'ListT' computations, see the + “Producers” section in "Pipes.Prelude" to build 'Producer's. + These can then be converted to 'ListT' using 'Select'. + * To aggregate the values from a 'ListT' computation (for example, + to compute the sum of a 'ListT' of numbers), first apply + 'enumerate' to obtain a 'Producer'. Then see the “Folds” + section in "Pipes.Prelude" to proceed. +-} +newtype ListT m a = Select { enumerate :: Producer a m () } + +instance Functor m => Functor (ListT m) where + fmap f p = Select (for (enumerate p) (\a -> yield (f a))) + {-# INLINE fmap #-} + +instance Functor m => Applicative (ListT m) where + pure a = Select (yield a) + {-# INLINE pure #-} + mf <*> mx = Select ( + for (enumerate mf) (\f -> + for (enumerate mx) (\x -> + yield (f x) ) ) ) + +instance Monad m => Monad (ListT m) where + return = pure + {-# INLINE return #-} + m >>= f = Select (for (enumerate m) (\a -> enumerate (f a))) + {-# INLINE (>>=) #-} +#if !MIN_VERSION_base(4,13,0) + fail _ = mzero + {-# INLINE fail #-} +#endif + +instance Monad m => MonadFail (ListT m) where + fail _ = mzero + {-# INLINE fail #-} + +instance Foldable m => Foldable (ListT m) where + foldMap f = go . enumerate + where + go p = case p of + Request v _ -> closed v + Respond a fu -> f a `mappend` go (fu ()) + M m -> F.foldMap go m + Pure _ -> mempty + {-# INLINE foldMap #-} + +instance (Functor m, Traversable m) => Traversable (ListT m) where + traverse k (Select p) = fmap Select (traverse_ p) + where + traverse_ (Request v _ ) = closed v + traverse_ (Respond a fu) = _Respond <$> k a <*> traverse_ (fu ()) + where + _Respond a_ a' = Respond a_ (\_ -> a') + traverse_ (M m ) = fmap M (traverse traverse_ m) + traverse_ (Pure r ) = pure (Pure r) + +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) + {-# INLINE liftIO #-} + +instance (Functor m) => Alternative (ListT m) where + empty = Select (return ()) + {-# INLINE empty #-} + p1 <|> p2 = Select (do + enumerate p1 + enumerate p2 ) + +instance (Monad m) => MonadPlus (ListT m) where + mzero = empty + {-# INLINE mzero #-} + mplus = (<|>) + {-# INLINE mplus #-} + +instance MFunctor ListT where + hoist morph = Select . hoist morph . enumerate + {-# INLINE hoist #-} + +instance MMonad ListT where + embed f (Select p0) = Select (loop p0) + where + loop (Request a' fa ) = Request a' (\a -> loop (fa a )) + loop (Respond b fb') = Respond b (\b' -> loop (fb' b')) + loop (M m ) = for (enumerate (fmap loop (f m))) id + loop (Pure r ) = Pure r + {-# INLINE embed #-} + +instance (Functor m) => Semigroup (ListT m a) where + (<>) = (<|>) + {-# INLINE (<>) #-} + +instance (Functor m) => Monoid (ListT m a) where + mempty = empty + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<|>) + {-# INLINE mappend #-} +#endif + +instance (MonadState s m) => MonadState s (ListT m) where + get = lift get + {-# INLINE get #-} + + put s = lift (put s) + {-# INLINE put #-} + + state f = lift (state f) + {-# INLINE state #-} + +instance (MonadWriter w m) => MonadWriter w (ListT m) where + writer = lift . writer + {-# INLINE writer #-} + + tell w = lift (tell w) + {-# INLINE tell #-} + + 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 + {-# INLINE ask #-} + + local f l = Select (local f (enumerate l)) + {-# INLINE local #-} + + reader f = lift (reader f) + {-# INLINE reader #-} + +instance (MonadError e m) => MonadError e (ListT m) where + throwError e = lift (throwError e) + {-# INLINE throwError #-} + + catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e))) + {-# INLINE catchError #-} + +instance MonadThrow m => MonadThrow (ListT m) where + throwM = Select . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (ListT m) where + catch l k = Select (Control.Monad.Catch.catch (enumerate l) (\e -> enumerate (k e))) + {-# INLINE catch #-} + +instance Monad m => MonadZip (ListT m) where + mzipWith f = go + where + go xs ys = Select $ do + xres <- lift $ next (enumerate xs) + case xres of + Left r -> return r + Right (x, xnext) -> do + yres <- lift $ next (enumerate ys) + case yres of + Left r -> return r + Right (y, ynext) -> do + yield (f x y) + enumerate (go (Select xnext) (Select ynext)) + +-- | Run a self-contained `ListT` computation +runListT :: Monad m => ListT m a -> m () +runListT l = runEffect (enumerate (l >> mzero)) +{-# INLINABLE runListT #-} + +{-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful + containers to 'ListT's. + + Instances of 'Enumerable' must satisfy these two laws: + +> toListT (return r) = return r +> +> toListT $ do x <- m = do x <- toListT m +> f x toListT (f x) + + In other words, 'toListT' is monad morphism. +-} +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 (ExceptT e) where + toListT m = Select $ do + x <- lift $ runExceptT 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' :: ('Functor' m, 'Foldable' f) => f a -> 'Producer' a m () +@ +-} +each :: (Functor m, Foldable f) => f a -> Proxy x' x () 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 :: (Monad m, Enumerable t) => t m a -> Proxy x' x () 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 +(<-<) + :: Functor 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" re-exports 'void' + + "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 new file mode 100644 --- /dev/null +++ b/src/Pipes/Core.hs @@ -0,0 +1,894 @@ +{-| 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) +@ + +#respond-diagram# + + The following diagrams show the flow of information: + +@ +'respond' :: 'Functor' m + => a -> 'Proxy' x' x a' a m a' + +\ a + | + +----|----+ + | | | + x' <== \\ /==== a' + | X | + x ==> / \\===> a + | | | + +----|----+ + v + a' + +('/>/') :: 'Functor' 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') + +\ 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' + +('//>') :: 'Functor' m + => 'Proxy' x' x b' b m a' + -> (b -> 'Proxy' x' x c' c m b') + -> 'Proxy' x' x c' c m a' + +\ /===> b + / | + +---------+ / +----|----+ +---------+ + | | / | 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 :: Functor m => a -> Proxy x' x a' a m a' +respond a = Respond a Pure +{-# INLINABLE [1] respond #-} + +{-| Compose two unfolds, creating a new unfold + +@ +(f '/>/' g) x = f x '//>' g +@ + + ('/>/') is the composition operator of the respond category. +-} +(/>/) + :: Functor 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 ('/>/') +-} +(//>) + :: Functor 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 (go <$> m) + Pure a -> Pure a +{-# INLINE [1] (//>) #-} + +{-# 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 ((\p' -> p' //> fb) <$> m); + "(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) +@ + +#request-diagram# + + The following diagrams show the flow of information: + +@ +'request' :: 'Functor' m + => a' -> 'Proxy' a' a y' y m a + +\ a' + | + +----|----+ + | | | + a' <=====/ <== y' + | | + a ======\\ ==> y + | | | + +----|----+ + v + a + +('\>\') :: 'Functor' 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 + +('>\\') :: Functor m + => (b' -> Proxy a' a y' y m b) + -> Proxy b' b y' y m c + -> Proxy a' a y' y m c + +\ b'<=====\\ + | \\ + +----|----+ \\ +---------+ +---------+ + | 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 :: Functor m => a' -> Proxy a' a y' y m a +request a' = Request a' Pure +{-# INLINABLE [1] request #-} + +{-| Compose two folds, creating a new fold + +@ +(f '\>\' g) x = f '>\\' g x +@ + + ('\>\') is the composition operator of the request category. +-} +(\>\) + :: Functor 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 ('\>\') +-} +(>\\) + :: Functor 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 (go <$> m) + Pure a -> Pure a +{-# INLINE [1] (>\\) #-} + +{-# 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 ((\p' -> fb' >\\ p') <$> m); + "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' :: 'Functor' m + => a -> 'Proxy' a' a a' a m r + +\ a + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>~>') :: 'Functor' 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 :: Functor m => a -> Proxy a' a a' a m r +push = go + where + go a = Respond a (\a' -> Request a' go) +{-# INLINABLE [1] 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. +-} +(>~>) + :: Functor 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 a 'request' in @f@. + + Point-ful version of ('>~>') +-} +(>>~) + :: Functor 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 ((\p' -> p' >>~ fb) <$> m) + Pure r -> Pure r +{-# INLINE [1] (>>~) #-} + +{- $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) +@ + +#pull-diagram# + + The following diagrams show the flow of information: + +@ +'pull' :: 'Functor' m + => a' -> 'Proxy' a' a a' a m r + +\ a' + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>+>') :: 'Functor' 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 :: Functor m => a' -> Proxy a' a a' a m r +pull = go + where + go a' = Request a' (\a -> Respond a go) +{-# INLINABLE [1] 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. +-} +(>+>) + :: Functor 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 ('>+>') +-} +(+>>) + :: Functor 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 ((\p' -> fb' +>> p') <$> m) + Pure r -> Pure r +{-# INLINABLE [1] (+>>) #-} + +{- $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 :: Functor 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 (go <$> m) + 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 +(\<\) + :: Functor 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 +(<~<) + :: Functor 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 +(<+<) + :: Functor 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 +(<\\) + :: Functor 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 +(//<) + :: Functor 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 +(~<<) + :: Functor 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 +(<<+) + :: Functor 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 new file mode 100644 --- /dev/null +++ b/src/Pipes/Internal.hs @@ -0,0 +1,284 @@ +{-| 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 CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} + +module Pipes.Internal ( + -- * Internal + Proxy(..) + , unsafeHoist + , observe + , X + , closed + ) where + +import qualified Control.Monad.Fail as F (MonadFail(fail)) +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.Except (MonadError(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Writer (MonadWriter(..), censor) +import Data.Void (Void) + +#if MIN_VERSION_base(4,8,0) +import Control.Applicative (Alternative(..)) +#else +import Control.Applicative +#endif +import Data.Semigroup + +import qualified Data.Void + +{-| 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 Functor 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 (go <$> m) + Pure r -> Pure (f r) + +instance Functor 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 (go <$> m) + Pure f -> fmap f px + l *> r = go l 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 (go <$> m) + Pure _ -> r + +instance Functor m => Monad (Proxy a' a b' b m) where + return = pure + (>>=) = _bind + +_bind + :: Functor 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 (go <$> m) + Pure r -> f r +{-# NOINLINE[1] _bind #-} + +{-# 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 ((\p -> _bind p f) <$> m); + "_bind (Pure r ) f" forall r f . + _bind (Pure r ) f = f r; + #-} + +instance (Functor m, Semigroup r) => Semigroup (Proxy a' a b' b m r) where + p1 <> p2 = go p1 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 (go <$> m) + Pure r1 -> fmap (r1 <>) p2 + +instance (Functor m, Monoid r, Semigroup r) => Monoid (Proxy a' a b' b m r) where + mempty = Pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +instance MonadTrans (Proxy a' a b' b) where + lift m = M (Pure <$> m) + +{-| '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 + :: Functor 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 (go <$> m)) + 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 (go <$> m)) + 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 F.MonadFail m => F.MonadFail (Proxy a' a b' b m) where + fail = lift . F.fail + +instance MonadIO m => MonadIO (Proxy a' a b' b m) where + liftIO m = M (liftIO (Pure <$> m)) + +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 (go <$> local f m) + 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') <- censor (const mempty) (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 MonadThrow m => MonadThrow (Proxy a' a b' b m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (Proxy a' a b' b m) where + catch 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') ) `Control.Monad.Catch.catch` (\e -> return (f e)) ) + +{-| 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 +type X = Void + +-- | Use 'closed' to \"handle\" impossible outputs +closed :: X -> a +closed = Data.Void.absurd +{-# INLINABLE closed #-} diff --git a/src/Pipes/Lift.hs b/src/Pipes/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Lift.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE CPP #-} + +{-| 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 + + -- * ExceptT + , exceptP + , runExceptP + , 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.Except 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 Pipes.Internal (Proxy(..), unsafeHoist) +import Control.Monad.Morph (hoist, MFunctor(..)) +import Pipes.Core (runEffect, request, respond, (//>), (>\\)) + +#if MIN_VERSION_base(4,8,0) +#else +import Data.Monoid +#endif + +-- | 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.ExceptT' +exceptP + :: Monad m + => Proxy a' a b' b m (Either e r) + -> Proxy a' a b' b (E.ExceptT e m) r +exceptP p = do + x <- unsafeHoist lift p + lift $ E.ExceptT (return x) +{-# INLINABLE exceptP #-} + +-- | Run 'E.ExceptT' in the base monad +runExceptP + :: Monad m + => Proxy a' a b' b (E.ExceptT e m) r + -> Proxy a' a b' b m (Either e r) +runExceptP = E.runExceptT . distribute +{-# INLINABLE runExceptP #-} + +-- | Catch an error in the base monad +catchError + :: Monad m + => Proxy a' a b' b (E.ExceptT e m) r + -- ^ + -> (e -> Proxy a' a b' b (E.ExceptT e m) r) + -- ^ + -> Proxy a' a b' b (E.ExceptT e m) r +catchError e h = exceptP . E.runExceptT $ + E.catchE (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.ExceptT': + +> import Control.Monad.Trans.Error +> import Pipes +> +> example :: Monad m => Pipe Int Int (ExceptT 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 +>>> runExceptT $ 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 (ExceptT 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: + +>>> runExceptT $ 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 new file mode 100644 --- /dev/null +++ b/src/Pipes/Prelude.hs @@ -0,0 +1,1009 @@ +{-| 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 + , unfoldr + + -- * Consumers + -- $consumers + , stdoutLn + , stdoutLn' + , mapM_ + , print + , toHandle + , drain + + -- * Pipes + -- $pipes + , map + , mapM + , sequence + , mapFoldable + , filter + , mapMaybe + , filterM + , wither + , take + , takeWhile + , takeWhile' + , drop + , dropWhile + , concat + , elemIndices + , findIndices + , scan + , scanM + , chain + , read + , show + , seq + + -- *ListT + , loop + + -- * Folds + -- $folds + , fold + , fold' + , foldM + , foldM' + , all + , any + , and + , or + , elem + , notElem + , find + , findIndex + , head + , index + , last + , length + , maximum + , minimum + , null + , sum + , product + , toList + , toListM + , toListM' + + -- * Zips + , zip + , zipWith + + -- * Utilities + , tee + , generalize + ) where + +import Control.Exception (throwIO, try) +import Control.Monad (liftM, when, unless, (>=>)) +import Control.Monad.Trans.State.Strict (get, put) +import Data.Functor.Identity (Identity, runIdentity) +import Foreign.C.Error (Errno(Errno), ePIPE) +import GHC.Exts (build) +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 + , mapM_ + , maximum + , minimum + , notElem + , null + , or + , print + , product + , read + , readLn + , sequence + , show + , seq + , 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 :: MonadIO m => IO.Handle -> Proxy x' x () 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 :: Monad m => m a -> Proxy x' x () a m r +repeatM m = lift m >~ cat +{-# INLINABLE [1] 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' :: 'Monad' m => Int -> m a -> 'Producer' a m () +@ +-} +replicateM :: Monad m => Int -> m a -> Proxy x' x () 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 #-} + +{-| Write 'String's to 'IO.stdout' using 'putStrLn' + + This does not handle a broken output pipe, but has a polymorphic return + value +-} +stdoutLn' :: MonadIO m => Consumer' String m r +stdoutLn' = for cat (\str -> liftIO (putStrLn str)) +{-# INLINABLE [1] stdoutLn' #-} + +{-# RULES + "p >-> stdoutLn'" forall p . + p >-> stdoutLn' = for p (\str -> liftIO (putStrLn str)) + #-} + +-- | Consume all values using a monadic function +mapM_ :: Monad m => (a -> m ()) -> Consumer' a m r +mapM_ f = for cat (\a -> lift (f a)) +{-# INLINABLE [1] mapM_ #-} + +{-# RULES + "p >-> mapM_ f" forall p f . + p >-> mapM_ f = for p (\a -> lift (f a)) + #-} + +-- | 'print' values to 'IO.stdout' +print :: (MonadIO m, Show a) => Consumer' a m r +print = for cat (\a -> liftIO (Prelude.print a)) +{-# INLINABLE [1] 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 [1] toHandle #-} + +{-# RULES + "p >-> toHandle handle" forall p handle . + p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str)) + #-} + +-- | 'discard' all incoming values +drain :: Functor m => Consumer' a m r +drain = for cat discard +{-# INLINABLE [1] 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 :: Functor m => (a -> b) -> Pipe a b m r +map f = for cat (\a -> yield (f a)) +{-# INLINABLE [1] 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 [1] 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 :: (Functor m, Foldable t) => (a -> t b) -> Pipe a b m r +mapFoldable f = for cat (\a -> each (f a)) +{-# INLINABLE [1] 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 f = mapMaybe (\a -> a <$ guard (f a)) +-} +filter :: Functor m => (a -> Bool) -> Pipe a a m r +filter predicate = for cat $ \a -> when (predicate a) (yield a) +{-# INLINABLE [1] filter #-} + +{-# RULES + "p >-> filter predicate" forall p predicate. + p >-> filter predicate = for p (\a -> when (predicate a) (yield a)) + #-} + +{-| @(mapMaybe f)@ yields 'Just' results of 'f'. + +Basic laws: + +> mapMaybe (f >=> g) = mapMaybe f >-> mapMaybe g +> +> mapMaybe (pure @Maybe . f) = mapMaybe (Just . f) = map f +> +> mapMaybe (const Nothing) = drain + +As a result of the second law, + +> mapMaybe return = mapMaybe Just = cat +-} +mapMaybe :: Functor m => (a -> Maybe b) -> Pipe a b m r +mapMaybe f = for cat $ maybe (pure ()) yield . f +{-# INLINABLE [1] mapMaybe #-} + +{-# RULES + "p >-> mapMaybe f" forall p f. + p >-> mapMaybe f = for p $ maybe (pure ()) yield . f + #-} + +{-| @(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 f = wither (\a -> (\b -> a <$ guard b) <$> f a) +-} +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 [1] filterM #-} + +{-# RULES + "p >-> filterM predicate" forall p predicate . + p >-> filterM predicate = for p (\a -> do + b <- lift (predicate a) + when b (yield a) ) + #-} + +{-| @(wither f)@ forwards 'Just' values produced by the + monadic action. + +Basic laws: + +> wither (runMaybeT . (MaybeT . f >=> MaybeT . g)) = wither f >-> wither g +> +> wither (runMaybeT . lift . f) = wither (fmap Just . f) = mapM f +> +> wither (pure . f) = mapMaybe f + +As a result of the second law, + +> wither (runMaybeT . return) = cat + +As a result of the third law, + +> wither (pure . const Nothing) = wither (const (pure Nothing)) = drain +-} +wither :: Monad m => (a -> m (Maybe b)) -> Pipe a b m r +wither f = for cat $ lift . f >=> maybe (pure ()) yield +{-# INLINABLE [1] wither #-} + +{-# RULES + "p >-> wither f" forall p f . + p >-> wither f = for p $ lift . f >=> maybe (pure ()) yield + #-} + +{-| @(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 :: Functor m => Int -> Pipe a a m () +take = go + where + go 0 = return () + go n = do + a <- await + yield a + go (n-1) +{-# 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 :: Functor 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 #-} + +{-| @(takeWhile' p)@ is a version of takeWhile that returns the value failing + the predicate. + +> takeWhile' (pure True) = cat +> +> takeWhile' (liftA2 (&&) p1 p2) = takeWhile' p1 >-> takeWhile' p2 +-} +takeWhile' :: Functor m => (a -> Bool) -> Pipe a a m a +takeWhile' predicate = go + where + go = do + a <- await + if (predicate a) + then do + yield a + go + else return a +{-# INLINABLE takeWhile' #-} + +{-| @(drop n)@ discards @n@ values going downstream + +> drop 0 = cat +> +> drop (m + n) = drop m >-> drop n +-} +drop :: Functor m => Int -> Pipe a a m r +drop = go + where + go 0 = cat + go n = do + await + go (n-1) +{-# 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 :: Functor 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 :: (Functor m, Foldable f) => Pipe (f a) a m r +concat = for cat each +{-# INLINABLE [1] concat #-} + +{-# RULES + "p >-> concat" forall p . p >-> concat = for p each + #-} + +-- | Outputs the indices of all elements that match the given element +elemIndices :: (Functor 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 :: Functor m => (a -> Bool) -> Pipe a Int m r +findIndices predicate = go 0 + where + go n = do + a <- await + when (predicate a) (yield n) + go $! n + 1 +{-# INLINABLE findIndices #-} + +{-| Strict left scan + +> Control.Foldl.purely scan :: Monad m => Fold a b -> Pipe a b m r +-} +scan :: Functor m => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r +scan step begin done = go begin + where + go x = do + yield (done x) + a <- await + let x' = step x a + go $! x' +{-# INLINABLE scan #-} + +{-| Strict, monadic left scan + +> Control.Foldl.impurely scanM :: Monad m => FoldM m a 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 + go x + where + go x = do + b <- lift (done x) + yield b + a <- await + x' <- lift (step x a) + go $! 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 [1] 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 :: (Functor m, Read a) => Pipe String a m r +read = for cat $ \str -> case (reads str) of + [(a, "")] -> yield a + _ -> return () +{-# INLINABLE [1] 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 :: (Functor m, Show a) => Pipe a String m r +show = map Prelude.show +{-# INLINABLE show #-} + +-- | Evaluate all values flowing downstream to WHNF +seq :: Functor m => Pipe a a m r +seq = for cat $ \a -> yield $! a +{-# INLINABLE seq #-} + +{-| Create a `Pipe` from a `ListT` transformation + +> loop (k1 >=> k2) = loop k1 >-> loop k2 +> +> loop return = cat +-} +loop :: Monad m => (a -> ListT m b) -> Pipe a b m r +loop k = for cat (every . k) +{-# INLINABLE loop #-} + +{- $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 Prelude.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 = go p0 begin + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> go (fu ()) $! step x a + M m -> m >>= \p' -> go p' x + Pure _ -> return (done x) +{-# INLINABLE fold #-} + +{-| Strict fold of the elements of a 'Producer' that preserves the return value + +> Control.Foldl.purely fold' :: Monad m => Fold a b -> Producer a m r -> m (b, r) +-} +fold' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m r -> m (b, r) +fold' step begin done p0 = go p0 begin + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> go (fu ()) $! step x a + M m -> m >>= \p' -> go p' x + Pure r -> return (done x, r) +{-# 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 + go p0 x0 + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> do + x' <- step x a + go (fu ()) $! x' + M m -> m >>= \p' -> go p' x + Pure _ -> done x +{-# INLINABLE foldM #-} + +{-| Strict, monadic fold of the elements of a 'Producer' + +> Control.Foldl.impurely foldM' :: Monad m => FoldM a b -> Producer a m r -> m (b, r) +-} +foldM' + :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m r -> m (b, r) +foldM' step begin done p0 = do + x0 <- begin + go p0 x0 + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> do + x' <- step x a + go (fu ()) $! x' + M m -> m >>= \p' -> go p' x + Pure r -> do + b <- done x + return (b, r) +{-# 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') -> go a p' + where + go a p = do + x <- next p + case x of + Left _ -> return (Just a) + Right (a', p') -> go 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 prod0 = build (go prod0) + where + go prod cons nil = + case prod of + Request v _ -> closed v + Respond a fu -> cons a (go (fu ()) cons nil) + M m -> go (runIdentity m) cons nil + Pure _ -> nil +{-# INLINE 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 = fold step begin done + where + step x a = x . (a:) + begin = id + done x = x [] +{-# INLINABLE toListM #-} + +{-| Convert an effectful 'Producer' into a list alongside the return value + + 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 r -> m ([a], r) +toListM' = fold' step begin done + where + step x a = x . (a:) + begin = id + done x = x [] +{-# INLINABLE toListM' #-} + +-- | Zip two 'Producer's +zip :: Monad m + => (Producer a m r) + -> (Producer b m r) + -> (Proxy x' x () (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) + -> (Proxy x' x () 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 #-} + +{-| The natural unfold into a 'Producer' with a step function and a seed + +> unfoldr next = id +-} +unfoldr :: Monad m + => (s -> m (Either r (a, s))) -> s -> Producer a m r +unfoldr step = go where + go s0 = do + e <- lift (step s0) + case e of + Left r -> return r + Right (a,s) -> do + yield a + go s +{-# INLINABLE unfoldr #-} diff --git a/src/Pipes/Tutorial.hs b/src/Pipes/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Tutorial.hs @@ -0,0 +1,1622 @@ +{-# 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\", + + * part III \"Monads in the Real World\" of the tutorial \"All About Monads\", + + * 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 + + -- * Copyright + -- $copyright + ) where + +import Control.Category +import Control.Monad +import Pipes +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 creates three copies + of every value: + +> -- nested.hs +> +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude already has 'stdinLn' +> +> triple :: Monad m => a -> Producer a m () +> triple x = do +> yield x +> yield x +> yield x +> +> loop :: Producer String IO () +> loop = for P.stdinLn triple +> +> -- This is the exact same as: +> -- +> -- loop = for P.stdinLn $ \x -> do +> -- yield x +> -- yield x +> -- yield x + + This time our @loop@ is a 'Producer' that outputs 'String's, specifically + three 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 repeated stream: + +> -- nested.hs +> +> main = runEffect $ for loop (lift . putStrLn) + + This creates a program which echoes every line from standard input to + standard output three times: + +> $ ./nested +> Test +> Test +> Test +> Test +> ABC +> 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 (triple 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. \'triple\' + \-\- 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 ()) + -> (b -> 'Producer' c m ()) + -> (a -> 'Producer' c m ()) + (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 () + g :: Monad m => b -> 'Producer' c m () + h :: Monad m => c -> 'Producer' d m () + +\ \-\- 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 (triple ~> 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 + ('>~') (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 analogous 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. + + `ListT` computations can be combined in more ways than `Pipe`s, so try to + program in `ListT` as much as possible and defer converting it to a `Pipe` + as late as possible using `P.loop`. + + You can combine `ListT` computations even if their inputs and outputs are + completely different: + +> data In +> = InA A +> | InB B +> | InC C +> +> data Out +> = OutD D +> | OutE E +> | OutF F +> +> -- Independent computations +> +> example1 :: A -> ListT IO D +> example2 :: B -> ListT IO E +> example3 :: C -> ListT IO F +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = case input of +> InA a -> fmap OutD (example1 a) +> InB b -> fmap OutE (example2 b) +> InC c -> fmap OutF (example3 c) + + Sometimes you have multiple computations that handle different inputs but + the same output, in which case you don't need to unify their outputs: + +> -- Overlapping outputs +> +> example1 :: A -> ListT IO Out +> example2 :: B -> ListT IO Out +> example3 :: C -> ListT IO Out +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = case input of +> InA a -> example1 a +> InB b -> example2 b +> InC c -> example3 c + + Other times you have multiple computations that handle the same input but + produce different outputs. You can unify their outputs using the `Monoid` + and `Functor` instances for `ListT`: + +> -- Overlapping inputs +> +> example1 :: In -> ListT IO D +> example2 :: In -> ListT IO E +> example3 :: In -> ListT IO F +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = +> fmap OutD (example1 input) +> <> fmap OutE (example2 input) +> <> fmap OutF (example3 input) + + You can also chain `ListT` computations, feeding the output of the first + computation as the input to the next computation: + +> -- End-to-end +> +> aToB :: A -> ListT IO B +> bToC :: B -> ListT IO C +> +> -- Combined computation +> +> aToC :: A -> LIstT IO C +> aToC = aToB >=> bToC + + ... or you can just use @do@ notation if you prefer. + + However, the `Pipe` type is more general than `ListT` and can represent + things like termination. Therefore you should consider mixing `Pipe`s with + `ListT` when you need to take advantage of these extra features: + +> -- Mix ListT with Pipes +> +> example :: In -> ListT IO Out +> +> pipe :: Pipe In Out IO () +> pipe = Pipes.takeWhile (not . isC) >-> loop example +> where +> isC (InC _) = True +> isC _ = False + + So promote your `ListT` logic to a `Pipe` when you need to take advantage of + these `Pipe`-specific features. +-} + +{- $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@ + + * @pipes-group@: Grouping streams in constant space + + 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-extras@: Miscellaneous utilities + + * @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. +-} + +{- $copyright + This tutorial is licensed under a + +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +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