diff --git a/Control/Pipe.hs b/Control/Pipe.hs deleted file mode 100644 --- a/Control/Pipe.hs +++ /dev/null @@ -1,201 +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 - {-# DEPRECATED "Use 'Control.Proxy' instead of '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.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class (C) -import Prelude hiding ((.), id) - --- For documentation -import Control.Category (Category((.), 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: - -> data 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 7 <+< -infixl 7 >+> - --- | 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,36 +0,0 @@ -{-| Recommended entry import for this library - - Read "Control.Proxy.Tutorial" for an extended 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 requires implementation hiding to enforce the monad - transformer laws. - - * "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,756 +0,0 @@ --- | This module defines the theoretical framework underpinning this library - -{-# LANGUAGE Rank2Types, KindSignatures #-} - -module Control.Proxy.Class ( - -- * The Proxy Class - Proxy(..), - - -- * Composition operators - (>->), - (>~>), - (\>\), - (/>/), - - -- ** Flipped operators - (<-<), - (<~<), - (/)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Monoid (Monoid(mempty, mappend)) - -{- * 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. --} -infixr 5 <-<, ->> -infixl 5 >->, <<- -infixr 6 >~>, ~<< -infixl 6 <~<, >>~ -infixl 7 \<\, //> -infixr 7 />/, <\\ -infixr 8 /\\ -infixl 8 \>\, //< -infixl 1 ?>= -- This should match the fixity of >>= - -{-| The 'Proxy' class defines a 'Monad' that intersects four streaming - categories: - - * The \"request\" category: 'request' and ('\>\') - - * The \"respond\" category: 'respond' and ('/>/') - - * The \"pull\" category: 'pull' and ('>->') - - * The \"push\" category: 'push' and ('>~>') - - This class requires the \"point-ful\" version of each category's composition - operator for efficiency. - - Minimal definition: - - * 'request' - - * 'respond' - - * ('->>') - - * ('>>~') - - * ('>\\') - - * ('//>') - - * 'turn' --} -class (ProxyInternal p) => Proxy p where - {-| 'request' sends a value of type @a'@ upstream and receives a value of - type @a@. - -} - request :: (Monad m) => a' -> p a' a b' b m a - - -- | @(f >\\\\ p)@ replaces each 'request' in @p@ with @f@. - (>\\) - :: (Monad m) - => (b' -> p a' a x' x m b) - -> p b' b x' x m c - -> p a' a x' x m c - - {-| 'respond' sends a value of type @b@ downstream and receives a value of - type @b'@. - -} - respond :: (Monad m) => b -> p a' a b' b m b' - - -- | @(p \/\/> f)@ replaces each 'respond' in @p@ with @f@. - (//>) - :: (Monad m) - => p x' x b' b m a' - -> (b -> p x' x c' c m b') - -> p x' x c' c m a' - - -- | @pull = request >=> respond >=> pull@ - pull :: (Monad m, Proxy p) => a' -> p a' a a' a m r - pull = go where - go a' = - request a' ?>= \a -> - respond a ?>= \a'2 -> - go a'2 - {- DO NOT replace 'go' with 'push' or ghc-7.4.2 will not terminate while - compiling `pipes` -} - - -- | @(f ->> p)@ pairs each 'request' in @p@ with a 'respond' in @f@. - (->>) - :: (Monad m) - => (b' -> p a' a b' b m r) - -> p b' b c' c m r - -> p a' a c' c m r - - -- | @push = respond >=> request >=> push@ - push :: (Monad m, Proxy p) => a -> p a' a a' a m r - push = go where - go a = - respond a ?>= \a' -> - request a' ?>= \a2 -> - go a2 - {- DO NOT replace 'go' with 'push' or ghc-7.4.2 will not terminate while - compiling `pipes` -} - - -- | @(p >>~ f)@ pairs each 'respond' in @p@ with a 'request' in @f@. - (>>~) - :: (Monad m) - => p a' a b' b m r - -> (b -> p b' b c' c m r) - -> p a' a c' c m r - - -- | 'turn' swaps 'request's and 'respond's - turn :: (Monad m) => p a' a b' b m r -> p b b' a a' m r - -{-| \"pull\" composition - -> (f >-> g) x = f ->> g x - - Compose two proxies blocked on a 'respond', generating a new proxy 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) -f >-> g = \c' -> f ->> g c' -{-# INLINABLE (>->) #-} - -{-| \"push\" composition - -> (f >~> g) x = f x >>~ g - - Compose two proxies blocked on a 'request', generating 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) -k1 >~> k2 = \a -> k1 a >>~ k2 -{-# INLINABLE (>~>) #-} - -{-| \"request\" composition - -> (f \>\ g) x = f >\\ g x - - Compose two folds, generating a new fold --} -(\>\) - :: (Monad m, Proxy p) - => (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 = \c' -> f >\\ g c' -{-# INLINABLE (\>\) #-} - -{-| \"respond\" composition - -> (f />/ g) x = f x //> g - - Compose two unfolds, generating a new unfold --} -(/>/) - :: (Monad m, Proxy p) - => (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 = \a -> f a //> g -{-# INLINABLE (/>/) #-} - --- | Equivalent to ('>->') with the arguments flipped -(<-<) - :: (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 -{-# INLINABLE (<-<) #-} - --- | Equivalent to ('>~>') with the arguments flipped -(<~<) - :: (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 -{-# INLINABLE (<~<) #-} - --- | Equivalent to ('\>\') with the arguments flipped -(/ (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 -{-# INLINABLE (//') with the arguments flipped -(\<\) - :: (Monad m, Proxy 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 -{-# INLINABLE (\<\) #-} - --- | Equivalent to ('->>') with the arguments flipped -(<<-) - :: (Monad m, Proxy p) - => p b' b c' c m r - -> (b' -> p a' a b' b m r) - -> p a' a c' c m r -k <<- p = p ->> k -{-# INLINABLE (<<-) #-} - --- | Equivalent to ('>>~') with the arguments flipped -(~<<) - :: (Monad m, Proxy p) - => (b -> p b' b c' c m r) - -> p a' a b' b m r - -> p a' a c' c m r -k ~<< p = p >>~ k -{-# INLINABLE (~<<) #-} - --- | Equivalent to ('>\\') with the arguments flipped -(//<) - :: (Monad m, Proxy p) - => p b' b x' x m c - -> (b' -> p a' a x' x m b) - -> p a' a x' x m c -p //< f = f >\\ p -{-# INLINABLE (//<) #-} - --- | Equivalent to ('//>') with the arguments flipped -(<\\) - :: (Monad m, Proxy p) - => (b -> p x' x c' c m b') - -> p x' x b' b m a' - -> p x' x c' c m a' -f <\\ p = p //> f -{-# INLINABLE (<\\) #-} - --- | A monad transformer over a proxy's downstream output -newtype RespondT (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' a b' m b = - RespondT { runRespondT :: p a' a b' b m b' } - -instance (Monad m, Proxy p) => Functor (RespondT p a' a b' m) where - fmap f p = RespondT (runRespondT p //> \a -> respond (f a)) - -instance (Monad m, Proxy p) => Applicative (RespondT p a' a b' m) where - pure a = RespondT (respond a) - mf <*> mx = RespondT ( - runRespondT mf //> \f -> - runRespondT mx //> \x -> - respond (f x) ) - -instance (Monad m, Proxy p) => Monad (RespondT p a' a b' m) where - return a = RespondT (respond a) - m >>= f = RespondT (runRespondT m //> \a -> runRespondT (f a)) - -instance (Proxy p) => MonadTrans (RespondT p a' a b') where - lift m = RespondT (lift_P m ?>= \a -> respond a) - -instance (MonadIO m, Proxy p) => MonadIO (RespondT p a' a b' m) where - liftIO m = lift (liftIO m) - -instance (Monad m, Proxy p, Monoid b') - => Alternative (RespondT p a' a b' m) where - empty = RespondT (return_P mempty) - p1 <|> p2 = RespondT ( - runRespondT p1 ?>= \r1 -> - runRespondT p2 ?>= \r2 -> - return_P (mappend r1 r2) ) - -instance (Monad m, Proxy p, Monoid b') => MonadPlus (RespondT p a' a b' m) where - mzero = empty - mplus = (<|>) - -{- $listT - The 'RespondT' monad transformer is equivalent to 'ListT' over the - downstream output. The 'RespondT' Kleisli category corresponds to the - \"respond\" category. - - The 'RequestT' monad transformer is equivalent to 'ListT' over the upstream - output. The 'RequestT' Kleisli category corresponds to the \"request\" - category. - - Unlike 'ListT' from @transformers@, these monad transformers are correct by - construction and always satisfy the monad and monad transformer laws. --} - - --- | A monad transformer over a proxy's upstream output -newtype RequestT (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a b' b m a' = - RequestT { runRequestT :: p a' a b' b m a } - -instance (Monad m, Proxy p) => Functor (RequestT p a b' b m) where - fmap f p = RequestT (runRequestT p //< \a -> request (f a)) - -instance (Monad m, Proxy p) => Applicative (RequestT p a b' b m) where - pure a = RequestT (request a) - mf <*> mx = RequestT ( - runRequestT mf //< \f -> - runRequestT mx //< \x -> - request (f x) ) - -instance (Monad m, Proxy p) => Monad (RequestT p a b' b m) where - return a = RequestT (request a) - m >>= f = RequestT (runRequestT m //< \a -> runRequestT (f a)) - -instance (Proxy p) => MonadTrans (RequestT p a' a b') where - lift m = RequestT (lift_P m ?>= \a -> request a) - -instance (MonadIO m, Proxy p) => MonadIO (RequestT p a b' b m) where - liftIO m = lift (liftIO m) - -instance (Monad m, Proxy p, Monoid a) - => Alternative (RequestT p a b' b m) where - empty = RequestT (return_P mempty) - p1 <|> p2 = RequestT ( - runRequestT p1 ?>= \r1 -> - runRequestT p2 ?>= \r2 -> - return_P (mappend r1 r2) ) - -instance (Monad m, Proxy p, Monoid a) => MonadPlus (RequestT p a b' b m) where - mzero = empty - mplus = (<|>) - --- | The empty type, denoting a \'@C@\'losed end -data C = C -- Constructor not exported, but I include it to avoid EmptyDataDecls - --- | 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 'runProxy' - - 'Session's never 'request' or 'respond'. --} -type Session (p :: * -> * -> * -> * -> (* -> *) -> * -> *) = p C () () C - --- | 'ProduceT' is 'ListT' over the downstream output -type ProduceT p = RespondT p C () () - --- | 'CoProduceT' is 'ListT' over the upstream output -type CoProduceT p = RequestT p () () C - -{- $laws - First, all proxies sit at the intersection of five categories: - - * The Kleisli category (all proxies are monads) - -> return >=> f = f -> -> f >=> return = f -> -> (f >=> g) >=> h = f >=> (g >=> h) - - * The \"request\" category - -> request \>\ f = f -> -> f \>\ request = f -> -> (f \>\ g) \>\ h = f \>\ (g \>\ h) - - * The \"respond\" category - -> respond />/ f = f -> -> f />/ respond = f -> -> (f />/ g) />/ h = f />/ (g />/ h) - - * The \"pull\" category - -> pull >-> f = f -> -> f >-> pull = f -> -> (f >-> g) >-> h = (f >-> g) >-> h - - * The \"push\" category - -> push >~> f = f -> -> f >~> push = f -> -> (f >~> g) >~> h = f >~> (g >~> h) - - Second, @(turn .)@ transforms each streaming category into its dual: - - * The \"request\" category - -> turn . request = respond -> -> turn . (f \>\ g) = turn . f \<\ turn . g - - * The \"respond\" category - -> turn . respond = request -> -> turn . (f />/ g) = turn . f / turn . pull = push -> -> turn . (f >-> g) = turn . f <~< turn . g - - * The \"push\" category - -> turn . push = pull -> -> turn . (f >~> g) = turn . f <-< turn . g - - Third, all proxies are monad transformers and must satisfy the monad - transformer laws, using: - - * @lift = lift_P@ - - Fourth, all proxies are functors in the category of monads and must satisfy - the functor laws, using: - - * @hoist = hoist_P@ - - Fifth, ('\>\') and ('/>/') both define functors between Kleisli categories - -> a \>\ (b >=> c) = (a \>\ b) >=> (a \>\ c) -> -> a \>\ return = return - -> (b >=> c) />/ a = (b />/ a) >=> (c />/ a) -> -> return />/ a = return - - Sixth, all proxies must satisfy these additional 'Proxy' laws: - -> p \>\ lift . f = lift . f -> -> p \>\ respond = respond -> -> lift . f />/ p = lift . f -> -> request />/ p = request -> -> pull = request >=> respond >=> pull -> -> push = respond >=> request >=> push -> -> p1 >-> lift . f = lift . f -> -> p1 >-> (lift . f >=> respond >=> p2) = lift . f >=> respond >=> (p1 >-> p2) -> -> (lift . g >=> respond >=> p1) >-> (lift . f >=> request >=> lift . h >=> p2) -> = lift . (f >=> g >=> h) >=> (p1 >-> p2) -> -> (lift . g >=> request >=> p1) >-> (lift . f >=> request >=> p2) -> = lift . (f >=> g) >=> request >=> (p1 >~> p2) -> -> lift . f >~> p2 = lift . f -> -> (lift . f >=> request >=> p1) >~> p2 = lift . f >=> request >=> (p1 >~> p2) -> -> (lift . f >=> respond >=> lift . h >=> p1) >~> (lift . g >=> request >=> p2) -> = lift . (f >=> g >=> h) >=> (p1 >~> p2) -> -> (lift . f >=> respond >=> p1) >~> (lift . g >=> respond >=> p2) -> = lift . (f >=> g) >=> (p1 >-> p2) - --} - -{- $poly - The 'ProxyInternal' and 'MonadPlusP' type classes duplicate 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 (Proxy 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) => ... - - 'ProxyInternal' and 'MonadPlusP' exist solely for internal type class - plumbing and I discourage you from using the methods in these classes - unless you enjoy making your code less readable. 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 @(ProxyInternal p)@ constraint is (basically) equivalent to the - following polymorphic constraint: - -> (forall a' a b' b m . (Monad m) -> => Monad (p a' a b' b m) -> , MonadTrans (p a' a b' b ) -> , MFunctor (p a' a b' b m) -> , MonadIO (p a' a b' b m) -> ) => ... --} -class ProxyInternal p where - return_P :: (Monad m) => r -> p a' a b' b m r - (?>=) - :: (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 :: (Monad m) => m r -> p a' a b' b m r - - hoist_P - :: (Monad m) - => (forall r . m r -> n r) -> (p a' a b' b m r' -> p a' a b' b n r') - - liftIO_P :: (MonadIO m) => IO r -> p a' a b' b m r - - thread_P - :: (Monad m) - => p a' a b' b m r -> s -> p (a', s) (a, s) (b', s) (b, s) m (r, s) - -{-| The @(MonadPlusP p)@ constraint is equivalent to the following polymorphic - 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 - -{- $deprecate - These will be removed in version @4.0.0@ --} - -idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r -idT = pull -{-# INLINABLE idT #-} -{-# DEPRECATED idT "Use 'pull' instead" #-} - -coidT :: (Monad m, Proxy p) => a -> p a' a a' a m r -coidT = push -{-# INLINABLE coidT #-} -{-# DEPRECATED coidT "Use 'push' instead" #-} - -class (Proxy p) => ListT p where -{-# DEPRECATED ListT "Use 'Proxy' instead" #-} - -runRespondK :: (q -> RespondT p a' a b' m b) -> (q -> p a' a b' b m b') -runRespondK k q = runRespondT (k q) -{-# INLINABLE runRespondK #-} -{-# DEPRECATED runRespondK "Use '(runRespondT .)' instead" #-} - -runRequestK :: (q -> RequestT p a b' b m a') -> (q -> p a' a b' b m a) -runRequestK k q = runRequestT (k q) -{-# INLINABLE runRequestK #-} -{-# DEPRECATED runRequestK "Use '(runRequestK .)' instead" #-} diff --git a/Control/Proxy/Core.hs b/Control/Proxy/Core.hs deleted file mode 100644 --- a/Control/Proxy/Core.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | Default imports for the "Control.Proxy" hierarchy - -module Control.Proxy.Core ( - -- * Modules - -- $modules - module Control.Proxy.Class, - module Control.Proxy.Prelude, - module Control.Proxy.Trans, - module Control.Proxy.Trans.Identity, - module Control.Proxy.Morph, - module Control.Monad, - module Control.Monad.Trans.Class, - module Control.Monad.Morph, - ) where - -import Control.Monad (forever, (>=>), (<=<)) -import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class -import Control.Proxy.Morph -import Control.Proxy.Prelude -import Control.Proxy.Trans -import Control.Proxy.Trans.Identity - -{- $modules - "Control.Proxy.Class" defines the 'Proxy' type class that lets you program - generically over proxy implementations and their transformers. - - "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.Proxy.Morph" exports 'hoistP'. - - "Control.Monad" exports 'forever', ('>=>'), and ('<=<'). - - "Control.Monad.Trans.Class" exports 'lift'. - - "Control.Monad.Morph" 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,196 +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(..), - ProxyStep(..), - - -- * Run Sessions - -- $run - runProxy, - runProxyK - ) where - -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P) ) - -{-| A 'ProxyCorrect' communicates with an upstream interface and a downstream - interface. - - The type variables signify: - - * @a'@ - The request supplied to the upstream interface - - * @a @ - The response provided by the upstream interface - - * @b'@ - The request supplied by the downstream interface - - * @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 (ProxyStep a' a b' b m r) } - --- | The pure component of 'ProxyCorrect' -data ProxyStep a' a b' b m r - = Request a' (a -> ProxyCorrect a' a b' b m r) - | Respond b (b' -> ProxyCorrect a' a b' b m r) - | Pure r - -instance (Monad m) => Functor (ProxyCorrect a' a b' b m) where - fmap f = go 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 m = Proxy (m >>= \r -> return (Pure r)) - -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 ))) - -instance (MonadIO m) => MonadIO (ProxyCorrect a' a b' b m) where - liftIO m = Proxy (liftIO (m >>= \r -> return (Pure r))) - -instance ProxyInternal ProxyCorrect where - return_P = return - (?>=) = (>>=) - - lift_P = lift - - hoist_P = hoist - - liftIO_P = liftIO - - thread_P p s = Proxy (do - x <- unProxy p - return (case x of - Request a' fa -> - Request (a', s) (\(a , s') -> thread_P (fa a ) s') - Respond b fb' -> - Respond (b , s) (\(b', s') -> thread_P (fb' b') s') - Pure r -> - Pure (r, s) ) ) - -instance Proxy ProxyCorrect where - fb' ->> p = Proxy (do - x <- unProxy p - 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) ) - p >>~ fb = Proxy (do - x <- unProxy p - 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'))))) - - fb' >\\ p0 = go p0 - where - go p = Proxy (do - y <- unProxy p - case y of - Request b' fb -> unProxy (fb' b' >>= \b -> go (fb b)) - Respond x fx' -> return (Respond x (\x' -> go (fx' x'))) - Pure a -> return (Pure a) ) - p0 //> fb = go p0 - where - go p = Proxy (do - y <- unProxy p - case y of - Request x' fx -> return (Request x' (\x -> go (fx x))) - Respond b fb' -> unProxy (fb b >>= \b' -> go (fb' b')) - Pure a -> return (Pure a) ) - - turn = go - where - go p = Proxy (do - x <- unProxy p - return (case x of - Request a fa' -> Respond a (\a' -> go (fa' a')) - Respond b' fb -> Request 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', converting it back to the base monad -run :: (Monad m) => ProxyCorrect a' () () b m r -> m r -run p = do - x <- unProxy p - case x of - Request _ fa -> run (fa ()) - Respond _ fb' -> run (fb' ()) - Pure r -> return r - -{-| 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 = run (k ()) where -{-# INLINABLE runProxy #-} - -{-| Run a self-sufficient 'ProxyCorrect' Kleisli arrow, converting it back to a - Kleisli arrow in the base monad --} -runProxyK :: (Monad m) => (q -> ProxyCorrect a' () () b m r) -> (q -> m r) -runProxyK k q = run (k q) -{-# INLINABLE runProxyK #-} 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,282 +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 - - The monad transformer laws do hold when viewed through the safe API exported - from "Control.Proxy". - - 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. --} - -{-# LANGUAGE Trustworthy #-} -{- The rewrite RULES require the 'TrustWorthy' annotation. Their proofs are - pretty trivial since they are just inlining the definition of their - respective operators. GHC doesn't do this inlining automatically because the - @go@ helper function is recursive. --} - -module Control.Proxy.Core.Fast ( - -- * Types - ProxyFast(..), - - -- * Run Sessions - -- $run - runProxy, - runProxyK, - - -- * Safety - observe - ) where - -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P)) - -{-| A 'ProxyFast' communicates with an upstream interface and a downstream - interface. - - The type variables signify: - - * @a'@ - The request supplied to the upstream interface - - * @a @ - The response provided by the upstream interface - - * @b'@ - The request supplied by the downstream interface - - * @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 - -{-# RULES - "_bind (Request a' k) f" forall a' k f . - _bind (Request a' k) f = Request a' (\a -> _bind (k a) f); - "_bind (Respond b k) f" forall b k f . - _bind (Respond b k) f = Respond b (\b' -> _bind (k b') f); - "_bind (M m) f" forall m f . - _bind (M m) f = M (m >>= \p -> return (_bind p f)); - "_bind (Pure r ) f" forall r f . - _bind (Pure r) f = f r; - #-} - --- | Only satisfies monad transformer 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)) - -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 - -instance (MonadIO m) => MonadIO (ProxyFast a' a b' b m) where - liftIO m = M (liftIO (m >>= \r -> return (Pure r))) - -instance ProxyInternal ProxyFast where - return_P = Pure - (?>=) = _bind - - lift_P = _lift - - liftIO_P = liftIO - - hoist_P = hoist - - thread_P p s = case p of - Request a' fa -> Request (a', s) (\(a , s') -> thread_P (fa a ) s') - Respond b fb' -> Respond (b, s) (\(b', s') -> thread_P (fb' b') s') - M m -> M (m >>= \p' -> return (thread_P p' s)) - Pure r -> Pure (r, s) - -instance Proxy ProxyFast where - fb' ->> p = case p of - Request b' fb -> fb' b' >>~ fb - Respond c fc' -> Respond c (\c' -> fb' ->> fc' c') - M m -> M (m >>= \p' -> return (fb' ->> p')) - Pure r -> Pure r - p >>~ fb = case p of - Request a' fa -> Request a' (\a -> fa a >>~ fb) - Respond b fb' -> fb' ->> fb b - M m -> M (m >>= \p' -> return (p' >>~ fb)) - Pure r -> Pure r - - request = \a' -> Request a' Pure - respond = \b -> Respond b Pure - - (>\\) = _req - (//>) = _resp - - turn = go - where - go p = case p of - Request a' fa -> Respond a' (\a -> go (fa a )) - Respond b fb' -> Request b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure r -> Pure r - -_req - :: (Monad m) - => (b' -> ProxyFast a' a x' x m b) - -> ProxyFast b' b x' x m c - -> ProxyFast a' a x' x m c -fb' `_req` p0 = go p0 where - go p = case p of - Request b' fb -> fb' b' >>= \b -> go (fb b) - Respond x fx' -> Respond x (\x' -> go (fx' x')) - M m -> M (m >>= \p' -> return (go p')) - Pure a -> Pure a - -{-# RULES - "_req fb' (Request b' fb )" forall fb' b' fb . - _req fb' (Request b' fb ) = _bind (fb' b') (\b -> _req fb' (fb b)); - "_req fb' (Respond x fx')" forall fb' x fx' . - _req fb' (Respond x fx') = Respond x (\x' -> _req fb' (fx' x')); - "_req fb' (M m )" forall fb' m . - _req fb' (M m ) = M (m >>= \p' -> return (_req fb' p')); - "_req fb' (Pure a )" forall fb' a . - _req fb' (Pure a ) = Pure a; - #-} - -_resp - :: (Monad m) - => ProxyFast x' x b' b m a' - -> (b -> ProxyFast x' x c' c m b') - -> ProxyFast x' x c' c m a' -p0 `_resp` fb = go p0 where - go p = case p of - Request x' fx -> Request x' (\x -> go (fx x)) - Respond b fb' -> fb b >>= \b' -> go (fb' b') - M m -> M (m >>= \p' -> return (go p')) - Pure a -> Pure a - -{-# RULES - "_resp (Request x' fx ) fb" forall x' fx fb . - _resp (Request x' fx ) fb = Request x' (\x -> _resp (fx x) fb); - "_resp (Respond b fb') fb" forall b fb' fb . - _resp (Respond b fb') fb = _bind (fb b) (\b' -> _resp (fb' b') fb); - "_resp (M m ) fb" forall m fb . - _resp (M m ) fb = M (m >>= \p' -> return (_resp p' fb)); - "_resp (Pure a ) fb" forall a fb . - _resp (Pure a ) fb = Pure a; - #-} - -{- $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', converting it back to the base monad -run :: (Monad m) => ProxyFast a' () () b m r -> m r -run p = case p of - Request _ fa -> run (fa ()) - Respond _ fb' -> run (fb' ()) - M m -> m >>= run - Pure r -> return r - -{-| 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 = run (k ()) -{-# INLINABLE runProxy #-} - -{-| Run a self-sufficient 'ProxyFast' Kleisli arrow, converting it back to a - Kleisli arrow in the base monad --} -runProxyK :: (Monad m) => (q -> ProxyFast a' () () b m r) -> (q -> m r) -runProxyK k q = run (k q) -{-# INLINABLE runProxyK #-} - -{-| 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 p0 = M (go p0) 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'))) -{-# INLINABLE observe #-} diff --git a/Control/Proxy/Morph.hs b/Control/Proxy/Morph.hs deleted file mode 100644 --- a/Control/Proxy/Morph.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-| A proxy morphism is a natural transformation: - -> morph :: forall r . p a' a b' b m r -> q a' a b' b n r - - ... that defines a functor between five categories: - - * Functor between Kleisli categories: - -> morph . p1 >=> morph . p2 = morph . (p1 >=> p2) -> -> morph . return = return - - * Functor between 'P.Proxy' composition categories: - -> morph . p1 >-> morph . p2 = morph . (p1 >-> p2) -> -> morph . pull = pull - -> morph . p1 >~> morph . p2 = morph . (p1 >~> p2) -> -> morph . push = push - - * Functor between 'ListT' Kleisli categories: - -> morph . p1 \>\ morph . p2 = morph . (p2 \>\ p2) -> -> morph . request = request - -> morph . p1 />/ morph . p2 = morph . (p2 />/ p2) -> -> morph . respond = respond - - Examples of proxy morphisms include: - - * 'liftP' (from 'ProxyTrans') - - * 'squashP' (See below) - - * @'hoistP' f@ (See below) if @f@ is a proxy morphism - - * @(f . g)@, if @f@ and @g@ are both proxy morphisms - - * 'id' - - Proxy morphisms commonly arise when manipulating existing proxy transformer - code for compatibility purposes. The 'PFUnctor', 'ProxyTrans', and 'PMonad' - classes define standard ways to change proxy transformer stacks: - - * 'liftP' introduces a new proxy transformer layer of any type:. - - * 'squashP' flattens two identical monad transformer layers into a single - layer of the same type. - - * 'hoistP' maps proxy morphisms to modify deeper layers of the proxy - transformer stack. --} - -{-# LANGUAGE KindSignatures, Rank2Types #-} - -module Control.Proxy.Morph ( - -- * Functors over Proxies - PFunctor(..), - - -- * Monads over Proxies - PMonad(..), - squashP - ) where - -import Control.Proxy.Class (Proxy) - --- For documentation -import Control.Proxy.Trans (ProxyTrans(liftP)) - -{-| A functor in the category of proxies, using 'hoistP' as the analog of - 'fmap': - -> hoistP f . hoistP g = hoistP (f . g) -> -> hoistP id = id --} -class PFunctor (t - :: (* -> * -> * -> * -> (* -> *) -> * -> *) - -> * -> * -> * -> * -> (* -> *) -> * -> * ) where - {-| Lift a proxy morphism from @p1@ to @p2@ into a proxy morphism from - @(t p1)@ to @(t p2)@ - -} - hoistP - :: (Monad m1, Proxy p1) - => (forall _a' _a _b' _b _r . - p1 _a' _a _b' _b m1 _r -> p2 _a' _a _b' _b m2 _r) - -- ^ Proxy morphism - -> ( t p1 a' a b' b m1 r -> t p2 a' a b' b m2 r) - -{-| A monad in the category of monads, using 'liftP' from 'ProxyTrans' as the - analog of 'return' and 'embedP' as the analog of ('=<<'): - -> embedP liftP = id -> -> embedP f (liftP p) = f p -> -> embed g (embed f t) = embed (\p -> embed g (f p)) t --} -class (PFunctor t, ProxyTrans t) => PMonad t where - {-| Embed a newly created 'PMonad' layer within an existing layer - - 'embedP' is analogous to ('=<<') - -} - embedP - :: (Monad m2, Proxy p2) - => (forall _a' _a _b' _b _r - . p1 _a' _a _b' _b m1 _r -> t p2 _a' _a _b' _b m2 _r) - -- ^ Proxy morphism - -> ( t p1 a' a b' b m1 r -> t p2 a' a b' b m2 r) - -{-| Squash two 'PMonad' layers into a single layer - - 'squashP' is analogous to 'join' --} -squashP - :: (Monad m, Proxy p, PMonad t) - => t (t p) a' a b' b m r -> t p a' a b' b m r -squashP = embedP id -{-# INLINABLE squashP #-} diff --git a/Control/Proxy/Pipe.hs b/Control/Proxy/Pipe.hs deleted file mode 100644 --- a/Control/Proxy/Pipe.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-| 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. --} -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Pipe - {-# DEPRECATED "Use official 'Proxy' operations instead" #-} ( - -- * 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, respond, request, (->>), Pipe, C) -import Control.Proxy.Trans.Identity (runIdentityP) - --- For documentation -import Control.Proxy.Class (Consumer, Producer) - -{-| 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 () -{-# INLINABLE await #-} - -{-| 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 b' -yield = respond -{-# INLINABLE yield #-} - --- | 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) -{-# INLINABLE pipe #-} - -infixr 7 <+< -infixl 7 >+> - --- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<+<) - :: (Monad m, Proxy p) - => p b' b c' c m r - -> p a' a b' b m r - -> p a' a c' c m r -p1 <+< p2 = p2 >+> p1 -{-# INLINABLE (<+<) #-} - --- | Corresponds to ('>>>') from @Control.Category@ -(>+>) - :: (Monad m, Proxy p) - => p a' a b' b m r - -> p b' b c' c m r - -> p a' a c' c m r -p1 >+> p2 = (\_ -> p1) ->> p2 -{-# INLINABLE (>+>) #-} - --- | 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 -{-# INLINABLE idP #-} - -{-| 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,1076 +0,0 @@ --- | General purpose proxies - -{-# LANGUAGE Rank2Types #-} - -module Control.Proxy.Prelude ( - -- * I/O - stdinS, - stdoutD, - readLnS, - hGetLineS, - hPutStrLnD, - printD, - printU, - printB, - - -- * Maps - mapD, - mapU, - mapMD, - mapMU, - useD, - useU, - execD, - execU, - - -- * Filters - takeB, - takeB_, - takeWhileD, - takeWhileU, - dropD, - dropU, - dropWhileD, - dropWhileU, - filterD, - filterU, - - -- * Lists and Enumerations - fromListS, - enumFromS, - enumFromToS, - eachS, - rangeS, - - -- * Folds - foldD, - allD, - allD_, - anyD, - anyD_, - sumD, - productD, - lengthD, - headD, - headD_, - lastD, - toListD, - foldrD, - - -- * ArrowChoice - -- $choice - leftD, - rightD, - - -- * Zips and Merges - zipD, - mergeD, - - -- * Closed Adapters - -- $open - unitD, - unitU, - - -- * Kleisli utilities - foreverK, - - -- * Re-exports - module Data.Monoid, - - -- * Deprecated - -- $deprecate - mapB, - mapMB, - useB, - execB, - fromListC, - enumFromC, - enumFromToC, - eachC, - rangeC, - getLineS, - getLineC, - readLnC, - putStrLnD, - putStrLnU, - putStrLnB, - hGetLineC, - hPutStrLnU, - hPutStrLnB, - hPrintD, - hPrintU, - hPrintB, - replicateK, - liftK, - hoistK, - raise, - raiseK, - hoistPK, - raiseP, - raisePK - ) where - -import Control.Monad (forever) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class -import Control.Proxy.Morph (PFunctor(hoistP)) -import Control.Proxy.Trans (ProxyTrans(liftP)) -import Control.Proxy.Trans.Identity ( - IdentityP(IdentityP, runIdentityP), runIdentityK) -import Control.Proxy.Trans.Writer (WriterP, tell) -import Data.Monoid ( - Monoid(mempty, mappend), - Endo(Endo, appEndo), - All(All, getAll), - Any(Any, getAny), - Sum(Sum, getSum), - Product(Product, getProduct), - First(First, getFirst), - Last(Last, getLast) ) -import qualified System.IO as IO - -{-| A 'Producer' that sends lines from 'stdin' downstream - -> stdinS = hGetLineS stdin --} -stdinS :: (Proxy p) => () -> Producer p String IO r -stdinS () = runIdentityP $ forever $ do - str <- lift getLine - respond str -{-# INLINABLE stdinS #-} - -{-| 'putStrLn's all values flowing \'@D@\'ownstream to 'stdout' - -> stdoutD = hPutStrLnD stdout --} -stdoutD :: (Proxy p) => x -> p x String x String IO r -stdoutD = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ putStrLn a - respond a -{-# INLINABLE stdoutD #-} - --- | '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 -{-# INLINABLE readLnS #-} - --- | 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 -{-# INLINABLE hGetLineS #-} - --- | '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 -{-# INLINABLE hPutStrLnD #-} - --- | '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 -{-# INLINABLE printD #-} - --- | '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 -{-# INLINABLE printU #-} - -{-| '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 -{-# INLINABLE printB #-} - -{-| @(mapD f)@ applies @f@ to all values going \'@D@\'ownstream. - -> mapD f1 >-> mapD f2 = mapD (f2 . f1) -> -> mapD id = pull --} -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 = runIdentityK (foreverK $ request >=> respond . f) -{-# INLINABLE mapD #-} - -{-| @(mapU g)@ applies @g@ to all values going \'@U@\'pstream. - -> mapU g1 >-> mapU g2 = mapU (g1 . g2) -> -> mapU id = pull --} -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 -{-# INLINABLE mapU #-} - -{-| @(mapMD f)@ applies the monadic function @f@ to all values going downstream - -> mapMD f1 >-> mapMD f2 = mapMD (f1 >=> f2) -> -> mapMD return = pull --} -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 -{-# INLINABLE mapMD #-} - -{-| @(mapMU g)@ applies the monadic function @g@ to all values going upstream - -> mapMU g1 >-> mapMU g2 = mapMU (g2 >=> g1) -> -> mapMU return = pull --} -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 -{-# INLINABLE mapMU #-} - -{-| @(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 ()) = pull --} -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 -{-# INLINABLE useD #-} - -{-| @(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 ()) = pull --} -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 -{-# INLINABLE useU #-} - -{-| @(execD md)@ executes @md@ every time values flow downstream through it. - -> execD md1 >-> execD md2 = execD (md1 >> md2) -> -> execD (return ()) = pull --} -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 -} -{-# INLINABLE execD #-} - -{-| @(execU mu)@ executes @mu@ every time values flow upstream through it. - -> execU mu1 >-> execU mu2 = execU (mu2 >> mu1) -> -> execU (return ()) = pull --} -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 -} -{-# INLINABLE execU #-} - -{-| @(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 = runIdentityK (replicateK n $ request >=> respond) -{-# INLINABLE takeB #-} - --- | '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) -{-# INLINABLE takeB_ #-} - -{-| @(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 = pull --} -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 () -{-# INLINABLE takeWhileD #-} - -{-| @(takeWhileU p)@ allows values to pass upstream so long as they satisfy the - predicate @p@. - -> takeWhileU p1 >-> takeWhileU p2 = takeWhileU (p1 <> p2) -> -> takeWhileD mempty = pull --} -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 () -{-# INLINABLE takeWhileU #-} - -{-| @(dropD n)@ discards @n@ values going downstream - -> dropD n1 >-> dropD n2 = dropD (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropD 0 = pull --} -dropD :: (Monad m, Proxy p) => Int -> () -> Pipe p a a m r -dropD n0 = \() -> runIdentityP (go n0) where - go n - | n <= 0 = pull () - | otherwise = do - _ <- request () - go (n - 1) -{- dropD n () = do - replicateM_ n $ request () - pull () -} -{-# INLINABLE dropD #-} - -{-| @(dropU n)@ discards @n@ values going upstream - -> dropU n1 >-> dropU n2 = dropU (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropU 0 = pull --} -dropU :: (Monad m, Proxy p) => Int -> a' -> CoPipe p a' a' m r -dropU n0 = runIdentityK (go n0) where - go n - | n <= 0 = pull - | otherwise = \_ -> do - a' <- respond () - go (n - 1) a' -{-# INLINABLE dropU #-} - -{-| @(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 = pull --} -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 - pull x -{-# INLINABLE dropWhileD #-} - -{-| @(dropWhileU p)@ discards values going upstream until one violates the - predicate @p@. - -> dropWhileU p1 >-> dropWhileU p2 = dropWhileU (p1 <> p2) -> -> dropWhileU mempty = pull --} -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 pull a' -{-# INLINABLE dropWhileU #-} - -{-| @(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 = pull --} -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 -{-# INLINABLE filterD #-} - -{-| @(filterU p)@ discards values going upstream if they fail the predicate @p@ - -> filterU p1 >-> filterU p2 = filterU (p1 <> p2) -> -> filterU mempty = pull --} -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 -{-# INLINABLE filterU #-} - -{-| 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 -{-# INLINABLE fromListS #-} - --- | '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 -{-# INLINABLE enumFromS #-} - --- | '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 -{-# INLINABLE enumFromToS #-} - -{-| Non-deterministically choose from all values in the given list - -> mappend <$> eachS xs <*> eachS ys = eachS (mappend <$> xs <*> ys) -> -> eachS (pure mempty) = pure mempty --} -eachS :: (Monad m, Proxy p) => [b] -> ProduceT p m b -eachS bs = RespondT (fromListS bs ()) -{-# INLINABLE eachS #-} - --- | Non-deterministically choose from all values in the given range -rangeS :: (Enum b, Ord b, Monad m, Proxy p) => b -> b -> ProduceT p m b -rangeS b1 b2 = RespondT (enumFromToS b1 b2 ()) -{-# INLINABLE rangeS #-} - -{-| Strict fold over values flowing \'@D@\'ownstream. - -> foldD f >-> foldD g = foldD (f <> g) -> -> foldD mempty = idPull --} -foldD - :: (Monad m, Proxy p, Monoid w) => (a -> w) -> x -> WriterP w p x a x a m r -foldD f = go where - go x = do - a <- request x - tell (f a) - x2 <- respond a - go x2 -{-# INLINABLE foldD #-} - -{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the - predicate --} -allD :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP All p x a x a m r -allD predicate = foldD (All . predicate) -{-# INLINABLE allD #-} - -{-| 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 -> WriterP All p x a x a m () -allD_ predicate = go where - go x = do - a <- request x - if (predicate a) - then do - x2 <- respond a - go x2 - else tell (All False) -{-# INLINABLE allD_ #-} - -{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies the - predicate --} -anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> WriterP Any p x a x a m r -anyD predicate = foldD (Any . predicate) -{-# INLINABLE anyD #-} - -{-| 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 -> WriterP Any p x a x a m () -anyD_ predicate = go where - go x = do - a <- request x - if (predicate a) - then tell (Any True) - else do - x2 <- respond a - go x2 -{-# INLINABLE anyD_ #-} - --- | Compute the 'Sum' of all values that flow \'@D@\'ownstream -sumD :: (Monad m, Proxy p, Num a) => x -> WriterP (Sum a) p x a x a m r -sumD = foldD Sum -{-# INLINABLE sumD #-} - --- | Compute the 'Product' of all values that flow \'@D@\'ownstream -productD :: (Monad m, Proxy p, Num a) => x -> WriterP (Product a) p x a x a m r -productD = foldD Product -{-# INLINABLE productD #-} - --- | Count how many values flow \'@D@\'ownstream -lengthD :: (Monad m, Proxy p) => x -> WriterP (Sum Int) p x a x a m r -lengthD = foldD (\_ -> Sum 1) -{-# INLINABLE lengthD #-} - --- | Retrieve the first value going \'@D@\'ownstream -headD :: (Monad m, Proxy p) => x -> WriterP (First a) p x a x a m r -headD = foldD (First . Just) -{-# INLINABLE headD #-} - -{-| Retrieve the first value going \'@D@\'ownstream - - 'headD_' terminates on the first value it receives --} -headD_ :: (Monad m, Proxy p) => x -> WriterP (First a) p x a x a m () -headD_ x = do - a <- request x - tell $ First (Just a) -{-# INLINABLE headD_ #-} - --- | Retrieve the last value going \'@D@\'ownstream -lastD :: (Monad m, Proxy p) => x -> WriterP (Last a) p x a x a m r -lastD = foldD (Last . Just) -{-# INLINABLE lastD #-} - --- | Fold the values flowing \'@D@\'ownstream into a list -toListD :: (Monad m, Proxy p) => x -> WriterP [a] p x a x a m r -toListD = foldD (\x -> [x]) -{-# INLINABLE toListD #-} - -{-| 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 -> WriterP (Endo b) p x a x a m r -foldrD step = foldD (Endo . step) -{-# INLINABLE foldrD #-} - -{- $choice - 'leftD' and 'rightD' satisfy the 'ArrowChoice' laws using @arr = mapD@. --} - -{-| Lift a proxy to operate only on 'Left' values flowing \'@D@\'ownstream and - forward 'Right' values --} -leftD - :: (Monad m, Proxy p) - => (q -> p x a x b m r) -> (q -> p x (Either a e) x (Either b e) m r) -leftD k = runIdentityK (up \>\ (IdentityP . k />/ dn)) - where - dn b = respond (Left b) - up x = do - ma <- request x - case ma of - Left a -> return a - Right e -> do - x2 <- respond (Right e) - up x2 -{-# INLINABLE leftD #-} - -{-| Lift a proxy to operate only on 'Right' values flowing \'@D@\'ownstream and - forward 'Left' values --} -rightD - :: (Monad m, Proxy p) - => (q -> p x a x b m r) -> (q -> p x (Either e a) x (Either e b) m r) -rightD k = runIdentityK (up \>\ (IdentityP . k />/ dn)) - where - dn b = respond (Right b) - up x = do - ma <- request x - case ma of - Left e -> do - x2 <- respond (Left e) - up x2 - Right a -> return a -{-# INLINABLE rightD #-} - --- | 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 -{-# INLINABLE zipD #-} - --- | 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 -{-# INLINABLE mergeD #-} - -{- $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) => q -> p x' x y' () m r -unitD _ = runIdentityP go where - go = do - _ <- respond () - go -{-# INLINABLE unitD #-} - --- | Compose 'unitU' with a closed downstream end to create a polymorphic end -unitU :: (Monad m, Proxy p) => q -> p () x y' y m r -unitU _ = runIdentityP go where - go = do - _ <- request () - go -{-# INLINABLE unitU #-} - -{- $modules - These modules help you build, run, and extract folds --} - -{-| 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 --} -{-# INLINABLE foreverK #-} - -{- $deprecate - To be removed in version @4.0.0@ --} - -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 -{-# INLINABLE mapB #-} -{-# DEPRECATED mapB "Combine 'mapD' and 'mapU' instead" #-} - -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 -{-# INLINABLE mapMB #-} -{-# DEPRECATED mapMB "Combine 'mapMD' and 'mapMU' instead" #-} - -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 -{-# INLINABLE useB #-} -{-# DEPRECATED useB "Combined 'useD' and 'useU' instead" #-} - -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 -{-# INLINABLE execB #-} -{-# DEPRECATED execB "Combine 'execD' and 'execU' instead" #-} - -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 -{-# INLINABLE fromListC #-} -{-# DEPRECATED fromListC "Use 'turn . fromListS xs' instead" #-} - -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' -{-# INLINABLE enumFromC #-} -{-# DEPRECATED enumFromC "Use 'turn . enumFromS n' instead" #-} - -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 -{-# INLINABLE enumFromToC #-} -{-# DEPRECATED enumFromToC "Use 'turn . enumFromToS n1 n2' instead" #-} - -eachC :: (Monad m, Proxy p) => [a'] -> CoProduceT p m a' -eachC a's = RequestT (fromListC a's ()) -{-# INLINABLE eachC #-} -{-# DEPRECATED eachC "Use 'RequestT $ turn $ fromListS xs ()' instead" #-} - -rangeC - :: (Enum a', Ord a', Monad m, Proxy p) => a' -> a' -> CoProduceT p m a' -rangeC a'1 a'2 = RequestT (enumFromToC a'1 a'2 ()) -{-# INLINABLE rangeC #-} -{-# DEPRECATED rangeC "Use 'RequestT $ turn $ enumFromToS n1 n2 ()' instead" #-} - -getLineS :: (Proxy p) => () -> Producer p String IO r -getLineS () = runIdentityP $ forever $ do - str <- lift getLine - respond str -{-# INLINABLE getLineS #-} -{-# DEPRECATED getLineS "Use 'stdinS' instead" #-} - -getLineC :: (Proxy p) => () -> CoProducer p String IO r -getLineC () = runIdentityP $ forever $ do - str <- lift getLine - request str -{-# INLINABLE getLineC #-} -{-# DEPRECATED getLineC "Use 'turn . stdinS' instead" #-} - -readLnC :: (Read a', Proxy p) => () -> CoProducer p a' IO r -readLnC () = runIdentityP $ forever $ do - a <- lift readLn - request a -{-# INLINABLE readLnC #-} -{-# DEPRECATED readLnC "Use 'turn . readLnC' instead" #-} - -putStrLnD :: (Proxy p) => x -> p x String x String IO r -putStrLnD = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ putStrLn a - respond a -{-# INLINABLE putStrLnD #-} -{-# DEPRECATED putStrLnD "Use 'stdoutD' instead" #-} - -putStrLnU :: (Proxy p) => String -> p String x String x IO r -putStrLnU = runIdentityK $ foreverK $ \a' -> do - lift $ putStrLn a' - x <- request a' - respond x -{-# INLINABLE putStrLnU #-} -{-# DEPRECATED putStrLnU "Use 'execU putStrLn' instead" #-} - -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 -{-# INLINABLE putStrLnB #-} -{-# DEPRECATED putStrLnB "Not that useful" #-} - -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 -{-# INLINABLE hGetLineC #-} -{-# DEPRECATED hGetLineC "Use 'turn . hGetLineS h'" #-} - --- | '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 -{-# INLINABLE hPrintD #-} -{-# DEPRECATED hPrintD "Not that useful" #-} - --- | '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 -{-# INLINABLE hPrintU #-} -{-# DEPRECATED hPrintU "Not that useful" #-} - -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 -{-# INLINABLE hPrintB #-} -{-# DEPRECATED hPrintB "Not that useful" #-} - -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 -{-# INLINABLE hPutStrLnU #-} -{-# DEPRECATED hPutStrLnU "Not that useful" #-} - -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 -{-# INLINABLE hPutStrLnB #-} -{-# DEPRECATED hPutStrLnB "Not that useful" #-} - -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) -{-# INLINABLE replicateK #-} -{-# DEPRECATED replicateK "Not very useful" #-} - -liftK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b) -liftK k a = lift (k a) -{-# INLINABLE liftK #-} -{-# DEPRECATED liftK "Use '(lift .)' instead" #-} - -hoistK - :: (Monad m, MFunctor t) - => (forall a . m a -> n a) -- ^ Monad morphism - -> (b' -> t m b) -- ^ Kleisli arrow - -> (b' -> t n b) -hoistK k p a' = hoist k (p a') -{-# INLINABLE hoistK #-} -{-# DEPRECATED hoistK "Use '(hoist f .)' instead" #-} - -raise :: (Monad m, MFunctor t1, MonadTrans t2) => t1 m r -> t1 (t2 m) r -raise = hoist lift -{-# INLINABLE raise #-} -{-# DEPRECATED raise "Use 'hoist lift' instead" #-} - -raiseK - :: (Monad m, MFunctor t1, MonadTrans t2) - => (q -> t1 m r) -> (q -> t1 (t2 m) r) -raiseK = (hoist lift .) -{-# INLINABLE raiseK #-} -{-# DEPRECATED raiseK "Use '(hoist lift .)' instead" #-} - -hoistPK - :: (Monad m, Proxy p1, PFunctor t) - => (forall _a' _a _b' _b _r . - p1 _a' _a _b' _b m _r -> p2 _a' _a _b' _b n _r) -- ^ Proxy morphism - -> (q -> t p1 a' a b' b m r) -- ^ Proxy Kleisli arrow - -> (q -> t p2 a' a b' b n r) -hoistPK f = (hoistP f .) -{-# INLINABLE hoistPK #-} -{-# DEPRECATED hoistPK "Use '(hoistP f .)' instead" #-} - -raiseP - :: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2) - => t1 p a' a b' b m r -- ^ Proxy - -> t1 (t2 p) a' a b' b m r -raiseP = hoistP liftP -{-# INLINABLE raiseP #-} -{-# DEPRECATED raiseP "Use 'hoistP liftP' instead" #-} - -raisePK - :: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2) - => (q -> t1 p a' a b' b m r) -- ^ Proxy Kleisli arrow - -> (q -> t1 (t2 p) a' a b' b m r) -raisePK = hoistPK liftP -{-# INLINABLE raisePK #-} -{-# DEPRECATED raisePK "Use '(hoistP liftP .)' instead" #-} diff --git a/Control/Proxy/Trans.hs b/Control/Proxy/Trans.hs deleted file mode 100644 --- a/Control/Proxy/Trans.hs +++ /dev/null @@ -1,31 +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(..), - - -- * Deprecated - -- $deprecate - mapP - ) where - -import Control.Proxy.Class (Proxy) - --- | 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 - -{- $deprecate - To be removed in version @4.0.0@ --} - -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 .) -{-# INLINABLE mapP #-} -{-# DEPRECATED mapP "Use '(liftP .)' instead" #-} diff --git a/Control/Proxy/Trans/Codensity.hs b/Control/Proxy/Trans/Codensity.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Codensity.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-| This module provides the proxy transformer equivalent of 'CodensityT'. - - The base 'Proxy' implementations suffer a quadratic time complexity if - you repeatedly left-associate the monad bind operation. You can recover - linear time complexity just by adding 'runCodensityK' right after - 'runProxy', which transforms the base 'Proxy' implementation to use - continuation-passing style: - -> -- Before: -> runProxy $ ... -> -> -- After: -> runProxy $ runCodensityK $ ... - - Everything will still type-check if you you wrote your code to be - polymorphic over the base 'Proxy'. - - Note that even though 'CodensityP' has better time complexity for - left-associated binds, it has worse constant factors for everything else - (about 6x slower on pure benchmarks), because: - - * You cannot optimize it using rewrite rules - - * It has a slower composition operation - - So only use it if you actually need it, which is typically only the case if - you left associate your monad binds on the order of hundreds of times. Even - better: only wrap the problematic portions of the pipeline in - 'runCodensityK' so that the performance of the rest of the pipeline does not - suffer. --} - -{-# LANGUAGE KindSignatures, PolymorphicComponents #-} - -module Control.Proxy.Trans.Codensity ( - -- * Codensity Proxy Transformer - CodensityP, - runCodensityP, - runCodensityK - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP)) -import Control.Proxy.Trans (ProxyTrans(liftP)) - --- | The 'Codensity' proxy transformer -newtype CodensityP p a' a b' b (m :: * -> *) r - = CodensityP { unCodensityP - :: forall x . (Monad m, Proxy p) - => (r -> p a' a b' b m x) -> p a' a b' b m x } -{- The type class instances only satisfy their laws if you hide the constructor - for 'CodensityP'. - - Normally you would not have to hide it and you could rely on parametricity to - guarantee that 'CodensityP p' is isomorphic to 'p'. However, the 'MFunctor' - and 'PFunctor' type classes require including class constraints within the - constructor, which breaks parametricity and makes it possible to define - 'CodensityP' values which break the laws for the following type class - instances. --} - -instance (Monad m, Proxy p) => Functor (CodensityP p a' a b' b m) where - fmap f p = CodensityP (\k -> - unCodensityP p (\a -> - k (f a)) ) - -instance (Monad m, Proxy p) => Applicative (CodensityP p a' a b' b m) where - pure = return - fp <*> xp = CodensityP (\k -> - unCodensityP fp (\f -> - unCodensityP xp (\x -> - k (f x) ) ) ) - -instance (Monad m, Proxy p) => Monad (CodensityP p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (CodensityP p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (CodensityP p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (CodensityP p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, MonadPlusP p) => Alternative (CodensityP p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, MonadPlusP p) => MonadPlus (CodensityP p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (CodensityP p) where - return_P = \r -> CodensityP (\k -> k r) - m ?>= f = CodensityP (\k -> - unCodensityP m (\a -> - unCodensityP (f a) k ) ) - - lift_P m = CodensityP (\k -> lift_P m ?>= k) - - hoist_P nat p = CodensityP (\k -> - hoist_P nat (unCodensityP p return_P) ?>= k) - - liftIO_P m = CodensityP (\k -> liftIO_P m ?>= k) - - thread_P p s = CodensityP (\k -> thread_P (unCodensityP p return_P) s ?>= k) - -instance (MonadPlusP p) => MonadPlusP (CodensityP p) where - mzero_P = CodensityP (\_ -> mzero_P) - mplus_P m1 m2 = CodensityP (\k -> - mplus_P (unCodensityP m1 k) (unCodensityP m2 k) ) - -instance (Proxy p) => Proxy (CodensityP p) where - fb' ->> p = CodensityP (\k -> - ((\b' -> unCodensityP (fb' b') return_P) ->> unCodensityP p return_P) - ?>= k ) - p >>~ fb = CodensityP (\k -> - (unCodensityP p return_P >>~ (\b -> unCodensityP (fb b) return_P)) - ?>= k ) - request = \a' -> CodensityP (\k -> request a' ?>= k) - respond = \b -> CodensityP (\k -> respond b ?>= k) - - fb' >\\ p = CodensityP (\k -> - ((\b' -> unCodensityP (fb' b') return_P) >\\ unCodensityP p return_P) - ?>= k ) - p //> fb = CodensityP (\k -> - (unCodensityP p return_P //> (\b -> unCodensityP (fb b) return_P)) - ?>= k ) - - turn p = CodensityP (\k -> turn (unCodensityP p return_P) ?>= k) - -instance ProxyTrans CodensityP where - liftP p = CodensityP (\k -> p ?>= k) - -instance PFunctor CodensityP where - hoistP nat p = CodensityP (\k -> nat (unCodensityP p return_P) ?>= k) - --- | Run a 'CodensityP' proxy, converting, converting it back to the base proxy -runCodensityP - :: (Monad m, Proxy p) => CodensityP p a' a b' b m r -> p a' a b' b m r -runCodensityP p = unCodensityP p return_P -{-# INLINABLE runCodensityP #-} - -{-| Run a 'CodensityP' \'@K@\'leisli arrow, converting it back to the base proxy --} -runCodensityK - :: (Monad m, Proxy p) - => (q -> CodensityP p a' a b' b m r) -> (q -> p a' a b' b m r) -runCodensityK k q = runCodensityP (k q) -{-# INLINABLE runCodensityK #-} 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,224 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'EitherT'. - -{-# LANGUAGE KindSignatures, CPP #-} - -module Control.Proxy.Trans.Either ( - -- * EitherP - EitherP(..), - runEitherK, - - -- * Either operations - left, - right, - - -- * Symmetric monad - -- $symmetry - throw, - catch, - handle, - fmapL - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP), PMonad(embedP)) -import Control.Proxy.Trans (ProxyTrans(liftP)) -#if MIN_VERSION_base(4,6,0) -#else -import Prelude hiding (catch) -#endif -import Data.Monoid (Monoid(mempty, mappend)) - --- | 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 (Monad m, Proxy p) => 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) ) ) - -instance (Monad m, Proxy p) => 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) ) ) - -instance (Monad m, Proxy p) => Monad (EitherP e p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (EitherP e p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (EitherP e p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (EitherP e p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, Proxy p, Monoid e) - => Alternative (EitherP e p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, Proxy p, Monoid e) - => MonadPlus (EitherP e p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (EitherP e p) where - return_P = \r -> EitherP (return_P (Right r)) - m ?>= f = EitherP ( - runEitherP m ?>= \e -> - case e of - Left l -> return_P (Left l) - Right r -> runEitherP (f r) ) - - lift_P m = EitherP (lift_P (m >>= \x -> return (Right x))) - - hoist_P nat p = EitherP (hoist_P nat (runEitherP p)) - - liftIO_P m = EitherP (liftIO_P (m >>= \x -> return (Right x))) - - thread_P p s = EitherP ( - thread_P (runEitherP p) s ?>= \(x, s') -> - return_P (case x of - Left e -> Left e - Right r -> Right (r, s') ) ) - -instance (Proxy p) => Proxy (EitherP e p) where - fb' ->> p = EitherP ((\b' -> runEitherP (fb' b')) ->> runEitherP p) - p >>~ fb = EitherP (runEitherP p >>~ (\b -> runEitherP (fb b))) - request = \a' -> EitherP (request a' ?>= \a -> return_P (Right a )) - respond = \b -> EitherP (respond b ?>= \b' -> return_P (Right b')) - - p //> fb = EitherP ( - (runEitherP p >>~ absorb) //> \b -> runEitherP (fb b) ) - where - absorb b = - respond b ?>= \x -> - case x of - Left e -> return_P (Left e) - Right b' -> - request b' ?>= \b2 -> - absorb b2 - fb' >\\ p = EitherP ( - (\b' -> runEitherP (fb' b')) >\\ (absorb ->> runEitherP p) ) - where - absorb b' = - request b' ?>= \x -> - case x of - Left e -> return_P (Left e) - Right b -> - respond b ?>= \b'2 -> - absorb b'2 - - turn p = EitherP (turn (runEitherP p)) - -instance (Proxy p, Monoid e) => MonadPlusP (EitherP e p) where - mzero_P = EitherP (return_P (Left mempty)) - mplus_P p1 p2 = EitherP ( - runEitherP p1 ?>= \e1 -> - case e1 of - Right r -> return_P (Right r) - Left l1 -> - runEitherP p2 ?>= \e2 -> - case e2 of - Right r -> return_P (Right r) - Left l2 -> return_P (Left (mappend l1 l2)) ) - -instance ProxyTrans (EitherP e) where - liftP p = EitherP (p ?>= \x -> return_P (Right x)) - -instance PFunctor (EitherP e) where - hoistP nat p = EitherP (nat (runEitherP p)) - -instance PMonad (EitherP e) where - embedP nat p = EitherP ( - runEitherP (nat (runEitherP p)) ?>= \x -> - return_P (case x of - Left e -> Left e - Right (Left e) -> Left e - Right (Right a) -> Right a ) ) - --- | 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) -{-# INLINABLE runEitherK #-} - --- | 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)) -{-# INLINABLE 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)) -{-# INLINABLE 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 -{-# INLINABLE throw #-} - --- | 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 )) -{-# INLINABLE catch #-} - --- | '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 -{-# INLINABLE handle #-} - --- | 'fmap' over the \'@L@\'eft variable -fmapL - :: (Monad m, Proxy p) - => (e -> f) -> EitherP e p a' a b' b m r -> EitherP f p a' a b' b m r -fmapL f p = catch p (\e -> throw (f e)) -{-# INLINABLE fmapL #-} 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,114 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'IdentityT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Identity ( - -- * Identity Proxy Transformer - IdentityP(..), - runIdentityK, - - -- * Deprecated - -- $deprecate - identityK - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP), PMonad(embedP)) -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 (Monad m, Proxy p) => Functor (IdentityP p a' a b' b m) where - fmap f p = IdentityP ( - runIdentityP p ?>= \x -> - return_P (f x) ) - -instance (Monad m, Proxy p) => Applicative (IdentityP p a' a b' b m) where - pure = return - fp <*> xp = IdentityP ( - runIdentityP fp ?>= \f -> - runIdentityP xp ?>= \x -> - return_P (f x) ) - -instance (Monad m, Proxy p) => Monad (IdentityP p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (IdentityP p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (IdentityP p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (IdentityP p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, MonadPlusP p) => Alternative (IdentityP p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, MonadPlusP p) => MonadPlus (IdentityP p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (IdentityP p) where - return_P = \r -> IdentityP (return_P r) - m ?>= f = IdentityP ( - runIdentityP m ?>= \x -> - runIdentityP (f x) ) - - lift_P m = IdentityP (lift_P m) - - hoist_P nat p = IdentityP (hoist_P nat (runIdentityP p)) - - liftIO_P m = IdentityP (liftIO_P m) - - thread_P p s = IdentityP (thread_P (runIdentityP p) s) - -instance (Proxy p) => Proxy (IdentityP p) where - fb' ->> p = IdentityP ((\b' -> runIdentityP (fb' b')) ->> runIdentityP p) - p >>~ fb = IdentityP (runIdentityP p >>~ (\b -> runIdentityP (fb b))) - - request = \a' -> IdentityP (request a') - respond = \b -> IdentityP (respond b ) - - fb' >\\ p = IdentityP ((\b' -> runIdentityP (fb' b')) >\\ runIdentityP p) - p //> fb = IdentityP (runIdentityP p //> (\b -> runIdentityP (fb b))) - - turn p = IdentityP (turn (runIdentityP p)) - -instance (MonadPlusP p) => MonadPlusP (IdentityP p) where - mzero_P = IdentityP mzero_P - mplus_P m1 m2 = IdentityP (mplus_P (runIdentityP m1) (runIdentityP m2)) - -instance ProxyTrans IdentityP where - liftP = IdentityP - -instance PFunctor IdentityP where - hoistP nat p = IdentityP (nat (runIdentityP p)) - -instance PMonad IdentityP where - embedP nat p = nat (runIdentityP p) - --- | Run an 'IdentityP' \'@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) -{-# INLINABLE runIdentityK #-} - -{- $deprecate - To be removed in version @4.0.0@ --} - -identityK :: (q -> p a' a b' b m r) -> (q -> IdentityP p a' a b' b m r) -identityK k q = IdentityP (k q) -{-# INLINABLE identityK #-} -{-# DEPRECATED identityK "Use '(IdentityP .)' instead" #-} 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,154 +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.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP), PMonad(embedP)) -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 (Monad m, Proxy p) => 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) ) ) - -instance (Monad m, Proxy p) => 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)) ) - -instance (Monad m, Proxy p) => Monad (MaybeP p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (MaybeP p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (MaybeP p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (MaybeP p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, Proxy p) => Alternative (MaybeP p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, Proxy p) => MonadPlus (MaybeP p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (MaybeP p) where - return_P = \r -> MaybeP (return_P (Just r)) - m ?>= f = MaybeP ( - runMaybeP m ?>= \ma -> - runMaybeP (case ma of - Nothing -> MaybeP (return_P Nothing) - Just a -> f a ) ) - - lift_P m = MaybeP (lift_P (m >>= \x -> return (Just x))) - - hoist_P nat p = MaybeP (hoist_P nat (runMaybeP p)) - - liftIO_P m = MaybeP (liftIO_P (m >>= \x -> return (Just x))) - - thread_P p s = MaybeP ( - thread_P (runMaybeP p) s ?>= \(x, s') -> - return_P (case x of - Nothing -> Nothing - Just r -> Just (r, s') ) ) - -instance (Proxy p) => Proxy (MaybeP p) where - fb' ->> p = MaybeP ((\b' -> runMaybeP (fb' b')) ->> runMaybeP p) - p >>~ fb = MaybeP (runMaybeP p >>~ (\b -> runMaybeP (fb b))) - request = \a' -> MaybeP (request a' ?>= \a -> return_P (Just a )) - respond = \b -> MaybeP (respond b ?>= \b' -> return_P (Just b')) - - p //> fb = MaybeP ( - (runMaybeP p >>~ absorb) //> \b -> runMaybeP (fb b) ) - where - absorb b = - respond b ?>= \x -> - case x of - Nothing -> return_P Nothing - Just b' -> - request b' ?>= \b2 -> - absorb b2 - fb' >\\ p = MaybeP ( - (\b' -> runMaybeP (fb' b')) >\\ (absorb ->> runMaybeP p) ) - where - absorb b' = - request b' ?>= \x -> - case x of - Nothing -> return_P Nothing - Just b -> - respond b ?>= \b'2 -> - absorb b'2 - - turn p = MaybeP (turn (runMaybeP p)) - -instance (Proxy p) => MonadPlusP (MaybeP p) where - mzero_P = MaybeP (return_P Nothing) - mplus_P m1 m2 = MaybeP ( - runMaybeP m1 ?>= \ma -> - case ma of - Nothing -> runMaybeP m2 - Just a -> return_P (Just a) ) - -instance ProxyTrans MaybeP where - liftP p = MaybeP (p ?>= \x -> return_P (Just x)) - -instance PFunctor MaybeP where - hoistP nat p = MaybeP (nat (runMaybeP p)) - -instance PMonad MaybeP where - embedP nat p = MaybeP ( - runMaybeP (nat (runMaybeP p)) ?>= \x -> - return_P (case x of - Nothing -> Nothing - Just Nothing -> Nothing - Just (Just a) -> Just a ) ) - --- | 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) -{-# INLINABLE runMaybeK #-} - --- | A synonym for 'mzero' -nothing :: (Monad m, Proxy p) => MaybeP p a' a b' b m r -nothing = MaybeP (return_P Nothing) -{-# INLINABLE 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)) -{-# INLINABLE just #-} 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,135 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'ReaderT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.Reader ( - -- * ReaderP - ReaderP(..), - runReaderP, - runReaderK, - - -- * Reader operations - ask, - asks, - local, - withReaderP, - ) where - -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP), PMonad(embedP)) -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 (Monad m, Proxy p) => Functor (ReaderP i p a' a b' b m) where - fmap f p = ReaderP (\i -> - unReaderP p i ?>= \x -> - return_P (f x) ) - -instance (Monad m, Proxy p) => 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 (Monad m, Proxy p) => Monad (ReaderP i p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (ReaderP i p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (ReaderP i p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (ReaderP i p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, MonadPlusP p) => Alternative (ReaderP i p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, MonadPlusP p) => MonadPlus (ReaderP i p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (ReaderP i p) where - return_P = \r -> ReaderP (\_ -> return_P r) - m ?>= f = ReaderP (\i -> - unReaderP m i ?>= \a -> - unReaderP (f a) i ) - - lift_P m = ReaderP (\_ -> lift_P m) - - hoist_P nat p = ReaderP (\i -> hoist_P nat (unReaderP p i)) - - liftIO_P m = ReaderP (\_ -> liftIO_P m) - - thread_P p s = ReaderP (\i -> thread_P (unReaderP p i) s) - -instance (Proxy p) => Proxy (ReaderP i p) where - fb' ->> p = ReaderP (\i -> (\b' -> unReaderP (fb' b') i) ->> unReaderP p i) - p >>~ fb = ReaderP (\i -> unReaderP p i >>~ (\b -> unReaderP (fb b) i)) - - request = \a -> ReaderP (\_ -> request a) - respond = \a -> ReaderP (\_ -> respond a) - - fb' >\\ p = ReaderP (\i -> (\b' -> unReaderP (fb' b') i) >\\ unReaderP p i) - p //> fb = ReaderP (\i -> unReaderP p i //> (\b -> unReaderP (fb b) i)) - - turn p = ReaderP (\i -> turn (unReaderP p i)) - -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 ProxyTrans (ReaderP i) where - liftP m = ReaderP (\_ -> m) - -instance PFunctor (ReaderP i) where - hoistP nat p = ReaderP (\i -> nat (unReaderP p i)) - -instance PMonad (ReaderP i) where - embedP nat p = ReaderP (\i -> unReaderP (nat (unReaderP p i)) i) - --- | 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 -{-# INLINABLE runReaderP #-} - --- | 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) -{-# INLINABLE runReaderK #-} - --- | Get the environment -ask :: (Monad m, Proxy p) => ReaderP i p a' a b' b m i -ask = ReaderP return_P -{-# INLINABLE ask #-} - --- | Get a function of the environment -asks :: (Monad m, Proxy p) => (i -> r) -> ReaderP i p a' a b' b m r -asks f = ReaderP (\i -> return_P (f i)) -{-# INLINABLE asks #-} - --- | 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 -{-# INLINABLE local #-} - --- | 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)) -{-# INLINABLE 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,196 +0,0 @@ --- | This module provides the proxy transformer equivalent of 'StateT'. - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Trans.State ( - -- * StateP - StateP(..), - state, - stateT, - 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.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP)) -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', s) (a, s) (b', s) (b, s) m (r, s) } - -instance (Monad m, Proxy p) => 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) ) - -instance (Monad m, Proxy p) => 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 (Monad m, Proxy p) => Monad (StateP s p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (StateP s p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (StateP s p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (StateP s p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, MonadPlusP p) => Alternative (StateP s p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, MonadPlusP p) => MonadPlus (StateP s p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (StateP s p) where - 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)) - - liftIO_P m = StateP (\s -> liftIO_P (m >>= \r -> return (r, s))) - - thread_P p s = StateP (\s' -> - ((up ->> thread_P (unStateP p s') s) >>~ dn) ?>= next ) - where - up ((a', s1), s2) = - request ((a', s2 ), s1 ) ?>= \((a , s1'), s2') -> - respond ((a , s2'), s1') ?>= up - dn ((b , s1), s2) = - respond ((b , s2 ), s1 ) ?>= \((b', s1'), s2') -> - request ((b', s2'), s1') ?>= dn - next ((r, s1), s2) = return_P ((r, s2), s1) - -instance (Proxy p) => Proxy (StateP s p) where - fb' ->> p = StateP (\s -> - (\(b', s') -> unStateP (fb' b') s') ->> unStateP p s) - p >>~ fb = StateP (\s -> - unStateP p s >>~ (\(b, s') -> unStateP (fb b) s') ) - request = \a' -> StateP (\s -> request (a', s)) - respond = \b -> StateP (\s -> respond (b , s)) - - fb' >\\ p = StateP (\s -> - (\(b', s') -> unStateP (fb' b') s') >\\ unStateP p s) - p //> fb = StateP (\s -> - unStateP p s //> (\(b, s') -> unStateP (fb b) s') ) - - turn p = StateP (\s -> turn (unStateP p s)) - -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 ProxyTrans (StateP s) where - liftP m = StateP (thread_P m) - -instance PFunctor (StateP s) where - hoistP nat p = StateP (\s -> nat (unStateP p s)) - --- | Convert a State to a 'StateP' -state :: (Monad m, Proxy p) => (s -> (r, s)) -> StateP s p a' a b' b m r -state f = StateP (\s -> return_P (f s)) -{-# INLINABLE state #-} - --- | Convert a StateT to a 'StateP' -stateT :: (Monad m, Proxy p) => (s -> m (r, s)) -> StateP s p a' a b' b m r -stateT f = StateP (\s -> lift_P (f s)) -{-# INLINABLE stateT #-} - --- | Run a 'StateP' computation, producing the final result and state -runStateP - :: (Monad m, Proxy p) - => s -> StateP s p a' a b' b m r -> p a' a b' b m (r, s) -runStateP s0 m = up >\\ unStateP m s0 //> dn - where - up (a', s) = - request a' ?>= \a -> - return_P (a , s) - dn (b , s) = - respond b ?>= \b' -> - return_P (b', s) -{-# INLINABLE runStateP #-} - --- | Run a 'StateP' \'@K@\'leisli arrow, procuding the final result and state -runStateK - :: (Monad m, Proxy p) - => s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m (r, s)) -runStateK s k q = runStateP s (k q) -{-# INLINABLE runStateK #-} - --- | Evaluate a 'StateP' computation, but discard the final state -evalStateP - :: (Monad m, Proxy p) => s -> StateP s p a' a b' b m r -> p a' a b' b m r -evalStateP s p = runStateP s p ?>= \(r, _) -> return_P r -{-# INLINABLE evalStateP #-} - --- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final state -evalStateK - :: (Monad m, Proxy p) - => 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) -{-# INLINABLE evalStateK #-} - --- | Evaluate a 'StateP' computation, but discard the final result -execStateP - :: (Monad m, Proxy p) => s -> StateP s p a' a b' b m r -> p a' a b' b m s -execStateP s p = runStateP s p ?>= \(_, s') -> return_P s' -{-# INLINABLE execStateP #-} - --- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final result -execStateK - :: (Monad m, Proxy p) - => 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) -{-# INLINABLE execStateK #-} - --- | Get the current state -get :: (Monad m, Proxy p) => StateP s p a' a b' b m s -get = StateP (\s -> return_P (s, s)) -{-# INLINABLE get #-} - --- | Set the current state -put :: (Monad m, Proxy p) => s -> StateP s p a' a b' b m () -put s = StateP (\_ -> return_P ((), s)) -{-# INLINABLE put #-} - --- | Modify the current state using a function -modify :: (Monad m, Proxy p) => (s -> s) -> StateP s p a' a b' b m () -modify f = StateP (\s -> return_P ((), f s)) -{-# INLINABLE modify #-} - --- | Get the state filtered through a function -gets :: (Monad m, Proxy p) => (s -> r) -> StateP s p a' a b' b m r -gets f = StateP (\s -> return_P (f s, s)) -{-# INLINABLE gets #-} 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,195 +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, - writer, - writerT, - 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.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P), - MonadPlusP(mzero_P, mplus_P) ) -import Control.Proxy.Morph (PFunctor(hoistP)) -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', w) (a, w) (b', w) (b, w) m (r, w) } - -instance (Monad m, Proxy p) => 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 (Monad m, Proxy p) => 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) ) - -instance (Monad m, Proxy p) => Monad (WriterP w p a' a b' b m) where - return = return_P - (>>=) = (?>=) - -instance (Proxy p) => MonadTrans (WriterP w p a' a b' b) where - lift = lift_P - -instance (Proxy p) => MFunctor (WriterP w p a' a b' b) where - hoist = hoist_P - -instance (MonadIO m, Proxy p) => MonadIO (WriterP w p a' a b' b m) where - liftIO = liftIO_P - -instance (Monad m, MonadPlusP p) => Alternative (WriterP w p a' a b' b m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, MonadPlusP p) => MonadPlus (WriterP w p a' a b' b m) where - mzero = mzero_P - mplus = mplus_P - -instance (Proxy p) => ProxyInternal (WriterP w p) where - 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)) - - liftIO_P m = WriterP (\w -> liftIO_P (m >>= \r -> return (r, w))) - - thread_P p w = WriterP (\w' -> - ((up ->> thread_P (unWriterP p w') w) >>~ dn) ?>= next ) - where - up ((a', w1), w2) = - request ((a', w2 ), w1 ) ?>= \((a , w1'), w2') -> - respond ((a , w2'), w1') ?>= up - dn ((b , w1), w2) = - respond ((b , w2 ), w1 ) ?>= \((b', w1'), w2') -> - request ((b', w2'), w1') ?>= dn - next ((r, w1), w2) = return_P ((r, w2), w1) - -instance (Proxy p) => Proxy (WriterP w p) where - fb' ->> p = WriterP (\w -> - (\(b', w') -> unWriterP (fb' b') w') ->> unWriterP p w ) - p >>~ fb = WriterP (\w -> - unWriterP p w >>~ (\(b, w') -> unWriterP (fb b) w') ) - - request = \a' -> WriterP (\w -> request (a', w)) - respond = \b -> WriterP (\w -> respond (b , w)) - - fb' >\\ p = WriterP (\w -> - (\(b', w') -> unWriterP (fb' b') w') >\\ unWriterP p w ) - p //> fb = WriterP (\w -> - unWriterP p w //> (\(b, w') -> unWriterP (fb b) w') ) - - turn p = WriterP (\w -> turn (unWriterP p w)) - -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 ProxyTrans (WriterP w) where - liftP m = WriterP (thread_P m) - -instance PFunctor (WriterP w) where - hoistP nat p = WriterP (\s -> nat (unWriterP p s)) - --- | Convert a Writer to a 'WriterP' -writer :: (Monad m, Proxy p, Monoid w) => (r, w) -> WriterP w p a' a b' b m r -writer x = writerP (return_P x) -{-# INLINABLE writer #-} - --- | Convert a WriterT to a 'WriterP' -writerT :: (Monad m, Proxy p, Monoid w) => m (r, w) -> WriterP w p a' a b' b m r -writerT m = writerP (lift_P m) -{-# INLINABLE writerT #-} - --- | Create a 'WriterP' from a proxy that generates a result and a monoid -writerP - :: (Monad m, Proxy p, Monoid w) - => p a' a b' b m (r, w) -> WriterP w p a' a b' b m r -writerP p = WriterP (\w -> - thread_P p w ?>= \((r, w2), w1) -> - let w' = mappend w1 w2 - in w' `seq` return_P (r, w') ) -{-# INLINABLE writerP #-} - --- | Run a 'WriterP' computation, producing the final result and monoid -runWriterP - :: (Monad m, Proxy p, Monoid w) - => WriterP w p a' a b' b m r -> p a' a b' b m (r, w) -runWriterP p = up >\\ unWriterP p mempty //> dn - where - up (a', w) = - request a' ?>= \a -> - return_P (a , w) - dn (b , w) = - respond b ?>= \b' -> - return_P (b', w) -{-# INLINABLE runWriterP #-} - --- | Run a 'WriterP' \'@K@\'leisli arrow, producing the final result and monoid -runWriterK - :: (Monad m, Proxy p, 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) -{-# INLINABLE runWriterK #-} - --- | Evaluate a 'WriterP' computation, but discard the final result -execWriterP - :: (Monad m, Proxy p, 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 -{-# INLINABLE execWriterP #-} - --- | Evaluate a 'WriterP' \'@K@\'leisli arrow, but discard the final result -execWriterK - :: (Monad m, Proxy p, 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) -{-# INLINABLE execWriterK #-} - --- | Add a value to the monoid -tell :: (Monad m, Proxy p, 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'')) -{-# INLINABLE tell #-} - --- | Modify the result of a writer computation -censor - :: (Monad m, Proxy p, 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) ) -{-# INLINABLE censor #-} diff --git a/Control/Proxy/Tutorial.hs b/Control/Proxy/Tutorial.hs deleted file mode 100644 --- a/Control/Proxy/Tutorial.hs +++ /dev/null @@ -1,2270 +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. - - I've condensed all the code examples into a self-contained code block in the - Appendix section that you can use to follow along. --} - -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 - - -- * Sequencing Proxies - -- $mixmonadcomp - - -- * ListT - -- $listT - - -- * Resource Management - -- $resource - - -- * Extensions - -- $extend - - -- ** Error handling - -- $error - - -- ** Folds - -- $folds - - -- ** State - -- $state - - -- * Branching, zips, and merges - -- $branch - - -- * Mixing Proxies - -- $proxytrans - - -- * Proxy Morphism Laws - -- $proxymorph - - -- * Functors on Proxies - -- $proxyfunctor - - -- * Conclusion - -- $conclusion - - -- * Appendix - -- $appendix - ) where - --- For documentation -import Control.Category (Category) -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy -import Control.Proxy.Core.Correct (ProxyCorrect) -import Control.Proxy.Trans.Either - -{- $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, or - - * 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 () -> 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 -> lines' h >-> printer :: (Proxy p) => () -> Session p IO () -> -> promptInt >-> printer :: (Proxy p) => () -> Session p IO r - - ('>->') 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" ReadMode $ \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' and never 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' requests and - responds with 'Bool's: - -> -- 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 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 can reuse the same 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, 'Pipe'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 'Proxy' that auto-forwards values both ways, beginning - from its upstream interface: - -> pull :: (Monad m, Proxy p) => a' -> p a' a a' a m r -> pull = runIdentityK loop where -> loop a' = do -> a <- request a' -> a'2 <- respond a -> loop a'2 -> -> -- or: pull = runIdentityK $ foreverK $ request >=> respond -> -- = runIdentityK $ request >=> respond >=> request >=> respond ... - - Diagramatically, this looks like: - -> +------+ -> | | -> a' <========= a' <- All values pass -> | pull | straight through -> a =========> a <- immediately -> | | -> +------+ - - 'pull' is completely invisible to composition, meaning that: - -> pull >-> p = p -> -> p >-> pull = p - - In other words, 'pull' is an identity of composition. - - This means that proxies form a true 'Category' where ('>->') is composition - and 'pull' 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 and the morphisms are the proxies. - - These 'Category' laws guarantee the following important properties: - - * You can reason about each proxy's behavior independently of other proxies - (otherwise composition wouldn't be associative) - - * You don't encounter weird behavior at the interface between two components - or at the 'Server' or 'Client' ends of a 'Session' (otherwise 'pull' - wouldn't be an identity) --} - -{- $class - All the proxy code we wrote was generic over the 'Proxy' type class, which - defines the library's central API. This type class actually defines four - separate categories that all proxies obey! Each category has an identity - operation: - - * 'request': The identity of the \"request\" composition - - * 'respond': The identity of the \"respond\" composition - - * 'pull': The identity of pull-based composition - - * 'push': The identity of push-based composition - - ... and each category has a composition operation: - - * ('\>\'): \"request\" composition - - * ('/>/'): \"respond\" composition - - * ('>->'): pull-based composition - - * ('>~>'): push-based composition - - However, the 'Proxy' type class actually defines the \"pointful\" versions - of these composition operator for efficiency reasons: - - * ('->>'): \"Pointful\" version of ('>->') - - * ('>>~'): \"Pointful\" version of ('>~>') - - * ('>\\'): \"Pointful\" version of ('\>\') - - * ('//>'): \"Pointful\" version of ('/>/') - - For now I will only cover pull-based composition for simplicity, but just - keep these other categories in the back of your mind. If you ever struggle - with the pull-based category, chances are that an elegant solution resides - within one of the other three categories. - - @pipes@ defines everything in terms of these four categories, which is - why all the library's utilities are generic 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 -- Correct by construction - - 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, meaning that it requires no implementation - hiding. - - 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 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 downstream -> 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" 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 pull = pull - - ... 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: 'pull'. - - 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" 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) -- from the "safe" package -> -> 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 an 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 @mmorph@ - package, which transforms the base monad of any monad transformer that - implements 'MFunctor'. Since all proxies implement 'MFunctor' you can use - 'hoist' from 'MFunctor' 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 an Integer" - - Also, note that ('.') has higher precedence than ('>->'), so you can drop - the parentheses: - ->>> runEitherT $ runProxy $ promptInt2 >-> hoist lift . printer -... - - For more information on using 'MFunctor', consult the tutorial in the - @Control.Monad.Morph@ module from the @mmorph@ package. --} - -{- $utilities - "Control.Proxy.Prelude" 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: - -> readLnS :: (Proxy p, Read a) => () -> Producer p a IO r - - ... so we can read 'Int's just by specializing its type: - -> 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@ values 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 IO () -> 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 'stdinS': - -> stdinS :: (Proxy p) => () -> 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 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) => () -> Pipe p Int Int IO () -> sink1 () = runIdentityP $ 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) => () -> Pipe p Int Int IO () -> sink2 = intermediate >-> printD where -> intermediate () = runIdentityP $ do -> takeB_ 3 () -- Intermediate stage 1 -> takeWhileD (< 4) () -- Intermediate stage 2 -> -> -- or: sink2 = (takeB_ 3 >=> takeWhileD (< 4)) >-> printD - ->>> runProxy $ source2 >-> sink2 - - - These examples demonstrate two possible ways to combine proxies: - - * \"Vertical\" composition, using ('>=>') from the Kleisli category - - * \"Horizontal\" composition: using ('>->') from the Proxy category - - You can assemble many proxies simply by composing them in one or both of - these two categories. --} - -{- $listT - Proxies generalize lists by allowing you to interleave effects between list - elements, but you might be surprised to learn that they also generalize the - list monad, too! You can convert back and forth between proxies and - @ListT@-like monad transformers that bind proxy outputs at either end. - - For example, let's say that we want to select elements from two separate - lists, except interleaving side effects, too: - -> -- +-- ListT that will compile to a 'Producer' -> -- | -> -- v -> pairs :: (Proxy p) => () -> ProduceT p IO (Int, Int) -> pairs () = do -> x <- rangeS 1 3 -- Select a number betwen 1 and 3 -> lift $ putStrLn $ "Currently using: " ++ show x -> y <- eachS [4,6,8] -- Select one of 4, 6, or 8 -> return (x, y) - - We can compile the above 'ProduceT' code to a 'Producer' using - 'runRespondK': - -> -- runRespondK's type is actually more general -> runRespondK :: (() -> ProduceT p m b) -> () -> Producer p b m () -> -> runRespondK pairs :: (Proxy p) => () -> Producer p (Int, Int) IO () - - The return value of the 'ProduceT' becomes the output of the corresponding - 'Producer', which produces one output for each permutation of elements that - we could have selected: - ->>> runProxy $ runRespondK pairs >-> printD -Currently using: 1 -(1,4) -(1,6) -(1,8) -Currently using: 2 -(2,4) -(2,6) -(2,8) -Currently using: 3 -(3,4) -(3,6) -(3,8) - - This works the other way around, too! You can wrap any 'Producer' in the - 'RespondT' newtype to bind its output in the 'ProduceT' monad: - -> pairs2 :: (Proxy p) => () -> ProduceT p IO (Int, Int) -> pairs2 () = do -> x <- RespondT $ runIdentityP $ do -> respond 1 -> lift $ putStrLn "Here" -> respond 2 -> y <- RespondT $ runIdentityP $ do -> respond 3 -> lift $ putStrLn "There" -> respond 4 -> return (x, y) - ->>> runProxy $ runRespondK pairs2 >-> printD -(1,3) -There -(1,4) -Here -(2,3) -There -(2,4) - - In fact, this is how 'eachS' and 'rangeS' are implemented: - -> eachS :: (Monad m, Proxy p) => [b] -> ProduceT p m b -> eachS xs = RespondT (fromList xs ()) -> -> rangeS :: (Enum b, Monad m, Ord b, Proxy p) => b -> b -> ProduceT p m b -> rangeS n1 n2 = RespondT (enumFromS n1 n2 ()) - - 'ProduceT' is actually a special case of 'RespondT', related by the - following type synonym: - -> type ProduceT p = RespondT p C () () - - This more general 'RespondT' monad lets you bind more general things than - 'Producer's. For example, you can bind 'Pipe' outputs this way: - -> pairs3 :: (Proxy p) => () -> RespondT p () Int () IO (Int, Int) -> pairs3 () = do -> x <- RespondT $ runIdentityP $ replicateM_ 2 $ do -> a <- request () -> lift $ putStrLn $ "Received " ++ show a -> respond a -> y <- RespondT $ runIdentityP $ replicateM_ 3 $ do -> a <- request () -> lift $ putStrLn $ "Received " ++ show a -> respond a -> return (x, y) - - ... and you will get a 'Pipe' back when you 'runRespondK' the final result: - -> runRespondK pairs3 :: Proxy p => () -> Pipe p Int (Int, Int) IO () - ->>> runProxy $ enumFromS 1 >-> runRespondK pairs3 >-> printD -Received 1 -Received 2 -(1,2) -Received 3 -(1,3) -Received 4 -(1,4) -Received 5 -Received 6 -(5,6) -Received 7 -(5,7) -Received 8 -(5,8) - - Proxies actually form two symmetric 'ListT'-like monad transformers: one - binds elements output from the proxy's downstream interface and one binds - elements output from the proxy's upstream interface. To distinguish them, - I call the downstream one 'RespondT' and the upstream one 'RequestT'. - - Remember how I said there were three extra categories? Well, two of them - directly correspond to the 'RespondT' and 'RequestT' monds: - - * ('\>\') and 'request': Equivalent to ('<=<') and 'return' for 'RequestT' - - * ('/>/') and 'respond': Equivalent to ('>=>') for 'return' for 'RespondT' - - In other words, two of the 'Proxy' categories are 'ListT' Kleisli - categories in disguise! - - 'RequestT' and 'RespondT' are correct by construction, meaning that they - always satisfy the monad and monad transformer laws without exception, - unlike 'ListT' from @transformers@. In other words, they behave like two - symmetric implementations of \"ListT done right\". --} - -{- $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': - -> readFileS :: () -> FilePath -> () -> Producer p String IO () -> readFileS 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 $ readFileS "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 $ readFileS "test.txt" >-> return --- Outputs nothing - - But it gives exactly the wrong behavior if we partially demand the file: - ->>> runProxy $ readFileS "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 @readFileS@ does not get a chance to - finalize the file. - - The @pipes-safe@ library solves this problem by providing resource - management abstractions built on top of @pipes@ and offers several other - nice features: - - * It is completely exception safe, even against asynchronous exceptions - - * It is backwards compatible with \"unmanaged\" ordinary proxies - - Backwards compatibility means that you don't need to buy in to the - @pipes-safe@ way of doing things. This matters because another common - approach is to just open 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 might write: - -> cp :: FilePath -> FilePath -> IO () -> cp inFile outFile = -> withFile inFile ReadMode $ \hIn -> -> withFile outFile WriteMode $ \hOut -> -> runProxy $ hGetLineS hIn >-> hPutStrLnD hOut - - Some people prefer that approach because it: - - * is straightforward, and - - * can reuse functions from @Control.Exception@ - - The disadvantage is that this does not lazily allocate resources, nor does - this promptly deallocate them. Also, there is no way to recover from - exceptions and resume the 'Session'. On the other hand, @pipes-safe@ lets - you do all of these. - - Fortunately, you can choose whichever approach you prefer and rest assured - that the two approaches safely interoperate. @Control.Proxy.Safe.Tutorial@ - from the @pipes-safe@ package provides a separate tutorial on how to: - - * extend @pipes@ with resource management, - - * handle exceptions natively within proxies, and - - * interoperate with unmanaged code. --} - -{- $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', and 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 an Integer" -> Just n -> respond n - - There is no way to recover from the error and resume streaming data. You - can only handle the '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 an 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 $ E.runEitherK $ promptInt3 >-> printer :: IO (Either String r) -Enter an Integer: -Hello -Left "Could not read an 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 'E.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 an 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 locally on a subset of the pipeline like so: - ->>> runProxy $ (E.runEitherK $ heartbeat . promptInt3 >-> takeB_ 2) >-> printer --} - -{- $folds - You can fold a stream of values using the 'WriterP' proxy transformer. - -> import qualified Control.Proxy.Trans.Writer as W - - "Control.Proxy.Prelude" provides several common folds implemented this - way, such as: - - * 'lengthD': Count how many values flow downstream - -> lengthD :: (Monad m, Proxy p) => x -> W.WriterP (Sum Int) p x a x a m r - - * 'toListD': Fold the values flowing downstream into a list. - -> toListD :: (Monad m, Proxy p) => x -> W.WriterP [a] p x a x a m r - - * 'anyD': Determine whether any values satisfy the predicate - -> anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> W.WriterP Any p x a x a m r - - Now, let's try these folds out and see if we can build a list from user - input: - ->>> runProxy $ W.runWriterK $ promptInt >-> takeB_ 3 >-> toListD -Enter an Integer: -1 -Enter an Integer: -66 -Enter an Integer: -5 -((),[1,66,5]) - - You can insert these folds anywhere in the middle of a pipeline and they - still work: - ->>> runProxy $ W.runWriterK $ fromListS [5, 7, 4] >-> lengthD >-> printD -5 -7 -4 -((),Sum {getSum = 3}) - - You can also run multiple folds at the same time just by adding more - 'WriterP' layers to your proxy transformer stack. You can use 'liftP' - (see \"Proxy Transformers\" below) to mix these two folds together: - -> fromListS [9, 10] >-> anyD even >-> liftP . sumD -> :: (Monad m, Proxy p) -> => () -> Producer (W.WriterP Any (W.WriterP (Sum Int) p)) c m () - - Then you just run both 'WriterP' layers: - ->>> runProxy $ W.runWriterK $ W.runWriterK $ fromListS [9, 10] >-> anyD even >-> mapP 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 -> W.WriterP (First a) p x a x a m () - ->>> runProxy $ runWriterK $ fromListS [3, 4, 9] >-> printD >-> headD_ -3 -((),First {getFirst = Just 3}) - - Compare this to 'headD' without underscore, which folds the entire input: - ->>> runProxy $ W.runWriterK $ fromListS [3, 4, 9] >-> 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. --} - -{- $state - The 'StateP' proxy lets you embed 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.modify (+1) - - We could then embed it into any 'Proxy', such as the following ones: - -> 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 - - The state is shared across connected proxies, and we can prove this by - composing two 'StateP' proxies. Let's define a stateful consumer: - -> increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r -> increment2 () = forever $ do -> nTheirs <- request () -> S.modify (+2) -> nOurs <- S.get -> lift $ print (nTheirs, nOurs) - - .. and hook it up directly to @increment@: - ->>> runProxy $ S.evalStateK 0 $ increment >-> takeB_ 3 >-> increment2 -(0,2) -(3,5) -(6,8) - --} - -{- $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 (Producer 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 (EitherP String p) Int IO r -> -> increment2 :: (Proxy p) => () -> Consumer (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 - - It's very easy to use. Just use 'liftP' to lift one proxy transformer to - match another one. For example, we can 'liftP' @increment2@ to match - @promptInt3@: - -> promptInt3 -> :: (Proxy stateP) -> => () -> Producer (EitherP String stateP ) Int IO r -> -> liftP . increment2 -> :: (Proxy p, ProxyTrans eitherP) -> => () -> Consumer (eitherP (StateP Int p)) Int IO r -> -> promptInt3 >-> liftP . increment2 -> :: (Proxy p) -> => () -> Session (EitherP String (StateP Int p)) IO r - - 'liftP' creates a new 'ProxyTrans' layer that type-checks as 'EitherP', and - @StateP Int p@ type-checks as the 'Proxy' in @promptInt3@'s signature. - ->>> 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 an Integer" - - ... or we could instead 'liftP' @promptInt3@ to match @increment2@ and switch - the order of the two proxy transformers: - -> liftP . promptInt3 -> :: (Proxy p, ProxyTrans stateP) -> => () -> Producer (stateP (EitherP String p)) Int IO r -> -> increment2 -> :: (Proxy eitherP) -> => () -> Consumer (StateP Int eitherP ) Int IO r -> -> liftP . promptInt3 >-> increment2 -> :: (Proxy p) -> => () -> Session (StateP Int (EitherP String p)) IO r - - 'liftP' creates a new 'ProxyTrans' layer that type-checks as 'StateP', and - @EitherP Int p@ type-checks as the 'Proxy' in @increment2@'s signature. - ->>> 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 an Integer" - - Like monad transformers, proxy transformers lift a base 'Monad' instance - to an extended 'Monad' instance and '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'. - - This means you can seamlessly mix effects from different proxy transformer - layers just by using 'liftP' to access inner layers: - -> twoLayers -> :: (Proxy p) -> => () -> Consumer (E.EitherP String (S.StateP Int p)) Int IO r -> twoLayers () = forever $ do -> a <- request () -> if (a >= 0) -> then liftP $ S.modify (+ a) -> else E.throw "Negative number" - ->>> runProxy $ S.runStateK 0 $ E.runEitherK $ fromListS [1, 2, -4] >-> twoLayers -(Left "Negative number",3) - - This exactly resembles how you use 'lift' to access inner layers of a monad - transformer stack. --} - -{- $proxymorph - Monad transformers impose certain laws to ensure that 'lift' behaves - correctly. These are known as the \"monad morphism 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 -- These are functor laws! -> -> liftP . 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 morphism laws\": - -> liftP . (f >-> g) = liftP . f >-> liftP . g -- These are functor laws, too! -> -> liftP . pull = pull - - 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 we know that proxies also form three other - categories, so we expect 'liftP' to correctly lift those categories, too: - -> liftP . (f >~> g) = liftP . f >~> liftP . g -> -> liftP . push = push - -> liftP . (f \>\ g) = liftP . f \>\ liftP . g -> -> liftP . request = request - -> liftP . (f />/ g) = liftP . f />/ liftP . g -> -> liftP . respond = respond - - I want to highlight two of the above laws: - -> liftP . request = request -> -> liftP . respond = respond - - The \"pointful\" statement of those laws is: - -> 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 these proxy morphism laws, - which ensures that 'liftP' always does \"the right thing\". --} - -{- $proxyfunctor - Proxy transformers also implement 'hoistP' from the 'PFunctor' class in - "Control.Proxy.Morph". This exactly parallels 'hoist' from - @Control.Monad.Morph@. - - You will most commonly use 'hoistP' to insert arbitrary proxy transformer - layers to get two mismatched proxy transformer stacks to type-check. - - For example, consider the following two very different proxy transformer - stacks: - -> p1 :: (Monad m, Proxy p) => a' -> StateP s (ReaderP i p) a' a a' a m a' -> p2 :: (Monad m, Proxy p) => a' -> MaybeP (WriterP w p) a' a a' a m a' - - I can normalize them to use same proxy transformer stack by judiciously - inserting extra proxy transformer layers using a combination of 'hoistP' - and 'liftP': - -> p1' :: (Monad m, Proxy p) -> => a' -> StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a m a' -> p1' = hoistP liftP . p1 -> -> p2' :: (Monad m, Proxy p) -> => a' -> StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a m a' -> p2' = liftP . hoistP liftP . p2 - - Now that I've made them agree on a common proxy transformer stack, I can - sequence them or compose them: - -> pSequence -> :: (Proxy p) -> => a' -> StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a m a' -> pSequence = p1' >=> p2' -> -> pCompose -> :: (Proxy p) -> => a' -> StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a m a' -> pCompose = p1' >-> p2' --} - -{- $conclusion - The @pipes@ library implements all functionality using theoretically - inspired abstractions: - - * Monads, Monad Transformers, and Functors on Monads - - * Proxies, Proxy Transformers, and Functors on Proxies - - 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. --} - --- $appendix --- I've provided the full code for the above examples here so you can easily --- play with the examples yourself: --- --- > import Control.Monad --- > import Control.Proxy hiding (zipD) --- > import System.IO --- > import qualified Data.Map as M --- > import Control.Monad.Trans.Either --- > import Safe (readMay) --- > import qualified Control.Proxy.Trans.Either as E --- > import qualified Control.Proxy.Trans.State as S --- > --- > lines' :: (Proxy p) => Handle -> () -> Producer p String IO () --- > 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 --- > --- > 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 --- > {- --- > promptInt = readLnS >-> execU (putStrLn "Enter an Integer:") --- > -} --- > --- > 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 --- > {- --- > printer :: (Proxy p, Show a) => x -> p x a x a IO r --- > printer = execD (putStrLn "Received a value:") >-> printD --- > -} --- > --- > take' :: (Proxy p) => Int -> () -> Pipe p a a IO () --- > 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!" --- > --- > 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 "*" --- > --- > comparer :: (Proxy p) => Int -> Server p Int Bool IO r --- > comparer = runIdentityK $ foreverK $ \argument -> do --- > lift $ putStrLn $ "Server Receives: " ++ show argument --- > let result = argument > 2 --- > lift $ putStrLn $ "Server Sends: " ++ show result --- > respond result --- > --- > 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 --- > --- > 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 downstream --- > lift $ print 4 --- > --- > 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 an Integer" --- > Just n -> respond n --- > --- > readIntS :: (Proxy p) => () -> Producer p Int IO r --- > readIntS = readLnS --- > --- > source1 :: (Proxy p) => () -> Producer p Int IO r --- > source1 () = runIdentityP $ do --- > fromListS [4, 4] () -- Source 1 --- > readLnS () -- Source 2 --- > --- > source2 :: (Proxy p) => () -> Producer p Int IO () --- > source2 () = runIdentityP $ do --- > fromListS [4, 4] () --- > (readLnS >-> takeB_ 3) () -- You can compose inside a do block! --- > --- > sink1 :: (Proxy p) => () -> Pipe p Int Int IO () --- > sink1 () = runIdentityP $ do --- > (takeB_ 3 >-> printD) () -- Sink 1 --- > (takeWhileD (< 4) >-> printD) () -- Sink 2 --- > --- > sink2 :: (Proxy p) => () -> Pipe p Int Int IO () --- > sink2 = intermediate >-> printD where --- > intermediate () = runIdentityP $ do --- > takeB_ 3 () -- Intermediate stage 1 --- > takeWhileD (< 4) () -- Intermediate stage 2 --- > --- > pairs :: (Proxy p) => () -> ProduceT p IO (Int, Int) --- > pairs () = do --- > x <- rangeS 1 3 -- Select a number betwen 1 and 3 --- > lift $ putStrLn $ "Currently using: " ++ show x --- > y <- eachS [4,6,8] -- Select one of 4, 6, or 8 --- > return (x, y) --- > --- > pairs2 :: (Proxy p) => () -> ProduceT p IO (Int, Int) --- > pairs2 () = do --- > x <- RespondT $ runIdentityP $ do --- > respond 1 --- > lift $ putStrLn "Here" --- > respond 2 --- > y <- RespondT $ runIdentityP $ do --- > respond 3 --- > lift $ putStrLn "There" --- > respond 4 --- > return (x, y) --- > --- > pairs3 :: (Proxy p) => () -> RespondT p () Int () IO (Int, Int) --- > pairs3 () = do --- > x <- RespondT $ runIdentityP $ replicateM_ 2 $ do --- > a <- request () --- > lift $ putStrLn $ "Received " ++ show a --- > respond a --- > y <- RespondT $ runIdentityP $ replicateM_ 3 $ do --- > a <- request () --- > lift $ putStrLn $ "Received " ++ show a --- > respond a --- > return (x, y) --- > --- > readFileS :: (Proxy p) => FilePath -> () -> Producer p String IO () --- > readFileS file () = runIdentityP $ do --- > h <- lift $ openFile file ReadMode --- > lift $ putStrLn "Opening file" --- > hGetLineS h () --- > lift $ putStrLn "Closing file" --- > lift $ hClose h --- > --- > cp :: FilePath -> FilePath -> IO () --- > cp inFile outFile = --- > withFile inFile ReadMode $ \hIn -> --- > withFile outFile WriteMode $ \hOut -> --- > runProxy $ hGetLineS hIn >-> hPutStrLnD hOut --- > --- > promptInt3 :: (Proxy p) => () -> Producer (E.EitherP String p) Int IO r --- > promptInt3 () = forever $ do --- > str <- lift $ do --- > putStrLn "Enter an Integer:" --- > getLine --- > case readMay str of --- > Nothing -> E.throw "Could not read an Integer" --- > Just n -> respond n --- > --- > 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' --- > --- > increment :: (Monad m, Proxy p) => () -> Producer (S.StateP Int p) Int m r --- > increment () = forever $ do --- > n <- S.get --- > respond n --- > S.modify (+1) --- > --- > 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! --- > --- > increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r --- > increment2 () = forever $ do --- > nTheirs <- request () --- > S.modify (+2) --- > nOurs <- S.get --- > lift $ print (nTheirs, nOurs) --- > --- > 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) $ 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' --- > --- > p1 = runProxyK $ zipD <-< fromListS [1..3] --- > p2 = runProxyK $ p1 <-< fromListS [4..] --- > p3 = runProxy $ printD <-< p2 --- > --- > 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' --- > --- > {- --- > p1 = runProxyK $ fork <-< fromListS [1..3] --- > p2 = runProxyK $ raiseK printD <-< mapD (> 2) <-< p1 --- > p3 = runProxy $ printD <-< mapD show <-< p2 --- > -} --- > --- > {- --- > p1 = runProxyK $ S.evalStateK 0 $ fork <-< increment --- > p2 = runProxyK $ raiseK printD <-< mapD (+ 10) <-< p1 --- > p3 = runProxy $ E.runEitherK $ printD <-< (takeB_ 3 >=> E.throw) <-< p2 --- > -} --- > --- > twoLayers --- > :: (Proxy p) --- > => () -> Consumer (E.EitherP String (S.StateP Int p)) Int IO r --- > twoLayers () = forever $ do --- > a <- request () --- > if (a >= 0) --- > then liftP $ S.modify (+ a) --- > else E.throw "Negative number" diff --git a/benchmarks/LiftBench.hs b/benchmarks/LiftBench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/LiftBench.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE RankNTypes #-} +module Main (main) where + +import Common (commonMain) +import Control.DeepSeq +import Control.Monad.Identity +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Strict as W +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Criterion.Main +import Data.Monoid +import Pipes +import Pipes.Lift + +defaultMax :: Int +defaultMax = 1000000 + +instance NFData a => NFData (Sum a) + +main :: IO () +main = commonMain defaultMax liftBenchmarks + +iter :: forall m a . (Monad m , Ord a, Num a) => (a -> m a) -> a -> Effect m a +iter a vmax = loop 0 + where + loop n + | n > vmax = return vmax + | otherwise = do + x <- lift $ a n + loop $! x + +s_bench :: Int -> Effect (S.StateT Int Identity) Int +s_bench = iter (\n -> S.get >>= (\a -> S.put $! a + n) >> return (n + 1)) + +w_bench :: Int -> Effect (W.WriterT (Sum Int) Identity) Int +w_bench = iter (\n -> (W.tell $! Sum n) >> return (n + 1)) + +r_bench :: Int -> Effect (R.ReaderT Int Identity) Int +r_bench = iter (\n -> R.ask >>= (\a -> return $ n + a)) + +rwsp_bench :: Int -> Effect (RWS.RWST Int (Sum Int) Int Identity) Int +rwsp_bench = iter act + where + act n = do + x <- RWS.ask + RWS.tell (Sum n) + s <- RWS.get + RWS.put $! (s + n) + return $ n + x + +-- 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) + ] + , bgroup "WriterT" $ applyBench + [ + -- Running WriterP after runEffect will space leak. + bench "runWriterP_B" . nf (runB runWriterP . w_bench) + , bench "execWriterP_B" . nf (runB execWriterP . w_bench) + ] + , bgroup "RWSP" $ + let defT f = (\d -> f d 1 0) + in applyBench + [ + bench "runRWSP_B" . nf (runB (runRWSP 1 0) . rwsp_bench) + , bench "runRWSP_A" . nf (runA (defT RWS.runRWST) . rwsp_bench) + , bench "evalRWSP_B" . nf (runB (evalRWSP 1 0) . rwsp_bench) + , bench "evalRWSP_A" . nf (runA (defT RWS.evalRWST) . rwsp_bench) + , bench "execRWSP_B" . nf (runB (execRWSP 1 0) . rwsp_bench) + , bench "execRWSP_A" . nf (runA (defT RWS.execRWST) . rwsp_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 = 1000000 + +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,6 +1,6 @@ Name: pipes -Version: 3.3.0 -Cabal-Version: >=1.8.0.2 +Version: 4.0.0 +Cabal-Version: >= 1.10 Build-Type: Simple License: BSD3 License-File: LICENSE @@ -10,58 +10,76 @@ Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues Synopsis: Compositional pipelines Description: - \"Coroutines done right\". This library generalizes iteratees and coroutines - simply and elegantly. - . - Advantages over traditional iteratee\/coroutine implementations: + `pipes` is a clean and powerful stream processing library that lets you build + and connect reusable streaming components . - * /Concise API/: Use three simple commands: ('>->'), 'request', and 'respond' + Advantages over traditional streaming libraries: . - * /Bidirectionality/: Implement duplex channels + * /Concise API/: Use simple commands like 'for', ('>->'), 'await', and 'yield' . * /Blazing fast/: Implementation tuned for speed . - * /Elegant semantics/: Use practical category theory + * /Lightweight Dependency/: @pipes@ is small and compiles very rapidly, + including dependencies . - * /Extension Framework/: Mix and match extensions and create your own + * /Elegant semantics/: Use practical category theory . - * /ListT/: Correct implementation of ListT that interconverts with pipes + * /ListT/: Correct implementation of 'ListT' that interconverts with pipes . - * /Lightweight Dependency/: @pipes@ depends only on @transformers@ and - @mmorph@ 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 an extensive tutorial. -Category: Control, Pipes, Proxies + Read "Pipes.Tutorial" for an extensive tutorial. +Category: Control, Pipes Source-Repository head Type: git Location: https://github.com/Gabriel439/Haskell-Pipes-Library Library + Default-Language: Haskell2010 + HS-Source-Dirs: src Build-Depends: base >= 4 && < 5 , mmorph >= 1.0.0 && < 1.1, - transformers >= 0.2.0.0 && < 0.4 + mtl >= 2.0.1.0 && < 2.2, + transformers >= 0.2.0.0 && < 0.4, + void < 0.7 Exposed-Modules: - Control.Pipe, - Control.Proxy, - Control.Proxy.Class, - Control.Proxy.Core, - Control.Proxy.Core.Fast, - Control.Proxy.Core.Correct, - Control.Proxy.Morph, - Control.Proxy.Pipe, - Control.Proxy.Trans, - Control.Proxy.Trans.Codensity, - 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 - GHC-Options: -O2 + Pipes, + Pipes.Core, + Pipes.Internal, + Pipes.Lift, + Pipes.Prelude, + Pipes.Tutorial + GHC-Options: -O2 -Wall + +Benchmark prelude-benchmarks + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: PreludeBench.hs + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4 && < 5 , + criterion >= 0.8 && < 0.9, + mtl >= 2.0.1.0 && < 2.2, + pipes >= 4.0.0 && < 4.1 + +Benchmark lift-benchmarks + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + HS-Source-Dirs: benchmarks + Main-Is: LiftBench.hs + GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind + + Build-Depends: + base >= 4 && < 5 , + criterion >= 0.8 && < 0.9, + deepseq , + mtl >= 2.0.1.0 && < 2.2, + pipes >= 4.0.0 && < 4.1, + transformers >= 0.2.0.0 && < 0.4 diff --git a/src/Pipes.hs b/src/Pipes.hs new file mode 100644 --- /dev/null +++ b/src/Pipes.hs @@ -0,0 +1,424 @@ +{-| 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. +-} + +{-# LANGUAGE RankNTypes, CPP #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +{- The rewrite RULES require the 'TrustWorthy' annotation. -} + +module Pipes ( + -- * The Proxy Monad Transformer + Proxy, + Effect, + Effect', + runEffect, + + -- ** Producers + -- $producers + Producer, + Producer', + yield, + for, + (~>), + (<~), + + -- ** Consumers + -- $consumers + Consumer, + Consumer', + await, + (>~), + (~<), + + -- ** Pipes + -- $pipes + Pipe, + cat, + (>->), + (<-<), + + -- * ListT + ListT(..), + Enumerable(..), + + -- * Utilities + next, + each, + every, + discard, + + -- * Re-exports + -- $reexports + module Control.Monad.IO.Class, + module Control.Monad.Trans.Class, + module Control.Monad.Morph, + module Data.Foldable, + module Data.Void + ) 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.Monad.Trans.Error (ErrorT(runErrorT)) +import Control.Monad.Trans.Identity (IdentityT(runIdentityT)) +import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import Data.Void (Void) +import qualified Data.Void as V +import Pipes.Internal (Proxy(..)) +import Pipes.Core + +-- Re-exports +import Control.Monad.Morph (MFunctor(hoist)) + +infixl 4 <~ +infixr 4 ~> +infixl 5 ~< +infixr 5 >~ +infixl 7 >-> +infixr 7 <-< + +{- $producers + Use 'yield' to produce output and ('~>') \/ 'for' to substitute 'yield's. + + 'yield' and ('~>') obey the 'Control.Category.Category' laws: + +@ +\-\- Substituting \'yield\' with \'f\' gives \'f\' +'yield' '~>' f = f + +\-\- Substituting every \'yield\' with another \'yield\' does nothing +f '~>' 'yield' = f + +\-\- \'yield\' substitution is associative +(f '~>' g) '~>' h = f '~>' (g '~>' h) +@ + + These are equivalent to the following \"for loop laws\": + +@ +\-\- Looping over a single yield simplifies to function application +'for' ('yield' x) f = f x + +\-\- Re-yielding every element of a stream returns the original stream +'for' s 'yield' = s + +\-\- Nested for loops can become a sequential 'for' loops if the inner loop +\-\- body ignores the outer loop variable +'for' s (\\a -\> 'for' (f a) g) = 'for' ('for' s f) g = 'for' s (f '~>' g) +@ + +-} + +{-| Produce a value + +@ +'yield' :: 'Monad' m => a -> 'Pipe' x a m () +@ +-} +yield :: (Monad m) => a -> Producer' a m () +yield = respond +{-# INLINABLE yield #-} + +{-| @(for p body)@ loops over @p@ replacing each 'yield' with @body@. + +@ +'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r +'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Effect' m ()) -> 'Consumer' x m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Producer' c m ()) -> 'Pipe' x c m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r +'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r +@ +-} +for :: (Monad m) + => Proxy x' x b' b m a' + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x c' c m a' +for = (//>) +{-# INLINABLE for #-} + +{-# RULES + "for cat f" forall f . + for cat f = + let go = do + x <- await + f x + go + in go + ; "m >~ cat" forall m . + m >~ cat = + let go = do + x <- m + yield x + go + in go + #-} + +{-| Compose loop bodies + +@ +('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) +('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Effect' m ()) -> (a -> 'Consumer' x m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Pipe' x c m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) +('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) +@ +-} +(~>) + :: (Monad m) + => (a -> Proxy x' x b' b m a') + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x c' c m a') +(~>) = (/>/) +{-# INLINABLE (~>) #-} + +-- | ('~>') with the arguments flipped +(<~) + :: (Monad m) + => (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x b' b m a') + -- ^ + -> (a -> Proxy x' x c' c m a') +g <~ f = f ~> g +{-# INLINABLE (<~) #-} + +{- $consumers + Use 'await' to request input and ('>~') to substitute 'await's. + + 'await' and ('>~') obey the 'Control.Category.Category' laws: + +@ +\-\- Substituting every \'await\' with another \'await\' does nothing +'await' '>~' f = f + +\-\- Substituting \'await\' with \'f\' gives \'f\' +f '>~' 'await' = f + +\-\- \'await\' substitution is associative +(f '>~' g) '>~' h = f '>~' (g '>~' h) +@ + +-} + +{-| Consume a value + +@ +'await' :: 'Monad' m => 'Pipe' a y m a +@ +-} +await :: (Monad m) => Consumer' a m a +await = request () +{-# INLINABLE await #-} + +{-| @(draw >~ p)@ loops over @p@ replacing each 'await' with @draw@ + +@ +('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +('>~') :: 'Monad' m => 'Effect' m b -> 'Pipe' b y m c -> 'Producer' y m c +('>~') :: 'Monad' m => 'Consumer' a m b -> 'Pipe' b y m c -> 'Pipe' a y m c +('>~') :: 'Monad' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c +('>~') :: 'Monad' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c +@ +-} +(>~) + :: (Monad m) + => Proxy a' a y' y m b + -- ^ + -> Proxy () b y' y m c + -- ^ + -> Proxy a' a y' y m c +p1 >~ p2 = (\() -> p1) >\\ p2 +{-# INLINABLE (>~) #-} + +-- | ('>~') with the arguments flipped +(~<) + :: (Monad m) + => Proxy () b y' y m c + -- ^ + -> Proxy a' a y' y m b + -- ^ + -> Proxy a' a y' y m c +p2 ~< p1 = p1 >~ p2 +{-# INLINABLE (~<) #-} + +{- $pipes + Use 'await' and 'yield' to build 'Pipe's and ('>->') to connect 'Pipe's. + + 'cat' and ('>->') obey the 'Control.Category.Category' laws: + +@ +\-\- Useless use of cat +'cat' '>->' f = f + +\-\- Redirecting output to cat does nothing +f '>->' 'cat' = f + +\-\- The pipe operator is associative +(f '>->' g) '>->' h = f '>->' (g '>->' h) +@ + +-} + +-- | The identity 'Pipe', analogous to the Unix @cat@ program +cat :: (Monad m) => Pipe a a m r +cat = pull () +{-# INLINABLE cat #-} + +{-| 'Pipe' composition, analogous to the Unix pipe operator + +@ +('>->') :: 'Monad' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r +('>->') :: 'Monad' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r +('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r +('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +@ +-} +(>->) + :: (Monad m) + => Proxy a' a () b m r + -- ^ + -> Proxy () b c' c m r + -- ^ + -> Proxy a' a c' c m r +p1 >-> p2 = (\() -> p1) +>> p2 +{-# INLINABLE (>->) #-} + +{-| The list monad transformer, which extends a monad with non-determinism + + 'return' corresponds to 'yield', yielding a single value + + ('>>=') corresponds to 'for', calling the second computation once for each + time the first computation 'yield's. +-} +newtype ListT m a = Select { enumerate :: Producer a m () } + +instance (Monad m) => Functor (ListT m) where + fmap f p = Select (for (enumerate p) (\a -> yield (f a))) + +instance (Monad m) => Applicative (ListT m) where + pure a = Select (yield a) + mf <*> mx = Select ( + for (enumerate mf) (\f -> + for (enumerate mx) (\x -> + yield (f x) ) ) ) + +instance (Monad m) => Monad (ListT m) where + return a = Select (yield a) + m >>= f = Select (for (enumerate m) (\a -> enumerate (f a))) + +instance MonadTrans ListT where + lift m = Select (do + a <- lift m + yield a ) + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO m = lift (liftIO m) + +instance (Monad m) => Alternative (ListT m) where + empty = Select (return ()) + p1 <|> p2 = Select (do + enumerate p1 + enumerate p2 ) + +instance (Monad m) => MonadPlus (ListT m) where + mzero = empty + mplus = (<|>) + +instance MFunctor ListT where + hoist morph = Select . hoist morph . enumerate + +{-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful + containers to 'ListT's. +-} +class Enumerable t where + toListT :: (Monad m) => t m a -> ListT m a + +instance Enumerable ListT where + toListT = id + +instance Enumerable IdentityT where + toListT m = Select $ do + a <- lift $ runIdentityT m + yield a + +instance Enumerable MaybeT where + toListT m = Select $ do + x <- lift $ runMaybeT m + case x of + Nothing -> return () + Just a -> yield a + +instance Enumerable (ErrorT e) where + toListT m = Select $ do + x <- lift $ runErrorT m + case x of + Left _ -> return () + Right a -> yield a + +{-| Consume the first value from a 'Producer' + + 'next' either fails with a 'Left' if the 'Producer' terminates or succeeds + with a 'Right' providing the next value and the remainder of the 'Producer'. +-} +next :: (Monad m) => Producer a m r -> m (Either r (a, Producer a m r)) +next = go + where + go p = case p of + Request v _ -> V.absurd v + Respond a fu -> return (Right (a, fu ())) + M m -> m >>= go + Pure r -> return (Left r) +{-# INLINABLE next #-} + +-- | Convert a 'F.Foldable' to a 'Producer' +each :: (Monad m, F.Foldable f) => f a -> Producer' a m () +each = F.mapM_ yield +{-# INLINABLE each #-} + +-- | Convert an 'Enumerable' to a 'Producer' +every :: (Monad m, Enumerable t) => t m a -> Producer' a m () +every it = discard >\\ enumerate (toListT it) +{-# INLINABLE every #-} + +-- | Discards a value +discard :: (Monad m) => a -> m () +discard _ = return () +{-# INLINABLE discard #-} + +-- | ('>->') with the arguments flipped +(<-<) + :: (Monad m) + => Proxy () b c' c m r + -- ^ + -> Proxy a' a () b m r + -- ^ + -> Proxy a' a c' c m r +p2 <-< p1 = p1 >-> p2 +{-# INLINABLE (<-<) #-} + +{- $reexports + "Control.Monad.IO.Class" re-exports 'MonadIO'. + + "Control.Monad.Trans.Class" re-exports 'MonadTrans'. + + "Control.Monad.Morph" re-exports 'MFunctor'. + + "Data.Foldable" re-exports 'Foldable' (the class name only) + + "Data.Void" re-exports 'Void'. +-} 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,834 @@ +{-| 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 CPP, RankNTypes #-} + +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +{- The rewrite RULES require the 'TrustWorthy' annotation. Their proofs are + pretty trivial since they are just inlining the definition of their + respective operators. GHC doesn't do this inlining automatically for these + functions because they are recursive. +-} + +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 + 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 _ -> absurd v + Respond v _ -> absurd v + M m -> m >>= go + Pure r -> return r +{-# INLINABLE runEffect #-} + +{- + * Keep proxy composition lower in precedence than function composition, which + is 9 at the time of of this comment, so that users can write things like: + + +> lift . k >+> p +> +> hoist f . k >+> p + + * Keep the priorities different so that users can mix composition operators + like: + +> up \>\ p />/ dn +> +> up >~> p >+> dn + + * Keep 'request' and 'respond' composition lower in precedence than 'pull' + and 'push' composition, so that users can do: + +> read \>\ pull >+> writer + + * I arbitrarily choose a lower priority for downstream operators so that lazy + pull-based computations need not evaluate upstream stages unless absolutely + necessary. +-} +infixl 3 //> +infixr 3 <\\ -- GHC will raise a parse error if either of these lines ends +infixr 4 />/, >\\ -- with '\', which is why this comment is here +infixl 4 \<\, //< +infixl 5 \>\ -- Same thing here +infixr 5 /> +infixl 7 >+>, >>~ +infixr 7 <+<, ~<< +infixl 8 <~< +infixr 8 >~> + +{- $categories + A 'Control.Category.Category' is a set of components that you can connect + with a composition operator, ('Control.Category..'), that has an identity, + 'Control.Category.id'. The ('Control.Category..') and 'Control.Category.id' + must satisfy the following three 'Control.Category.Category' laws: + +@ +\-\- Left identity +'Control.Category.id' 'Control.Category..' f = f + +\-\- Right identity +f 'Control.Category..' 'Control.Category.id' = f + +\-\- Associativity +(f 'Control.Category..' g) 'Control.Category..' h = f 'Control.Category..' (g 'Control.Category..' h) +@ + + The 'Proxy' type sits at the intersection of five separate categories, four + of which are named after their identity: + +@ + Identity | Composition | Point-ful + +-------------+-------------+-------------+ + respond category | 'respond' | '/>/' | '//>' | + request category | 'request' | '\>\' | '>\\' | + push category | 'push' | '>~>' | '>>~' | + pull category | 'pull' | '>+>' | '+>>' | + Kleisli category | 'return' | 'Control.Monad.>=>' | '>>=' | + +-------------+-------------+-------------+ +@ + + Each composition operator has a \"point-ful\" version, analogous to how + ('>>=') is the point-ful version of ('Control.Monad.>=>'). For example, + ('//>') is the point-ful version of ('/>/'). The convention is that the + odd character out faces the argument that is a function. +-} + +{- $respond + The 'respond' category closely corresponds to the generator design pattern. + + The 'respond' category obeys the category laws, where 'respond' is the + identity and ('/>/') is composition: + +@ +\-\- Left identity +'respond' '/>/' f = f + +\-\- Right identity +f '/>/' 'respond' = f + +\-\- Associativity +(f '/>/' g) '/>/' h = f '/>/' (g '/>/' h) +@ + + The following diagrams show the flow of information: + +@ +'respond' :: ('Monad' m) + => a -> 'Proxy' x' x a' a m a' + +\ a + | + +----|----+ + | | | + x' <== \\ /==== a' + | X | + x ==> / \\===> a + | | | + +----|----+ + v + a' + +('/>/') :: ('Monad' m) + => (a -> 'Proxy' x' x b' b m a') + -> (b -> 'Proxy' x' x c' c m b') + -> (a -> 'Proxy' x' x b' b m a') + +\ a /===> b a + | / | | + +----|----+ / +----|----+ +----|----+ + | v | / | v | | v | + x' <== <== b' <==\\ / x'<== <== c' x' <== <== c' + | f | X | g | = | f '/>/' g | + x ==> ==> b ===/ \\ x ==> ==> c x ==> ==> c' + | | | \\ | | | | | | + +----|----+ \\ +----|----+ +----|----+ + v \\ v v + a' \\==== b' a' +@ + +-} + +{-| Send a value of type @a@ downstream and block waiting for a reply of type + @a'@ + + 'respond' is the identity of the respond category. +-} +respond :: (Monad m) => a -> Proxy x' x a' a m a' +respond a = Respond a Pure +{-# INLINABLE respond #-} + +{-| Compose two unfolds, creating a new unfold + +@ +(f '/>/' g) x = f x '//>' g +@ + + ('/>/') is the composition operator of the respond category. +-} +(/>/) + :: (Monad m) + => (a -> Proxy x' x b' b m a') + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x c' c m a') + -- ^ +(fa />/ fb) a = fa a //> fb +{-# INLINABLE (/>/) #-} + +{-| @(p \/\/> f)@ replaces each 'respond' in @p@ with @f@. + + Point-ful version of ('/>/') +-} +(//>) + :: (Monad m) + => Proxy x' x b' b m a' + -- ^ + -> (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x c' c m a' + -- ^ +p0 //> fb = go p0 + where + go p = case p of + Request x' fx -> Request x' (\x -> go (fx x)) + Respond b fb' -> fb b >>= \b' -> go (fb' b') + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a +{-# INLINABLE (//>) #-} + +{-# RULES + "(Request x' fx ) //> fb" forall x' fx fb . + (Request x' fx ) //> fb = Request x' (\x -> fx x //> fb); + "(Respond b fb') //> fb" forall b fb' fb . + (Respond b fb') //> fb = fb b >>= \b' -> fb' b' //> fb; + "(M m ) //> fb" forall m fb . + (M m ) //> fb = M (m >>= \p' -> return (p' //> fb)); + "(Pure a ) //> fb" forall a fb . + (Pure a ) //> fb = Pure a; + #-} + +{- $request + The 'request' category closely corresponds to the iteratee design pattern. + + The 'request' category obeys the category laws, where 'request' is the + identity and ('\>\') is composition: + +@ +-- Left identity +'request' '\>\' f = f + +\-\- Right identity +f '\>\' 'request' = f + +\-\- Associativity +(f '\>\' g) '\>\' h = f '\>\' (g '\>\' h) +@ + + The following diagrams show the flow of information: + +@ +'request' :: ('Monad' m) + => a' -> 'Proxy' a' a y' y m a + +\ a' + | + +----|----+ + | | | + a' <=====/ <== y' + | | + a ======\\ ==> y + | | | + +----|----+ + v + a + +('\>\') :: ('Monad' m) + => (b' -> 'Proxy' a' a y' y m b) + -> (c' -> 'Proxy' b' b y' y m c) + -> (c' -> 'Proxy' a' a y' y m c) + +\ b'<=====\\ c' c' + | \\ | | + +----|----+ \\ +----|----+ +----|----+ + | v | \\ | v | | v | + a' <== <== y' \\== b' <== <== y' a' <== <== y' + | f | | g | = | f '\>\' g | + a ==> ==> y /=> b ==> ==> y a ==> ==> y + | | | / | | | | | | + +----|----+ / +----|----+ +----|----+ + v / v v + b ======/ c c +@ +-} + +{-| Send a value of type @a'@ upstream and block waiting for a reply of type @a@ + + 'request' is the identity of the request category. +-} +request :: (Monad m) => a' -> Proxy a' a y' y m a +request a' = Request a' Pure +{-# INLINABLE request #-} + +{-| Compose two folds, creating a new fold + +@ +(f '\>\' g) x = f '>\\' g x +@ + + ('\>\') is the composition operator of the request category. +-} +(\>\) + :: (Monad m) + => (b' -> Proxy a' a y' y m b) + -- ^ + -> (c' -> Proxy b' b y' y m c) + -- ^ + -> (c' -> Proxy a' a y' y m c) + -- ^ +(fb' \>\ fc') c' = fb' >\\ fc' c' +{-# INLINABLE (\>\) #-} + +{-| @(f >\\\\ p)@ replaces each 'request' in @p@ with @f@. + + Point-ful version of ('\>\') +-} +(>\\) + :: (Monad m) + => (b' -> Proxy a' a y' y m b) + -- ^ + -> Proxy b' b y' y m c + -- ^ + -> Proxy a' a y' y m c + -- ^ +fb' >\\ p0 = go p0 + where + go p = case p of + Request b' fb -> fb' b' >>= \b -> go (fb b) + Respond x fx' -> Respond x (\x' -> go (fx' x')) + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a +{-# INLINABLE (>\\) #-} + +{-# RULES + "fb' >\\ (Request b' fb )" forall fb' b' fb . + fb' >\\ (Request b' fb ) = fb' b' >>= \b -> fb' >\\ fb b; + "fb' >\\ (Respond x fx')" forall fb' x fx' . + fb' >\\ (Respond x fx') = Respond x (\x' -> fb' >\\ fx' x'); + "fb' >\\ (M m )" forall fb' m . + fb' >\\ (M m ) = M (m >>= \p' -> return (fb' >\\ p')); + "fb' >\\ (Pure a )" forall fb' a . + fb' >\\ (Pure a ) = Pure a; + #-} + +{- $push + The 'push' category closely corresponds to push-based Unix pipes. + + The 'push' category obeys the category laws, where 'push' is the identity + and ('>~>') is composition: + +@ +\-\- Left identity +'push' '>~>' f = f + +\-\- Right identity +f '>~>' 'push' = f + +\-\- Associativity +(f '>~>' g) '>~>' h = f '>~>' (g '>~>' h) +@ + + The following diagram shows the flow of information: + +@ +'push' :: ('Monad' m) + => a -> 'Proxy' a' a a' a m r + +\ a + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>~>') :: ('Monad' m) + => (a -> 'Proxy' a' a b' b m r) + -> (b -> 'Proxy' b' b c' c m r) + -> (a -> 'Proxy' a' a c' c m r) + +\ a b a + | | | + +----|----+ +----|----+ +----|----+ + | v | | v | | v | + a' <== <== b' <== <== c' a' <== <== c' + | f | | g | = | f '>~>' g | + a ==> ==> b ==> ==> c a ==> ==> c + | | | | | | | | | + +----|----+ +----|----+ +----|----+ + v v v + r r r +@ + +-} + +{-| Forward responses followed by requests + +@ +'push' = 'respond' 'Control.Monad.>=>' 'request' 'Control.Monad.>=>' 'push' +@ + + 'push' is the identity of the push category. +-} +push :: (Monad m) => a -> Proxy a' a a' a m r +push = go + where + go a = Respond a (\a' -> Request a' go) +{-# INLINABLE push #-} + +{-| Compose two proxies blocked while 'request'ing data, creating a new proxy + blocked while 'request'ing data + +@ +(f '>~>' g) x = f x '>>~' g +@ + + ('>~>') is the composition operator of the push category. +-} +(>~>) + :: (Monad m) + => (_a -> Proxy a' a b' b m r) + -- ^ + -> ( b -> Proxy b' b c' c m r) + -- ^ + -> (_a -> Proxy a' a c' c m r) + -- ^ +(fa >~> fb) a = fa a >>~ fb +{-# INLINABLE (>~>) #-} + +{-| @(p >>~ f)@ pairs each 'respond' in @p@ with an 'request' in @f@. + + Point-ful version of ('>~>') +-} +(>>~) + :: (Monad m) + => Proxy a' a b' b m r + -- ^ + -> (b -> Proxy b' b c' c m r) + -- ^ + -> Proxy a' a c' c m r + -- ^ +p >>~ fb = case p of + Request a' fa -> Request a' (\a -> fa a >>~ fb) + Respond b fb' -> fb' +>> fb b + M m -> M (m >>= \p' -> return (p' >>~ fb)) + Pure r -> Pure r +{-# INLINABLE (>>~) #-} + +{- $pull + The 'pull' category closely corresponds to pull-based Unix pipes. + + The 'pull' category obeys the category laws, where 'pull' is the identity + and ('>+>') is composition: + +@ +\-\- Left identity +'pull' '>+>' f = f + +\-\- Right identity +f '>+>' 'pull' = f + +\-\- Associativity +(f '>+>' g) '>+>' h = f '>+>' (g '>+>' h) +@ + + The following diagrams show the flow of information: + +@ +'pull' :: ('Monad' m) + => a' -> 'Proxy' a' a a' a m r + +\ a' + | + +----|----+ + | v | + a' <============ a' + | | + a ============> a + | | | + +----|----+ + v + r + +('>+>') :: ('Monad' m) + -> (b' -> 'Proxy' a' a b' b m r) + -> (c' -> 'Proxy' b' b c' c m r) + -> (c' -> 'Proxy' a' a c' c m r) + +\ b' c' c' + | | | + +----|----+ +----|----+ +----|----+ + | v | | v | | v | + a' <== <== b' <== <== c' a' <== <== c' + | f | | g | = | f >+> g | + a ==> ==> b ==> ==> c a ==> ==> c + | | | | | | | | | + +----|----+ +----|----+ +----|----+ + v v v + r r r +@ + +-} + +{-| Forward requests followed by responses: + +@ +'pull' = 'request' 'Control.Monad.>=>' 'respond' 'Control.Monad.>=>' 'pull' +@ + + 'pull' is the identity of the pull category. +-} +pull :: (Monad m) => a' -> Proxy a' a a' a m r +pull = go + where + go a' = Request a' (\a -> Respond a go) +{-# INLINABLE pull #-} + +{-| Compose two proxies blocked in the middle of 'respond'ing, creating a new + proxy blocked in the middle of 'respond'ing + +@ +(f '>+>' g) x = f '+>>' g x +@ + + ('>+>') is the composition operator of the pull category. +-} +(>+>) + :: (Monad m) + => ( b' -> Proxy a' a b' b m r) + -- ^ + -> (_c' -> Proxy b' b c' c m r) + -- ^ + -> (_c' -> Proxy a' a c' c m r) + -- ^ +(fb' >+> fc') c' = fb' +>> fc' c' +{-# INLINABLE (>+>) #-} + +{-| @(f +>> p)@ pairs each 'request' in @p@ with a 'respond' in @f@. + + Point-ful version of ('>+>') +-} +(+>>) + :: (Monad m) + => (b' -> Proxy a' a b' b m r) + -- ^ + -> Proxy b' b c' c m r + -- ^ + -> Proxy a' a c' c m r + -- ^ +fb' +>> p = case p of + Request b' fb -> fb' b' >>~ fb + Respond c fc' -> Respond c (\c' -> fb' +>> fc' c') + M m -> M (m >>= \p' -> return (fb' +>> p')) + Pure r -> Pure r +{-# INLINABLE (+>>) #-} + +{- $reflect + @(reflect .)@ transforms each streaming category into its dual: + + * The request category is the dual of the respond category + +@ +'reflect' '.' 'respond' = 'request' + +'reflect' '.' (f '/>/' g) = 'reflect' '.' f '/\' g) = 'reflect' '.' f '\<\' 'reflect' '.' g +@ + + * The pull category is the dual of the push category + +@ +'reflect' '.' 'push' = 'pull' + +'reflect' '.' (f '>~>' g) = 'reflect' '.' f '<+<' 'reflect' '.' g +@ + +@ +'reflect' '.' 'pull' = 'push' + +'reflect' '.' (f '>+>' g) = 'reflect' '.' f '<~<' 'reflect' '.' g +@ +-} + +-- | Switch the upstream and downstream ends +reflect :: (Monad m) => Proxy a' a b' b m r -> Proxy b b' a a' m r +reflect = go + where + go p = case p of + Request a' fa -> Respond a' (\a -> go (fa a )) + Respond b fb' -> Request b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure r +{-# INLINABLE reflect #-} + +{-| An effect in the base monad + + 'Effect's neither 'Pipes.await' nor 'Pipes.yield' +-} +type Effect = Proxy Void () () Void + +-- | 'Producer's can only 'Pipes.yield' +type Producer b = Proxy Void () () 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 () Void + +{-| @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 () Void + +{-| @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 Void () b' b + +-- | Like 'Effect', but with a polymorphic type +type Effect' m r = forall x' x y' y . Proxy x' x y' y m r + +-- | Like 'Producer', but with a polymorphic type +type Producer' b m r = forall x' x . Proxy x' x () b m r + +-- | Like 'Consumer', but with a polymorphic type +type Consumer' a m r = forall y' y . Proxy () a y' y m r + +-- | Like 'Server', but with a polymorphic type +type Server' b' b m r = forall x' x . Proxy x' x b' b m r + +-- | Like 'Client', but with a polymorphic type +type Client' a' a m r = forall y' y . Proxy a' a y' y m r + +-- | Equivalent to ('/>/') with the arguments flipped +(\<\) + :: (Monad m) + => (b -> Proxy x' x c' c m b') + -- ^ + -> (a -> Proxy x' x b' b m a') + -- ^ + -> (a -> Proxy x' x c' c m a') + -- ^ +p1 \<\ p2 = p2 />/ p1 +{-# INLINABLE (\<\) #-} + +-- | Equivalent to ('\>\') with the arguments flipped +(/ (c' -> Proxy b' b x' x m c) + -- ^ + -> (b' -> Proxy a' a x' x m b) + -- ^ + -> (c' -> Proxy a' a x' x m c) + -- ^ +p1 /\ p1 +{-# INLINABLE (/~>') with the arguments flipped +(<~<) + :: (Monad m) + => (b -> Proxy b' b c' c m r) + -- ^ + -> (a -> Proxy a' a b' b m r) + -- ^ + -> (a -> Proxy a' a c' c m r) + -- ^ +p1 <~< p2 = p2 >~> p1 +{-# INLINABLE (<~<) #-} + +-- | Equivalent to ('>+>') with the arguments flipped +(<+<) + :: (Monad m) + => (c' -> Proxy b' b c' c m r) + -- ^ + -> (b' -> Proxy a' a b' b m r) + -- ^ + -> (c' -> Proxy a' a c' c m r) + -- ^ +p1 <+< p2 = p2 >+> p1 +{-# INLINABLE (<+<) #-} + +-- | Equivalent to ('//>') with the arguments flipped +(<\\) + :: (Monad m) + => (b -> Proxy x' x c' c m b') + -- ^ + -> Proxy x' x b' b m a' + -- ^ + -> Proxy x' x c' c m a' + -- ^ +f <\\ p = p //> f +{-# INLINABLE (<\\) #-} + +-- | Equivalent to ('>\\') with the arguments flipped +(//<) + :: (Monad m) + => Proxy b' b y' y m c + -- ^ + -> (b' -> Proxy a' a y' y m b) + -- ^ + -> Proxy a' a y' y m c + -- ^ +p //< f = f >\\ p +{-# INLINABLE (//<) #-} + +-- | Equivalent to ('>>~') with the arguments flipped +(~<<) + :: (Monad m) + => (b -> Proxy b' b c' c m r) + -- ^ + -> Proxy a' a b' b m r + -- ^ + -> Proxy a' a c' c m r + -- ^ +k ~<< p = p >>~ k +{-# INLINABLE (~<<) #-} + +-- | Equivalent to ('+>>') with the arguments flipped +(<<+) + :: (Monad m) + => Proxy b' b c' c m r + -- ^ + -> (b' -> Proxy a' a b' b m r) + -- ^ + -> Proxy a' a c' c m r + -- ^ +k <<+ p = p +>> k +{-# INLINABLE (<<+) #-} 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,237 @@ +{-| This is an internal module, meaning that it is unsafe to import unless you + understand the risks. + + This module provides a fast implementation by weakening the monad + transformer laws. These laws do not hold if you can pattern match on the + constructors, as the following counter-example illustrates: + +@ +'lift' '.' 'return' = 'M' '.' 'return' '.' 'Pure' + +'return' = 'Pure' + +'lift' '.' 'return' /= 'return' +@ + + You do not need to worry about this if you do not import this module, since + the other modules in this library do not export the constructors or export + any functions which can violate the monad transformer laws. +-} + +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , RankNTypes + , UndecidableInstances + , CPP + #-} +module Pipes.Internal ( + -- * Internal + Proxy(..), + unsafeHoist, + observe, + ) where + +import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) +import Control.Monad (liftM, MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Morph (MFunctor(hoist)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Error (MonadError(..)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Writer (MonadWriter(..)) +import Data.Monoid (mempty,mappend) + +{-| A 'Proxy' is a monad transformer that receives and sends information on both + an upstream and downstream interface. + + The type variables signify: + + * @a'@ and @a@ - The upstream interface, where @(a')@s go out and @(a)@s + come in + + * @b'@ and @b@ - The downstream interface, where @(b)@s go out and @(b')@s + come in + + * @m @ - The base monad + + * @r @ - The return value +-} +data Proxy a' a b' b m r + = Request a' (a -> Proxy a' a b' b m r ) + | Respond b (b' -> Proxy a' a b' b m r ) + | M (m (Proxy a' a b' b m r)) + | Pure r + +instance (Monad m) => Functor (Proxy a' a b' b m) where + fmap f p0 = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure (f r) + +instance (Monad m) => Applicative (Proxy a' a b' b m) where + pure = Pure + pf <*> px = go pf where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure f -> fmap f px + +instance (Monad m) => Monad (Proxy a' a b' b m) where + return = Pure + (>>=) = _bind + +_bind + :: (Monad m) + => Proxy a' a b' b m r + -> (r -> Proxy a' a b' b m r') + -> Proxy a' a b' b m r' +p0 `_bind` f = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> f r + +{-# RULES + "_bind (Request a' k) f" forall a' k f . + _bind (Request a' k) f = Request a' (\a -> _bind (k a) f); + "_bind (Respond b k) f" forall b k f . + _bind (Respond b k) f = Respond b (\b' -> _bind (k b') f); + "_bind (M m) f" forall m f . + _bind (M m) f = M (m >>= \p -> return (_bind p f)); + "_bind (Pure r ) f" forall r f . + _bind (Pure r ) f = f r; + #-} + +instance MonadTrans (Proxy a' a b' b) where + lift m = M (m >>= \r -> return (Pure r)) + +{-| 'unsafeHoist' is like 'hoist', but faster. + + This is labeled as unsafe because you will break the monad transformer laws + if you do not pass a monad morphism as the first argument. This function is + safe if you pass a monad morphism as the first argument. +-} +unsafeHoist + :: (Monad m) + => (forall x . m x -> n x) -> Proxy a' a b' b m r -> Proxy a' a b' b n r +unsafeHoist nat = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (nat (m >>= \p' -> return (go p'))) + Pure r -> Pure r + +instance MFunctor (Proxy a' a b' b) where + hoist nat p0 = go (observe p0) where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (nat (m >>= \p' -> return (go p'))) + Pure r -> Pure r + +instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where + liftIO m = M (liftIO (m >>= \r -> return (Pure r))) + +instance (MonadReader r m) => MonadReader r (Proxy a' a b' b m) where + ask = lift ask + local f = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M (go `liftM` local f m) +#if MIN_VERSION_mtl(2,1,0) + reader = lift . reader +#else +#endif + +instance (MonadState s m) => MonadState s (Proxy a' a b' b m) where + get = lift get + put = lift . put +#if MIN_VERSION_mtl(2,1,0) + state = lift . state +#else +#endif + +instance (MonadWriter w m) => MonadWriter w (Proxy a' a b' b m) where +#if MIN_VERSION_mtl(2,1,0) + writer = lift . writer +#else +#endif + tell = lift . tell + listen proxy = go proxy 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) + Pure r -> Pure (r, w) + M m -> M ( + (\(p', w') -> go p' $! mappend w w') `liftM` listen m) + + pass = 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 (go `liftM` m) + Pure (r, f) -> M (pass (return (Pure r, f))) + +instance (MonadError e m) => MonadError e (Proxy a' a b' b m) where + throwError = lift . throwError + catchError p0 f = go p0 + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M ((do + p' <- m + return (go p') ) `catchError` (\e -> return (f e)) ) + +instance (MonadPlus m) => Alternative (Proxy a' a b' b m) where + empty = mzero + (<|>) = mplus + +instance (MonadPlus m) => MonadPlus (Proxy a' a b' b m) where + mzero = lift mzero + mplus p0 p1 = go p0 + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r + M m -> M ((do + p' <- m + return (go p') ) `mplus` return p1 ) + +{-| The monad transformer laws are correct when viewed through the 'observe' + function: + +@ +'observe' ('lift' ('return' r)) = 'observe' ('return' r) + +'observe' ('lift' (m '>>=' f)) = 'observe' ('lift' m '>>=' 'lift' '.' f) +@ + + This correctness comes at a small cost to performance, so use this function + sparingly. + + This function is a convenience for low-level @pipes@ implementers. You do + not need to use 'observe' if you stick to the safe API. +-} +observe :: (Monad m) => Proxy a' a b' b m r -> Proxy a' a b' b m r +observe p0 = M (go p0) where + go p = case p of + Request a' fa -> return (Request a' (\a -> observe (fa a ))) + Respond b fb' -> return (Respond b (\b' -> observe (fb' b'))) + M m' -> m' >>= go + Pure r -> return (Pure r) +{-# INLINABLE observe #-} 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,305 @@ +{-| 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. +-} + +{-# LANGUAGE CPP #-} + +module Pipes.Lift ( + -- * ErrorT + errorP, + runErrorP, + catchError, + liftCatchError, + + -- * MaybeT + maybeP, + runMaybeP, + + -- * ReaderT + readerP, + runReaderP, + + -- * StateT + stateP, + runStateP, + evalStateP, + execStateP, + + -- * WriterT + -- $writert + writerP, + runWriterP, + execWriterP, + + -- * RWST + rwsP, + runRWSP, + evalRWSP, + execRWSP + ) where + +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Trans.Error as E +import qualified Control.Monad.Trans.Maybe as M +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State.Strict as S +import qualified Control.Monad.Trans.Writer.Strict as W +import qualified Control.Monad.Trans.RWS.Strict as RWS +import Data.Monoid (Monoid(mempty, mappend)) +import Pipes.Internal + +-- | Wrap the base monad in 'E.ErrorT' +errorP + :: (Monad m, E.Error e) + => Proxy a' a b' b m (Either e r) + -> Proxy a' a b' b (E.ErrorT e m) r +errorP p = do + x <- unsafeHoist lift p + lift $ E.ErrorT (return x) +{-# INLINABLE errorP #-} + +-- | Run 'E.ErrorT' in the base monad +runErrorP + :: (Monad m) + => Proxy a' a b' b (E.ErrorT e m) r -> Proxy a' a b' b m (Either e r) +runErrorP = 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 (Right r) + M m -> M (do + x <- E.runErrorT m + return (case x of + Left e -> Pure (Left e) + Right p' -> go p' ) ) +{-# INLINABLE runErrorP #-} + +-- | Catch an error in the base monad +catchError + :: (Monad m) + => Proxy a' a b' b (E.ErrorT e m) r + -- ^ + -> (e -> Proxy a' a b' b (E.ErrorT f m) r) + -- ^ + -> Proxy a' a b' b (E.ErrorT f m) r +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 (E.ErrorT (do + x <- E.runErrorT m + return (Right (case x of + Left e -> f e + Right p' -> go p' )) )) +{-# 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 = 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 (Just r) + M m -> M (do + x <- M.runMaybeT m + return (case x of + Nothing -> Pure Nothing + Just p' -> go 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 i = 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 (do + p' <- R.runReaderT m i + return (go 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 = go + where + go s p = case p of + Request a' fa -> Request a' (\a -> go s (fa a )) + Respond b fb' -> Respond b (\b' -> go s (fb' b')) + Pure r -> Pure (r, s) + M m -> M (do + (p', s') <- S.runStateT m s + return (go s' 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 = fmap fst . runStateP s +{-# 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 = fmap snd . runStateP s +{-# 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 = go mempty + where + go w p = case p of + Request a' fa -> Request a' (\a -> go w (fa a )) + Respond b fb' -> Respond b (\b' -> go w (fb' b')) + Pure r -> Pure (r, w) + M m -> M (do + (p', w') <- W.runWriterT m + let wt = mappend w w' + wt `seq` return (go wt 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 = fmap snd . runWriterP +{-# 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) + => i + -> s + -> Proxy a' a b' b (RWS.RWST i w s m) r + -> Proxy a' a b' b m (r, s, w) +runRWSP i = go mempty + where + go w s p = case p of + Request a' fa -> Request a' (\a -> go w s (fa a )) + Respond b fb' -> Respond b (\b' -> go w s (fb' b')) + Pure r -> Pure (r, s, w) + M m -> M (do + (p', s', w') <- RWS.runRWST m i s + let wt = mappend w w' + wt `seq` return (go w' s' p') ) +{-# INLINABLE runRWSP #-} + +-- | Evaluate 'RWS.RWST' in the base monad +evalRWSP :: (Monad m, Monoid w) + => i + -> s + -> Proxy a' a b' b (RWS.RWST i w s m) r + -> Proxy a' a b' b m (r, w) +evalRWSP i s = fmap go . runRWSP i s + where go (r, _, w) = (r, w) +{-# INLINABLE evalRWSP #-} + +-- | Execute 'RWS.RWST' in the base monad +execRWSP :: (Monad m, Monoid w) + => i + -> s + -> Proxy a' a b' b (RWS.RWST i w s m) r + -> Proxy a' a b' b m (s, w) +execRWSP i s = fmap go . runRWSP i s + where go (_, s', w) = (s', w) +{-# INLINABLE execRWSP #-} 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,629 @@ +{-| 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 upcoming 'ByteString' and + 'Text' utilities for @pipes@ will preserve newlines. +-} + +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Pipes.Prelude ( + -- * Producers + -- $producers + stdinLn, + readLn, + fromHandle, + replicateM, + + -- * Consumers + -- $consumers + stdoutLn, + print, + toHandle, + + -- * Pipes + -- $pipes + map, + mapM, + filter, + filterM, + take, + takeWhile, + drop, + dropWhile, + concat, + elemIndices, + findIndices, + scan, + scanM, + chain, + read, + show, + + -- * Folds + -- $folds + fold, + foldM, + all, + any, + and, + or, + elem, + notElem, + find, + findIndex, + head, + index, + last, + length, + maximum, + minimum, + null, + sum, + product, + toList, + toListM, + + -- * Zips + zip, + zipWith, + + -- * Utilities + tee, + generalize + ) where + +import Control.Exception (throwIO, try) +import Control.Monad (liftM, replicateM_, when, unless) +import Control.Monad.Trans.State.Strict (get, put) +import Data.Functor.Identity (Identity, runIdentity) +import Data.Void (absurd) +import Foreign.C.Error (Errno(Errno), ePIPE) +import qualified GHC.IO.Exception as G +import Pipes +import Pipes.Core +import Pipes.Internal +import Pipes.Lift (evalStateP) +import qualified System.IO as IO +import qualified Prelude +import Prelude hiding ( + all, + and, + any, + concat, + drop, + dropWhile, + elem, + filter, + head, + last, + length, + map, + mapM, + maximum, + minimum, + notElem, + null, + or, + print, + product, + read, + readLn, + show, + sum, + take, + takeWhile, + zip, + zipWith ) + +{- $producers + Use 'for' loops to iterate over 'Producer's whenever you want to perform the + same action for every element: + +> -- Echo all lines from standard input to standard output +> runEffect $ for P.stdinLn $ \str -> do +> lift $ putStrLn str + + ... or more concisely: + +>>> runEffect $ for P.stdinLn (lift . putStrLn) +Test +Test +ABC +ABC +... + +-} + +{-| Read 'String's from 'IO.stdin' using 'getLine' + + Terminates on end of input +-} +stdinLn :: (MonadIO m) => Producer' String m () +stdinLn = fromHandle IO.stdin +{-# INLINABLE stdinLn #-} + +-- | 'read' values from 'IO.stdin', ignoring failed parses +readLn :: (MonadIO m) => (Read a) => Producer' a m () +readLn = stdinLn >-> read +{-# INLINABLE readLn #-} + +{-| Read 'String's from a 'IO.Handle' using 'IO.hGetLine' + + Terminates on end of input +-} +fromHandle :: (MonadIO m) => IO.Handle -> Producer' String m () +fromHandle h = go + where + go = do + eof <- liftIO $ IO.hIsEOF h + unless eof $ do + str <- liftIO $ IO.hGetLine h + yield str + go +{-# INLINABLE fromHandle #-} + +-- | Repeat a monadic action a fixed number of times, 'yield'ing each result +replicateM :: (Monad m) => Int -> m a -> Producer a m () +replicateM n m = lift m >~ take n +{-# INLINABLE replicateM #-} + +{- $consumers + Feed a 'Consumer' the same value repeatedly using ('>~'): + +>>> runEffect $ lift getLine >~ P.stdoutLn +Test +Test +ABC +ABC +... + +-} + +{-| Write 'String's to 'IO.stdout' using 'putStrLn' + + Unlike 'toHandle', 'stdoutLn' gracefully terminates on a broken output pipe +-} +stdoutLn :: (MonadIO m) => Consumer' String m () +stdoutLn = go + where + go = do + str <- await + x <- liftIO $ try (putStrLn str) + case x of + Left (G.IOError { G.ioe_type = G.ResourceVanished + , G.ioe_errno = Just ioe }) + | Errno ioe == ePIPE + -> return () + Left e -> liftIO (throwIO e) + Right () -> go +{-# INLINABLE stdoutLn #-} + +-- | 'print' values to 'IO.stdout' +print :: (MonadIO m) => (Show a) => Consumer' a m r +print = for cat (liftIO . Prelude.print) +{-# INLINABLE print #-} + +-- | Write 'String's to a 'IO.Handle' using 'IO.hPutStrLn' +toHandle :: (MonadIO m) => IO.Handle -> Consumer' String m r +toHandle handle = for cat $ \str -> liftIO (IO.hPutStrLn handle str) +{-# INLINABLE toHandle #-} + +{- $pipes + Use ('>->') to connect 'Producer's, 'Pipe's, and 'Consumer's: + +>>> runEffect $ P.stdinLn >-> P.takeWhile (/= "quit") >-> P.stdoutLn +Test +Test +ABC +ABC +quit +>>> + +-} + +-- | Apply a function to all values flowing downstream +map :: (Monad m) => (a -> b) -> Pipe a b m r +map f = for cat (yield . f) +{-# INLINABLE map #-} + +-- | Apply a monadic function to all values flowing downstream +mapM :: (Monad m) => (a -> m b) -> Pipe a b m r +mapM f = for cat $ \a -> do + b <- lift (f a) + yield b +{-# INLINABLE mapM #-} + +-- | @(filter predicate)@ only forwards values that satisfy the predicate. +filter :: (Monad m) => (a -> Bool) -> Pipe a a m r +filter predicate = for cat $ \a -> when (predicate a) (yield a) +{-# INLINABLE filter #-} + +{-| @(filterM predicate)@ only forwards values that satisfy the monadic + predicate +-} +filterM :: (Monad m) => (a -> m Bool) -> Pipe a a m r +filterM predicate = for cat $ \a -> do + b <- lift (predicate a) + when b (yield a) +{-# INLINABLE filterM #-} + +-- | @(take n)@ only allows @n@ values to pass through +take :: (Monad m) => Int -> Pipe a a m () +take n = replicateM_ n $ do + a <- await + yield a +{-# INLINABLE take #-} + +{-| @(takeWhile p)@ allows values to pass downstream so long as they satisfy + the predicate @p@. +-} +takeWhile :: (Monad m) => (a -> Bool) -> Pipe a a m () +takeWhile predicate = go + where + go = do + a <- await + if (predicate a) + then do + yield a + go + else return () +{-# INLINABLE takeWhile #-} + +-- | @(drop n)@ discards @n@ values going downstream +drop :: (Monad m) => Int -> Pipe a a m r +drop n = do + replicateM_ n await + cat +{-# INLINABLE drop #-} + +{-| @(dropWhile p)@ discards values going downstream until one violates the + predicate @p@. +-} +dropWhile :: (Monad m) => (a -> Bool) -> Pipe a a m r +dropWhile predicate = go + where + go = do + a <- await + if (predicate a) + then go + else do + yield a + cat +{-# INLINABLE dropWhile #-} + +-- | Flatten all 'Foldable' elements flowing downstream +concat :: (Monad m, Foldable f) => Pipe (f a) a m r +concat = for cat each +{-# INLINABLE concat #-} + +-- | Outputs the indices of all elements that match the given element +elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r +elemIndices a = findIndices (a ==) +{-# INLINABLE elemIndices #-} + +-- | Outputs the indices of all elements that satisfied the predicate +findIndices :: (Monad m) => (a -> Bool) -> Pipe a Int m r +findIndices predicate = loop 0 + where + loop n = do + a <- await + when (predicate a) (yield n) + loop $! n + 1 +{-# INLINABLE findIndices #-} + +-- | Strict left scan +scan :: (Monad m) => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r +scan step begin done = loop begin + where + loop x = do + yield (done x) + a <- await + let x' = step x a + loop $! x' +{-# INLINABLE scan #-} + +-- | Strict, monadic left scan +scanM :: (Monad m) => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r +scanM step begin done = do + x <- lift begin + loop x + where + loop x = do + b <- lift (done x) + yield b + a <- await + x' <- lift (step x a) + loop $! x' +{-# INLINABLE scanM #-} + +-- | Apply an action to all values flowing downstream +chain :: (Monad m) => (a -> m ()) -> Pipe a a m r +chain f = for cat $ \a -> do + lift (f a) + yield a +{-# INLINABLE chain #-} + +-- | Parse 'Read'able values, only forwarding the value if the parse succeeds +read :: (Monad m, Read a) => Pipe String a m r +read = for cat $ \str -> case (reads str) of + [(a, "")] -> yield a + _ -> return () +{-# INLINABLE read #-} + +-- | Convert 'Show'able values to 'String's +show :: (Monad m, Show a) => Pipe a String m r +show = map Prelude.show +{-# INLINABLE show #-} + +{- $folds + Use these to fold the output of a 'Producer'. Many of these folds will stop + drawing elements if they can compute their result early, like 'any': + +>>> P.any null P.stdinLn +Test +ABC + +True +>>> + +-} + +-- | Strict fold of the elements of a 'Producer' +fold :: (Monad m) => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b +fold step begin done p0 = loop p0 begin + where + loop p x = case p of + Request v _ -> absurd v + Respond a fu -> loop (fu ()) $! step x a + M m -> m >>= \p' -> loop p' x + Pure _ -> return (done x) +{-# INLINABLE fold #-} + +-- | Strict, monadic fold of the elements of a 'Producer' +foldM + :: (Monad m) + => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b +foldM step begin done p0 = do + x0 <- begin + loop p0 x0 + where + loop p x = case p of + Request v _ -> absurd v + Respond a fu -> do + x' <- step x a + loop (fu ()) $! x' + M m -> m >>= \p' -> loop p' x + Pure _ -> done x +{-# INLINABLE foldM #-} + +{-| @(all predicate p)@ determines whether all the elements of @p@ satisfy the + predicate. +-} +all :: (Monad m) => (a -> Bool) -> Producer a m () -> m Bool +all predicate p = null $ for p $ \a -> when (not $ predicate a) (yield 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 $ for p $ \a -> when (predicate a) (yield a) +{-# 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 $ for p $ \a -> when (predicate a) (yield a) +{-# 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 + case x of + Left _ -> return Nothing + Right (a, _) -> return (Just a) +{-# INLINABLE head #-} + +-- | Index into a 'Producer' +index :: (Monad m) => Int -> Producer a m () -> m (Maybe a) +index n p = head (p >-> drop n) +{-# INLINABLE index #-} + +-- | Retrieve the last element from a 'Producer' +last :: (Monad m) => Producer a m () -> m (Maybe a) +last p0 = do + x <- next p0 + case x of + Left _ -> return Nothing + Right (a, p') -> loop a p' + where + loop a p = do + x <- next p + case x of + Left _ -> return (Just a) + Right (a', p') -> loop a' p' +{-# INLINABLE last #-} + +-- | Count the number of elements in a 'Producer' +length :: (Monad m) => Producer a m () -> m Int +length = fold (\n _ -> n + 1) 0 id +{-# INLINABLE length #-} + +-- | Find the maximum element of a 'Producer' +maximum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a) +maximum = fold step Nothing id + where + step x a = Just $ case x of + Nothing -> a + Just a' -> max a a' +{-# INLINABLE maximum #-} + +-- | Find the minimum element of a 'Producer' +minimum :: (Monad m, Ord a) => Producer a m () -> m (Maybe a) +minimum = fold step Nothing id + where + step x a = Just $ case x of + Nothing -> a + Just a' -> min a a' +{-# INLINABLE minimum #-} + +-- | Determine if a 'Producer' is empty +null :: (Monad m) => Producer a m () -> m Bool +null p = do + x <- next p + return $ case x of + Left _ -> True + Right _ -> False +{-# INLINABLE null #-} + +-- | Compute the sum of the elements of a 'Producer' +sum :: (Monad m, Num a) => Producer a m () -> m a +sum = fold (+) 0 id +{-# INLINABLE sum #-} + +-- | Compute the product of the elements of a 'Producer' +product :: (Monad m, Num a) => Producer a m () -> m a +product = fold (*) 1 id +{-# INLINABLE product #-} + +-- | Convert a pure 'Producer' into a list +toList :: Producer a Identity () -> [a] +toList = loop + where + loop p = case p of + Request v _ -> absurd v + Respond a fu -> a:loop (fu ()) + M m -> loop (runIdentity m) + Pure _ -> [] +{-# INLINABLE toList #-} + +{-| Convert an effectful 'Producer' into a list + + Note: 'toListM' is not an idiomatic use of @pipes@, but I provide it for + simple testing purposes. Idiomatic @pipes@ style consumes the elements + immediately as they are generated instead of loading all elements into + memory. +-} +toListM :: (Monad m) => Producer a m () -> m [a] +toListM = loop + where + loop p = case p of + Request v _ -> absurd v + Respond a fu -> do + as <- loop (fu ()) + return (a:as) + M m -> m >>= loop + Pure _ -> return [] +{-# INLINABLE toListM #-} + +-- | Zip two 'Producer's +zip :: (Monad m) + => (Producer a m r) + -> (Producer b m r) + -> (Producer' (a, b) m r) +zip = zipWith (,) +{-# INLINABLE zip #-} + +-- | Zip two 'Producer's using the provided combining function +zipWith :: (Monad m) + => (a -> b -> c) + -> (Producer a m r) + -> (Producer b m r) + -> (Producer' c m r) +zipWith f = go + where + go p1 p2 = do + e1 <- lift $ next p1 + case e1 of + Left r -> return r + Right (a, p1') -> do + e2 <- lift $ next p2 + case e2 of + Left r -> return r + Right (b, p2') -> do + yield (f a b) + go p1' p2' +{-# INLINABLE zipWith #-} + +{-| Transform a 'Consumer' to a 'Pipe' that reforwards all values further + downstream +-} +tee :: (Monad m) => Consumer a m r -> Pipe a a m r +tee p = evalStateP Nothing $ do + r <- up >\\ (hoist lift p //> dn) + ma <- lift get + case ma of + Nothing -> return () + Just a -> yield a + return r + where + up () = do + ma <- lift get + case ma of + Nothing -> return () + Just a -> yield a + a <- await + lift $ put (Just a) + return a + dn v = absurd v +{-# INLINABLE tee #-} + +{-| Transform a unidirectional 'Pipe' to a bidirectional 'Proxy' + +> generalize (f >-> g) = generalize f >+> generalize g +> +> generalize cat = pull +-} +generalize :: (Monad m) => Pipe a b m r -> x -> Proxy x a x b m r +generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn + where + up () = do + x <- lift get + request x + dn a = do + x <- respond a + lift $ put x +{-# INLINABLE generalize #-} diff --git a/src/Pipes/Tutorial.hs b/src/Pipes/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/Tutorial.hs @@ -0,0 +1,1422 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-| Conventional Haskell stream programming forces you to choose only two of the + following three features: + + * Effects + + * Streaming + + * Composability + + If you sacrifice /Effects/ you get Haskell's pure and lazy lists, which you + can transform using composable functions in constant space, but without + interleaving effects. + + If you sacrifice /Streaming/ you get 'mapM', 'forM' and + \"ListT done wrong\", which are composable and effectful, but do not return + a single result until the whole list has first been processed and loaded + into memory. + + If you sacrifice /Composability/ you write a tightly coupled read, + transform, and write loop in 'IO', which is streaming and effectful, but is + not modular or separable. + + @pipes@ gives you all three features: effectful, streaming, and composable + programming. @pipes@ also provides a wide variety of stream programming + abstractions which are all subsets of a single unified machinery: + + * effectful 'Producer's (like generators), + + * effectful 'Consumer's (like iteratees), + + * effectful 'Pipe's (like Unix pipes), and: + + * 'ListT' done right. + + All of these are connectable and you can combine them together in clever and + unexpected ways because they all share the same underlying type. + + @pipes@ requires a basic understanding of monad transformers, which you can + learn about by reading either: + + * the paper \"Monad Transformers - Step by Step\", + + * chapter 18 of \"Real World Haskell\" on monad transformers, or: + + * the documentation of the @transformers@ library. + + If you want a Quick Start guide to @pipes@, read the documentation in + "Pipes.Prelude" from top to bottom. + + This tutorial is more extensive and explains the @pipes@ API in greater + detail and illustrates several idioms. +-} + +module Pipes.Tutorial ( + -- * Introduction + -- $introduction + + -- * Producers + -- $producers + + -- * Composability + -- $composability + + -- * Consumers + -- $consumers + + -- * Pipes + -- $pipes + + -- * ListT + -- $listT + + -- * Tricks + -- $tricks + + -- * Conclusion + -- $conclusion + + -- * Appendix: Types + -- $types + ) where + +import Control.Category +import Control.Monad +import Control.Monad.Trans.Error +import Control.Monad.Trans.Writer.Strict +import Pipes +import Pipes.Lift +import qualified Pipes.Prelude as P +import Prelude hiding ((.), id) + +{- $introduction + The @pipes@ library decouples stream processing stages from each other so + that you can mix and match diverse stages to produce useful streaming + programs. If you are a library writer, @pipes@ lets you package up + streaming components into a reusable interface. If you are an application + writer, @pipes@ lets you connect pre-made streaming components with minimal + effort to produce a highly-efficient program that streams data in constant + memory. + + To enforce loose coupling, components can only communicate using two + commands: + + * 'yield': Send output data + + * 'await': Receive input data + + @pipes@ has four types of components built around these two commands: + + * 'Producer's can only 'yield' values and they model streaming sources + + * 'Consumer's can only 'await' values and they model streaming sinks + + * 'Pipe's can both 'yield' and 'await' values and they model stream + transformations + + * 'Effect's can neither 'yield' nor 'await' and they model non-streaming + components + + You can connect these components together in four separate ways which + parallel the four above types: + + * 'for' handles 'yield's + + * ('>~') handles 'await's + + * ('>->') handles both 'yield's and 'await's + + * ('>>=') handles return values + + As you connect components their types will change to reflect inputs and + outputs that you've fused away. You know that you're done connecting things + when you get an 'Effect', meaning that you have handled all inputs and + outputs. You run this final 'Effect' to begin streaming. +-} + +{- $producers + 'Producer's are effectful streams of input. Specifically, a 'Producer' is a + monad transformer that extends any base monad with a new 'yield' command. + This 'yield' command lets you send output downstream to an anonymous + handler, decoupling how you generate values from how you consume them. + + The following @stdinLn@ 'Producer' shows how to incrementally read in + 'String's from standard input and 'yield' them downstream, terminating + gracefully when reaching the end of the input: + +> -- echo.hs +> +> import Control.Monad (unless) +> import Pipes +> import System.IO (isEOF) +> +> -- +--------+-- A 'Producer' that yields 'String's +> -- | | +> -- | | +-- Every monad transformer has a base monad. +> -- | | | This time the base monad is 'IO'. +> -- | | | +> -- | | | +-- Every monadic action has a return value. +> -- | | | | This action returns '()' when finished +> -- v v v v +> stdinLn :: Producer String IO () +> stdinLn = do +> eof <- lift isEOF -- 'lift' an 'IO' action from the base monad +> unless eof $ do +> str <- lift getLine +> yield str -- 'yield' the 'String' +> stdinLn -- Loop + + 'yield' emits a value, suspending the current 'Producer' until the value is + consumed. If nobody consumes the value (which is possible) then 'yield' + never returns. You can think of 'yield' as having the following type: + +@ + 'yield' :: 'Monad' m => a -> 'Producer' a m () +@ + + The true type of 'yield' is actually more general and powerful. Throughout + the tutorial I will present type signatures like this that are simplified at + first and then later reveal more general versions. So read the above type + signature as simply saying: \"You can use 'yield' within a 'Producer', but + you may be able to use 'yield' in other contexts, too.\" + + Click the link to 'yield' to navigate to its documentation. There you will + see that 'yield' actually uses the 'Producer'' (with an apostrophe) type + synonym which hides a lot of polymorphism behind a simple veneer. The + documentation for 'yield' says that you can also use 'yield' within a + 'Pipe', too, because of this polymorphism: + +@ + 'yield' :: 'Monad' m => a -> 'Pipe' x a m () +@ + + Use simpler types like these to guide you until you understand the fully + general type. + + 'for' loops are the simplest way to consume a 'Producer' like @stdinLn@. + 'for' has the following type: + +@ + \-\- +-- Producer +-- The body of the +-- Result + \-\- | to loop | loop | + \-\- v over v v + \-\- -------------- ------------------ ---------- + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r +@ + + @(for producer body)@ loops over @(producer)@, substituting each 'yield' in + @(producer)@ with @(body)@. + + You can also deduce that behavior purely from the type signature: + + * The body of the loop takes exactly one argument of type @(a)@, which is + the same as the output type of the 'Producer'. Therefore, the body of the + loop must get its input from that 'Producer' and nowhere else. + + * The return value of the input 'Producer' matches the return value of the + result, therefore 'for' must loop over the entire 'Producer' and not skip + anything. + + The above type signature is not the true type of 'for', which is actually + more general. Think of the above type signature as saying: \"If the first + argument of 'for' is a 'Producer' and the second argument returns an + 'Effect', then the final result must be an 'Effect'.\" + + Click the link to 'for' to navigate to its documentation. There you will + see the fully general type and underneath you will see equivalent simpler + types. One of these says that if the body of the loop is a 'Producer', then + the result is a 'Producer', too: + +@ + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r +@ + + The first type signature I showed for 'for' was a special case of this + slightly more general signature because a 'Producer' that never 'yield's is + also an 'Effect': + +@ + data 'Void' -- The uninhabited type + +\ type 'Effect' m r = 'Producer' 'Void' 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 \'Void\' + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' 'Void' m ()) -> 'Producer' 'Void' m r + +\ -- Producer Void = Effect + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r +@ + + This is the same trick that all @pipes@ functions use to work with various + combinations of 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's. Each + function really has just one general type, which you can then simplify down + to multiple useful alternative types. + + Here's an example use of a 'for' @loop@, where the second argument (the + loop body) is an 'Effect': + +> -- echo.hs +> +> loop :: Effect IO () +> loop = for stdinLn $ \str -> do -- Read this like: "for str in stdinLn" +> lift $ putStrLn str -- The body of the 'for' loop +> +> -- more concise: loop = for stdinLn (lift . putStrLn) + + In this example, 'for' loops over @stdinLn@ and replaces every 'yield' in + @stdinLn@ with the body of the loop, printing each line. This is exactly + equivalent to the following code, which I've placed side-by-side with the + original definition of @stdinLn@ for comparison: + +> loop = do | stdinLn = do +> eof <- lift isEOF | eof <- lift isEOF +> unless eof $ do | unless eof $ do +> str <- lift getLine | str <- lift getLine +> (lift . putStrLn) str | yield str +> loop | stdinLn + + You can think of 'yield' as creating a hole and a 'for' loop is one way to + fill that hole. + + Notice how the final @loop@ only 'lift's actions from the base monad and + does nothing else. This property is true for all 'Effect's, which are just + glorified wrappers around actions in the base monad. This means we can run + these 'Effect's to remove their 'lift's and lower them back to the + equivalent computation in the base monad: + +@ + 'runEffect' :: 'Monad' m => 'Effect' m r -> m r +@ + + This is the real type signature of 'runEffect', which refuses to accept + anything other than an 'Effect'. This ensures that we handle all inputs and + outputs before streaming data: + +> -- echo.hs +> +> main :: IO () +> main = runEffect loop + + ... or you could inline the entire @loop@ into the following one-liner: + +> main = runEffect $ for stdinLn (lift . putStrLn) + + Our final program loops over standard input and echoes every line to + standard output until we hit @Ctrl-D@ to end the input stream: + +> $ ghc -O2 echo.hs +> $ ./echo +> Test +> Test +> ABC +> ABC +> +> $ + + The final behavior is indistinguishable from just removing all the 'lift's + from @loop@: + +> main = do | loop = do +> eof <- isEof | eof <- lift isEof +> unless eof $ do | unless eof $ do +> str <- getLine | str <- lift getLine +> putStrLn str | (lift . putStrLn) str +> main | loop + + This @main@ is what we might have written by hand if we were not using + @pipes@, but with @pipes@ we can decouple the input and output logic from + each other. When we connect them back together, we still produce streaming + code equivalent to what a sufficiently careful Haskell programmer would + have written. + + You can also use 'for' to loop over lists, too. To do so, convert the list + to a 'Producer' using 'each', which is exported by default from "Pipes": + +> each :: (Monad m) => [a] -> Producer a m () +> each as = mapM_ yield as + + Combine 'for' and 'each' to iterate over lists using a \"foreach\" loop: + +>>> runEffect $ for (each [1..4]) (lift . print) +1 +2 +3 +4 + + 'each' is actually more general and works for any 'Foldable': + +@ + 'each' :: ('Monad' m, 'Foldable' f) => f a -> 'Producer' a m () +@ + + So you can loop over any 'Foldable' container or even a 'Maybe': + +>>> runEffect $ for (each (Just 1)) (lift . print) +1 + +-} + +{- $composability + You might wonder why the body of a 'for' loop can be a 'Producer'. Let's + test out this feature by defining a new loop body that @duplicate@s every + value: + +> -- nested.hs +> +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude already has 'stdinLn' +> +> duplicate :: (Monad m) => a -> Producer a m () +> duplicate x = do +> yield x +> yield x +> +> loop :: Producer String IO () +> loop = for P.stdinLn duplicate +> +> -- This is the exact same as: +> -- +> -- loop = for P.stdinLn $ \x -> do +> -- yield x +> -- yield x + + This time our @loop@ is a 'Producer' that outputs 'String's, specifically + two copies of each line that we read from standard input. Since @loop@ is a + 'Producer' we cannot run it because there is still unhandled output. + However, we can use yet another 'for' to handle this new duplicated stream: + +> -- nested.hs +> +> main = runEffect $ for loop (lift . putStrLn) + + This creates a program which echoes every line from standard input to + standard output twice: + +> $ ./nested +> Test +> Test +> Test +> ABC +> ABC +> ABC +> +> $ + + But is this really necessary? Couldn't we have instead written this using a + nested for loop? + +> main = runEffect $ +> for P.stdinLn $ \str1 -> +> for (duplicate str1) $ \str2 -> +> lift $ putStrLn str2 + + Yes, we could have! In fact, this is a special case of the following + equality, which always holds no matter what: + +@ + \-\- s :: (Monad m) => 'Producer' a m () -- i.e. \'P.stdinLn\' + \-\- f :: (Monad m) => a -> 'Producer' b m () -- i.e. \'duplicate\' + \-\- g :: (Monad m) => b -> 'Producer' c m () -- i.e. \'(lift . putStrLn)\' + +\ for (for s f) g = for s (\\x -> for (f x) g) +@ + + We can understand the rationale behind this equality if we first define the + following operator that is the point-free counterpart to 'for': + +@ + (~>) :: (Monad m) + => (a -> 'Producer' b m r) + -> (b -> 'Producer' c m r) + -> (a -> 'Producer' c m r) + (f ~> g) x = for (f x) g +@ + + Using ('~>') (pronounced \"into\"), we can transform our original equality + into the following more symmetric equation: + +@ + f :: (Monad m) => a -> 'Producer' b m r + g :: (Monad m) => b -> 'Producer' c m r + h :: (Monad m) => c -> 'Producer' d m r + +\ \-\- Associativity + (f ~> g) ~> h = f ~> (g ~> h) +@ + + This looks just like an associativity law. In fact, ('~>') has another nice + property, which is that 'yield' is its left and right identity: + +> -- Left Identity +> yield ~> f = f + +> -- Right Identity +> f ~> yield = f + + In other words, 'yield' and ('~>') form a 'Category', specifically the + generator category, where ('~>') plays the role of the composition operator + and 'yield' is the identity. If you don't know what a 'Category' is, that's + okay, and category theory is not a prerequisite for using @pipes@. All you + really need to know is that @pipes@ uses some simple category theory to keep + the API intuitive and easy to use. + + Notice that if we translate the left identity law to use 'for' instead of + ('~>') we get: + +> for (yield x) f = f x + + This just says that if you iterate over a pure single-element 'Producer', + then you could instead cut out the middle man and directly apply the body of + the loop to that single element. + + If we translate the right identity law to use 'for' instead of ('~>') we + get: + +> for s yield = s + + This just says that if the only thing you do is re-'yield' every element of + a stream, you get back your original stream. + + These three \"for loop\" laws summarize our intuition for how 'for' loops + should behave and because these are 'Category' laws in disguise that means + that 'Producer's are composable in a rigorous sense of the word. + + In fact, we get more out of this than just a bunch of equations. We also + get a useful operator: ('~>'). We can use this operator to condense + our original code into the following more succinct form that composes two + transformations: + +> main = runEffect $ for P.stdinLn (duplicate ~> lift . putStrLn) + + This means that we can also choose to program in a more functional style and + think of stream processing in terms of composing transformations using + ('~>') instead of nesting a bunch of 'for' loops. + + The above example is a microcosm of the design philosophy behind the @pipes@ + library: + + * Define the API in terms of categories + + * Specify expected behavior in terms of category laws + + * Think compositionally instead of sequentially +-} + +{- $consumers + Sometimes you don't want to use a 'for' loop because you don't want to consume + every element of a 'Producer' or because you don't want to process every + value of a 'Producer' the exact same way. + + The most general solution is to externally iterate over the 'Producer' using + the 'next' command: + +@ + 'next' :: 'Monad' m => 'Producer' a m r -> m ('Either' r (a, 'Producer' a m r)) +@ + + Think of 'next' as pattern matching on the head of the 'Producer'. This + 'Either' returns a 'Left' if the 'Producer' is done or it returns a 'Right' + containing the next value, @a@, along with the remainder of the 'Producer'. + + However, sometimes we can get away with something a little more simple and + elegant, like a 'Consumer', which represents an effectful sink of values. A + 'Consumer' is a monad transformer that extends the base monad with a new + 'await' command. This 'await' command lets you receive input from an + anonymous upstream source. + + The following @stdoutLn@ 'Consumer' shows how to incrementally 'await' + 'String's and print them to standard output, terminating gracefully when + receiving a broken pipe error: + +> import Control.Monad (unless) +> import Control.Exception (try, throwIO) +> import qualified GHC.IO.Exception as G +> import Pipes +> +> -- +--------+-- A 'Consumer' that awaits 'String's +> -- | | +> -- v v +> stdoutLn :: Consumer String IO () +> stdoutLn = do +> str <- await -- 'await' a 'String' +> x <- lift $ try $ putStrLn str +> case x of +> -- Gracefully terminate if we got a broken pipe error +> Left e@(G.IOError { G.ioe_type = t}) -> +> lift $ unless (t == G.ResourceVanished) $ throwIO e +> -- Otherwise loop +> Right () -> stdoutLn + + 'await' is the dual of 'yield': we suspend our 'Consumer' until we receive a + new value. If nobody provides a value (which is possible) then 'await' + never returns. You can think of 'await' as having the following type: + +@ + 'await' :: 'Monad' m => 'Consumer' a m a +@ + + One way to feed a 'Consumer' is to repeatedly feed the same input using + using ('>~') (pronounced \"feed\"): + +@ + \-\- +- Feed +- Consumer to +- Returns new + \-\- | action | feed | Effect + \-\- v v v + \-\- ---------- -------------- ---------- + ('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +@ + + @(draw >~ consumer)@ loops over @(consumer)@, substituting each 'await' in + @(consumer)@ with @(draw)@. + + So the following code replaces every 'await' in 'P.stdoutLn' with + @(lift getLine)@ and then removes all the 'lift's: + +>>> runEffect $ lift getLine >~ stdoutLn +Test +Test +ABC +ABC +42 +42 +... + + You might wonder why ('>~') uses an 'Effect' instead of a raw action in the + base monad. The reason why is that ('>~') actually permits the following + more general type: + +@ + ('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +@ + + ('>~') is the dual of ('~>'), composing 'Consumer's instead of 'Producer's. + + This means that you can feed a 'Consumer' with yet another 'Consumer' so + that you can 'await' while you 'await'. For example, we could define the + following intermediate 'Consumer' that requests two 'String's and returns + them concatenated: + +> doubleUp :: (Monad m) => Consumer String m String +> doubleUp = do +> str1 <- await +> str2 <- await +> return (str1 ++ str2) +> +> -- more concise: doubleUp = (++) <$> await <*> await + + We can now insert this in between @(lift getLine)@ and @stdoutLn@ and see + what happens: + +>>> runEffect $ lift getLine >~ doubleUp >~ stdoutLn +Test +ing +Testing +ABC +DEF +ABCDEF +42 +000 +42000 +... + + 'doubleUp' splits every request from 'stdoutLn' into two separate requests + and + returns back the concatenated result. + + We didn't need to parenthesize the above chain of ('>~') operators, because + ('>~') is associative: + +> -- Associativity +> (f >~ g) >~ h = f >~ (g >~ h) + + ... so we can always omit the parentheses since the meaning is unambiguous: + +> f >~ g >~ h + + Also, ('>~') has an identity, which is 'await'! + +> -- Left identity +> await >~ f = f +> +> -- Right Identity +> f >~ await = f + + In other words, ('>~') and 'await' form a 'Category', too, specifically the + iteratee category, and 'Consumer's are also composable. +-} + +{- $pipes + Our previous programs were unsatisfactory because they were biased either + towards the 'Producer' end or the 'Consumer' end. As a result, we had to + choose between gracefully handling end of input (using 'P.stdinLn') or + gracefully handling end of output (using 'P.stdoutLn'), but not both at the + same time. + + However, we don't need to restrict ourselves to using 'Producer's + exclusively or 'Consumer's exclusively. We can connect 'Producer's and + 'Consumer's directly together using ('>->') (pronounced \"pipe\"): + +@ + ('>->') :: 'Monad' m => 'Producer' a m r -> 'Consumer' a m r -> 'Effect' m r +@ + + This returns an 'Effect' which we can run: + +> -- echo2.hs +> +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude also provides 'stdoutLn' +> +> main = runEffect $ P.stdinLn >-> P.stdoutLn + + This program is more declarative of our intent: we want to stream values + from 'P.stdinLn' to 'P.stdoutLn'. The above \"pipeline\" not only echoes + standard input to standard output, but also handles both end of input and + broken pipe errors: + +> $ ./echo2 +> Test +> Test +> ABC +> ABC +> 42 +> 42 +> +> $ + + ('>->') is \"pull-based\" meaning that control flow begins at the most + downstream component (i.e. 'P.stdoutLn' in the above example). Any time a + component 'await's a value it blocks and transfers control upstream and + every time a component 'yield's a value it blocks and restores control back + downstream, satisfying the 'await'. So in the above example, ('>->') + matches every 'await' from 'P.stdoutLn' with a 'yield' from 'P.stdinLn'. + + Streaming stops when either 'P.stdinLn' terminates (i.e. end of input) or + 'P.stdoutLn' terminates (i.e. broken pipe). This is why ('>->') requires + that both the 'Producer' and 'Consumer' share the same type of return value: + whichever one terminates first provides the return value for the entire + 'Effect'. + + Let's test this by modifying our 'Producer' and 'Consumer' to each return a + diagnostic 'String': + +> -- echo3.hs +> +> import Control.Applicative ((<$)) -- (<$) modifies return values +> import Pipes +> import qualified Pipes.Prelude as P +> import System.IO +> +> main = do +> hSetBuffering stdout NoBuffering +> str <- runEffect $ +> ("End of input!" <$ P.stdinLn) >-> ("Broken pipe!" <$ P.stdoutLn) +> hPutStrLn stderr str + + This lets us diagnose whether the 'Producer' or 'Consumer' terminated first: + +> $ ./echo3 +> Test +> Test +> +> End of input! +> $ ./echo3 | perl -e 'close STDIN' +> Test +> Broken pipe! +> $ + + You might wonder why ('>->') returns an 'Effect' that we have to run instead + of directly returning an action in the base monad. This is because you can + connect things other than 'Producer's and 'Consumer's, like 'Pipe's, which + are effectful stream transformations. + + A 'Pipe' is a monad transformer that is a mix between a 'Producer' and + 'Consumer', because a 'Pipe' can both 'await' and 'yield'. The following + example 'Pipe' is analagous to the Prelude's 'take', only allowing a fixed + number of values to flow through: + +> -- take.hs +> +> import Control.Monad (replicateM_) +> import Pipes +> import Prelude hiding (take) +> +> -- +--------- A 'Pipe' that +> -- | +---- 'await's 'a's and +> -- | | +-- 'yield's 'a's +> -- | | | +> -- v v v +> take :: Int -> Pipe a a IO () +> take n = do +> replicateM_ n $ do -- Repeat this block 'n' times +> x <- await -- 'await' a value of type 'a' +> yield x -- 'yield' a value of type 'a' +> lift $ putStrLn "You shall not pass!" -- Fly, you fools! + + You can use 'Pipe's to transform 'Producer's, 'Consumer's, or even other + 'Pipe's using the same ('>->') operator: + +@ + ('>->') :: 'Monad' m => 'Producer' a m r -> 'Pipe' a b m r -> 'Producer' b m r + ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r + ('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +@ + + For example, you can compose 'P.take' after 'P.stdinLn' to limit the number + of lines drawn from standard input: + +> maxInput :: Int -> Producer String IO () +> maxInput n = P.stdinLn >-> take n + +>>> runEffect $ maxInput 3 >-> P.stdoutLn +Test +Test +ABC +ABC +42 +42 +You shall not pass! +>>> + + ... or you can pre-compose 'P.take' before 'P.stdoutLn' to limit the number + of lines written to standard output: + +> maxOutput :: Int -> Consumer String IO () +> maxOutput n = take n >-> P.stdoutLn + +>>> runEffect $ P.stdinLn >-> maxOutput 3 + + + Those both gave the same behavior because ('>->') is associative: + +> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) + + Therefore we can just leave out the parentheses: + +>>> runEffect $ P.stdinLn >-> take 3 >-> P.stdoutLn + + + ('>->') is designed to behave like the Unix pipe operator, except with less + quirks. In fact, we can continue the analogy to Unix by defining 'cat' + (named after the Unix @cat@ utility), which reforwards elements endlessly: + +> cat :: (Monad m) => Pipe a a m r +> cat = forever $ do +> x <- await +> yield x + + 'cat' is the identity of ('>->'), meaning that 'cat' satisfies the + following two laws: + +> -- Useless use of 'cat' +> cat >-> p = p +> +> -- Forwarding output to 'cat' does nothing +> p >-> cat = p + + Therefore, ('>->') and 'cat' form a 'Category', specifically the category of + Unix pipes, and 'Pipe's are also composable. + + A lot of Unix tools have very simple definitions when written using @pipes@: + +> -- unix.hs +> +> import Control.Monad (forever) +> import Pipes +> import qualified Pipes.Prelude as P -- Pipes.Prelude provides 'take', too +> import Prelude hiding (head) +> +> head :: (Monad m) => Int -> Pipe a a m () +> head = P.take +> +> yes :: (Monad m) => Producer String m r +> yes = forever $ yield "y" +> +> main = runEffect $ yes >-> head 3 >-> P.stdoutLn + + This prints out 3 \'@y@\'s, just like the equivalent Unix pipeline: + +> $ ./unix +> y +> y +> y +> $ yes | head -3 +> y +> y +> y +> $ + + This lets us write \"Haskell pipes\" instead of Unix pipes. These are much + easier to build than Unix pipes and we can connect them directly within + Haskell for interoperability with the Haskell language and ecosystem. +-} + +{- $listT + @pipes@ also provides a \"ListT done right\" implementation. This differs + from the implementation in @transformers@ because this 'ListT': + + * obeys the monad laws, and + + * streams data immediately instead of collecting all results into memory. + + The latter property is actually an elegant consequence of obeying the monad + laws. + + To bind a list within a 'ListT' computation, combine 'Select' and 'each': + +> import Pipes +> +> pair :: ListT IO (Int, Int) +> pair = do +> x <- Select $ each [1, 2] +> lift $ putStrLn $ "x = " ++ show x +> y <- Select $ each [3, 4] +> lift $ putStrLn $ "y = " ++ show y +> return (x, y) + + You can then loop over a 'ListT' by using 'every': + +@ + 'every' :: 'Monad' m => 'ListT' m a -> 'Producer' a m () +@ + + So you can use your 'ListT' within a 'for' loop: + +>>> runEffect $ for (every pair) (lift . print) +x = 1 +y = 3 +(1,3) +y = 4 +(1,4) +x = 2 +y = 3 +(2,3) +y = 4 +(2,4) + + ... or a pipeline: + +>>> import qualified Pipes.Prelude as P +>>> runEffect $ every pair >-> P.print + + + Note that 'ListT' is lazy and only produces as many elements as we request: + +>>> runEffect $ for (every pair >-> P.take 2) (lift . print) +x = 1 +y = 3 +(1,3) +y = 4 +(1,4) + + You can also go the other way, binding 'Producer's directly within a + 'ListT'. In fact, this is actually what 'Select' was already doing: + +@ + 'Select' :: 'Producer' a m () -> 'ListT' m a +@ + + This lets you write crazy code like: + +> import Pipes +> import qualified Pipes.Prelude as P +> +> input :: Producer String IO () +> input = P.stdinLn >-> P.takeWhile (/= "quit") +> +> name :: ListT IO String +> name = do +> firstName <- Select input +> lastName <- Select input +> return (firstName ++ " " ++ lastName) + + Here we're binding standard input non-deterministically (twice) as if it + were an effectful list: + +>>> runEffect $ every name >-> P.stdoutLn +Daniel +Fischer +Daniel Fischer +Wagner +Daniel Wagner +quit +Donald +Stewart +Donald Stewart +Duck +Donald Duck +quit +quit +>>> + + Notice how this streams out values immediately as they are generated, rather + than building up a large intermediate result and then printing all the + values in one batch at the end. +-} + +{- $tricks + @pipes@ is more powerful than meets the eye so this section presents some + non-obvious tricks you may find useful. + + Many pipe combinators will work on unusual pipe types and the next few + examples will use the 'cat' pipe to demonstrate this. + + For example, you can loop over the output of a 'Pipe' using 'for', which is + how 'P.map' is defined: + +> map :: (Monad m) => (a -> b) -> Pipe a b m r +> map f = for cat $ \x -> yield (f x) +> +> -- Read this as: For all values flowing downstream, apply 'f' + + This is equivalent to: + +> map f = forever $ do +> x <- await +> yield (f x) + + You can also feed a 'Pipe' input using ('>~'). This means we could have + instead defined the @yes@ pipe like this: + +> yes :: (Monad m) => Producer String m r +> yes = return "y" >~ cat +> +> -- Read this as: Keep feeding "y" downstream + + This is equivalent to: + +> yes = forever $ yield "y" + + You can also sequence two 'Pipe's together. This is how 'P.drop' is + defined: + +> drop :: (Monad m) => Int -> Pipe a a m r +> drop n = do +> replicateM_ n await +> cat + + This is equivalent to: + +> drop n = do +> replicateM_ n await +> forever $ do +> x <- await +> yield x + + You can even compose pipes inside of another pipe: + +> customerService :: Producer String IO () +> customerService = do +> each [ "Hello, how can I help you?" -- Begin with a script +> , "Hold for one second." +> ] +> P.stdinLn >-> P.takeWhile (/= "Goodbye!") -- Now continue with a human + + Also, you can often use 'each' in conjunction with ('~>') to traverse nested + data structures. For example, you can print all non-'Nothing' elements + from a doubly-nested list: + +>>> runEffect $ (each ~> each ~> each ~> lift . print) [[Just 1, Nothing], [Just 2, Just 3]] +1 +2 +3 + + Another neat thing to know is that 'every' has a more general type: + +@ + 'every' :: ('Enumerable' t) => t m a -> 'Producer' a m () +@ + + 'Enumerable' generalizes 'Foldable' and if you have an effectful container + of your own that you want others to traverse using @pipes@, just have your + container implement the 'toListT' method of the 'Enumerable' class: + +> class Enumerable t where +> toListT :: (Monad m) => t m a -> ListT m a + + You can even use 'Enumerable' to traverse effectful types that are not even + proper containers, like 'Control.Monad.Trans.Maybe.MaybeT': + +> input :: MaybeT IO Int +> input = do +> str <- lift getLine +> guard (str /= "Fail") + +>>> runEffect $ every input >-> P.stdoutLn +Test +Test +>>> runEffect $ every input >-> P.stdoutLn +Fail +>>> + +-} + +{- $conclusion + This tutorial covers the concepts of connecting, building, and reading + @pipes@ code. However, this library is only the core component in an + ecosystem of streaming components. Derived libraries that build immediately + upon @pipes@ include: + + * @pipes-concurrency@: Concurrent reactive programming and message passing + + * @pipes-parse@: Minimal utilities for stream parsing + + * @pipes-safe@: Resource management and exception safety for @pipes@ + + These libraries provide functionality specialized to common streaming + domains. Additionally, there are several libraries on Hackage that provide + even higher-level functionality, which you can find by searching under the + \"Pipes\" category or by looking for packages with a @pipes-@ prefix in + their name. Current examples include: + + * @pipes-network@/@pipes-network-tls@: Networking + + * @pipes-zlib@: Compression and decompression + + * @pipes-binary@: Binary serialization + + * @pipes-attoparsec@: High-performance parsing + + * @pipes-aeson@: JSON serialization and deserialization + + Even these derived packages still do not explore the full potential of + @pipes@ functionality, which actually permits bidirectional communication. + Advanced @pipes@ users can explore this library in greater detail by + studying the documentation in the "Pipes.Core" module to learn about the + symmetry of the underlying 'Proxy' type and operators. + + To learn more about @pipes@, ask questions, or follow @pipes@ development, + you can subscribe to the @haskell-pipes@ mailing list at: + + + + ... or you can mail the list directly at: + + + + Additionally, for questions regarding types or type errors, you might find + the following appendix on types very useful. +-} + +{- $types + @pipes@ uses parametric polymorphism (i.e. generics) to overload all + operations. You've probably noticed this overloading already:: + + * 'yield' works within both 'Producer's and 'Pipe's + + * 'await' works within both 'Consumer's and 'Pipe's + + * ('>->') connects 'Producer's, 'Consumer's, and 'Pipe's in varying ways + + This overloading is great when it works, but when connections fail they + produce type errors that appear intimidating at first. This section + explains the underlying types so that you can work through type errors + intelligently. + + 'Producer's, 'Consumer's, 'Pipe's, and 'Effect's are all special cases of a + single underlying type: a 'Proxy'. This overarching type permits fully + bidirectional communication on both an upstream and downstream interface. + You can think of it as having the following shape: + +> Proxy a' a b' b m r +> +> Upstream | Downstream +> +---------+ +> | | +> a' <== <== b' -- Information flowing upstream +> | | +> a ==> ==> b -- Information flowing downstream +> | | | +> +----|----+ +> v +> r + + The four core types do not use the upstream flow of information. This means + that the @a'@ and @b'@ in the above diagram go unused unless you use the + more advanced features provided in "Pipes.Core". + + @pipes@ uses type synonyms to hide unused inputs or outputs and clean up + type signatures. These type synonyms come in two flavors: + + * Concrete type synonyms that explicitly close unused inputs and outputs of + the 'Proxy' type + + * Polymorphic type synonyms that don't explicitly close unused inputs or + outputs + + The concrete type synonyms use @()@ to close unused inputs and 'Void' (the + uninhabited type) to close unused outputs: + + * 'Effect': explicitly closes both ends, forbidding 'await's and 'yield's + +> type Effect = Proxy Void () () Void +> +> Upstream | Downstream +> +---------+ +> | | +> Void <== <== () +> | | +> () ==> ==> Void +> | | | +> +----|----+ +> v +> r + + * 'Producer': explicitly closes the upstream end, forbidding 'await's + +> type Producer b = Proxy Void () () b +> +> Upstream | Downstream +> +---------+ +> | | +> Void <== <== () +> | | +> () ==> ==> b +> | | | +> +----|----+ +> v +> r + + * 'Consumer': explicitly closes the downstream end, forbidding 'yield's + +> type Consumer a = Proxy () a () Void +> +> Upstream | Downstream +> +---------+ +> | | +> () <== <== () +> | | +> a ==> ==> Void +> | | | +> +----|----+ +> 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 +> +-----------+ +----------+ +------------+ +> | | | | | | +> Void <== <== () <== <== () <== <== () +> | stdinLn | | take 3 | | stdoutLn | +> () ==> ==> String ==> ==> String ==> ==> Void +> | | | | | | | | | +> +-----|-----+ +----|-----+ +------|-----+ +> v v v +> () () () + + Composition fuses away the intermediate interfaces, leaving behind an + 'Effect': + +> Effect +> +-----------------------------------+ +> | | +> Void <== <== () +> | stdinLn >-> take 3 >-> stdoutLn | +> () ==> ==> Void +> | | +> +----------------|------------------+ +> 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' a 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 induce higher-rank types and require you to enable the @RankNTypes@ + extension to use them in your own type signatures. + + * They give the wrong behavior when used in the negative position of a + function like this: + +> f :: Producer' a m r -> ... -- Wrong +> +> f :: Producer a m r -> ... -- Right + + * You can't use them within other types without the @ImpredicativeTypes@ + extension: + +> io :: IO (Producer' a m r) -- Type error + + * You can't partially apply them: + +> stack :: MaybeT (Producer' a m) r -- Type error + + In these scenarios you should fall back on the concrete type synonyms, which + are better behaved. + + 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 `Void' with actual type `String' + Expected type: Effect m0 r0 + Actual type: Proxy Void () () 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 Void () () Void IO () + + ... but 'P.stdinLn' type-checks as a 'Producer', which has the following + type: + +> Producer String IO () = Proxy Void () () String IO () + + The fourth type variable (the output) does not match. For an 'Effect' this + type variable should be closed (i.e. 'Void'), but 'P.stdinLn' has a 'String' + output, thus the type error: + +> Couldn't match expected type `Void' 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. +-}