diff --git a/Control/Pipe.hs b/Control/Pipe.hs --- a/Control/Pipe.hs +++ b/Control/Pipe.hs @@ -6,7 +6,8 @@ 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 ( +module Control.Pipe + {-# DEPRECATED "Use 'Control.Proxy' instead of 'Control.Pipe'" #-} ( -- * Types -- $types Pipe(..), @@ -32,11 +33,12 @@ ) where import Control.Applicative (Applicative(pure, (<*>))) -import Control.Category (Category((.), id), (<<<), (>>>)) -import Control.Monad (forever) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Synonym (C) +import 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 diff --git a/Control/Proxy.hs b/Control/Proxy.hs --- a/Control/Proxy.hs +++ b/Control/Proxy.hs @@ -1,6 +1,6 @@ {-| Recommended entry import for this library - Read "Control.Proxy.Tutorial" for an extended proxy tutorial. + Read "Control.Proxy.Tutorial" for an extended tutorial. -} module Control.Proxy ( @@ -20,8 +20,8 @@ their own 'runProxy' function: * "Control.Proxy.Core.Fast": This runs faster for code that is not - 'IO'-bound, but it only obeys the monad transformer laws modulo safe - observation functions. + '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. diff --git a/Control/Proxy/Class.hs b/Control/Proxy/Class.hs --- a/Control/Proxy/Class.hs +++ b/Control/Proxy/Class.hs @@ -1,123 +1,215 @@ -{-| The 'Proxy' class defines the library's core API. Everything else in this - library builds on top of the 'Proxy' type class so that all proxy - implementations and extensions can share the same standard library. --} +-- | This module defines the theoretical framework underpinning this library -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, KindSignatures #-} module Control.Proxy.Class ( - -- * Core proxy class + -- * The Proxy Class Proxy(..), + + -- * Composition operators (>->), - idT, (>~>), - coidT, + (\>\), + (/>/), -- ** 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)) -{- * I make educated guesses about which associativy is most efficient for each - operator. - * Keep proxy composition lower in precedence than function composition, which +{- * 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 7 <-<, ->> -infixl 7 >->, <<- -infixr 7 >~>, ~<< -infixl 7 <~<, >>~ +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 core API for the @pipes@ library -class (ProxyInternal p) => Proxy p where - {-| 'request' input from upstream, passing an argument with the request +{-| The 'Proxy' class defines a 'Monad' that intersects four streaming + categories: - @request a'@ passes @a'@ as a parameter to upstream that upstream may - use to decide what response to return. 'request' binds the upstream's - response of type @a@ to its own return value. + * 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 - {-| 'respond' with an output for downstream and bind downstream's next - 'request' - - @respond b@ satisfies a downstream 'request' by supplying the value @b@. - 'respond' blocks until downstream 'request's a new value and binds the - argument of type @b'@ from the next 'request' as its return value. + -- | @(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' - {-| Connect an upstream 'Proxy' that handles all 'request's + -- | @(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' - Point-ful version of ('>->') - -} + -- | @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 - {-| Connect a downstream 'Proxy' that handles all 'respond's + -- | @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` -} - Point-ful version of ('>~>') - -} + -- | @(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 -{-| Pull-based composition + -- | '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'. Begins from the downstream end and satisfies every - 'request' with a 'respond'. + 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) -k1 >-> k2 = \c' -> k1 ->> k2 c' +f >-> g = \c' -> f ->> g c' {-# INLINABLE (>->) #-} -{-| Pull-based identity - - 'idT' forwards requests followed by responses - -> idT = request >=> respond >=> idT --} -idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r -idT = go where - go a' = - request a' ?>= \a -> - respond a ?>= \a'2 -> - go a'2 --- idT = foreverK $ request >=> respond -{-# INLINABLE idT #-} +{-| \"push\" composition -{-| Push-based composition +> (f >~> g) x = f x >>~ g Compose two proxies blocked on a 'request', generating a new proxy blocked - on a 'request'. Begins from the upstream end and satisfies every 'respond' - with a 'request' + on a 'request' -} (>~>) :: (Monad m, Proxy p) @@ -127,21 +219,34 @@ k1 >~> k2 = \a -> k1 a >>~ k2 {-# INLINABLE (>~>) #-} -{-| Push-based identity +{-| \"request\" composition - 'coidT' forwards responses followed by requests +> (f \>\ g) x = f >\\ g x -> coidT = respond >=> request >=> coidT + Compose two folds, generating a new fold -} -coidT :: (Monad m, Proxy p) => a -> p a' a a' a m r -coidT = go where - go a = - respond a ?>= \a' -> - request a' ?>= \a2 -> - go a2 --- coidT = foreverK $ respond >=> request -{-# INLINABLE coidT #-} +(\>\) + :: (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) @@ -160,6 +265,24 @@ 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) @@ -178,82 +301,292 @@ 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 - The 'Proxy' class defines an interface to all core proxy capabilities that - all proxy-like types must implement. + First, all proxies sit at the intersection of five categories: - First, all proxies must support a bidirectional flow of information, defined - by: + * The Kleisli category (all proxies are monads) - * ('>->') +> return >=> f = f +> +> f >=> return = f +> +> (f >=> g) >=> h = f >=> (g >=> h) - * ('>~>') + * The \"request\" category - * 'request' +> request \>\ f = f +> +> f \>\ request = f +> +> (f \>\ g) \>\ h = f \>\ (g \>\ h) - * 'respond' + * The \"respond\" category - Intuitively, both @p1 >-> p2@ and @p1 >~> p2@ pair each 'request' in @p2@ - with a 'respond' in @p1@. ('>->') accepts proxies blocked on 'respond' and - begins from the downstream end, whereas ('>~>') accepts proxies blocked on - 'request' and begins from the upstream end. +> respond />/ f = f +> +> f />/ respond = f +> +> (f />/ g) />/ h = f />/ (g />/ h) - Second, all proxies are monads and must satify the monad laws using - @(>>=) = (?>=)@ and @return = return_P@. + * The \"pull\" category - Third, all proxies are monad transformers and must satisfy the monad - transformer laws, using @lift = lift_P@. +> pull >-> f = f +> +> f >-> pull = f +> +> (f >-> g) >-> h = (f >-> g) >-> h - Fourth, all proxies are functors in the category of monads and must satisfy - the functor laws, using @hoist = hoist_P@. + * The \"push\" category - Fifth, all proxies form two streaming categories: +> push >~> f = f +> +> f >~> push = f +> +> (f >~> g) >~> h = f >~> (g >~> h) - * ('>->') and 'idT' form the \"pull-based\" category: + Second, @(turn .)@ transforms each streaming category into its dual: -> Define: idT = request >=> respond >=> idT -> Define: k1 >-> k2 = \c' -> k1 ->> k2 c' + * The \"request\" category + +> turn . request = respond > -> idT >-> p = p +> turn . (f \>\ g) = turn . f \<\ turn . g + + * The \"respond\" category + +> turn . respond = request > -> p >-> idT = p +> turn . (f />/ g) = turn . f / turn . pull = push > -> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) +> turn . (f >-> g) = turn . f <~< turn . g - * ('>~>') and 'coidT' form the \"push-based\" category: + * The \"push\" category -> Define: coidT = respond >=> request >=> coidT -> Define: k1 >~> k2 = \a -> k1 a >>~ k2 +> turn . push = pull > -> coidT >~> p = p +> 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) > -> p >~> coidT = p +> a \>\ return = return + +> (b >=> c) />/ a = (b />/ a) >=> (c />/ a) > -> (p1 >~> p2) >~> p3 = p1 >~> (p2 >~> p3) +> return />/ a = return - Also, all proxies must satisfy the following 'Proxy' laws: + Sixth, all proxies must satisfy these additional 'Proxy' laws: -> -- Define: liftK = (lift .) +> p \>\ lift . f = lift . f > -> p1 >-> liftK f = liftK f +> p \>\ respond = respond > -> p1 >-> (liftK f >=> respond >=> p2) = liftK f >=> respond >=> (p1 >-> p2) +> lift . f />/ p = lift . f > -> (liftK g >=> respond >=> p1) >-> (liftK f >=> request >=> liftK h >=> p2) -> = liftK (f >=> g >=> h) >=> (p1 >-> p2) +> request />/ p = request > -> (liftK g >=> request >=> p1) >-> (liftK f >=> request >=> p2) -> = liftK (f >=> g) >=> request >=> (p1 >~> p2) +> pull = request >=> respond >=> pull > -> liftK f >~> p2 = liftK f +> push = respond >=> request >=> push > -> (liftK f >=> request >=> p1) >~> p2 = liftK f >=> request >=> (p1 >~> p2) +> p1 >-> lift . f = lift . f > -> (liftK f >=> respond >=> liftK h >=> p1) >~> (liftK g >=> request >=> p2) -> = liftK (f >=> g >=> h) >=> (p1 >~> p2) +> p1 >-> (lift . f >=> respond >=> p2) = lift . f >=> respond >=> (p1 >-> p2) > -> (liftK f >=> respond >=> p1) >~> (liftK g >=> respond >=> p2) -> = liftK (f >=> g) >=> (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 @@ -381,6 +714,10 @@ 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: @@ -390,3 +727,30 @@ 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 --- a/Control/Proxy/Core.hs +++ b/Control/Proxy/Core.hs @@ -4,35 +4,28 @@ -- * Modules -- $modules module Control.Proxy.Class, - module Control.Proxy.Synonym, module Control.Proxy.Prelude, module Control.Proxy.Trans, module Control.Proxy.Trans.Identity, - module Control.Proxy.ListT, module Control.Proxy.Morph, module Control.Monad, module Control.Monad.Trans.Class, module Control.Monad.Morph, ) where -import Control.Monad.Morph (MFunctor(hoist)) 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.ListT import Control.Proxy.Morph -import Control.Proxy.Synonym +import Control.Proxy.Prelude import Control.Proxy.Trans import Control.Proxy.Trans.Identity -import Control.Proxy.Prelude {- $modules "Control.Proxy.Class" defines the 'Proxy' type class that lets you program generically over proxy implementations and their transformers. - "Control.Proxy.Synonym" defines type synonyms for proxies that don't use all - of their inputs or outputs, such as 'Pipe's, 'Producer's, and 'Server's. - "Control.Proxy.Prelude" provides a standard library of proxies. "Control.Proxy.Trans" defines the 'ProxyTrans' type class that lets you @@ -40,9 +33,6 @@ "Control.Proxy.Trans.Identity" exports 'runIdentityP', which substantially eases writing completely polymorphic proxies. - - "Control.Proxy.ListT" defines a generalized @ListT@ monad transformer that - can interconvert with proxies. "Control.Proxy.Morph" exports 'hoistP'. diff --git a/Control/Proxy/Core/Correct.hs b/Control/Proxy/Core/Correct.hs --- a/Control/Proxy/Core/Correct.hs +++ b/Control/Proxy/Core/Correct.hs @@ -9,13 +9,12 @@ module Control.Proxy.Core.Correct ( -- * Types ProxyCorrect(..), - ProxyF(..), + ProxyStep(..), -- * Run Sessions -- $run runProxy, - runProxyK, - runPipe + runProxyK ) where import Control.Applicative (Applicative(pure, (<*>))) @@ -23,39 +22,37 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P) ) -import Control.Proxy.ListT (ListT((//>), (>\\))) + 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 of @ProxyCorrect req_a' resp_a req_b' resp_b m r@ - signify: + The type variables signify: - * @req_a'@ - The request supplied to the upstream interface + * @a'@ - The request supplied to the upstream interface - * @resp_a@ - The response provided by the upstream interface + * @a @ - The response provided by the upstream interface - * @req_b'@ - The request supplied by the downstream interface + * @b'@ - The request supplied by the downstream interface - * @resp_b@ - The response provided to the downstream interface + * @b @ - The response provided to the downstream interface - * @m @ - The base monad + * @m @ - The base monad - * @r @ - The final return value + * @r @ - The final return value -} data ProxyCorrect a' a b' b m r = - Proxy { unProxy :: m (ProxyF a' a b' b r (ProxyCorrect a' a b' b m r)) } + Proxy { unProxy :: m (ProxyStep a' a b' b m r) } --- | The base functor for the 'ProxyCorrect' type -data ProxyF a' a b' b r x - = Request a' (a -> x) - | Respond b (b' -> x) +-- | 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 p0 = go p0 where + fmap f = go where go p = Proxy (do x <- unProxy p return (case x of @@ -108,6 +105,16 @@ 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 @@ -127,22 +134,32 @@ respond = \b -> Proxy (return (Respond b (\b' -> Proxy (return (Pure b'))))) -instance ListT ProxyCorrect where - fb' >\\ p0 = go p0 where + fb' >\\ p0 = go p0 + where go p = Proxy (do - x <- unProxy p - case x of + 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 + p0 //> fb = go p0 + where go p = Proxy (do - x <- unProxy p - case x of + 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. @@ -155,27 +172,25 @@ '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 = go (k ()) where - go p = do - x <- unProxy p - case x of - Request _ fa -> go (fa ()) - Respond _ fb' -> go (fb' ()) - Pure r -> return 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) => (() -> ProxyCorrect a' () () b m r) -> (() -> m r) -runProxyK p = \() -> runProxy p +runProxyK :: (Monad m) => (q -> ProxyCorrect a' () () b m r) -> (q -> m r) +runProxyK k q = run (k q) {-# INLINABLE runProxyK #-} - --- | Run the 'Pipe' monad transformer, converting it back to the base monad -runPipe :: (Monad m) => ProxyCorrect a' () () b m r -> m r -runPipe p = runProxy (\_ -> p) -{-# INLINABLE runPipe #-} diff --git a/Control/Proxy/Core/Fast.hs b/Control/Proxy/Core/Fast.hs --- a/Control/Proxy/Core/Fast.hs +++ b/Control/Proxy/Core/Fast.hs @@ -12,8 +12,8 @@ > > lift . return /= return - These laws only hold when viewed through certain safe observation functions, - like 'runProxy' and 'observe'. + 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. @@ -37,7 +37,6 @@ -- $run runProxy, runProxyK, - runPipe, -- * Safety observe @@ -48,26 +47,25 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P)) -import Control.Proxy.ListT (ListT((//>), (>\\))) + 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 of @ProxyFast req_a' resp_a req_b' resp_b m r@ signify: + The type variables signify: - * @req_a'@ - The request supplied to the upstream interface + * @a'@ - The request supplied to the upstream interface - * @resp_a@ - The response provided by the upstream interface + * @a @ - The response provided by the upstream interface - * @req_b'@ - The request supplied by the downstream interface + * @b'@ - The request supplied by the downstream interface - * @resp_b@ - The response provided to the downstream interface + * @b @ - The response provided to the downstream interface - * @m @ - The base monad + * @m @ - The base monad - * @r @ - The final return value + * @r @ - The final return value -} data ProxyFast a' a b' b m r = Request a' (a -> ProxyFast a' a b' b m r ) @@ -121,8 +119,11 @@ -- | Only satisfies monad transformer laws modulo 'observe' instance MonadTrans (ProxyFast a' a b' b) where - lift m = M (m >>= \r -> return (Pure r)) + 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 @@ -138,12 +139,18 @@ return_P = Pure (?>=) = _bind - lift_P = lift + 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 @@ -159,10 +166,17 @@ request = \a' -> Request a' Pure respond = \b -> Respond b Pure -instance ListT ProxyFast where (>\\) = _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) @@ -221,30 +235,28 @@ '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 = go (k ()) where - go p = case p of - Request _ fa -> go (fa ()) - Respond _ fb' -> go (fb' ()) - M m -> m >>= go - Pure r -> return 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) => (() -> ProxyFast a' () () b m r) -> (() -> m r) -runProxyK p = \() -> runProxy p +runProxyK :: (Monad m) => (q -> ProxyFast a' () () b m r) -> (q -> m r) +runProxyK k q = run (k q) {-# INLINABLE runProxyK #-} --- | Run the 'Pipe' monad transformer, converting it back to the base monad -runPipe :: (Monad m) => ProxyFast a' () () b m r -> m r -runPipe p = runProxy (\_ -> p) -{-# INLINABLE runPipe #-} - {-| The monad transformer laws are correct when viewed through the 'observe' function: @@ -261,7 +273,7 @@ can violate the monad transformer laws. -} observe :: (Monad m) => ProxyFast a' a b' b m r -> ProxyFast a' a b' b m r -observe p = M (go p) where +observe p0 = M (go p0) where go p = case p of M m' -> m' >>= go Pure r -> return (Pure r) diff --git a/Control/Proxy/ListT.hs b/Control/Proxy/ListT.hs deleted file mode 100644 --- a/Control/Proxy/ListT.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-| This module implements \"ListT done right\" in terms of proxies. - - The 'RespondT' monad transformer is the 'ListT' monad transformer over the - downstream output type. Each 'respond' corresponds to an element of the - list. The monad bind operation non-deterministically selects one of the - previous 'respond's as input. The 'RespondT' Kleisli category corresponds - to the \"respond\" category of the 'ListT' class. - - Symmetrically, the 'RequestT' monad transformer is the 'ListT' monad - transformer over the upstream output type. Each 'request' corresponds to an - element of the list. The monad bind operation non-deterministically selects - one of the previous 'request's as input. The 'RequestT' Kleisli category - corresponds to the \"request\" category of the 'ListT' class. - - Unlike 'ListT' from @transformers@, these monad transformers are correct by - construction and always satisfy the monad and monad transformer laws. --} - -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.ListT ( - -- * Respond Monad Transformer - RespondT(..), - runRespondK, - ProduceT, - - -- * Request Monad Transformer - RequestT(..), - runRequestK, - CoProduceT, - - -- * ListT - ListT(..), - (\>\), - (/>/), - - -- ** 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 Control.Proxy.Class (Proxy(request, respond), return_P, (?>=), lift_P) -import Control.Proxy.Synonym (C) -import Data.Monoid (Monoid(mempty, mappend)) - --- For documentation -import Control.Monad ((>=>), (<=<)) - --- | 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, ListT p) => Functor (RespondT p a' a b' m) where - fmap f p = RespondT (runRespondT p //> \a -> respond (f a)) - -instance (Monad m, ListT 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, ListT p) => Monad (RespondT p a' a b' m) where - return a = RespondT (respond a) - m >>= f = RespondT (runRespondT m //> \a -> runRespondT (f a)) - -instance (ListT p) => MonadTrans (RespondT p a' a b') where - lift m = RespondT (lift_P m ?>= \a -> respond a) - -instance (MonadIO m, ListT p) => MonadIO (RespondT p a' a b' m) where - liftIO m = lift (liftIO m) - -instance (Monad m, ListT 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, ListT p, Monoid b') => MonadPlus (RespondT p a' a b' m) where - mzero = empty - mplus = (<|>) - --- | Convert a 'RespondT' \'@K@\'leisli arrow into a proxy -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 #-} - --- | 'ProduceT' is isomorphic to \"ListT done right\" -type ProduceT p = RespondT p C () () - --- | 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, ListT p) => Functor (RequestT p a b' b m) where - fmap f p = RequestT (runRequestT p //< \a -> request (f a)) - -instance (Monad m, ListT 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, ListT p) => Monad (RequestT p a b' b m) where - return a = RequestT (request a) - m >>= f = RequestT (runRequestT m //< \a -> runRequestT (f a)) - -instance (ListT p) => MonadTrans (RequestT p a' a b') where - lift m = RequestT (lift_P m ?>= \a -> request a) - -instance (MonadIO m, ListT p) => MonadIO (RequestT p a b' b m) where - liftIO m = lift (liftIO m) - -instance (Monad m, ListT 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, ListT p, Monoid a) => MonadPlus (RequestT p a b' b m) where - mzero = empty - mplus = (<|>) - --- | Convert a 'RequestT' \'@K@\'leisli arrow into a proxy -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 #-} - --- | 'CoProduceT' is isomorphic to \"ListT done right\" -type CoProduceT p = RequestT p () () C - -{- * I make educated guesses about which associativy is most efficient for each - operator. - * Keep 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 --} -infixr 8 /\\ -infixl 8 \>\, //< -infixl 8 \<\, //> -infixr 8 />/, <\\ - --- | The two generalized \"ListT\" categories -class (Proxy p) => ListT p where - {-| @f >\\\\ p@ replaces all 'request's in @p@ with @f@. - - Equivalent to to ('=<<') for 'RequestT' - - Point-ful version of ('\>\') - -} - (>\\) - :: (Monad m) - => (b' -> p a' a x' x m b) - -> p b' b x' x m c - -> p a' a x' x m c - - {-| @p \/\/> f@ replaces all 'respond's in @p@ with @f@. - - Equivalent to ('>>=') for 'RespondT' - - Point-ful version of ('/>/') - -} - (//>) - :: (Monad m) - => p x' x b' b m a' - -> (b -> p x' x c' c m b') - -> p x' x c' c m a' - -{-| @f \\>\\ g@ replaces all 'request's in 'g' with 'f'. - - Equivalent to ('<=<') for 'RequestT' - - Point-free version of ('>\\') --} -(\>\) - :: (Monad m, ListT 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 (\>\) #-} - -{-| @f \/>\/ g@ replaces all 'respond's in 'f' with 'g'. - - Equivalent to ('>=>') for 'RespondT' - - Point-free version of ('//>') --} -(/>/) - :: (Monad m, ListT 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 -(/ (_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, ListT 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, ListT 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, ListT 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 (<\\) #-} - -{- $laws - The 'ListT' class defines the ability to: - - * Replace existing 'request' commands using ('\>\') - - * Replace existing 'respond' commands using ('/>/') - - Laws: - - * ('/>/') and 'respond' form a ListT Kleisli category: - -> return = respond -> -> (>=>) = (//>) - - * ('\>\') and 'request' also form a ListT Kleisli category: - -> return = request -> -> (>>=) = (//<) - - Additionally, ('\>\') and ('/>/') both define functors between Proxy Kleisli - categories: - -> a \>\ (b >=> c) = (a \>\ b) >=> (a \>\ c) -> -> a \>\ return = return - -> (b >=> c) />/ a = (b />/ a) >=> (c />/ a) -> -> return />/ a = return --} diff --git a/Control/Proxy/Morph.hs b/Control/Proxy/Morph.hs --- a/Control/Proxy/Morph.hs +++ b/Control/Proxy/Morph.hs @@ -6,29 +6,29 @@ * Functor between Kleisli categories: -> morph p1 >=> morph p2 = morph (p1 >=> p2) +> morph . p1 >=> morph . p2 = morph . (p1 >=> p2) > -> morph return = return +> morph . return = return * Functor between 'P.Proxy' composition categories: -> morph p1 >-> morph p2 = morph (p1 >-> p2) +> morph . p1 >-> morph . p2 = morph . (p1 >-> p2) > -> morph idT = idT +> morph . pull = pull -> morph p1 >~> morph p2 = morph (p1 >~> p2) +> morph . p1 >~> morph . p2 = morph . (p1 >~> p2) > -> morph coidT = coidT +> morph . push = push * Functor between 'ListT' Kleisli categories: -> morph p1 \>\ morph p2 = morph (p2 \>\ p2) +> morph . p1 \>\ morph . p2 = morph . (p2 \>\ p2) > -> morph request = request +> morph . request = request -> morph p1 />/ morph p2 = morph (p2 />/ p2) +> morph . p1 />/ morph . p2 = morph . (p2 />/ p2) > -> morph respond = respond +> morph . respond = respond Examples of proxy morphisms include: @@ -67,6 +67,8 @@ ) 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 @@ -83,9 +85,11 @@ @(t p1)@ to @(t p2)@ -} hoistP - :: (Monad m, Proxy p1) - => (forall r1 . p1 a' a b' b m r1 -> p2 a' a b' b n r1) -- ^ Proxy morphism - -> ( t p1 a' a b' b m r2 -> t p2 a' a b' b n r2) + :: (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 ('=<<'): @@ -102,11 +106,13 @@ 'embedP' is analogous to ('=<<') -} embedP - :: (Monad n, Proxy p2) - => (forall r1 . p1 a' a b' b m r1 -> t p2 a' a b' b n r1) - -> ( t p1 a' a b' b m r2 -> t p2 a' a b' b n r2) + :: (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 to 'PMonad' layers into a single layer +{-| Squash two 'PMonad' layers into a single layer 'squashP' is analogous to 'join' -} diff --git a/Control/Proxy/Pipe.hs b/Control/Proxy/Pipe.hs --- a/Control/Proxy/Pipe.hs +++ b/Control/Proxy/Pipe.hs @@ -7,7 +7,8 @@ -} {-# LANGUAGE KindSignatures #-} -module Control.Proxy.Pipe ( +module Control.Proxy.Pipe + {-# DEPRECATED "Use official 'Proxy' operations instead" #-} ( -- * Create Pipes await, yield, @@ -29,9 +30,11 @@ ) where import Control.Monad (forever) -import Control.Proxy.Class (Proxy, respond, request, (->>)) -import Control.Proxy.Synonym (Pipe, Consumer, Producer, C) +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 diff --git a/Control/Proxy/Prelude.hs b/Control/Proxy/Prelude.hs --- a/Control/Proxy/Prelude.hs +++ b/Control/Proxy/Prelude.hs @@ -1,22 +1,1076 @@ --- | Entry point for the Control.Proxy.Prelude hierarchy - -module Control.Proxy.Prelude ( - -- * Modules - -- $modules - module Control.Proxy.Prelude.Base, - module Control.Proxy.Prelude.IO, - module Control.Proxy.Prelude.Kleisli - ) where - -import Control.Proxy.Prelude.Base -import Control.Proxy.Prelude.IO -import Control.Proxy.Prelude.Kleisli - -{- $modules - "Control.Proxy.Prelude.Base" provides pure utility proxies. - - "Control.Proxy.Prelude.IO" provides proxies for simple 'IO'. - - "Control.Proxy.Prelude.Kleisli" provides convenience functions for working - with Kleisli arrows. --} +-- | 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/Prelude/Base.hs b/Control/Proxy/Prelude/Base.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/Base.hs +++ /dev/null @@ -1,1013 +0,0 @@ --- | General purpose proxies - -module Control.Proxy.Prelude.Base ( - -- * Maps - mapD, - mapU, - mapB, - mapMD, - mapMU, - mapMB, - useD, - useU, - useB, - execD, - execU, - execB, - - -- * Filters - takeB, - takeB_, - takeWhileD, - takeWhileU, - dropD, - dropU, - dropWhileD, - dropWhileU, - filterD, - filterU, - - -- * Lists - fromListS, - fromListC, - - -- * Enumerations - enumFromS, - enumFromC, - enumFromToS, - enumFromToC, - - -- * ListT - eachS, - eachC, - rangeS, - rangeC, - - -- * Folds - foldD, - foldU, - allD, - allU, - allD_, - allU_, - anyD, - anyU, - anyD_, - anyU_, - sumD, - sumU, - productD, - productU, - lengthD, - lengthU, - headD, - headD_, - headU, - headU_, - lastD, - lastU, - toListD, - toListU, - foldrD, - foldrU, - foldlD', - foldlU', - - -- * ArrowChoice - -- $choice - leftD, - rightD, - leftU, - rightU, - - -- * Zips and Merges - zipD, - mergeD, - - -- * Closed Adapters - -- $open - unitD, - unitU, - - -- * Modules - -- $modules - module Control.Monad.Trans.State.Strict, - module Control.Monad.Trans.Writer.Lazy, - module Data.Monoid - ) where - -import Control.Monad.Morph (hoist) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Writer.Lazy ( - WriterT(runWriterT), execWriterT, runWriter, execWriter ) -import qualified Control.Monad.Trans.Writer.Lazy as W (tell) -import Control.Monad.Trans.State.Strict ( - StateT(StateT, runStateT), - execStateT, - evalStateT, - runState, - execState, - evalState ) -import Control.Proxy.Class -import Control.Proxy.ListT ( - ListT, - (\>\), - (/>/), - RespondT(RespondT), - RequestT(RequestT), - ProduceT, - CoProduceT ) -import Control.Proxy.Prelude.Kleisli (replicateK, foreverK) -import Control.Proxy.Synonym (Producer, Consumer, Pipe, CoProducer, CoPipe) -import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK, identityK) -import Data.Monoid ( - Monoid, - Endo(Endo, appEndo), - All(All, getAll), - Any(Any, getAny), - Sum(Sum, getSum), - Product(Product, getProduct), - First(First, getFirst), - Last(Last, getLast) ) - -{-| @(mapD f)@ applies @f@ to all values going \'@D@\'ownstream. - -> mapD f1 >-> mapD f2 = mapD (f2 . f1) -> -> mapD id = idT --} -mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r -mapD f = runIdentityK go where - go x = do - a <- request x - x2 <- respond (f a) - go x2 --- mapD f = 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 = idT --} -mapU :: (Monad m, Proxy p) => (b' -> a') -> b' -> p a' x b' x m r -mapU g = runIdentityK go where - go b' = do - x <- request (g b') - b'2 <- respond x - go b'2 --- mapU g = foreverK $ (request . g) >=> respond -{-# INLINABLE mapU #-} - -{-| @(mapB f g)@ applies @f@ to all values going downstream and @g@ to all - values going upstream. - - Mnemonic: map \'@B@\'idirectional - -> mapB f1 g1 >-> mapB f2 g2 = mapB (f2 . f1) (g1 . g2) -> -> mapB id id = idT --} -mapB :: (Monad m, Proxy p) => (a -> b) -> (b' -> a') -> b' -> p a' a b' b m r -mapB f g = runIdentityK go where - go b' = do - a <- request (g b') - b'2 <- respond (f a ) - go b'2 --- mapB f g = foreverK $ request . g >=> respond . f -{-# INLINABLE mapB #-} - -{-| @(mapMD f)@ applies the monadic function @f@ to all values going downstream - -> mapMD f1 >-> mapMD f2 = mapMD (f1 >=> f2) -> -> mapMD return = idT --} -mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r -mapMD f = runIdentityK go where - go x = do - a <- request x - b <- lift (f a) - x2 <- respond b - go x2 --- mapMD f = foreverK $ request >=> lift . f >=> respond -{-# INLINABLE mapMD #-} - -{-| @(mapMU g)@ applies the monadic function @g@ to all values going upstream - -> mapMU g1 >-> mapMU g2 = mapMU (g2 >=> g1) -> -> mapMU return = idT --} -mapMU :: (Monad m, Proxy p) => (b' -> m a') -> b' -> p a' x b' x m r -mapMU g = runIdentityK go where - go b' = do - a' <- lift (g b') - x <- request a' - b'2 <- respond x - go b'2 --- mapMU g = foreverK $ lift . g >=> request >=> respond -{-# INLINABLE mapMU #-} - -{-| @(mapMB f g)@ applies the monadic function @f@ to all values going - downstream and the monadic function @g@ to all values going upstream. - -> mapMB f1 g1 >-> mapMB f2 g2 = mapMB (f1 >=> f2) (g2 >=> g1) -> -> mapMB return return = idT --} -mapMB - :: (Monad m, Proxy p) => (a -> m b) -> (b' -> m a') -> b' -> p a' a b' b m r -mapMB f g = runIdentityK go where - go b' = do - a' <- lift (g b') - a <- request a' - b <- lift (f a ) - b'2 <- respond b - go b'2 --- mapMB f g = foreverK $ lift . g >=> request >=> lift . f >=> respond -{-# INLINABLE mapMB #-} - -{-| @(useD f)@ executes the monadic function @f@ on all values flowing - \'@D@\'ownstream - -> useD f1 >-> useD f2 = useD (\a -> f1 a >> f2 a) -> -> useD (\_ -> return ()) = idT --} -useD :: (Monad m, Proxy p) => (a -> m r1) -> x -> p x a x a m r -useD f = runIdentityK go where - go x = do - a <- request x - lift $ f a - x2 <- respond a - go x2 -{-# 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 ()) = idT --} -useU :: (Monad m, Proxy p) => (a' -> m r2) -> a' -> p a' x a' x m r -useU g = runIdentityK go where - go a' = do - lift $ g a' - x <- request a' - a'2 <- respond x - go a'2 -{-# INLINABLE useU #-} - -{-| @(useB f g)@ executes the monadic function @f@ on all values flowing - downstream and the monadic function @g@ on all values flowing upstream - -> useB f1 g1 >-> useB f2 g2 = useB (\a -> f1 a >> f2 a) (\a' -> g2 a' >> g1 a') -> -> useB (\_ -> return ()) (\_ -> return ()) = idT --} -useB - :: (Monad m, Proxy p) - => (a -> m r1) -> (a' -> m r2) -> a' -> p a' a a' a m r -useB f g = runIdentityK go where - go a' = do - lift $ g a' - a <- request a' - lift $ f a - a'2 <- respond a - go a'2 -{-# INLINABLE useB #-} - -{-| @(execD md)@ executes @md@ every time values flow downstream through it. - -> execD md1 >-> execD md2 = execD (md1 >> md2) -> -> execD (return ()) = idT --} -execD :: (Monad m, Proxy p) => m r1 -> a' -> p a' a a' a m r -execD md = runIdentityK go where - go a' = do - a <- request a' - lift md - a'2 <- respond a - go a'2 -{- execD md = foreverK $ \a' -> do - a <- request a' - lift md - respond a -} -{-# INLINABLE execD #-} - -{-| @(execU mu)@ executes @mu@ every time values flow upstream through it. - -> execU mu1 >-> execU mu2 = execU (mu2 >> mu1) -> -> execU (return ()) = idT --} -execU :: (Monad m, Proxy p) => m r2 -> a' -> p a' a a' a m r -execU mu = runIdentityK go where - go a' = do - lift mu - a <- request a' - a'2 <- respond a - go a'2 -{- execU mu = foreverK $ \a' -> do - lift mu - a <- request a' - respond a -} -{-# INLINABLE execU #-} - -{-| @(execB md mu)@ executes @mu@ every time values flow upstream through it, - and executes @md@ every time values flow downstream through it. - -> execB md1 mu1 >-> execB md2 mu2 = execB (md1 >> md2) (mu2 >> mu1) -> -> execB (return ()) = idT --} -execB :: (Monad m, Proxy p) => m r1 -> m r2 -> a' -> p a' a a' a m r -execB md mu = runIdentityK go where - go a' = do - lift mu - a <- request a' - lift md - a'2 <- respond a - go a'2 -{- execB md mu = foreverK $ \a' -> do - lift mu - a <- request a' - lift md - respond a -} -{-# INLINABLE execB #-} - -{-| @(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 = idT --} -takeWhileD :: (Monad m, Proxy p) => (a -> Bool) -> a' -> p a' a a' a m () -takeWhileD p = runIdentityK go where - go a' = do - a <- request a' - if (p a) - then do - a'2 <- respond a - go a'2 - else return () -{-# 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 = idT --} -takeWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' a a' a m () -takeWhileU p = runIdentityK go where - go a' = - if (p a') - then do - a <- request a' - a'2 <- respond a - go a'2 - else return_P () -{-# INLINABLE takeWhileU #-} - -{-| @(dropD n)@ discards @n@ values going downstream - -> dropD n1 >-> dropD n2 = dropD (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropD 0 = idT --} -dropD :: (Monad m, Proxy p) => Int -> () -> Pipe p a a m r -dropD n0 = \() -> runIdentityP (go n0) where - go n - | n <= 0 = idT () - | otherwise = do - request () - go (n - 1) -{- dropD n () = do - replicateM_ n $ request () - idT () -} -{-# INLINABLE dropD #-} - -{-| @(dropU n)@ discards @n@ values going upstream - -> dropU n1 >-> dropU n2 = dropU (n1 + n2) -- n2 >= 0 && n2 >= 0 -> -> dropU 0 = idT --} -dropU :: (Monad m, Proxy p) => Int -> a' -> CoPipe p a' a' m r -dropU n0 = runIdentityK (go n0) where - go n - | n <= 0 = idT - | otherwise = \_ -> do - a' <- respond () - go (n - 1) a' -{-# 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 = idT --} -dropWhileD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r -dropWhileD p () = runIdentityP go where - go = do - a <- request () - if (p a) - then go - else do - x <- respond a - idT x -{-# INLINABLE dropWhileD #-} - -{-| @(dropWhileU p)@ discards values going upstream until one violates the - predicate @p@. - -> dropWhileU p1 >-> dropWhileU p2 = dropWhileU (p1 <> p2) -> -> dropWhileU mempty = idT --} -dropWhileU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r -dropWhileU p = runIdentityK go where - go a' = - if (p a') - then do - a2 <- respond () - go a2 - else idT a' -{-# 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 = idT --} -filterD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r -filterD p = \() -> runIdentityP go where - go = do - a <- request () - if (p a) - then do - respond a - go - else go -{-# INLINABLE filterD #-} - -{-| @(filterU p)@ discards values going upstream if they fail the predicate @p@ - -> filterU p1 >-> filterU p2 = filterU (p1 <> p2) -> -> filterU mempty = idT --} -filterU :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> CoPipe p a' a' m r -filterU p = runIdentityK go where - go a' = - if (p a') - then do - request a' - a'2 <- respond () - go a'2 - else do - a'2 <- respond () - go a'2 -{-# 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 #-} - -{-| Convert a list into a 'CoProducer' - -> fromListC xs >=> fromListC ys = fromListC (xs ++ ys) -> -> fromListC [] = return --} -fromListC :: (Monad m, Proxy p) => [a'] -> () -> CoProducer p a' m () -fromListC xs = \_ -> foldr (\e a -> request e ?>= \_ -> a) (return_P ()) xs --- fromListC xs _ = mapM_ request xs -{-# INLINABLE fromListC #-} - --- | '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 #-} - --- | 'CoProducer' version of 'enumFrom' -enumFromC :: (Enum a', Monad m, Proxy p) => a' -> () -> CoProducer p a' m r -enumFromC a'0 = \_ -> runIdentityP (go a'0) where - go a' = do - request a' - go $! succ a' -{-# INLINABLE enumFromC #-} - --- | '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 #-} - --- | 'CoProducer' version of 'enumFromTo' -enumFromToC - :: (Enum a', Ord a', Monad m, Proxy p) - => a' -> a' -> () -> CoProducer p a' m () -enumFromToC a1 a2 _ = runIdentityP (go a1) where - go n - | n > a2 = return () - | otherwise = do - request n - go $! succ n -{-# INLINABLE enumFromToC #-} - -{-| 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, ListT p) => [b] -> ProduceT p m b -eachS bs = RespondT (fromListS bs ()) -{-# INLINABLE eachS #-} - -{-| Non-deterministically choose from all values in the given list - -> mappend <$> eachC xs <*> eachC ys = eachC (mappend <$> xs <*> ys) -> -> eachC (pure mempty) = pure mempty --} -eachC :: (Monad m, ListT p) => [a'] -> CoProduceT p m a' -eachC a's = RequestT (fromListC a's ()) -{-# INLINABLE eachC #-} - --- | Non-deterministically choose from all values in the given range -rangeS :: (Enum b, Ord b, Monad m, ListT p) => b -> b -> ProduceT p m b -rangeS b1 b2 = RespondT (enumFromToS b1 b2 ()) -{-# INLINABLE rangeS #-} - --- | Non-deterministically choose from all values in the given range -rangeC - :: (Enum a', Ord a', Monad m, ListT p) => a' -> a' -> CoProduceT p m a' -rangeC a'1 a'2 = RequestT (enumFromToC a'1 a'2 ()) -{-# INLINABLE rangeC #-} - -{-| Fold values flowing \'@D@\'ownstream - -> foldD f >-> foldD g = foldD (f <> g) -> -> foldD mempty = idT --} -foldD - :: (Monad m, Proxy p, Monoid w) - => (a -> w) -> x -> p x a x a (WriterT w m) r -foldD f = runIdentityK go where - go x = do - a <- request x - lift $ W.tell $ f a - x2 <- respond a - go x2 -{-# INLINABLE foldD #-} - -{-| Fold values flowing \'@U@\'pstream - -> foldU f >-> foldU g = foldU (g <> f) -> -> foldU mempty = idT --} -foldU - :: (Monad m, Proxy p, Monoid w) - => (a' -> w) -> a' -> p a' x a' x (WriterT w m) r -foldU f = runIdentityK go where - go a' = do - lift $ W.tell $ f a' - x <- request a' - a'2 <- respond x - go a'2 -{-# INLINABLE foldU #-} - -{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the - predicate --} -allD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) r -allD pred = foldD (All . pred) -{-# INLINABLE allD #-} - -{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the - predicate --} -allU - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) r -allU pred = foldU (All . pred) -{-# INLINABLE allU #-} - -{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the - predicate - - 'allD_' terminates on the first value that fails the predicate --} -allD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) () -allD_ pred = runIdentityK go where - go x = do - a <- request x - if (pred a) - then do - x2 <- respond a - go x2 - else lift $ W.tell $ All False -{-# INLINABLE allD_ #-} - -{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the - predicate - - 'allU_' terminates on the first value that fails the predicate --} -allU_ - :: (Monad m, Proxy p) - => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) () -allU_ pred = runIdentityK go where - go a' = - if (pred a') - then do - x <- request a' - a'2 <- respond x - go a'2 - else lift $ W.tell $ All False -{-# INLINABLE allU_ #-} - -{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies - the predicate --} -anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r -anyD pred = foldD (Any . pred) -{-# INLINABLE anyD #-} - -{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies - the predicate --} -anyU - :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) r -anyU pred = foldU (Any . pred) -{-# INLINABLE anyU #-} - -{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies the - predicate - - 'anyD_' terminates on the first value that satisfies the predicate --} -anyD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) () -anyD_ pred = runIdentityK go where - go x = do - a <- request x - if (pred a) - then lift $ W.tell $ Any True - else do - x2 <- respond a - go x2 -{-# INLINABLE anyD_ #-} - -{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies the - predicate - - 'anyU_' terminates on the first value that satisfies the predicate --} -anyU_ - :: (Monad m, Proxy p) - => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) () -anyU_ pred = runIdentityK go where - go a' = - if (pred a') - then lift $ W.tell $ Any True - else do - x <- request a' - a'2 <- respond x - go a'2 -{-# INLINABLE anyU_ #-} - --- | Compute the 'Sum' of all values that flow \'@D@\'ownstream -sumD :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Sum a) m) r -sumD = foldD Sum -{-# INLINABLE sumD #-} - --- | Compute the 'Sum' of all values that flow \'@U@\'pstream -sumU :: (Monad m, Proxy p, Num a') => a' -> p a' x a' x (WriterT (Sum a') m) r -sumU = foldU Sum -{-# INLINABLE sumU #-} - --- | Compute the 'Product' of all values that flow \'@D@\'ownstream -productD - :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Product a) m) r -productD = foldD Product -{-# INLINABLE productD #-} - --- | Compute the 'Product' of all values that flow \'@U@\'pstream -productU - :: (Monad m, Proxy p, Num a') - => a' -> p a' x a' x (WriterT (Product a') m) r -productU = foldU Product -{-# INLINABLE productU #-} - --- | Count how many values flow \'@D@\'ownstream -lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r -lengthD = foldD (\_ -> Sum 1) -{-# INLINABLE lengthD #-} - --- | Count how many values flow \'@U@\'pstream -lengthU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Sum Int) m) r -lengthU = foldU (\_ -> Sum 1) -{-# INLINABLE lengthU #-} - --- | Retrieve the first value going \'@D@\'ownstream -headD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) r -headD = foldD (First . Just) -{-# INLINABLE headD #-} - -{-| Retrieve the first value going \'@D@\'ownstream - - 'headD_' terminates on the first value it receives --} -headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () -headD_ x = runIdentityP $ do - a <- request x - lift $ W.tell $ First (Just a) -{-# INLINABLE headD_ #-} - --- | Retrieve the first value going \'@U@\'pstream -headU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) r -headU = foldU (First . Just) -{-# INLINABLE headU #-} - -{-| Retrieve the first value going \'@U@\'pstream - - 'headU_' terminates on the first value it receives --} -headU_ :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) () -headU_ a' = runIdentityP $ lift $ W.tell $ First (Just a') -{-# INLINABLE headU_ #-} - --- | Retrieve the last value going \'@D@\'ownstream -lastD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Last a) m) r -lastD = foldD (Last . Just) -{-# INLINABLE lastD #-} - --- | Retrieve the last value going \'@U@\'pstream -lastU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Last a') m) r -lastU = foldU (Last . Just) -{-# INLINABLE lastU #-} - --- | Fold the values flowing \'@D@\'ownstream into a list -toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r -toListD = foldD (\x -> [x]) -{-# INLINABLE toListD #-} - --- | Fold the values flowing \'@U@\'pstream into a list -toListU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT [a'] m) r -toListU = foldU (\x -> [x]) -{-# INLINABLE toListU #-} - -{-| Fold equivalent to 'foldr' - - To see why, consider this isomorphic type for 'foldr': - -> foldr :: (a -> b -> b) -> [a] -> Endo b --} -foldrD - :: (Monad m, Proxy p) - => (a -> b -> b) -> x -> p x a x a (WriterT (Endo b) m) r -foldrD step = foldD (Endo . step) -{-# INLINABLE foldrD #-} - --- | Fold equivalent to 'foldr' -foldrU - :: (Monad m, Proxy p) - => (a' -> b -> b) -> a' -> p a' x a' x (WriterT (Endo b) m) r -foldrU step = foldU (Endo . step) -{-# INLINABLE foldrU #-} - --- | Left strict fold over \'@D@\'ownstream values -foldlD' - :: (Monad m, Proxy p) => (b -> a -> b) -> x -> p x a x a (StateT b m) r -foldlD' f = runIdentityK go where - go x = do - a <- request x - lift $ StateT $ \b -> let b' = f b a in b' `seq` return ((), b') - x2 <- respond a - go x2 -{-# INLINABLE foldlD' #-} - --- | Left strict fold over \'@U@\'pstream values -foldlU' - :: (Monad m, Proxy p) => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r -foldlU' f = runIdentityK go where - go a' = do - lift $ StateT $ \b -> let b' = f b a' in b' `seq` return ((), b') - x <- request a' - a'2 <- respond x - go a'2 -{-# INLINABLE foldlU' #-} - -{- $choice - 'leftD' and 'rightD' satisfy the 'ArrowChoice' laws using @arr = mapD@. - - 'leftU' and 'rightU' satisfy the 'ArrowChoice' laws using @arr = mapU@. --} - -{-| Lift a proxy to operate only on 'Left' values flowing \'@D@\'ownstream and - forward 'Right' values --} -leftD - :: (Monad m, ListT 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 \>\ (identityK 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, ListT 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 \>\ (identityK 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 #-} - -{-| Lift a proxy to operate only on 'Left' values flowing \'@U@\'pstream and - forward 'Right' values --} -leftU - :: (Monad m, ListT p) - => (q -> p a' x b' x m r) -> (q -> p (Either a' e) x (Either b' e) x m r) -leftU k = runIdentityK ((up \>\ identityK k) />/ dn) - where - up a' = request (Left a') - dn x = do - mb' <- respond x - case mb' of - Left b' -> return b' - Right e -> do - x2 <- request (Right e) - dn x2 -{-# INLINABLE leftU #-} - -{-| Lift a proxy to operate only on 'Right' values flowing \'@D@\'ownstream and - forward 'Left' values --} -rightU - :: (Monad m, ListT p) - => (q -> p a' x b' x m r) -> (q -> p (Either e a') x (Either e b') x m r) -rightU k = runIdentityK ((up \>\ identityK k) />/ dn) - where - up a' = request (Right a') - dn x = do - mb' <- respond x - case mb' of - Left e -> do - x2 <- request (Left e) - dn x2 - Right b' -> return b' -{-# INLINABLE rightU #-} - --- | 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 --} diff --git a/Control/Proxy/Prelude/IO.hs b/Control/Proxy/Prelude/IO.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/IO.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-| 'String'-based 'IO' operations. - - Note that 'String's are very inefficient, and I will release future separate - packages with 'ByteString' and 'Text' operations. I only provide these to - allow users to test simple I/O without requiring additional library - dependencies. --} -module Control.Proxy.Prelude.IO ( - -- * Standard I/O - - -- ** Input - stdinS, - getLineS, - getLineC, - readLnS, - readLnC, - - -- ** Output - stdoutD, - putStrLnD, - putStrLnU, - putStrLnB, - printD, - printU, - printB, - - -- * Handle I/O - - -- ** Input - - hGetLineS, - hGetLineC, - - -- ** Output - hPrintD, - hPrintU, - hPrintB, - hPutStrLnD, - hPutStrLnU, - hPutStrLnB, - ) where - -import Control.Monad (forever) -import Control.Monad.Trans.Class (lift) -import Control.Proxy.Prelude.Kleisli (foreverK) -import Control.Proxy.Class (Proxy(request, respond)) -import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK) -import Control.Proxy.Synonym (Producer, CoProducer) -import qualified System.IO as IO - --- | Synonym for 'getLineS' -stdinS :: (Proxy p) => () -> Producer p String IO r -stdinS = getLineS -{-# INLINABLE stdinS #-} - --- | A 'Producer' that sends lines from 'stdin' downstream -getLineS :: (Proxy p) => () -> Producer p String IO r -getLineS () = runIdentityP $ forever $ do - str <- lift getLine - respond str -{-# INLINABLE getLineS #-} - --- | A 'CoProducer' that sends lines from 'stdin' upstream -getLineC :: (Proxy p) => () -> CoProducer p String IO r -getLineC () = runIdentityP $ forever $ do - str <- lift getLine - request str -{-# INLINABLE getLineC #-} - --- | '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 #-} - --- | 'read' input from 'stdin' one line at a time and send \'@U@\'pstream -readLnC :: (Read a', Proxy p) => () -> CoProducer p a' IO r -readLnC () = runIdentityP $ forever $ do - a <- lift readLn - request a -{-# INLINABLE readLnC #-} - --- | Synonym for 'putStrLnD' -stdoutD :: (Proxy p) => x -> p x String x String IO r -stdoutD = putStrLnD -{-# INLINABLE stdoutD #-} - --- | 'putStrLn's all values flowing \'@D@\'ownstream to 'stdout' -putStrLnD :: (Proxy p) => x -> p x String x String IO r -putStrLnD = runIdentityK $ foreverK $ \x -> do - a <- request x - lift $ putStrLn a - respond a -{-# INLINABLE putStrLnD #-} - --- | 'putStrLn's all values flowing \'@U@\'pstream to 'stdout' -putStrLnU :: (Proxy p) => String -> p String x String x IO r -putStrLnU = runIdentityK $ foreverK $ \a' -> do - lift $ putStrLn a' - x <- request a' - respond x -{-# INLINABLE putStrLnU #-} - -{-| 'putStrLn's all values flowing through it to 'stdout' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -putStrLnB :: (Proxy p) => String -> p String String String String IO r -putStrLnB = runIdentityK $ foreverK $ \a' -> do - lift $ do - putStr "U: " - putStrLn a' - a <- request a' - lift $ do - putStr "D: " - putStrLn a - respond a -{-# INLINABLE putStrLnB #-} - --- | '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 #-} - --- | 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 #-} - --- | A 'CoProducer' that sends lines from a 'Handle' upstream -hGetLineC :: (Proxy p) => IO.Handle -> () -> CoProducer p String IO () -hGetLineC h () = runIdentityP go where - go = do - eof <- lift $ IO.hIsEOF h - if eof - then return () - else do - str <- lift $ IO.hGetLine h - request str - go -{-# INLINABLE hGetLineC #-} - --- | '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 #-} - --- | '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 #-} - -{-| 'print's all values flowing through it to a 'Handle' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -hPrintB :: (Show a, Show a', Proxy p) => IO.Handle -> a' -> p a' a a' a IO r -hPrintB h = runIdentityK $ foreverK $ \a' -> do - lift $ do - IO.hPutStr h "U: " - IO.hPrint h a' - a <- request a' - lift $ do - IO.hPutStr h "D: " - IO.hPrint h a - respond a -{-# INLINABLE hPrintB #-} - --- | '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 #-} - --- | 'putStrLn's all values flowing \'@U@\'pstream to a 'Handle' -hPutStrLnU :: (Proxy p) => IO.Handle -> String -> p String x String x IO r -hPutStrLnU h = runIdentityK $ foreverK $ \a' -> do - lift $ IO.hPutStrLn h a' - x <- request a' - respond x -{-# INLINABLE hPutStrLnU #-} - -{-| 'putStrLn's all values flowing through it to a 'Handle' - - Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" --} -hPutStrLnB - :: (Proxy p) => IO.Handle -> String -> p String String String String IO r -hPutStrLnB h = runIdentityK $ foreverK $ \a' -> do - lift $ do - IO.hPutStr h "U: " - IO.hPutStrLn h a' - a <- request a' - lift $ do - IO.hPutStr h "D: " - IO.hPutStrLn h a - respond a -{-# INLINABLE hPutStrLnB #-} diff --git a/Control/Proxy/Prelude/Kleisli.hs b/Control/Proxy/Prelude/Kleisli.hs deleted file mode 100644 --- a/Control/Proxy/Prelude/Kleisli.hs +++ /dev/null @@ -1,123 +0,0 @@ --- | Utility functions for Kleisli arrows - -{-# LANGUAGE Rank2Types #-} - -module Control.Proxy.Prelude.Kleisli ( - -- * Core utility functions - foreverK, - replicateK, - liftK, - hoistK, - raise, - raiseK, - hoistPK, - raiseP, - raisePK - ) where - -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class (Proxy) -import Control.Proxy.Morph (PFunctor(hoistP)) -import Control.Proxy.Trans (ProxyTrans(liftP)) - -{-| 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 #-} - --- | Repeat a \'@K@\'leisli arrow multiple times -replicateK :: (Monad m) => Int -> (a -> m a) -> (a -> m a) -replicateK n0 k = go n0 where - go n - | n < 1 = return - | n == 1 = k - | otherwise = \a -> k a >>= go (n - 1) -{-# INLINABLE replicateK #-} - -{-| Convenience function equivalent to @(lift .)@ - -> liftK f >=> liftK g = liftK (f >=> g) -> -> liftK return = return --} -liftK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b) -liftK k a = lift (k a) --- liftK = (lift .) -{-# INLINABLE liftK #-} - --- | Convenience function equivalent to @(hoist f .)@ -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') --- hoistK k = (hoist k .) -{-# INLINABLE hoistK #-} - -{-| Lift the base monad - -> raise = hoist lift --} -raise :: (Monad m, MFunctor t1, MonadTrans t2) => t1 m r -> t1 (t2 m) r -raise = hoist lift -{-# INLINABLE raise #-} - -{-| Lift the base monad of a \'@K@\'leisli arrow - -> raiseK = hoistK lift --} -raiseK - :: (Monad m, MFunctor t1, MonadTrans t2) - => (q -> t1 m r) -> (q -> t1 (t2 m) r) -raiseK = (hoist lift .) -{-# INLINABLE raiseK #-} - --- | Convenience function equivalent to @(hoistP f .)@ -hoistPK - :: (Monad m, Proxy p1, PFunctor t) - => (forall r1 . p1 a' a b' b m r1 -> p2 a' a b' b n r1) -- ^ Proxy morphism - -> (q -> t p1 a' a b' b m r2) -- ^ Proxy Kleisli arrow - -> (q -> t p2 a' a b' b n r2) -hoistPK f = (hoistP f .) -{-# INLINABLE hoistPK #-} - -{-| Lift the base proxy - -> raiseP = hoistP liftP --} -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 #-} - -{-| Lift the base proxy of a \'@K@\'leisli arrow - -> raisePK = hoistPK liftP --} -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 #-} diff --git a/Control/Proxy/Synonym.hs b/Control/Proxy/Synonym.hs deleted file mode 100644 --- a/Control/Proxy/Synonym.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-| These type synonyms simplify type signatures when proxies do not use all - their type variables. --} -{-# LANGUAGE KindSignatures #-} - -module Control.Proxy.Synonym ( - -- * Closed - C, - - -- * Synonyms - Pipe, - Producer, - Consumer, - CoPipe, - CoProducer, - CoConsumer, - Client, - Server, - Session - ) where - --- | 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 diff --git a/Control/Proxy/Trans.hs b/Control/Proxy/Trans.hs --- a/Control/Proxy/Trans.hs +++ b/Control/Proxy/Trans.hs @@ -8,10 +8,10 @@ module Control.Proxy.Trans ( -- * Proxy Transformers ProxyTrans(..), - mapP - -- * Laws - -- $laws + -- * Deprecated + -- $deprecate + mapP ) where import Control.Proxy.Class (Proxy) @@ -20,53 +20,12 @@ class ProxyTrans t where liftP :: (Monad m, Proxy p) => p a' a b' b m r -> t p a' a b' b m r -{-| Lift a 'Proxy' Kleisli arrow - -> mapP = (lift .) +{- $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 #-} - -{- $laws - 'mapP' defines a functor that preserves five categories: - - * Kleisli category - - * The two Proxy categories - - * \"request\" category - - * \"respond\" category - - Laws: - - * Functor between 'Proxy' categories - -> mapP (f >-> g) = mapP f >-> mapP g -> -> mapP idT = idT - -> mapP (f >~> g) = mapP f >~> mapP g -> -> mapP idPush = idPush - - * Functor between Kleisli categories - -> mapP (f <=< g) = mapP f <=< mapP g -> -> mapP return = return - - * Functor between \"request\" categories - -> mapP (f / -> mapP request = request - - * Functor between \"respond\" categories - -> mapP (f \<\ g) = mapP f \<\ mapP g -- when \<\ is defined -> -> mapP respond = respond --} +{-# DEPRECATED mapP "Use '(liftP .)' instead" #-} diff --git a/Control/Proxy/Trans/Codensity.hs b/Control/Proxy/Trans/Codensity.hs --- a/Control/Proxy/Trans/Codensity.hs +++ b/Control/Proxy/Trans/Codensity.hs @@ -45,11 +45,10 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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.ListT (ListT((>\\), (//>))) import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Codensity' proxy transformer @@ -68,19 +67,19 @@ instances. -} -instance (Proxy p, Monad m) => Functor (CodensityP p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (CodensityP p a' a b' b m) where +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 (Proxy p, Monad m) => Monad (CodensityP p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (CodensityP p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -90,14 +89,14 @@ instance (Proxy p) => MFunctor (CodensityP p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (CodensityP p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (CodensityP p a' a b' b m) where liftIO = liftIO_P -instance (MonadPlusP p, Monad m) => Alternative (CodensityP p a' a b' b m) where +instance (Monad m, MonadPlusP p) => Alternative (CodensityP p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlusP p, Monad m) => MonadPlus (CodensityP p a' a b' b m) where +instance (Monad m, MonadPlusP p) => MonadPlus (CodensityP p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -114,6 +113,8 @@ 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 -> @@ -129,13 +130,14 @@ request = \a' -> CodensityP (\k -> request a' ?>= k) respond = \b -> CodensityP (\k -> respond b ?>= k) -instance (ListT p) => ListT (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 ) + + turn p = CodensityP (\k -> turn (unCodensityP p return_P) ?>= k) instance ProxyTrans CodensityP where liftP p = CodensityP (\k -> p ?>= k) diff --git a/Control/Proxy/Trans/Either.hs b/Control/Proxy/Trans/Either.hs --- a/Control/Proxy/Trans/Either.hs +++ b/Control/Proxy/Trans/Either.hs @@ -25,8 +25,8 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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)) @@ -40,14 +40,14 @@ newtype EitherP e p a' a b' b (m :: * -> *) r = EitherP { runEitherP :: p a' a b' b m (Either e r) } -instance (Proxy p, Monad m) => Functor (EitherP e p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (EitherP e p a' a b' b m) where +instance (Monad m, Proxy p) => Applicative (EitherP e p a' a b' b m) where pure = return fp <*> xp = EitherP ( runEitherP fp ?>= \e1 -> @@ -59,7 +59,7 @@ Left l -> Left l Right x -> Right (f x) ) ) -instance (Proxy p, Monad m) => Monad (EitherP e p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (EitherP e p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -69,15 +69,15 @@ instance (Proxy p) => MFunctor (EitherP e p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (EitherP e p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (EitherP e p a' a b' b m) where liftIO = liftIO_P -instance (Proxy p, Monad m, Monoid e) +instance (Monad m, Proxy p, Monoid e) => Alternative (EitherP e p a' a b' b m) where empty = mzero (<|>) = mplus -instance (Proxy p, Monad m, Monoid e) +instance (Monad m, Proxy p, Monoid e) => MonadPlus (EitherP e p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -96,11 +96,40 @@ 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)) diff --git a/Control/Proxy/Trans/Identity.hs b/Control/Proxy/Trans/Identity.hs --- a/Control/Proxy/Trans/Identity.hs +++ b/Control/Proxy/Trans/Identity.hs @@ -5,8 +5,11 @@ module Control.Proxy.Trans.Identity ( -- * Identity Proxy Transformer IdentityP(..), - identityK, - runIdentityK + runIdentityK, + + -- * Deprecated + -- $deprecate + identityK ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) @@ -15,29 +18,28 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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.ListT (ListT((>\\), (//>))) import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Identity' proxy transformer newtype IdentityP p a' a b' b (m :: * -> *) r = IdentityP { runIdentityP :: p a' a b' b m r } -instance (Proxy p, Monad m) => Functor (IdentityP p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (IdentityP p a' a b' b m) where +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 (Proxy p, Monad m) => Monad (IdentityP p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (IdentityP p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -47,14 +49,14 @@ instance (Proxy p) => MFunctor (IdentityP p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (IdentityP p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (IdentityP p a' a b' b m) where liftIO = liftIO_P -instance (MonadPlusP p, Monad m) => Alternative (IdentityP p a' a b' b m) where +instance (Monad m, MonadPlusP p) => Alternative (IdentityP p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlusP p, Monad m) => MonadPlus (IdentityP p a' a b' b m) where +instance (Monad m, MonadPlusP p) => MonadPlus (IdentityP p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -70,6 +72,8 @@ 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))) @@ -77,10 +81,11 @@ request = \a' -> IdentityP (request a') respond = \b -> IdentityP (respond b ) -instance (ListT p) => ListT (IdentityP p) where 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)) @@ -94,12 +99,16 @@ instance PMonad IdentityP where embedP nat p = nat (runIdentityP p) --- | Wrap a \'@K@\'leisli arrow in 'IdentityP' -identityK :: (q -> p a' a b' b m r) -> (q -> IdentityP p a' a b' b m r) -identityK k q = IdentityP (k q) -{-# INLINABLE identityK #-} - --- | Run an 'P' \'@K@\'leisli arrow +-- | 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 --- a/Control/Proxy/Trans/Maybe.hs +++ b/Control/Proxy/Trans/Maybe.hs @@ -11,15 +11,14 @@ 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, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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)) @@ -28,14 +27,14 @@ newtype MaybeP p a' a b' b (m :: * -> *) r = MaybeP { runMaybeP :: p a' a b' b m (Maybe r) } -instance (Proxy p, Monad m) => Functor (MaybeP p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (MaybeP p a' a b' b m) where +instance (Monad m, Proxy p) => Applicative (MaybeP p a' a b' b m) where pure = return fp <*> xp = MaybeP ( runMaybeP fp ?>= \m1 -> @@ -47,7 +46,7 @@ Nothing -> return_P Nothing Just x -> return_P (Just (f x)) ) -instance (Proxy p, Monad m) => Monad (MaybeP p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (MaybeP p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -57,14 +56,14 @@ instance (Proxy p) => MFunctor (MaybeP p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (MaybeP p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (MaybeP p a' a b' b m) where liftIO = liftIO_P -instance (Proxy p, Monad m) => Alternative (MaybeP p a' a b' b m) where +instance (Monad m, Proxy p) => Alternative (MaybeP p a' a b' b m) where empty = mzero (<|>) = mplus -instance (Proxy p, Monad m) => MonadPlus (MaybeP p a' a b' b m) where +instance (Monad m, Proxy p) => MonadPlus (MaybeP p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -82,11 +81,40 @@ 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) diff --git a/Control/Proxy/Trans/Reader.hs b/Control/Proxy/Trans/Reader.hs --- a/Control/Proxy/Trans/Reader.hs +++ b/Control/Proxy/Trans/Reader.hs @@ -21,30 +21,29 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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.ListT (ListT((>\\), (//>))) import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Reader' proxy transformer newtype ReaderP i p a' a b' b (m :: * -> *) r = ReaderP { unReaderP :: i -> p a' a b' b m r } -instance (Proxy p, Monad m) => Functor (ReaderP i p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (ReaderP i p a' a b' b m) where +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 (Proxy p, Monad m) => Monad (ReaderP i p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (ReaderP i p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -54,14 +53,14 @@ instance (Proxy p) => MFunctor (ReaderP i p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (ReaderP i p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (ReaderP i p a' a b' b m) where liftIO = liftIO_P -instance (MonadPlusP p, Monad m) => Alternative (ReaderP i p a' a b' b m) where +instance (Monad m, MonadPlusP p) => Alternative (ReaderP i p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlusP p, Monad m) => MonadPlus (ReaderP i p a' a b' b m) where +instance (Monad m, MonadPlusP p) => MonadPlus (ReaderP i p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -77,16 +76,20 @@ 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) -instance (ListT p) => ListT (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)) + 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)) @@ -111,12 +114,12 @@ {-# INLINABLE runReaderK #-} -- | Get the environment -ask :: (Proxy p, Monad m) => ReaderP i p a' a b' b m i +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 :: (Proxy p, Monad m) => (i -> r) -> ReaderP i p a' a b' b m r +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 #-} diff --git a/Control/Proxy/Trans/State.hs b/Control/Proxy/Trans/State.hs --- a/Control/Proxy/Trans/State.hs +++ b/Control/Proxy/Trans/State.hs @@ -5,6 +5,8 @@ module Control.Proxy.Trans.State ( -- * StateP StateP(..), + state, + stateT, runStateP, runStateK, evalStateP, @@ -25,29 +27,29 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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' a b' b m (r, s) } + = StateP { unStateP :: s -> p (a', s) (a, s) (b', s) (b, s) m (r, s) } -instance (Proxy p, Monad m) => Functor (StateP s p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (StateP s p a' a b' b m) where +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 (Proxy p, Monad m) => Monad (StateP s p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (StateP s p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -57,14 +59,14 @@ instance (Proxy p) => MFunctor (StateP s p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (StateP s p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (StateP s p a' a b' b m) where liftIO = liftIO_P -instance (MonadPlusP p, Monad m) => Alternative (StateP s p a' a b' b m) where +instance (Monad m, MonadPlusP p) => Alternative (StateP s p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlusP p, Monad m) => MonadPlus (StateP s p a' a b' b m) where +instance (Monad m, MonadPlusP p) => MonadPlus (StateP s p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -80,74 +82,115 @@ 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' -> unStateP (fb' b') s) ->> unStateP p s) - p >>~ fb = StateP (\s -> unStateP p s >>~ (\b -> unStateP (fb b) s)) - request = \a' -> StateP (\s -> request a' ?>= \a -> return_P (a , s)) - respond = \b -> StateP (\s -> respond b ?>= \b' -> return_P (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') ) + 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 (\s -> m ?>= \r -> return_P (r, s)) + 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 :: s -> StateP s p a' a b' b m r -> p a' a b' b m (r, s) -runStateP s m = unStateP m s +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 :: s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m (r, s)) -runStateK s k q = unStateP (k q) s +runStateK + :: (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 - :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m r -evalStateP s p = unStateP p s ?>= \x -> return_P (fst x) + :: (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 - :: (Proxy p, Monad m) + :: (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 - :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m s -execStateP s p = unStateP p s ?>= \x -> return_P (snd x) + :: (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 - :: (Proxy p, Monad m) + :: (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 :: (Proxy p, Monad m) => StateP s p a' a b' b m s +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 :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m () +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 :: (Proxy p, Monad m) => (s -> s) -> StateP s p a' a b' b m () +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 :: (Proxy p, Monad m) => (s -> r) -> StateP s p a' a b' b m r +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 --- a/Control/Proxy/Trans/Writer.hs +++ b/Control/Proxy/Trans/Writer.hs @@ -12,6 +12,8 @@ module Control.Proxy.Trans.Writer ( -- * WriterP WriterP, + writer, + writerT, writerP, runWriterP, runWriterK, @@ -29,30 +31,30 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy.Class ( - Proxy(request, respond, (->>), (>>~)), - ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P), + 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.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' a b' b m (r, w) } + = WriterP { unWriterP :: w -> p (a', w) (a, w) (b', w) (b, w) m (r, w) } -instance (Proxy p, Monad m) => Functor (WriterP w p a' a b' b m) where +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 (Proxy p, Monad m) => Applicative (WriterP w p a' a b' b m) where +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 (Proxy p, Monad m) => Monad (WriterP w p a' a b' b m) where +instance (Monad m, Proxy p) => Monad (WriterP w p a' a b' b m) where return = return_P (>>=) = (?>=) @@ -62,14 +64,14 @@ instance (Proxy p) => MFunctor (WriterP w p a' a b' b) where hoist = hoist_P -instance (Proxy p, MonadIO m) => MonadIO (WriterP w p a' a b' b m) where +instance (MonadIO m, Proxy p) => MonadIO (WriterP w p a' a b' b m) where liftIO = liftIO_P -instance (MonadPlusP p, Monad m) => Alternative (WriterP w p a' a b' b m) where +instance (Monad m, MonadPlusP p) => Alternative (WriterP w p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlusP p, Monad m) => MonadPlus (WriterP w p a' a b' b m) where +instance (Monad m, MonadPlusP p) => MonadPlus (WriterP w p a' a b' b m) where mzero = mzero_P mplus = mplus_P @@ -85,71 +87,107 @@ 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' -> unWriterP (fb' b') w) ->> unWriterP p w) - p >>~ fb = WriterP (\w -> unWriterP p w >>~ (\b -> unWriterP (fb b) w)) - request = \a' -> WriterP (\w -> request a' ?>= \a -> return_P (a, w)) - respond = \b -> WriterP (\w -> respond b ?>= \b' -> return_P (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') ) + 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 (\w -> m ?>= \r -> return_P (r, w)) + liftP m = WriterP (thread_P m) instance PFunctor (WriterP w) where hoistP nat p = WriterP (\s -> nat (unWriterP p s)) -instance (Monoid w) => PMonad (WriterP w) where - embedP nat p = writerP ( - runWriterP (nat (runWriterP p)) ?>= \((r, w1), w2) -> - return_P (r, mappend w1 w2) ) +-- | 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 -> - p ?>= \(r, w') -> - let w'' = mappend w w' - in w'' `seq` return_P (r, 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 :: (Monoid w) => WriterP w p a' a b' b m r -> p a' a b' b m (r, w) -runWriterP p = unWriterP p mempty +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 - :: (Monoid w) + :: (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 - :: (Proxy p, Monad m, Monoid w) + :: (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 - :: (Proxy p, Monad m, Monoid w) + :: (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) +execWriterK k q = execWriterP (k q) {-# INLINABLE execWriterK #-} -- | Add a value to the monoid -tell :: (Proxy p, Monad m, Monoid w) => w -> WriterP w p a' a b' b m () -tell w' = WriterP (\w -> let w'' = mappend w w' in w'' `seq` return_P ((), w'')) +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 - :: (Proxy p, Monad m, Monoid w) + :: (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) -> diff --git a/Control/Proxy/Tutorial.hs b/Control/Proxy/Tutorial.hs --- a/Control/Proxy/Tutorial.hs +++ b/Control/Proxy/Tutorial.hs @@ -33,31 +33,31 @@ -- * Utilities -- $utilities - -- * Mix Monads and Composition + -- * Sequencing Proxies -- $mixmonadcomp -- * ListT -- $listT - -- * Folds - -- $folds - -- * Resource Management -- $resource -- * Extensions -- $extend - -- * Error handling + -- ** Error handling -- $error - -- * Local state + -- ** Folds + -- $folds + + -- ** State -- $state -- * Branching, zips, and merges -- $branch - -- * Proxy Transformers + -- * Mixing Proxies -- $proxytrans -- * Proxy Morphism Laws @@ -78,7 +78,6 @@ import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Proxy -import Control.Proxy.Morph import Control.Proxy.Core.Correct (ProxyCorrect) import Control.Proxy.Trans.Either @@ -104,12 +103,13 @@ > 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 +> lines' h () = runIdentityP loop +> where > loop = do > eof <- lift $ hIsEOF h > if eof @@ -224,7 +224,7 @@ 2 You shall not pass! - When @take' 2@ terminates, it brings down every 'Proxy' composed with it. + 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 @@ -271,7 +271,7 @@ 'request'. 'Server's similarly generalize 'Producer's because they receive arguments - other than @()@. The following 'Server' receives 'Int' requests and + other than @()@. The following 'Server' receives 'Int' requests and responds with 'Bool's: > -- Receives 'Int's ---+ +--- Replies with 'Bool's @@ -543,7 +543,7 @@ as type synonyms on top of a single type class: 'Proxy'. This makes your life easier because: - * You only use one composition operator: ('>->') + * You can reuse the same composition operator: ('>->') * You can mix multiple abstractions together as long as the types match -} @@ -576,7 +576,7 @@ 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': @@ -687,41 +687,41 @@ > p1 >-> p2 >-> p3 - Also, we can define a \'@T@\'ransparent 'Proxy' that auto-forwards values - both ways: + Also, we can define a 'Proxy' that auto-forwards values both ways, beginning + from its upstream interface: -> idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r -> idT = runIdentityK loop where +> 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: idT = runIdentityK $ foreverK $ request >=> respond -> -- = runIdentityK $ request >=> respond >=> request >=> respond ... +> -- or: pull = runIdentityK $ foreverK $ request >=> respond +> -- = runIdentityK $ request >=> respond >=> request >=> respond ... Diagramatically, this looks like: -> +-----+ -> | | -> a' <======== a' <- All values pass -> | idT | straight through -> a ========> a <- immediately -> | | -> +-----+ +> +------+ +> | | +> a' <========= a' <- All values pass +> | pull | straight through +> a =========> a <- immediately +> | | +> +------+ - Transparency means that: + 'pull' is completely invisible to composition, meaning that: -> idT >-> p = p +> pull >-> p = p > -> p >-> idT = p +> p >-> pull = p - In other words, 'idT' is an identity of composition. + In other words, 'pull' is an identity of composition. This means that proxies form a true 'Category' where ('>->') is composition - and 'idT' is the identity. The associativity law and the two + 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. + the 'Proxy' interfaces and the morphisms are the proxies. These 'Category' laws guarantee the following important properties: @@ -729,31 +729,57 @@ (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 'idT' + 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 four central operations of this library's API: + defines the library's central API. This type class actually defines four + separate categories that all proxies obey! Each category has an identity + operation: - * ('->>'): \"Pointful\" pull-based composition, from which the point-free - ('>->') operator derives + * 'request': The identity of the \"request\" composition - * ('>>~'): \"Pointful\" push-based composition, from which the point-free - ('>~>') operator derives + * 'respond': The identity of the \"respond\" composition - * 'request': Request input from upstream + * 'pull': The identity of pull-based composition - * 'respond': Respond with output to downstream + * 'push': The identity of push-based composition - @pipes@ defines everything in terms of these four operations, which is - why all the library's utilities are polymorphic over the 'Proxy' type class. + ... 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 -- Strict monad transformer laws +> instance Proxy ProxyCorrect -- Correct by construction These two types provide the two alternative base implementations: @@ -762,8 +788,8 @@ hand-tuned code. * 'ProxyCorrect': This uses a monad transformer implementation that is - correct by construction, but runs about 8x slower on pure code segments. - However, for 'IO'-bound code, the performance gap is small. + 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 @@ -883,10 +909,10 @@ * If a 'Proxy' terminates, it terminates every 'Proxy' composed with it - Several of the utilities in "Control.Proxy.Prelude.Base" use these - equational laws to rigorously prove things about their behavior. For - example, consider the 'mapD' proxy, which applies a function @f@ to all - values flowing downstream: + 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 @@ -901,15 +927,15 @@ > mapD f >-> mapD g = mapD (g . f) > -> mapD id = idT +> 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: 'idT'. + 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.Base" is full of + category of 'Proxy' composition. "Control.Proxy.Prelude" is full of utilities like this that are simultaneously practical and theoretically elegant. -} @@ -954,41 +980,20 @@ Hello Left "Could not read an Integer" - This library provides three syntactic conveniences for making this easier to - write. - - First, ('.') has higher precedence than ('>->'), so you can drop the - parentheses: + Also, note that ('.') has higher precedence than ('>->'), so you can drop + the parentheses: >>> runEitherT $ runProxy $ promptInt2 >-> hoist lift . printer ... - Second, 'lift' is such a common argument to 'hoist' that I provide the - 'raise' function: - -> raise = hoist lift - ->>> runEitherT $ runProxy $ promptInt2 >-> raise . printer -... - - Third, I provide the 'hoistK' and 'raiseK' functions in case you think - composition looks ugly: - -> hoistK f = (hoist f .) -> -> raiseK = (raise .) - ->>> runEitherT $ runProxy $ promptInt2 >-> raiseK printer -... - For more information on using 'MFunctor', consult the tutorial in the @Control.Monad.Morph@ module from the @mmorph@ package. -} {- $utilities - The "Control.Proxy.Prelude" heirarchy provides several utility functions - for common tasks. We can redefine the previous example functions just by - composing these utilities. + "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: @@ -1126,7 +1131,7 @@ 34 ... - What if we only want the user to provide three values? We can + 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 () @@ -1153,8 +1158,8 @@ > sink1 :: (Proxy p) => () -> Pipe p Int Int IO () > sink1 () = runIdentityP $ do -> (takeB_ 3 >-> printD) () -- Sink 1 -> (takeWhileD (< 4) >-> printD) () -- Sink 2 +> (takeB_ 3 >-> printD) () -- Sink 1 +> (takeWhileD (< 4) >-> printD) () -- Sink 2 > > -- or: sink1 = (takeB_ 3 >-> printD) >=> (takeWhileD (< 4) >-> printD) @@ -1181,22 +1186,21 @@ >>> runProxy $ source2 >-> sink2 - These examples demonstrate the two principal ways to combine proxies: + These examples demonstrate two possible ways to combine proxies: * \"Vertical\" composition, using ('>=>') from the Kleisli category * \"Horizontal\" composition: using ('>->') from the Proxy category - You assemble most proxies simply by composing them in one or both of these - two categories. + 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! "Control.Proxy.ListT" provides the machinery necessary to - convert back and forth between proxies and a @ListT@-like monad transformer - that binds proxy outputs. + 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: @@ -1204,7 +1208,7 @@ > -- +-- ListT that will compile to a 'Producer' > -- | > -- v -> pairs :: (ListT p) => () -> ProduceT p IO (Int, Int) +> 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 @@ -1217,7 +1221,7 @@ > -- runRespondK's type is actually more general > runRespondK :: (() -> ProduceT p m b) -> () -> Producer p b m () > -> runRespondK pairs :: (ListT p) => () -> Producer p (Int, Int) IO () +> 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 @@ -1240,7 +1244,7 @@ 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 :: (ListT p) => () -> ProduceT p IO (Int, Int) +> pairs2 :: (Proxy p) => () -> ProduceT p IO (Int, Int) > pairs2 () = do > x <- RespondT $ runIdentityP $ do > respond 1 @@ -1263,10 +1267,10 @@ In fact, this is how 'eachS' and 'rangeS' are implemented: -> eachS :: (Monad m, ListT p) => [b] -> ProduceT p m b +> eachS :: (Monad m, Proxy p) => [b] -> ProduceT p m b > eachS xs = RespondT (fromList xs ()) > -> rangeS :: (Enum b, Monad m, Ord b, ListT p) => b -> b -> ProduceT p m b +> 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 @@ -1274,10 +1278,10 @@ > type ProduceT p = RespondT p C () () - Moreover, you can bind anything within 'RespondT', not just 'Producer's. - For example, you can bind 'Pipe's within the more general 'RespondT' monad: + This more general 'RespondT' monad lets you bind more general things than + 'Producer's. For example, you can bind 'Pipe' outputs this way: -> pairs3 :: (ListT p) => () -> RespondT p () Int () IO (Int, Int) +> pairs3 :: (Proxy p) => () -> RespondT p () Int () IO (Int, Int) > pairs3 () = do > x <- RespondT $ runIdentityP $ replicateM_ 2 $ do > a <- request () @@ -1291,7 +1295,7 @@ ... and you will get a 'Pipe' back when you 'runRespondK' the final result: -> runRespondK pairs3 :: ListT p => () -> Pipe p Int (Int, Int) IO () +> runRespondK pairs3 :: Proxy p => () -> Pipe p Int (Int, Int) IO () >>> runProxy $ enumFromS 1 >-> runRespondK pairs3 >-> printD Received 1 @@ -1314,145 +1318,22 @@ elements output from the proxy's upstream interface. To distinguish them, I call the downstream one 'RespondT' and the upstream one 'RequestT'. - "Control.Proxy.ListT" contains the 'ListT' class, which provides the the - underlying operators for both 'RespondT' and 'RequestT': - - * ('>\\'): Equivalent to ('=<<') for 'RequestT' - - * ('//>'): Equivalent to ('>>=') for 'RespondT' - - You don't need to use these operators directly, since you can instead just - wrap your proxies in the 'RespondT' or 'RequestT' monad transformers and - they will translate the binds in those monads to the above operators under - the hood. - - If those are the bind operators, though, then where are the corresponding - 'return' equivalents? Why, they are just 'respond' and 'request'! - -> -- return for 'RespondT' -> return b = RespondT (respond b) + Remember how I said there were three extra categories? Well, two of them + directly correspond to the 'RespondT' and 'RequestT' monds: -> -- return for 'RequestT' -> return a' = RequestT (request a') + * ('\>\') and 'request': Equivalent to ('<=<') and 'return' for 'RequestT' - Therefore, we can use the monad laws to reason about how 'respond' interacts - with 'RespondT' (and, dually, how 'request' interacts with 'RequestT'): + * ('/>/') and 'respond': Equivalent to ('>=>') for 'return' for 'RespondT' -> do x' <- RespondT (respond x) = do f x -> f x' -> -> do x <- m = do m -> RespondT (respond x) + 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 without exception, unlike - @ListT@ from @transformers@. In other words, they behave like two + 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\". -} -{- $folds - You can fold a stream of values in two ways, both of which use the base - monad: - - * Use 'WriterT' in the base monad and 'tell' the values to fold - - * Use 'StateT' in the base monad and 'put' strict values - - 'WriterT' is more elegant in principle but leaks space for a large number of - values to fold. 'StateT' does not leak space if you keep the accumulator - strict, but is less elegant and doesn't guarantee write-only behavior. To - remedy this, I am currently working on a stricter 'WriterT' implementation - that does not leak space to add to the @transformers@ package. - - "Control.Proxy.Prelude.Base" provides several common folds using 'WriterT' - as the base monad, such as: - - * 'lengthD': Count how many values flow downstream - -> lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r - - * 'toListD': Fold the values flowing downstream into a list. - -> toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r - - * 'anyD': Determine whether any values satisfy the predicate - -> anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r - - These 'WriterT' versions demonstrate how the elegant approach should work in - principle and they should be okay for folding a medium number of values - until I release the fixed 'WriterT'. If space leaks cause problems, you can - temporarily rewrite the 'WriterT' folds using the following two strict - 'StateT' folds: - - * 'foldlD'': Strictly fold values flowing downstream - -> foldlD' -> :: (Monad m, Proxy p) -> => (b -> a -> b) -> x -> p x a x a (StateT b m) r - - * 'foldlU'': Strictly fold values flowing upstream - -> foldU' -> :: (Monad m, Proxy p) -> => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r - - Now, let's try these folds out and see if we can build a list from user - input: - ->>> runWriterT $ runProxy $ raiseK promptInt >-> takeB_ 3 >-> toListD -Enter an Integer: -1 -Enter an Integer: -66 -Enter an Integer: -5 -((),[1,66,5]) - - Notice that @promptInt@ uses 'IO' as its base monad, but 'toListD' uses - @(WriterT [Int] m)@ as its base monad, so I use 'raiseK' to get the base - monads to match. - - You can insert these folds anywhere in the middle of a pipeline and they - still work: - ->>> runWriterT $ runProxy $ fromListS [5, 7, 4] >-> lengthD >-> raiseK printD -5 -7 -4 -((),Sum {getSum = 3}) - - You can also run multiple folds at the same time just by adding more - 'WriterT' layers to your base monad: - ->>> runWriterT $ runWriterT $ runProxy $ fromListS [9, 10] >-> anyD even >-> raiseK sumD -(((),Any {getAny = True}),Sum {getSum = 19} - - I designed certain special folds to terminate the 'Session' early if they - can compute their result prematurely, in order to draw as little input as - possible. These folds end with an underscore, such as 'headD_', which - terminates the stream once it receives an input: - -> headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () - ->>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD_ -3 -((),First {getFirst = Just 3}) - - Compare this to 'headD' without underscore, which folds the entire input: - ->>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD -3 -4 -9 -((),First {getFirst = Just 3}) - - Use the versions that don't prematurely terminate if you are running - multiple folds or if you want to continue to use the rest of the input when - the fold is done. Use the versions that do prematurely terminate if - collecting that single fold is the entire purpose of the session. --} - {- $resource This core library provides utilities for lazily streaming from resources, but does not provide utilities for lazily managing resource allocation and @@ -1650,14 +1531,90 @@ we can run it locally on a subset of the pipeline like so: >>> runProxy $ (E.runEitherK $ heartbeat . promptInt3 >-> takeB_ 2) >-> printer +-} - Proxy transformers do not use the base monad at all, so you can use them to - isolate effects from other proxies, as the next section demonstrates. +{- $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 local state into any 'Proxy' computation. - For example, we might want to gratuitously use state to generate successive + 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 @@ -1666,9 +1623,9 @@ > increment () = forever $ do > n <- S.get > respond n -> S.put (n + 1) +> S.modify (+1) - We could then embed it locally into any 'Proxy', such as the following one: + 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 @@ -1685,25 +1642,23 @@ 2 3 - We can also prove the effect is local even when you directly compose two - 'StateP' proxies before running them. Let's define a stateful consumer: + 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 -> nOurs <- S.get > nTheirs <- request () +> S.modify (+2) +> nOurs <- S.get > lift $ print (nTheirs, nOurs) -> S.put (nOurs + 2) .. and hook it up directly to @increment@: >>> runProxy $ S.evalStateK 0 $ increment >-> takeB_ 3 >-> increment2 -(0, 0) -(1, 2) -(2, 4) +(0,2) +(3,5) +(6,8) - They each share the same initial state, but they isolate their own side - effects completely from each other. -} {- $branch @@ -1855,30 +1810,24 @@ > liftP > :: (Monad m, Proxy p) > => p a' a b' b m r -> t p a' a b' b m r -> -> -- mapP is slightly more elegant -> mapP -> :: (Monad m, Proxy p, ProxyTrans t) -> => (q -> p a' a b' b m r) -> (q -> t p a' a b' b m r) -> mapP = (liftP .) - It's very easy to use. Just use 'mapP' to lift one proxy transformer to - match another one. For example, we can 'mapP' @increment2@ to match + 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 > -> mapP increment2 +> liftP . increment2 > :: (Proxy p, ProxyTrans eitherP) > => () -> Consumer (eitherP (StateP Int p)) Int IO r > -> promptInt3 >-> mapP increment2 +> promptInt3 >-> liftP . increment2 > :: (Proxy p) > => () -> Session (EitherP String (StateP Int p)) IO r - 'mapP' creates a new 'ProxyTrans' layer that type-checks as 'EitherP', and + '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 @@ -1892,10 +1841,10 @@ Hello Left "Could not read an Integer" - ... or we could instead 'mapP' @promptInt3@ to match @increment2@ and switch + ... or we could instead 'liftP' @promptInt3@ to match @increment2@ and switch the order of the two proxy transformers: -> mapP promptInt3 +> liftP . promptInt3 > :: (Proxy p, ProxyTrans stateP) > => () -> Producer (stateP (EitherP String p)) Int IO r > @@ -1903,11 +1852,11 @@ > :: (Proxy eitherP) > => () -> Consumer (StateP Int eitherP ) Int IO r > -> mapP promptInt3 >-> increment2 +> liftP . promptInt3 >-> increment2 > :: (Proxy p) > => () -> Session (StateP Int (EitherP String p)) IO r - 'mapP' creates a new 'ProxyTrans' layer that type-checks as 'StateP', and + '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 @@ -1950,9 +1899,9 @@ 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 . (f >=> g) = lift . f >=> lift . g > -> (lift .) return = return +> lift . return = return If you convert these laws to @do@ notation, they just say: @@ -1965,17 +1914,9 @@ base monad to the extended monad correctly. Just replace 'lift' with 'liftP': -> (liftP .) (f >=> g) = (liftP .) f >=> (liftP .) g -> -> (liftP .) return = return - - The only difference is 'mapP' sweetens these laws a little bit: - -> mapP = (liftP .) -> -> mapP (f >=> g) = mapP f >=> mapP g -- These are functor laws! +> liftP . (f >=> g) = liftP . f >=> liftP . g -- These are functor laws! > -> mapP return = return +> liftP . return = return However, proxy transformers do one extra thing above and beyond ordinary monad transformers. Proxy transformers lift the 'Proxy' type class, meaning @@ -1985,42 +1926,35 @@ transformer lifts the 'Proxy' instance correctly. I call these laws the \"proxy morphism laws\": -> mapP (f >-> g) = mapP f >-> mapP g -- These are functor laws, too! +> liftP . (f >-> g) = liftP . f >-> liftP . g -- These are functor laws, too! > -> mapP idT = idT +> 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 proxies actually form three other - categories, only one of which I have mentioned so far, and proxy - transformers lift these three other categories correctly, too: + 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: -> -- The push-based category -> -> mapP (f >~> g) = mapP f >~> mapP g +> liftP . (f >~> g) = liftP . f >~> liftP . g > -> mapP coidT = coidT +> liftP . push = push -> -- The upstream ListT Kleisli category -> -> mapP (f \>\ g) = mapP f \>\ mapP g +> liftP . (f \>\ g) = liftP . f \>\ liftP . g > -> mapP request = request +> liftP . request = request -> -- The downstream ListT Kleisli category -> -> mapP (f />/ g) = mapP f />/ mapP g +> liftP . (f />/ g) = liftP . f />/ liftP . g > -> mapP respond = respond +> liftP . respond = respond I want to highlight two of the above laws: -> mapP request = request +> liftP . request = request > -> mapP respond = respond +> liftP . respond = respond - We can translate those back to 'liftP' to get: + The \"pointful\" statement of those laws is: > liftP (request a') = request a' > @@ -2029,8 +1963,8 @@ In other words, 'request' and 'respond' in the extended proxy must behave exactly the same as lifting 'request' and 'respond' from the base proxy. - All the proxy transformers in this library obey the proxy morphism laws, - which ensure that 'liftP' / 'mapP' always do \"the right thing\". + All the proxy transformers in this library obey these proxy morphism laws, + which ensures that 'liftP' always does \"the right thing\". -} {- $proxyfunctor @@ -2054,7 +1988,7 @@ > 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 @@ -2074,16 +2008,12 @@ -} {- $conclusion - The @pipes@ library emphasizes the reuse of a small set of core abstractions - grounded in theory to implement all functionality: - - * Monads - - * Proxies: ('>->'), 'request', and 'respond' + The @pipes@ library implements all functionality using theoretically + inspired abstractions: - * Monad Transformers and Functors on Monads: 'lift' and 'hoist' + * Monads, Monad Transformers, and Functors on Monads - * Proxy Transformers and Functors on Proxies: 'liftP' and 'hoistP' + * 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 @@ -2096,7 +2026,7 @@ -- $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 @@ -2105,9 +2035,10 @@ -- > 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 +-- > lines' h () = runIdentityP loop +-- > where -- > loop = do -- > eof <- lift $ hIsEOF h -- > if eof @@ -2116,7 +2047,7 @@ -- > 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:" @@ -2125,7 +2056,7 @@ -- > {- -- > 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 @@ -2135,26 +2066,26 @@ -- > 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 @@ -2166,20 +2097,20 @@ -- > 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 @@ -2188,39 +2119,39 @@ -- > 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 :: (ListT p) => () -> ProduceT p IO (Int, Int) +-- > +-- > 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 :: (ListT p) => () -> ProduceT p IO (Int, Int) +-- > +-- > pairs2 :: (Proxy p) => () -> ProduceT p IO (Int, Int) -- > pairs2 () = do -- > x <- RespondT $ runIdentityP $ do -- > respond 1 @@ -2232,7 +2163,7 @@ -- > respond 4 -- > return (x, y) -- > --- > pairs3 :: (ListT p) => () -> RespondT p () Int () IO (Int, Int) +-- > pairs3 :: (Proxy p) => () -> RespondT p () Int () IO (Int, Int) -- > pairs3 () = do -- > x <- RespondT $ runIdentityP $ replicateM_ 2 $ do -- > a <- request () @@ -2251,13 +2182,13 @@ -- > 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 @@ -2266,7 +2197,7 @@ -- > 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 @@ -2274,40 +2205,40 @@ -- > 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.put (n + 1) --- > +-- > 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 --- > nOurs <- S.get -- > nTheirs <- request () +-- > S.modify (+2) +-- > nOurs <- S.get -- > lift $ print (nTheirs, nOurs) --- > S.put (nOurs + 2) --- > +-- > -- > 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 @@ -2316,19 +2247,19 @@ -- > 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 diff --git a/pipes.cabal b/pipes.cabal --- a/pipes.cabal +++ b/pipes.cabal @@ -1,5 +1,5 @@ Name: pipes -Version: 3.2.0 +Version: 3.3.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 @@ -28,13 +28,13 @@ * /ListT/: Correct implementation of ListT that interconverts with pipes . * /Lightweight Dependency/: @pipes@ depends only on @transformers@ and - compiles rapidly + @mmorph@ and compiles rapidly . * /Extensive Documentation/: Second to none! . Import "Control.Proxy" to use the library. . - Read "Control.Proxy.Tutorial" for a really extensive tutorial. + Read "Control.Proxy.Tutorial" for an extensive tutorial. Category: Control, Pipes, Proxies Source-Repository head Type: git @@ -52,10 +52,8 @@ Control.Proxy.Core, Control.Proxy.Core.Fast, Control.Proxy.Core.Correct, - Control.Proxy.ListT, Control.Proxy.Morph, Control.Proxy.Pipe, - Control.Proxy.Synonym, Control.Proxy.Trans, Control.Proxy.Trans.Codensity, Control.Proxy.Trans.Either, @@ -65,8 +63,5 @@ Control.Proxy.Trans.State, Control.Proxy.Trans.Writer, Control.Proxy.Tutorial, - Control.Proxy.Prelude, - Control.Proxy.Prelude.Base, - Control.Proxy.Prelude.IO, - Control.Proxy.Prelude.Kleisli + Control.Proxy.Prelude GHC-Options: -O2