diff --git a/Control/Frame.hs b/Control/Frame.hs deleted file mode 100644 --- a/Control/Frame.hs +++ /dev/null @@ -1,473 +0,0 @@ -{-| - 'Frame's extend 'Pipe's with: - - * The ability to fold input - - * Prompt and deterministic finalization - - 'Frame's differ from 'Pipe's because they form restricted monads rather than - forming ordinary monads. This means you must rebind @do@ notation to use - restricted monads from the @index-core@ package. See the \"Create Frames\" - section for details. For even more details, consult the @index-core@ - package. --} - -{-# LANGUAGE GADTs, TypeOperators #-} - -module Control.Frame ( - -- * Types - -- $types - C, - O, - M, - FrameF(..), - Frame, - Stack, - -- * Create Frames - -- $create - - -- ** Primitives - -- $primitives - yieldF, - awaitF, - close, - -- ** Pipe-like primitives - -- $pipeprims - yield, - await, - -- * Finalize Frames - -- $finalization - catchD, - catchF, - finallyD, - finallyF, - -- * Compose Frames - -- $compose - (<-<), - (>->), - idF, - FrameC(..), - -- * Run Frames - -- $run - runFrame - ) where - -import Control.Category -import Control.IMonad -import Control.IMonad.Trans -import Control.IMonad.Trans.Free -import Control.Monad.Instances () -import Data.Closed (C) -import Data.Maybe -import Prelude hiding ((.), id) - --- For documentation -import Control.Pipe hiding (await, yield, Await, Yield) - -{- $types - The first step to convert 'Pipe' code to 'Frame' code is to translate the - types. All types of the form \"@Pipe a b m r@\" become - \"@Frame b m (M a) C r@\". For example, given the following type signatures - from the tutorial: - -> printer :: (Show a) => Pipe b C IO r -> take' :: Int -> Pipe b b IO () -> fromList :: (Monad m) => [b] -> Pipe () b m () - - ... you would replace them with: - -> printer :: (Show a) => Frame C IO (M a) C r -> take' :: Int -> Frame a IO (M a) C () -> fromList :: (Monad m) => [a] -> Frame a m (M ()) C () -> -- To use the finalization example, change fromList's base monad to 'IO' -> fromList :: [a] -> Frame a IO (M ()) C () --} - --- | Index representing an open input end, receiving values of type @a@ -data O a = O -- Not exported - --- | Index representing an open input end, receiving values of type @Maybe a@ -type M a = O (Maybe a) - -{-| - Base functor for a pipe that can close its input end - - * @b@ - Output type - - * @x@ - Next step - - * @i@ - Current step's index --} -data FrameF b x i where - Yield :: b -> x i -> FrameF b x i - Await :: (a -> x (O a)) -> FrameF b x (O a) - Close :: x C -> FrameF b x (O a) - -instance IFunctor (FrameF b) where - fmapI f p = case p of - Yield b y -> Yield b (f y) - Await a -> Await (f . a) - Close c -> Close (f c) - -{-| - A 'Frame' is like a 'Pipe' with an indexed input end: - - * @b@ - The type of the 'Frame's output - - * @m@ - The base monad - - * @i@ - The initial index of the input end ('O'pen or 'C'losed) - - * @j@ - The final index of the input end ('O'pen or 'C'losed) - - * @r@ - The return value --} -type Frame b m i j r = IFreeT (FrameF (m (), b)) (U m) (r := j) i - --- | A self-contained 'Frame' that is ready to be run -type Stack m r = Frame C m (M ()) C r - --- $create --- The second step to convert 'Pipe' code to 'Frame' code is to change your --- module header to: --- --- > {-# LANGUAGE RebindableSyntax #-} --- > --- > import Control.IMonad.Do --- > import Control.Frame --- > import Prelude hiding (Monad(..)) --- --- "Control.Frame" replaces all 'Pipe' 'await's and 'yield's with their --- corresponding 'Frame' counterparts. @Control.IMonad.Do@ rebinds @do@ --- notation to work with restricted monads, which also requires using the --- @RebindableSyntax@ extension and hiding the 'Monad' class from the @Prelude@. --- --- You also must use the restricted monad utility functions, which have the --- same name as their ordinary monad counterparts except with an \'@R@\' suffix, --- such as 'foreverR' instead of 'forever'. Finally, you must use 'liftU' --- instead of 'lift' to invoke operations in the base monad. --- --- Finally, every terminating 'Frame' must be 'close'd exactly once before being --- passed to composition. --- --- > printer = foreverR $ do --- > a <- await --- > liftU $ print a --- > --- > take' n = do --- > replicateMR_ n $ do --- > a <- await --- > yield a --- > close --- > liftU $ putStrLn "You shall not pass!" --- > --- > fromList xs = do --- > close --- > mapMR_ yield xs - -{- $primitives - 'yieldF' guards against downstream termination by yielding the most - up-to-date finalization alongside each value, so that downstream can call - that finalizer if it terminates before requesting another value. - - 'awaitF' intercepts upstream termination by returning a 'Nothing' if - upstream terminates before providing a value. Further attempts to request - input from upstream will terminate the current 'Frame' using the - return value provided from upstream. - - While 'awaitF' is useful for folds, 'yieldF' is less useful for end-users of - this library and the higher-order 'catchF' / 'finallyF' finalization - functions are much more user-friendly. - - Composing two 'Frame's requires that each 'Frame' invokes 'close' exactly - once. Anything else will not type-check. Leave out the 'close' statement - when writing library components and let the person assembling the components - for composition specify where the 'close' goes. - - The earlier you 'close' the upstream 'Frame', the earlier it is finalized. - However, once you 'close' it you may no longer 'await'. --} - --- | 'Yield' the most current finalizer for this 'Frame' alongside the value -yieldF :: (Monad m) => m () -> b -> Frame b m i i () -yieldF m x = liftF $ Yield (m, x) (V ()) - --- | 'Await' a value from upstream, returning 'Nothing' if upstream terminates -awaitF :: (Monad m) => Frame b m (M a) (M a) (Maybe a) -awaitF = liftF $ Await V - --- | 'Close' the input end, calling the finalizers of every upstream 'Frame' -close :: (Monad m) => Frame b m (M a) C () -close = liftF $ Close (V ()) - -{- $pipeprims - The following 'Pipe'-like primitives are built on top of the 'Frame' - primitives. They behave identically to their 'Pipe' counterparts and can - be used as drop-in replacements for them. --} - --- | 'yield' a value upstream alongside an empty finalizer -yield :: (Monad m) => b -> Frame b m i i () -yield = yieldF (return ()) - --- | 'await' a value from upstream and terminate if upstream terminates -await :: (Monad m) => Frame b m (M a) (M a) a -await = awaitF !>= maybe await returnR - -{- $finalization - The third (and optional) step to convert 'Pipe' code to 'Frame' code is to - register finalizers for your 'Frame'. These finalizers may be arbitrarily - nested: - -> printer = foreverR $ catchF (putStrLn "printer interrupted") $ do -> a <- await -> liftU $ print a -> -> take' n = finallyF (putStrLn "You shall not pass!") $ do -> replicateMR_ n $ do -> a <- catchF (putStrLn "take' interrupted") await -> yield a -> close -> -> fromList xs = catchF (putStrLn "fromList interrupted") $ do -> close -> mapMR_ yield xs - - These convenience functions register block-level finalizers to be called if - another 'Frame' terminates first. The naming conventions are: - - * \"catch\" functions (i.e. 'catchD' / 'catchF') call the finalizer only if - another 'Frame' terminates before the block completes, but will not call - the finalizer if the block terminates normally. - - * \"finally\" functions (i.e. 'finallyD' / 'finallyF') are like \"catch\" - functions except that they also call the finalizer if the block terminates - normally. - - * Functions that end in a \'@D@\' suffix (i.e. 'catchD' / 'finallyD') only - guard against downstream termination. - - * Functions that end in a \'@F@\' suffix (i.e. 'catchF' / 'finallyF') guard - against termination in both directions. You usually want these ones. - - Note that finalization blocks that /begin/ after the 'close' statement may - only use the \'@D@\'-suffixed version as upstream has been closed off. This - is a consequence of a deficiency in Haskell's type system that will take - time to work around. However an \'@F@\'-suffixed block that begins before a - 'close' statement may continue through it normally. So, for code blocks - after a 'close' statement, use 'catchD' \/ 'finallyD', otherwise use - 'catchF' \/ 'finallyF'. In future releases, the \'@D@\'-suffixed versions - will be removed and merged into the \'@F@\'-suffixed versions. --} - -{-| - @catchD m p@ calls the finalizer @m@ if a downstream 'Frame' terminates - before @p@ finishes. --} -catchD :: (Monad m) => m () -> Frame b m i j r -> Frame b m i j r -catchD m p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Return r -> returnI r - Wrap (Close p') -> wrap $ Close (catchD m p') - Wrap (Yield (m', b) p') -> wrap $ Yield (m' >> m, b) (catchD m p') - Wrap (Await f ) -> wrap $ Await $ fmap (catchD m) f - -{-| - @catchF m p@ calls the finalizer @m@ if any 'Frame' terminates before @p@ - finishes. --} -catchF :: (Monad m) => m () -> Frame b m (M a) j r -> Frame b m (M a) j r -catchF m p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Return r -> returnI r - Wrap (Close p') -> wrap $ Close $ catchD m p' - Wrap (Yield (m', b) p') -> wrap $ Yield (m' >> m, b) (catchF m p') - Wrap (Await f ) -> wrap $ Await $ \e -> case e of - Nothing -> liftU m !> catchF m (f e) - Just _ -> catchF m (f e) - -{-| - @finallyD m p@ calls the finalizer @m@ if a downstream 'Frame' terminates - before @p@ finishes or if @p@ completes normally. --} -finallyD :: (Monad m) => m () -> Frame b m i j r -> Frame b m i j r -finallyD m p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Return r -> liftU m !> returnI r - Wrap (Close p') -> wrap $ Close (finallyD m p') - Wrap (Yield (m', b) p') -> wrap $ Yield (m' >> m, b) (finallyD m p') - Wrap (Await f ) -> wrap $ Await $ fmap (finallyD m) f - -{-| - @finallyF m p@ calls the finalizer @m@ if any 'Frame' terminates before @p@ - finishes or if @p@ completes normally. --} -finallyF :: (Monad m) => m () -> Frame b m (M a) j r -> Frame b m (M a) j r -finallyF m p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Return r -> liftU m !> returnI r - Wrap (Close p') -> wrap $ Close $ finallyD m p' - Wrap (Yield (m', b) p') -> wrap $ Yield (m' >> m, b) (finallyF m p') - Wrap (Await f ) -> wrap $ Await $ \e -> case e of - Nothing -> liftU m !> finallyF m (f e) - Just _ -> finallyF m (f e) - -(<~<) :: (Monad m) - => IFreeT (FrameF c) (U m) (r := C) (O b) - -> IFreeT (FrameF b) (U m) (r := C) (O a) - -> IFreeT (FrameF c) (U m) (r := C) (O a) -p1 <~< p2 = IFreeT $ U $ do - x1 <- unU $ runIFreeT p1 - unU $ runIFreeT $ case x1 of - Wrap (Close p1') -> wrap $ Close p1' - Wrap (Yield c p1') -> wrap $ Yield c (p1' <~< p2) - Wrap (Await f1 ) -> IFreeT $ U $ do - x2 <- unU $ runIFreeT p2 - let p1' = IFreeT $ returnI x1 - unU $ runIFreeT $ case x2 of - Wrap (Close p2') -> wrap $ Close $ p1' <~| p2' - Wrap (Yield b p2') -> f1 b <~< p2' - Wrap (Await f2) -> wrap $ Await $ fmap (\p2'-> p1' <~< p2') f2 - -(<~|) :: (Monad m) - => IFreeT (FrameF c) (U m) (r := C) (O b) - -> IFreeT (FrameF b) (U m) (r := C) C - -> IFreeT (FrameF c) (U m) (r := C) C -p1 <~| p2 = IFreeT $ U $ do - x1 <- unU $ runIFreeT p1 - unU $ runIFreeT $ case x1 of - Wrap (Close p1') -> p1' - Wrap (Yield c p1') -> wrap $ Yield c (p1' <~| p2) - Wrap (Await f1 ) -> IFreeT $ U $ do - x2 <- unU $ runIFreeT p2 - unU $ runIFreeT $ case x2 of - Return r -> returnI r - Wrap (Yield b p2') -> f1 b <~| p2' - -heap :: (Monad m) - => m () - -> IFreeT (FrameF (m (), c)) (U m) (r := C) (M b ) - -> IFreeT (FrameF (m (), c)) (U m) (r := C) (M (m (), b)) -heap m p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Wrap (Close p') -> wrap $ Close $ liftU m !> p' - Wrap (Yield (m', c) p') -> wrap $ Yield (m >> m', c) (heap m p') - Wrap (Await f ) -> wrap $ Await $ \e -> case e of - Nothing -> heap (return ()) (f Nothing) - Just (m', b) -> heap m' (f $ Just b) - -stack :: (Monad m) - => Bool - -> IFreeT (FrameF b ) (U m) (r := C) (M a) - -> IFreeT (FrameF (Maybe b)) (U m) (r := C) (M a) -stack t p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Wrap (Close p') -> wrap $ Close $ warn p' - Wrap (Yield b p') -> wrap $ Yield (Just b) (stack t p') - Wrap (Await f ) -> - let p' = wrap $ Await $ \e -> stack (isNothing e) (f e) - in case t of - False -> p' - True -> wrap $ Yield Nothing p' - -warn :: (Monad m) - => IFreeT (FrameF b ) (U m) (r := C) C - -> IFreeT (FrameF (Maybe b)) (U m) (r := C) C -warn p = IFreeT $ U $ do - x <- unU $ runIFreeT p - unU $ runIFreeT $ case x of - Return r -> wrap $ Yield Nothing (returnI r) - Wrap (Yield b p') -> wrap $ Yield (Just b) (warn p') - -{- $compose - The fourth step to convert 'Pipe' code to 'Frame' code is to replace ('<+<') - with ('<-<'): - -> printer <-< take' 3 <-< fromList [1..] - - Like 'Pipe's, Frames form a 'Category' where composition pipes the output - from the upstream 'Frame' to the input of the downstream 'Frame'. - Additionally, composition guarantees the following behaviors: - - * 'Frame's receive exactly one 'Nothing' if an upstream 'Frame' terminates. - - * Registered finalizers get called exactly once if a downstream 'Frame' - terminates. - - * Finalizers are always ordered from upstream to downstream. - - The 'Category' laws cannot be broken, so you don't have to be careful when - using 'Frame's. - - Note that you may only compose 'Frame's that begin open and end closed. --} - --- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<-<) :: Monad m - => Frame c m (M b) C r -> Frame b m (M a) C r -> Frame c m (M a) C r -p1 <-< p2 = heap (return ()) p1 <~< stack False p2 - --- | Corresponds to ('>>>') from @Control.Category@ -(>->) :: Monad m - => Frame b m (M a) C r -> Frame c m (M b) C r -> Frame c m (M a) C r -(>->) = flip (<-<) - -infixr 9 <-< -infixr 9 >-> - --- | Corresponds to 'id' from @Control.Category@ -idF :: (Monad m) => Frame a m (M a) C r -idF = foreverR $ await !>= yield - --- | 'Frame's form a 'Category' instance when you rearrange the type variables -newtype FrameC m r a b = FrameC { unFrameC :: Frame b m (M a) C r } - -instance (Monad m) => Category (FrameC m r) where - id = FrameC idF - (FrameC p1) . (FrameC p2) = FrameC (p1 <-< p2) - -{- $run - The fifth step to convert 'Pipe' code to 'Frame' code is to use 'runFrame' - instead of 'runPipe': - ->>> runFrame $ printer <-< take' 3 <-< fromList [1..] -1 -2 -3 -fromList interrupted -You shall not pass! -printer interrupted ->>> runFrame $ printer <-< take' 3 <-< fromList [1] -1 -You shall not pass! -take' interrupted -printer interrupted - --} - -{-| - Run the 'Frame' monad transformer, converting it back to the base monad. - - 'runFrame' is the 'Frame' equivalent to 'runPipe' and requires a - self-contained 'Stack'. --} -runFrame :: (Monad m) => Stack m r -> m r -runFrame p = do - x <- unU $ runIFreeT p - case x of - Wrap (Close p') -> runFrame' p' - Wrap (Yield _ p') -> runFrame p' - Wrap (Await f ) -> runFrame (f $ Just ()) - -runFrame' :: (Monad m) => Frame C m C C r -> m r -runFrame' p = do - x <- unU $ runIFreeT p - case x of - Return (V r) -> return r - Wrap (Yield _ p') -> runFrame' p' diff --git a/Control/Frame/Tutorial.hs b/Control/Frame/Tutorial.hs deleted file mode 100644 --- a/Control/Frame/Tutorial.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-| - This module provides the tutorial for "Control.Frame". --} - -module Control.Frame.Tutorial ( - -- * Restricted Monads - -- $restrict1 - - -- $extension - - -- $restrict2 - - -- * Type Signatures - -- $types - - -- * Prompt Finalization - -- $prompt - - -- * Composition - -- $compose - - -- * Finalization - -- $ensure - - -- * Folds - -- $fold - - -- * Strictness - -- $strict - - -- * Robustness - -- $robust - ) where - --- For documentation -import Control.Category -import Control.Frame -import Control.IMonad -import Control.IMonad.Trans -import Control.Monad.Trans.Class -import Control.Pipe hiding (await, yield, Await, Yield) - -{- $restrict1 - 'Frame's extend 'Pipe's with two new features: - - * Folding input and intercepting upstream termination - - * Guaranteeing prompt and deterministic finalization - - However, these extra features comes with some added complexity: restricted - monads, also known as indexed monads. Restricted monads sound scarier than - they are, so I'll demonstrate that if you are comfortable using monads, then - you'll be comfortable using restricted monads. - - Let's translate the @take'@ function from the 'Pipe's tutorial into a - 'Frame' to see what changes when we use restricted monads: - --} --- $extension --- > {-# LANGUAGE RebindableSyntax #-} --- > --- > import Control.Frame --- > import Control.IMonad.Do --- > import Control.IMonad.Trans --- > import Prelude hiding (Monad(..)) --- > --- > take' :: Int -> Frame a IO (M a) C () --- > take' n = do --- > replicateMR_ n $ do --- > x <- await --- > yield x --- > close --- > liftU $ putStrLn "You shall not pass!" -{- $restrict2 - This time I included all imports and highlighted the new @RebindableSyntax@ - extension. The new imports belong to the @Control.IMonad@ hierarchy from - the @index-core@ package, which provides the core restricted monad - functionality. - - Yet, you almost wouldn't even know you were using an restricted monad just - by looking at the code. This is because @index-core@ can rebind @do@ - notation to use restricted monads instead of ordinary extensions. Three - things make this possible: - - * The @RebindableSyntax@ extension, which allows libraries to override - @do@ syntax (among other things) - - * The @Control.IMonad.Do@ module which exports the new bindings for @do@ - notation - - * Hiding 'Monad' from the Prelude so that it does not conflict with the - bindings from @index-core@ - - However, you are not obligated to rebind @do@ notation to use 'Frame's. You - can choose to keep ordinary @do@ notation and desugar the restricted monad - by hand. Just import @Control.IMonad@ instead, drop the @RebindableSyntax@ - extension, and don't hide 'Monad'. Then you can desugar @take'@ manually - using the restricted monad operators: - -> import Control.Frame -> import Control.IMonad -> import Control.IMonad.Trans -> -> take' :: Int -> Frame a IO (M a) C () -> take' n = -> (replicateMR_ n $ -> await !>= \x -> -> yield x) !>= \_ -> -> close !>= \_ -> -> liftU $ putStrLn "You shall not pass!" - - However, for this tutorial I will use the @do@ notation, since it's prettier - and easier to use. - - You'll also notice functions that resemble the ones in @Control.Monad@, - except with an \'@R@\' suffix on the end of them, like 'replicateMR_'. - Most functions in @Control.Monad@ have a restricted counterpart provided by - @Control.IMonad.Restrict@ (which is in turn re-exported by - @Control.IMonad@), such as 'whenR', 'foreverR', and 'mapMR'. - - Also, every time you lift an operation from the base monad, you must use - 'liftU' instead of 'lift'. 'Frame's are \"restricted monad transformers\", - and they would normally lift a base restricted monad using 'liftI', but - they can also lift ordinary monads, too, using 'liftU' (mnemonic: \"lift\" - an ordinary monad and \'U\'pgrade it to a restricted monad). --} - -{- $types - The 'Frame' type constructor also looks a bit different, too: - -> Frame a IO (M a) C () - - Let's dissect that to understand how 'Frame's work: - -> | Output | Base monad | Initial Input | Final Input | Return Value -> Frame a IO (M a) C () - - 'Frame's differ from 'Pipe's in that their input end indexes the beginning - and end of the operation. Our @take'@ function starts off with an open - input end (@M a@), and ends with a closed input end (@C@). - - @take'@ finishes with a closed input end because it called the 'close' - function, which seals off and finalizes upstream. You can see that the - 'close' primitive changes the index just by looking at its type: - -> close :: Monad m => Frame b m (M a) C () - - The 'close' instruction begins with an open input end (@M a@) and finishes - with a closed input end (@C@). If you tried to call 'close' twice, you'd - get a type error: - -> -- wrong! -> do close -> close - - This prevents you from accidentally finalizing upstream twice. - - 'close' is the only primitive that changes the index, and there is no way to - reopen the input once you have closed it. 'close' also forbids you from - 'await'ing input from upstream after you have already closed it. If you - try, you will get a type error - -> -- wrong! -> do close -> await - - This prevents you from requesting input from a finalized pipe. In fact, - once you 'close' your input end, every upstream 'Frame' disappears - completely. You couldn't get input from upstream anyway, even if you - somehow allowed 'await' statements after 'close'. - - You can check out 'await''s type signature to see why it won't type-check - after 'close': - -> await :: Monad m => Frame b m (M a) (M a) a - - 'await' must begin with the input end open (@M a@) and it leaves the input - end open when done (@M a@). However, you can still use a 'yield' anywhere: - -> yield :: Monad m => b -> Frame b m i i () - - 'yield' will work whether or not the input end is open, and it leaves the - input end in the same state once 'yield' is done. --} - -{- $prompt - Every 'Frame' must close its input end /exactly/ one time before you can - compose it with other 'Frame's. The only exception is if a 'Frame' never - terminates: - -> -- This type-checks because foreverR is polymorphic in the final index -> printer :: (Show b) => Frame C IO (M b) C r -> printer = foreverR $ do -> a <- await -> liftU $ print a - - However, when a 'Frame' no longer needs input then you should 'close' it as - early as possible. The earlier you 'close' upstream, the more promptly - upstream gets finalized. - - If you write a stand-alone producer from start to finish, you can be sure it - will never need upstream, so you can close it immediately: - -> -- I'm keeping fromList's input end polymorphic for a later example -> fromList :: (M.Monad m) => [b] -> Frame b m (M a) C () -> fromList xs = do -> close -> mapMR_ yield xs - - However, if @fromList@ were a library function, you would remove the 'close' - statement as you cannot guarantee that your user won't want to 'await' after - @fromList@. Or, the user might want to call @fromList@ twice within the - same 'Frame', and having two close statements would lead to a type error. - Therefore, a good rule of thumb when writing library code for 'Frame's is to - always let the user decide when to 'close' the 'Frame' unless you are - writing a stand-alone 'Frame'. - - So for right now, I will leave the 'close' in @fromList@ for simplicity and - treat it as a stand-alone 'Frame'. Also, it will come in handy for a later - example. --} - -{- $compose - Composition works just like 'Pipe's, except you use the ('<-<') composition - operator instead of ('<+<'): - -> stack :: Stack IO () -> stack = printer <-< take' 3 <-< fromList [1..] - - The 'Frame' equivalent to 'Pipeline' is a 'Stack' (mnemonic: call stack; - also the name 'Frame' refers to a call stack frame): - -> type Stack m r = Frame C m (M ()) C r - - Similarly, you use 'runFrame' instead of 'runPipe' to convert the 'Frame' - back to the base monad: - ->>> runFrame stack -1 -2 -3 -You shall not pass! - - However, let's carefully inspect the type of composition: - -> (<-<) :: Monad m -> => Frame c m (M b) C r -> -> Frame b m (M a) C r -> -> Frame c m (M a) C r - - Each argument 'Frame' must begin in an open state and end in a closed state. - This means that each 'Frame' in a 'Stack' must call 'close' exactly once - before it may be used. 'runFrame' has the exact same restriction: - -> runFrame :: Monad m => Stack m r -> m r -> runFrame ~ Monad m => Frame C m (M ()) C r -> m r - - Composition specifically requires the user to define when to finalize - upstream and does not assume this occurs at the end of the 'Frame'. This - doesn't pose a problem for stand-alone 'Frame's, since they will know when - they no longer need input, but smaller library components designed to be - assembled into larger 'Frame's should let the user decide at the very last - moment where to 'close' the 'Pipe'. There is no way to know ahead of time - where the 'close' should be until the complete 'Frame' has been assembled. --} - -{- $ensure - With 'Frame's in hand, we can now write a safe @read'@ function: - -> readFile' :: Handle -> Frame Text IO C C () -> readFile' h = do -> eof <- liftU $ hIsEOF h -> whenR (not eof) $ do -> s <- liftU $ hGetLine h -> yield s -> readFile' h -> -> read' :: FilePath -> Frame Text IO C C () -> read' file = do -> liftU $ putStrLn "Opening file..." -> h <- liftU $ openFile file ReadMode -> -- The following requires "import qualified Control.Monad as M" -> finallyD (putStrLn "Closing file ..." M.>> hClose h) $ readFile' h - - The 'finallyD' function registers a block-level finalizer that executes if a - downstream 'Pipe' terminates or if the block completes normally. The more - general 'finallyF' function will call the finalizer if /any/ 'Frame' - terminates. - - Usually you would always want to use 'finallyF', but because of some type - limitations you can only use 'finallyD' after a 'Frame' is closed. A future - release of this library will fix this and merge 'finallyD' into 'finallyF'. - So that means that for everything beginning before a 'close' statement, use - 'finallyF', otherwise use 'finallyD'. - - Similarly, you can use the 'catchF' / 'catchD' counterparts to the - \"finally\" functions. The \"catch\" functions run the finalizer only if - another 'Frame' terminates before the block is done, but not if the block - terminates normally. - - We don't 'close' the @read'@ function because it's not a stand-alone - 'Frame'. We want to be able to concatenate multiple @read'@s together - within the same 'Frame', like so: - -> files = do -> close -> read' "file1.txt" -> read' "file2.txt" - - So let's assume those two files have the following contents: - - \"@file1.txt@\" - -> Line 1 -> Line 2 -> Line 3 - - \"@file2.txt@\" - -> A -> B -> C - - We can now check to see if our @files@ producer works: - ->>> runFrame $ printer <-< files -Opening file... -"Line1" -"Line2" -"Line3" -Closing file ... -Opening file... -"A" -"B" -"C" -Closing file ... - - More importantly, files are never opened if they aren't demanded and they - are always properly finalized if the consumer terminates early: - ->>> runFrame $ printer <-< take' 2 <-< files -Opening file... -"Line1" -"Line2" -Closing file ... -You shall not pass! - - So we get lazy, deterministic, and prompt resource management. Nice! - --} - -{- $fold - 'Frame's can actually do more than just manage finalization! Using - 'Frame's, we can now correctly implement folds like @toList@ in a way that - is truly compositional: - -> toList :: (M.Monad m) => Frame b m (M a) (M a) [a] -> toList = do -> a' <- awaitF -> case a' of -> Nothing -> return [] -> Just a -> do -> as <- toList -> return (a:as) - - We used one new function this time: 'awaitF'. This is like 'await' except - that it returns a 'Nothing' if upstream terminates before 'yield'ing back a - value. This allows you to intercept upstream termination and do some - cleanup, and in our case we use it to end the fold. - - You only receive a 'Nothing' once when you use 'awaitF'. Any attempt to - request more input after you receive the first 'Nothing' will terminate the - current 'Frame' using the upstream return value. In fact, 'await' is built - on top of 'awaitF': - -> await = do -> a' <- awaitF -> case a' of -> Nothing -> await -> Just a -> return a - - If it gets a 'Nothing', it just ignores it and 'await's again, choosing to - not do any cleanup. - - Now let's make sure our @toList@ function works. I didn't make @toList@ a - stand-alone 'Frame', so we will have to include a 'close' statement to - complete it before composing it: - -> p1 = do -> xs <- toList -> close -> return (Just xs) -> -> p2 xs = do -> fromList xs -> return Nothing -- Remember: they need the same return type - ->>> runFrame $ p1 <-< p2 [1..10] -Just [1,2,3,4,5,6,7,8,9,10] --} - -{- $strict - Lazy resource management has one important disadvantage: we can't free the - resource until downstream no longer needs input. Many libraries duplicate - their code to provide Lazy and Strict versions, allowing the user to decide - if they want: - - * Lazy input, which conserves memory, but holds onto the resource until - downstream is done processing it - - * Strict input, which loads everything into memory, but can then immediately - dispose of the resource before the input is processed - - What if there were a way to seamlessly switch between those semantics or - even choose something in between? Well, it turns out we can! - - First, we can combine @fromList@ and @toList@ into something even cooler: - -> strict :: (M.Monad m) => Frame a m (M a) C () -> strict = do -> xs <- toList -> fromList xs - - As the name suggests, the @strict@ function is strict in its input. - @strict@ loads the entire input into memory, finalizes upstream, then - proceeds to hand the input off to downstream. We can prove this just by - using it: - ->>> runFrame $ printer <-< strict <-< files -> Opening file... -> Closing file ... -> Opening file... -> Closing file ... -> "Line1" -> "Line2" -> "Line3" -> "A" -> "B" -> "C" - - Both files were disposed of immediately, at the expense of using more - memory. - - But what if we want something in between strictness and laziness? Maybe - something like this: - ->>> runFrame $ printer <-< strict <-< take' 2 <-< files -Opening file... -Closing file ... -You shall not pass! -"Line1" -"Line2" - - Now we have the best of both worlds. We can pick and choose how much of - our source to strictly load into memory. In the above example, we specified - that we wanted to be strict only in the first two lines of our input, and as - a result the third line of \"@file1.txt@\" is never read and \"@file2.txt@\" - is never even opened! - - Now we have a way to seamlessly slide anywhere on the spectrum between - laziness and strictness, and it's all implemented entirely within Haskell - in a way that is elegant and intuitive without the use of artificial and - clumsy 'seq' annotations. --} - -{- $robust - The 'Frame' implementation exposes all internals, yet this does not - compromise safety or invariants in any way. The library's implementation is - \"correct-by-construction\", meaning that you can extend it with your own - features if you so choose, and you never have to worry about accidentally - breaking any laws, such as the associativity of composition. - - This has the following important practical benefits for finalization and - folds: - - * Finalizers never get duplicated or dropped - - * Folds can be performed anywhere within the 'Stack', not just at the most - downstream 'Frame', as the @strict@ example illustrates. - - * You can reason about each 'Frame's finalization behavior completely - independently of other 'Frame's. - - Composition elegantly handles every single corner case. This directly - follows from strictly enforcing the 'Category' laws, because categories have - no corners! --} diff --git a/Control/IMonad/Trans/Free.hs b/Control/IMonad/Trans/Free.hs deleted file mode 100644 --- a/Control/IMonad/Trans/Free.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | This module is the indexed version of "Control.Monad.Trans.Free" - -{-# LANGUAGE KindSignatures, TypeOperators #-} - -module Control.IMonad.Trans.Free ( - -- * Free monad transformers - -- $freet - IFreeF(..), - IFreeT(..), - wrap, - liftF - ) where - -import Control.Category.Index -import Control.IMonad -import Control.IMonad.Trans - -{- $freet - Indexed free monad transformers lift the constructor signatures to - the category of indexed Haskell functions: (':->'). - -> Return :: r :-> IFreeF f r x -> Wrap :: f x :-> IFreeF f r x -> -> IFreeT :: m (IFreeF f r (IFreeT f m r)) :-> IFreeT f m r --} - --- | Indexed equivalent to @FreeF@ -data IFreeF f r (x :: * -> *) i = Return (r i) | Wrap (f x i) - --- | Indexed equivalent to @FreeT@ -newtype IFreeT f m r i = IFreeT { runIFreeT :: m (IFreeF f r (IFreeT f m r)) i } - -instance (IFunctor f, IMonad m) => IFunctor (IFreeT f m) where - fmapI f x = x ?>= returnI . f - -instance (IFunctor f, IMonad m) => IMonad (IFreeT f m) where - returnI = IFreeT . returnI . Return - bindI f m = IFreeT $ - runIFreeT m ?>= \x -> - runIFreeT $ case x of - Return r -> f r - Wrap w -> wrap $ fmapI (bindI f) w - -instance (IFunctor f) => IMonadTrans (IFreeT f) where - liftI = IFreeT . fmapI Return - --- | Indexed equivalent to @wrap@ -wrap :: (IMonad m) => f (IFreeT f m r) :-> IFreeT f m r -wrap = IFreeT . returnI . Wrap - --- | Indexed equivalent to @liftF@ -liftF :: (IFunctor f, IMonad m) => f r :-> IFreeT f m r -liftF x = wrap $ fmapI returnI x - --- FIXME: Add IIdentity so that IFree can be defined in terms of IFreeT diff --git a/Control/MFunctor.hs b/Control/MFunctor.hs --- a/Control/MFunctor.hs +++ b/Control/MFunctor.hs @@ -3,12 +3,54 @@ {-# LANGUAGE Rank2Types #-} module Control.MFunctor ( - -- * Monads over functors - MFunctor(..) + -- * Functors over Monads + MFunctor(..), + raise ) where +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Identity (IdentityT, mapIdentityT) +import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) +import Control.Monad.Trans.RWS (RWST, mapRWST) +import qualified Control.Monad.Trans.State.Strict as StateStrict +import qualified Control.Monad.Trans.State.Lazy as StateLazy +import qualified Control.Monad.Trans.Writer.Strict as WriterStrict +import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy + -- | A functor in the category of monads class MFunctor t where {-| Lift a monad morphism from @m@ to @n@ into a monad morphism from @(t m)@ to @(t n)@ -} - mapT :: (Monad m, Monad n) => (forall a . m a -> n a) -> t m b -> t n b + hoist :: (Monad m) => (forall a . m a -> n a) -> t m b -> t n b + +instance MFunctor IdentityT where + hoist nat = mapIdentityT nat + +instance MFunctor MaybeT where + hoist nat = mapMaybeT nat + +instance MFunctor (ReaderT r) where + hoist nat = mapReaderT nat + +instance MFunctor (RWST r w s) where + hoist nat = mapRWST nat + +instance MFunctor (StateStrict.StateT s) where + hoist nat = StateStrict.mapStateT nat + +instance MFunctor (StateLazy.StateT s) where + hoist nat = StateLazy.mapStateT nat + +instance MFunctor (WriterStrict.WriterT w) where + hoist nat = WriterStrict.mapWriterT nat + +instance MFunctor (WriterLazy.WriterT w) where + hoist nat = WriterLazy.mapWriterT nat + +{-| Lift the base monad + +> raise = hoist lift +-} +raise :: (Monad m, MFunctor t1, MonadTrans t2) => t1 m r -> t1 (t2 m) r +raise = hoist lift diff --git a/Control/PFunctor.hs b/Control/PFunctor.hs new file mode 100644 --- /dev/null +++ b/Control/PFunctor.hs @@ -0,0 +1,32 @@ +-- | This module defines functors in the category of proxies + +{-# LANGUAGE KindSignatures, Rank2Types #-} + +module Control.PFunctor ( + -- * Functors over Proxies + PFunctor(..), + raiseP + ) where + +import Control.Proxy.Class (Proxy) +import Control.Proxy.Trans (ProxyTrans(liftP)) + +-- | A functor in the category of monads +class PFunctor ( + t :: (* -> * -> * -> * -> (* -> *) -> * -> *) + -> * -> * -> * -> * -> (* -> *) -> * -> * ) where + {-| Lift a proxy morphism from @p@ to @q@ into a proxy morphism from + @(t p)@ to @(t q)@ -} + hoistP + :: (Monad m, Proxy p) + => (forall a' a b' b r1 . p a' a b' b m r1 -> q a' a b' b m r1) + -> (t p a' a b' b m r2 -> t q a' a b' b m r2) + +{-| Lift the base proxy + +> raiseP = hoistP liftP +-} +raiseP + :: (Monad m, Proxy p, PFunctor t1, ProxyTrans t2) + => t1 p a' a b' b m r -> t1 (t2 p) a' a b' b m r +raiseP = hoistP liftP diff --git a/Control/Pipe.hs b/Control/Pipe.hs --- a/Control/Pipe.hs +++ b/Control/Pipe.hs @@ -1,14 +1,200 @@ --- | Top-level import for the "Control.Pipe" hierarchy +{-| This module remains as a wistful reminder of this library's humble origins. + This library now builds upon the more general 'Proxy' type, but still keeps + the @pipes@ name. Read "Control.Proxy.Tutorial" to learn about this new + implementation. + The 'Pipe' type is a monad transformer that enriches the base monad with the + ability to 'await' or 'yield' data to and from other 'Pipe's. -} + module Control.Pipe ( - -- * Modules - -- $modules - module Control.Pipe.Core + -- * Types + -- $types + Pipe(..), + Producer, + Consumer, + Pipeline, + -- * Create Pipes + -- $create + await, + yield, + pipe, + -- * Compose Pipes + -- $category + (<+<), + (>+>), + idP, + PipeC(..), + -- * Run Pipes + runPipe ) where -import Control.Pipe.Core +import Control.Applicative (Applicative(pure, (<*>))) +import Control.Category (Category((.), id), (<<<), (>>>)) +import Control.Monad (forever) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Proxy.Synonym (C) +import Prelude hiding ((.), id) -{- $modules - "Control.Pipe.Core" provides the core type and primitives. - - "Control.Pipe.Tutorial" provides an extended tutorial. -} +{- $types + The 'Pipe' type is strongly inspired by Mario Blazevic's @Coroutine@ type in + his concurrency article from Issue 19 of The Monad Reader. +-} + +{-| + The base type for pipes + + * @a@ - The type of input received from upstream pipes + + * @b@ - The type of output delivered to downstream pipes + + * @m@ - The base monad + + * @r@ - The type of the return value +-} +data Pipe a b m r + = Await (a -> Pipe a b m r) + | Yield b (Pipe a b m r) + | M (m (Pipe a b m r)) + | Pure r +{- +Technically, the correct implementation that satisfies the monad transformer +laws is: + +type PipeF a b x = Await (a -> x) | Yield b x deriving (Functor) + +type Pipe a b = FreeT (PipeF a b) +-} + +instance (Monad m) => Functor (Pipe a b m) where + fmap f pr = go pr where + go p = case p of + Await k -> Await (\a -> go (k a)) + Yield b p' -> Yield b (go p') + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure (f r) + +instance (Monad m) => Applicative (Pipe a b m) where + pure = Pure + pf <*> px = go pf where + go p = case p of + Await k -> Await (\a -> go (k a)) + Yield b p' -> Yield b (go p') + M m -> M (m >>= \p' -> return (go p')) + Pure f -> fmap f px + +instance (Monad m) => Monad (Pipe a b m) where + return = Pure + pm >>= f = go pm where + go p = case p of + Await k -> Await (\a -> go (k a)) + Yield b p' -> Yield b (go p') + M m -> M (m >>= \p' -> return (go p')) + Pure r -> f r + +instance MonadTrans (Pipe a b) where + lift m = M (m >>= \r -> return (Pure r)) + +-- | A pipe that produces values +type Producer b m r = Pipe () b m r + +-- | A pipe that consumes values +type Consumer a m r = Pipe a C m r + +-- | A self-contained pipeline that is ready to be run +type Pipeline m r = Pipe () C m r + +{- $create + 'yield' and 'await' are the only two primitives you need to create pipes. + Since @Pipe a b m@ is a monad, you can assemble 'yield' and 'await' + statements using ordinary @do@ notation. Since @Pipe a b@ is also a monad + transformer, you can use 'lift' to invoke the base monad. For example, you + could write a pipe stage that requests permission before forwarding any + output: + +> check :: (Show a) => Pipe a a IO r +> check = forever $ do +> x <- await +> lift $ putStrLn $ "Can '" ++ (show x) ++ "' pass?" +> ok <- read <$> lift getLine +> when ok (yield x) +-} + +{-| + Wait for input from upstream. + + 'await' blocks until input is available from upstream. +-} +await :: Pipe a b m a +await = Await Pure + +{-| + Deliver output downstream. + + 'yield' restores control back upstream and binds its value to 'await'. +-} +yield :: b -> Pipe a b m () +yield b = Yield b (Pure ()) + +{-| + Convert a pure function into a pipe + +> pipe f = forever $ do +> x <- await +> yield (f x) +-} +pipe :: (Monad m) => (a -> b) -> Pipe a b m r +pipe f = go where + go = Await (\a -> Yield (f a) go) + +{- $category + 'Pipe's form a 'Category', meaning that you can compose 'Pipe's using + ('>+>') and also define an identity 'Pipe': 'idP'. These satisfy the + category laws: + +> idP >+> p = p +> +> p >+> idP = p +> +> (p1 >+> p2) >+> p3 = p1 >+> (p2 >+> p3) + + @(p1 >+> p2)@ satisfies all 'await's in @p2@ with 'yield's in @p1@. If any + 'Pipe' terminates the entire 'Pipeline' terminates. +-} + +-- | 'Pipe's form a 'Category' instance when you rearrange the type variables +newtype PipeC m r a b = PipeC { unPipeC :: Pipe a b m r} + +instance (Monad m) => Category (PipeC m r) where + id = PipeC idP + PipeC p1 . PipeC p2 = PipeC $ p1 <+< p2 + +-- | Corresponds to ('<<<')/('.') from @Control.Category@ +(<+<) :: (Monad m) => Pipe b c m r -> Pipe a b m r -> Pipe a c m r +(Yield b p1) <+< p2 = Yield b (p1 <+< p2) +(M m ) <+< p2 = M (m >>= \p1 -> return (p1 <+< p2)) +(Pure r ) <+< _ = Pure r +(Await k ) <+< (Yield b p2) = k b <+< p2 +p1 <+< (Await k) = Await (\a -> p1 <+< k a) +p1 <+< (M m) = M (m >>= \p2 -> return (p1 <+< p2)) +_ <+< (Pure r) = Pure r + +-- | Corresponds to ('>>>') from @Control.Category@ +(>+>) :: (Monad m) => Pipe a b m r -> Pipe b c m r -> Pipe a c m r +p2 >+> p1 = p1 <+< p2 + +infixr 8 <+< +infixl 8 >+> + +-- | Corresponds to 'id' from @Control.Category@ +idP :: (Monad m) => Pipe a a m r +idP = go where + go = Await (\a -> Yield a go) + +-- | Run the 'Pipe' monad transformer, converting it back into the base monad +runPipe :: (Monad m) => Pipe () b m r -> m r +runPipe pl = go pl where + go p = case p of + Yield _ p' -> go p' + Await k -> go (k ()) + M m -> m >>= go + Pure r -> return r diff --git a/Control/Pipe/Core.hs b/Control/Pipe/Core.hs deleted file mode 100644 --- a/Control/Pipe/Core.hs +++ /dev/null @@ -1,230 +0,0 @@ -{-| 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.Core ( - -- * Types - -- $types - Pipe(..), - C, - Producer, - Consumer, - Pipeline, - -- * Create Pipes - -- $create - await, - yield, - pipe, - -- * Compose Pipes - -- $category - (<+<), - (>+>), - idP, - PipeC(..), - -- * Run Pipes - -- $runpipe - runPipe - ) where - -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Category (Category((.), id), (<<<), (>>>)) -import Control.Monad (forever) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Closed (C) -import Prelude hiding ((.), id) - -{- $types - The 'Pipe' type is strongly inspired by Mario Blazevic's @Coroutine@ type in - his concurrency article from Issue 19 of The Monad Reader. --} - -{-| - The base type for pipes - - * @a@ - The type of input received from upstream pipes - - * @b@ - The type of output delivered to downstream pipes - - * @m@ - The base monad - - * @r@ - The type of the return value --} -data Pipe a b m r - = Await (a -> Pipe a b m r) - | Yield b (Pipe a b m r) - | M (m (Pipe a b m r)) - | Pure r -{- -type PipeF a b x = Await (a -> x) | Yield b x deriving (Functor) - -type Pipe a b = FreeT (PipeF a b) --} - -instance (Monad m) => Functor (Pipe a b m) where - fmap f pr = go pr where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure r -> Pure (f r) - -instance (Monad m) => Applicative (Pipe a b m) where - pure = Pure - pf <*> px = go pf where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure f -> fmap f px - -instance (Monad m) => Monad (Pipe a b m) where - return = Pure - pm >>= f = go pm where - go p = case p of - Await k -> Await (\a -> go (k a)) - Yield b p' -> Yield b (go p') - M m -> M (m >>= \p' -> return (go p')) - Pure r -> f r - -instance MonadTrans (Pipe a b) where - lift m = M (m >>= \r -> return (Pure r)) - --- | A pipe that produces values -type Producer b = Pipe () b - --- | A pipe that consumes values -type Consumer b = Pipe b C - --- | A self-contained pipeline that is ready to be run -type Pipeline = Pipe () C - -{- $create - 'yield' and 'await' are the only two primitives you need to create pipes. - Since @Pipe a b m@ is a monad, you can assemble 'yield' and 'await' - statements using ordinary @do@ notation. Since @Pipe a b@ is also a monad - transformer, you can use 'lift' to invoke the base monad. For example, you - could write a pipe stage that requests permission before forwarding any - output: - -> check :: (Show a) => Pipe a a IO r -> check = forever $ do -> x <- await -> lift $ putStrLn $ "Can '" ++ (show x) ++ "' pass?" -> ok <- read <$> lift getLine -> when ok (yield x) --} - -{-| - Wait for input from upstream. - - 'await' blocks until input is available from upstream. --} -await :: Pipe a b m a -await = Await Pure - -{-| - Deliver output downstream. - - 'yield' restores control back upstream and binds the result to 'await'. --} -yield :: b -> Pipe a b m () -yield b = Yield b (Pure ()) - -{-| - Convert a pure function into a pipe - -> pipe f = forever $ do -> x <- await -> yield (f x) --} -pipe :: (Monad m) => (a -> b) -> Pipe a b m r -pipe f = go where - go = Await (\a -> Yield (f a) go) - -{- $category - 'Pipe's form a 'Category', meaning that you can compose 'Pipe's using - ('<+<') and also define an identity 'Pipe': 'idP'. These satisfy the - category laws: - -> idP <+< p = p -> -> p <+< idP = p -> -> (p1 <+< p2) <+< p3 = p1 <+< (p2 <+< p3) - - 'Pipe' composition binds the output of the upstream 'Pipe' to the input of - the downstream 'Pipe'. Like Haskell functions, 'Pipe's are lazy, meaning - that upstream 'Pipe's are only evaluated as far as necessary to generate - enough input for downstream 'Pipe's. If any 'Pipe' terminates, it also - terminates every 'Pipe' composed with it. --} - --- | 'Pipe's form a 'Category' instance when you rearrange the type variables -newtype PipeC m r a b = PipeC { unPipeC :: Pipe a b m r} - -instance (Monad m) => Category (PipeC m r) where - id = PipeC idP - PipeC p1 . PipeC p2 = PipeC $ p1 <+< p2 - --- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<+<) :: (Monad m) => Pipe b c m r -> Pipe a b m r -> Pipe a c m r -(Yield b p1) <+< p2 = Yield b (p1 <+< p2) -(M m ) <+< p2 = M (m >>= \p1 -> return (p1 <+< p2)) -(Pure r ) <+< _ = Pure r -(Await k ) <+< (Yield b p2) = k b <+< p2 -p1 <+< (Await k) = Await (\a -> p1 <+< k a) -p1 <+< (M m) = M (m >>= \p2 -> return (p1 <+< p2)) -_ <+< (Pure r) = Pure r - --- | Corresponds to ('>>>') from @Control.Category@ -(>+>) :: (Monad m) => Pipe a b m r -> Pipe b c m r -> Pipe a c m r -p2 >+> p1 = p1 <+< p2 - -{- These associativities might help performance since pipe evaluation is - downstream-biased. I set them to the same priority as (.). -} -infixr 9 <+< -infixl 9 >+> - --- | Corresponds to 'id' from @Control.Category@ -idP :: (Monad m) => Pipe a a m r -idP = go where - go = Await (\a -> Yield a go) - -{- $runpipe - Note that you can also unwrap a 'Pipe' a single step at a time using - 'runFreeT' (since 'Pipe' is just a type synonym for a free monad - transformer). This will take you to the next /external/ 'await' or 'yield' - statement. This means that a closed 'Pipeline' will unwrap to a single - step, in which case you would have been better served by 'runPipe'. --} -{-| - Run the 'Pipe' monad transformer, converting it back into the base monad. - - 'runPipe' imposes two conditions: - - * The pipe's input, if any, is trivially satisfiable (i.e. @()@) - - * The pipe does not 'yield' any output - - The latter restriction makes 'runPipe' less polymorphic than it could be, - and I settled on the restriction for three reasons: - - * It prevents against accidental data loss. - - * It protects against silent failures - - * It prevents wastefully draining a scarce resource by gratuitously - driving it to completion - - If you believe that discarding output is the appropriate behavior, you can - specify this by explicitly feeding your output to a pipe that gratuitously - discards it: - -> runPipe $ forever await <+< p --} -runPipe :: (Monad m) => Pipeline m r -> m r -runPipe pl = go pl where - go p = case p of - Yield _ p' -> go p' - Await k -> go (k ()) - M m -> m >>= go - Pure r -> return r diff --git a/Control/Pipe/Tutorial.hs b/Control/Pipe/Tutorial.hs deleted file mode 100644 --- a/Control/Pipe/Tutorial.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-| - This module provides the tutorial for "Control.Pipe". --} - -module Control.Pipe.Tutorial ( - -- * Types - -- $type - - -- * Composition - -- $compose - - -- * Modularity - -- $modular - - -- * Vertical Concatenation - -- $vertical - - -- * Return Values - -- $return - - -- * Termination - -- $terminate - - -- * Folds - -- $folds - - -- * Resource Management - -- $resource - - -- * Bidirectional Pipes - -- $bidirectional - ) where - --- For documentation -import Control.Category -import Control.Frame hiding (await, yield) -import Control.Monad.Trans.Class -import Control.Pipe - -{- $type - This library represents unidirectional streaming computations using the - 'Pipe' type. - - 'Pipe' is a monad transformer that extends the base monad with the ability - to 'await' input from or 'yield' output to other 'Pipe's. 'Pipe's resemble - enumeratees in other libraries because they receive an input stream and - transform it into a new output stream. - - I'll introduce our first 'Pipe', which is a verbose version of the Prelude's - 'take' function: - -> take' :: Int -> Pipe a a IO () -> take' n = do -> replicateM_ n $ do -> x <- await -> yield x -> lift $ putStrLn "You shall not pass!" - - This 'Pipe' forwards the first @n@ values it receives undisturbed, then it - outputs a cute message. - - Let's dissect the above 'Pipe''s type to learn a bit about how 'Pipe's work: - -> | Input Type | Output Type | Base monad | Return value -> Pipe a a IO () - - So @take'@ 'await's input values of type \'@a@\' from upstream 'Pipe's and - 'yield's output values of type \'@a@\' to downstream 'Pipe's. @take'@ uses - 'IO' as its base monad because it invokes the 'putStrLn' function. If we - were to remove the call to 'putStrLn', the compiler would infer the - following type instead, which is polymorphic in the base monad: - -> take' :: (Monad m) => Int -> Pipe a a m () - - Now let's create a function that converts a list into a 'Pipe' by 'yield'ing - each element of the list: - -> fromList :: (Monad m) => [b] -> Pipe a b m () -> fromList = mapM_ yield - - Note that @fromList xs@ is polymorphic in its input. This is because it - does not 'await' any input. If we wanted, we could type-restrict it to: - -> fromList :: (Monad m) => [b] -> Pipe () b m () - - There is no type that forbids a 'Pipe' from 'await'ing, but you can - guarantee that if it does 'await', the request is trivially satisfiable by - supplying it with @()@. - - A 'Pipe' that doesn't 'await' (any useful input) can serve as the first - stage in a 'Pipeline'. I provide a type synonym for this common case: - -> type Producer b m r = Pipe () b m r - - 'Producer's resemble enumerators in other libraries because they function as - data sources. - - You can then use the 'Producer' type synonym to rewrite the type signature - for @fromList@ as: - -> fromList :: (Monad m) => [b] -> Producer b m () - - Now let's create a 'Pipe' that prints every value delivered to it: - -> printer :: (Show b) => Pipe b c IO r -> printer = forever $ do -> x <- await -> lift $ print x - - Here, @printer@ is polymorphic in its output. We could type-restrict it to - guarantee it will never 'yield' by setting the output to 'C', an unhabited - type that \'@C@\'loses the output end: - -> printer :: (Show b) => Pipe b C IO r - - A 'Pipe' that never 'yield's can be the final stage in a 'Pipeline'. Again, - I provide a type synonym for this common case: - -> type Consumer b m r = Pipe b C m r - - So we could instead write @printer@'s type as: - -> printer :: (Show b) => Consumer b IO r - - 'Consumer's resemble iteratees in other libraries because they function as - data sinks. --} - -{- $compose - What distinguishes 'Pipe's from every other iteratee implementation is that - they form a true 'Category'. Because of this, you can literally compose - 'Pipe's into 'Pipeline's using ordinary composition: - -> newtype PipeC m r a b = PipeC { unPipeC :: Pipe a b m r } -> instance Category (PipeC m r) where ... - - For example, you can compose the above 'Pipe's with: - -> pipeline :: Pipe () C IO () -> pipeline = unPipeC $ PipeC printer . PipeC (take' 3) . PipeC (fromList [1..]) - - The compiler deduces that the final 'Pipe' must be blocked at both ends, - meaning it will never 'await' useful input and it will never 'yield' any - output. This represents a self-contained 'Pipeline' and I provide a type - synonym for this common case: - -> type Pipeline m r = Pipe () C m r - - Also, I provide '<+<' as a convenience operator for composing 'Pipe's - without the burden of wrapping and unwrapping newtypes: - -> p1 <+< p2 == unPipeC $ PipeC p1 . PipeC p2 - - So you can rewrite @pipeline@ as: - -> pipeline :: Pipeline IO () -> pipeline = printer <+< take' 3 <+< fromList [1..] - - Like many other monad transformers, you convert the 'Pipe' monad back to the - base monad using some sort of \"@run...@\" function. In this case, it's the - 'runPipe' function: - -> runPipe :: (Monad m) => Pipeline m r -> m r - - 'runPipe' only works on self-contained 'Pipeline's, but you don't need to - worry about explicitly type-restricting any of your 'Pipe's. Self-contained - 'Pipeline's will automatically have polymorphic input and output ends and - they will type-check when you provide them to 'runPipe'. - - Let's try using 'runPipe': - ->>> runPipe pipeline -1 -2 -3 -You shall not pass! - - Fascinating! Our 'Pipe' terminates even though @printer@ never terminates - and @fromList@ never terminates when given an infinite list. To illustrate - why our 'Pipe' terminates, let's outline the 'Pipe' flow control rules for - composition: - - * 'Pipe's are lazy, so execution begins at the most downstream 'Pipe' - (@printer@ in our example). - - * When a 'Pipe' 'await's, it blocks until it receives input from the next - 'Pipe' upstream - - * When a 'Pipe' 'yield's, it blocks until it receives a new 'await' request - from downstream. - - * If a 'Pipe' terminates, it terminates every other 'Pipe' composed with it. - - All of these flow control rules uniquely follow from the 'Category' laws. - - It might surprise you that termination brings down the entire 'Pipeline' - until you realize that: - - * Downstream 'Pipe's depending on the result from the terminated 'Pipe' - cannot proceed - - * Upstream 'Pipe's won't be further evaluated because the terminated 'Pipe' - will not request any further input from them - - So in our previous example, the 'Pipeline' terminated because \"@take' 3@\" - terminated and brought down the entire 'Pipeline' with it. - - Actually, these flow control rules will mislead you into thinking that - composed 'Pipe's behave as a collection of sub-'Pipe's with some sort of - message passing architecture between them, but nothing could be further from - the truth! When you compose 'Pipe's, they automatically fuse into a single - 'Pipe' that corresponds to how you would have written the control flow by - hand. - - For example, if you compose @printer@ and @fromList@: - -> printer <+< fromList [1..] - - The result is indistinguishable from: - -> lift (mapM_ print [1..]) - - ... which is what we would have written by hand if we had not used 'Pipe's - at all! All 'runPipe' does is just remove the 'lift'! --} - -{- $modular - Given a loop like: - -> loop :: IO r -> loop = forever $ do -> x <- dataSource -> y <- processData x -> dataSink y - - We could decompose it into three separate parts: - -> stage1 :: Producer a IO r -> stage1 = forever $ do -> x <- dataSource -> yield x -> -> stage2 :: Pipe a b IO r -> stage2 = forever $ do -> x <- await -> y <- processData x -> yield y -> -> -> stage3 :: Consumer b IO r -> stage3 = forever $ do -> y <- await -> dataSink y -> -> stage3 <+< stage2 <+< stage1 = lift loop - - In other words, 'Pipe's let you decompose loops into modular components, - which promotes loose coupling and allows you to freely mix and match those - components. - - To demonstrate this, let's define a new data source that indefinitely - prompts the user for integers: - -> prompt :: Producer Int IO a -> prompt = forever $ do -> lift $ putStrLn "Enter a number: " -> n <- read <$> lift getLine -> yield n - - Now we can use it as a drop-in replacement for @fromList@: - ->>> runPipe $ printer <+< take' 3 <+< prompt -Enter a number: -1 -1 -Enter a number: -2 -2 -Enter a number: -3 -3 -You shall not pass! - --} - -{- $vertical - You can easily \"vertically\" concatenate 'Pipe's, 'Producer's, and - 'Consumer's, all using simple monad sequencing: ('>>'). For example, here - is how you concatenate 'Producer's: - ->>> runPipe $ printer <+< (fromList [1..3] >> fromList [10..12]) -1 -2 -3 -10 -11 -12 - - Here's how you would concatenate 'Consumer's: - ->>> let print' n = printer <+< take' n :: (Show a) => Int -> Consumer a IO () ->>> runPipe $ (print' 3 >> print' 4) <+< fromList [1..] -1 -2 -3 -You shall not pass! -4 -5 -6 -7 -You shall not pass! - - ... but the above example is gratuitous because we could have just - concatenated the intermediate @take'@ 'Pipe': - ->>> runPipe $ printer <+< (take' 3 >> take' 4) <+< fromList [1..] -1 -2 -3 -You shall not pass! -4 -5 -6 -7 -You shall not pass! - --} - -{- $return - 'Pipe' composition imposes an important requirement: You can only compose - 'Pipe's that have the same return type. For example, I could write the - following function: - -> deliver :: (Monad m) => Int -> Consumer a m [a] -> deliver n = replicateM n await - - ... and I might try to compose it with @fromList@: - ->>> runPipe $ deliver 3 <+< fromList [1..10] -- wrong! - - ... but this wouldn't type-check, because @fromList@ has a return type of - @()@ and @deliver@ has a return type of @[Int]@. Composition requires that - every 'Pipe' has a return value ready in case it terminates first. - - Fortunately, we don't have to rewrite the @fromList@ function because we can - just add a return value using vertical concatenation: - ->>> runPipe $ deliver 3 <+< (fromList [1..10] >> return []) -[1,2,3] - - ... although a more idiomatic Haskell version would be: - ->>> runPipe $ (Just <$> deliver 3) <+< (fromList [1..10] *> pure Nothing) -Just [1,2,3] - - This forces you to cover all code paths by thinking about what return value - you would provide if something were to go wrong. For example, let's say I - were to make a mistake and request more input than @fromList@ can deliver: - ->>> runPipe $ (Just <$> deliver 99) <+< (fromList [1..10] *> pure Nothing) -Nothing - - The type system saved me by forcing me to cover all corner cases and handle - every way my program could terminate. --} - -{- $terminate - - Now what if you wanted to write a 'Pipe' that only reads from its input end - (i.e. a 'Consumer') and returns a list of every value delivered to it when - its input 'Pipe' terminates? - -> toList :: (Monad m) => Consumer a m [a] -> toList = ??? - - You can't write such a 'Pipe' because if its input terminates then it brings - down @toList@ with it! This is correct because @toList@ as defined is not - compositional (yet!). - - To see why, let's say you somehow got @toList@ to work and the following - imaginary code sample worked: - ->>> runPipe $ toList <+< (fromList [1..5] >> return []) -[1,2,3,4,5] - - @toList@ is defined to return its value when the 'Pipe' immediately upstream - (@fromList@ in this case) terminates. This behavior immediately leads to a - problem. What if I were to insert an \"identity\" 'Pipe' between @toList@ - and @fromList@: - -> identity = forever $ await >>= yield -> -- This is how id is actually implemented! - - This 'Pipe' forwards every valued untouched, so we would expect it to not - have any affect if we were to insert it in the middle: - ->>> runPipe $ toList <+< identity <+< (fromList [1..5] >> return []) -??? -- Oops! Something other than [1,2,3,4,5], perhaps even non-termination - - The answer couldn't be @[1,2,3,4,5]@ because @toList@ would monitor - @identity@ instead of @fromList@ and since @identity@ never terminates - @toList@ never terminates. This is what I mean when I say that @toList@'s - specified behavior is non-compositional. It only works if it is coupled - directly to the desired 'Pipe' and breaks when you introduce intermediate - stages. - - Note that a terminated 'Pipe' only brings down 'Pipe's composed with it. To - illustrate this, let's use the following example: - -> p = do a <+< b -> c - - @a@, @b@, and @c@ are 'Pipe's, and @c@ shares the same input and output as - the composite 'Pipe' @a <+< b@, otherwise we cannot combine them within the - same monad. In the above example, either @a@ or @b@ could terminate and - bring down the other one since they are composed, but @c@ is guaranteed to - continue after @a <+< b@ terminates because it is not composed with them. - Conceptually, we can think of this as @c@ automatically taking over the - 'Pipe''s channeling responsibilities when @a <+< b@ can no longer continue. - There is no need to \"restart\" the input or output manually as in some - other iteratee libraries. - - The @pipes@ library, unlike other iteratee libraries, grounds its vertical - and horizontal concatenation in category theory by deriving horizontal - concatenation ('.') from its 'Category' instance and vertical concatenation - ('>>') from its 'Monad' instance. This makes it easier to reason about - 'Pipe's because you can leverage your intuition about 'Category's and - 'Monad's to understand their behavior. The only 'Pipe'-specific primitives - are 'await' and 'yield'. --} - -{- $folds - While we cannot intercept termination, we can still fold our input. We can - embed 'WriterT' in our base monad, since 'Pipe' is a monad transformer, and - store the result in the monoid: - -> toList :: Consumer a (WriterT [a] m) r -> toList = forever $ do -> a <- await -> lift $ tell [a] - ->>> execWriterT $ runPipe $ toList <+< fromList [1..4] -[1,2,3,4] - - But what if other pipes have a base monad that is not compatible, such as: - -> prompt3 :: Producer Int IO a -> prompt3 = take' 3 <+< prompt - - That's okay, because we can transparently 'lift' any Pipe's base monad, - using 'hoistFreeT' from @Control.Monad.Trans.Free@ in the @free@ package: - ->>> execWriterT $ runPipe $ toList <+< hoistFreeT lift prompt3 -3 -4 -6 -[3,4,6] - --} - -{- $resource - Pipes handle streaming computations well, but do not handle resource - management well. To see why, let's say we have the file \"@test.txt@\" - with the following contents: - -> Line 1 -> Line 2 -> Line 3 - - .. and we wish to lazily read one line at a time from it: - -> readFile' :: Handle -> Producer Text IO () -> readFile' h = do -> eof <- lift $ hIsEOF h -> when (not eof) $ do -> s <- lift $ hGetLine h -> yield s -> readFile' h - - We could then try to be slick and write a lazy version that only reads as - many lines as we request: - -> read' :: FilePath -> Producer Text IO () -> read' file = do -> lift $ putStrLn "Opening file ..." -> h <- lift $ openFile file ReadMode -> readFile' h -> lift $ putStrLn "Closing file ..." -> lift $ hClose h - - Now compose! - ->>> runPipe $ printer <+< read' "test.xt" -Opening file ... -"Line 1" -"Line 2" -"Line 3" -Closing file ... - - So far, so good. Equally important, the file is never opened if we replace - @printer@ with a 'Pipe' that never demands input: - ->>> runPipe $ (lift $ putStrLn "I don't need input") <+< read' "test.txt" -I don't need input - - There is still one problem, though. What if we wrote: - ->>> runPipe $ printer <+< take' 2 <+< read' "test.txt" -Opening file ... -"Line 1" -"Line 2" -You shall not pass! - - Oh no! While it was lazy and only read two lines from the file, it was also - too lazy to properly close our file! \"@take' 2@\" terminated before - @read'@, preventing @read'@ from properly closing \"test.txt\". This is why - 'Pipe' composition fails to guarantee deterministic finalization. - - The "Control.Frame" module of this library provides a temporary solution to - this problem, but in the longer run there will be a more elegant solution - built on top of "Control.Proxy". --} - -{- $bidirectional - The 'Pipe' type suffers from one restriction: it only handles a - unidirectional flow of information. If you want a bidirectional 'Pipe' - type, then use the 'Proxy' type from "Control.Proxy", which generalizes the - 'Pipe' type to bidirectional flow. - - More importantly, the 'Proxy' type is a strict superset of the 'Pipe' type, - so all 'Pipe' utilities and extensions are actually written as 'Proxy' - utilities and extensions, in order to avoid code duplication. - - So if you want to use these extensions, import "Control.Proxy" instead, - which exports a backwards compatible 'Pipe' implementation along with all - utilities and extensions. The 'Pipe' implementation in "Control.Pipe.Core" - exists purely as a reference implementation for people who wish to study the - simpler 'Pipe' type when building their own iteratee libraries. --} diff --git a/Control/Proxy.hs b/Control/Proxy.hs --- a/Control/Proxy.hs +++ b/Control/Proxy.hs @@ -1,32 +1,35 @@ --- | Default imports for the "Control.Proxy" hierarchy +{-| Recommended entry import for this library + Read "Control.Proxy.Tutorial" for an extended proxy tutorial. -} + module Control.Proxy ( -- * Modules - -- $modules - module Control.Proxy.Class, + -- $default module Control.Proxy.Core, - module Control.Proxy.Pipe, - module Control.Proxy.Trans, - module Control.Proxy.Prelude + module Control.Proxy.Core.Fast ) where -import Control.Proxy.Class import Control.Proxy.Core -import Control.Proxy.Pipe -import Control.Proxy.Trans -import Control.Proxy.Prelude +import Control.Proxy.Core.Fast hiding (Request, Respond, M, Pure) -{- $modules - "Control.Proxy.Core" provides the core 'Proxy' type. +{- $default + "Control.Proxy.Core" exports everything except 'runProxy'. - "Control.Proxy.Class" provides the abstract interface to 'Proxy' operations. + This library provides two base proxy implementations, each of which export + their own 'runProxy' function: - "Control.Proxy.Trans" provides proxy transformers. + * "Control.Proxy.Core.Fast": This runs faster for code that is not + 'IO'-bound, but it only obeys the monad transformer laws modulo safe + observation functions. - "Control.Proxy.Pipe" provides a backwards-compatible re-implementation of - 'Pipe's. + * "Control.Proxy.Core.Correct": This trades speed on pure code segments, but + strictly preserves the monad transformer laws. - "Control.Proxy.Prelude" provides a standard library of proxies. + This module selects the currently recommended implementation (Fast). - Consult "Control.Proxy.Tutorial" for an extended tutorial. + You can switch to the correct implementation by importing + "Control.Proxy.Core" and "Control.Proxy.Core.Correct". + + You can lock in the fast implementation (in case I change the recommended + default) by importing "Control.Proxy.Core" and "Control.Proxy.Core.Fast". -} diff --git a/Control/Proxy/Class.hs b/Control/Proxy/Class.hs --- a/Control/Proxy/Class.hs +++ b/Control/Proxy/Class.hs @@ -1,72 +1,308 @@ -{-| This module provides an abstract interface to 'Proxy'-like behavior, so that - multiple proxy implementations can share the same library of utility - proxies. -} +{-# LANGUAGE Rank2Types #-} +{-| The 'Proxy' class defines the library's core API. Everything else in this + library builds exclusively on top of the 'Proxy' type class so that all + proxy implementations and extensions can share the same standard library. + + Several of these type classes duplicate methods from familiar type-classes + (such as ('?>=') duplicating ('>>=')). You do NOT need to use these + duplicate methods. Instead, read the \"Polymorphic proxies\" section below + which explains their purpose and how they help clean up type signatures. -} + module Control.Proxy.Class ( - -- * Proxy composition - Channel(..), - -- * Proxy request and respond + -- * Core proxy class + Proxy(..), + idT, + coidT, + (<-<), + (<~<), + + -- * request/respond substitution Interact(..), + (/ lift . k >-> p +> +> hoist f . k >-> p +-} infixr 7 <-< infixl 7 >-> infixr 8 /\ infixl 8 \<\ infixr 8 />/ +infixl 1 ?>= -- This should match the fixity of >>= -{-| The 'Channel' class defines an interface to a bidirectional flow of - information. +{-| The core API for the @pipes@ library - Laws: + You should only use 'request', 'respond', and ('>->') + I only provide ('>~>') for theoretical symmetry, and the remaining methods + just implement internal type class plumbing. +-} +class Proxy p where + {-| 'request' input from upstream, passing an argument with the request + + @request a'@ passes @a'@ as a parameter to upstream that upstream may + use to decide what response to return. 'request' binds the upstream's + response of type @a@ to its own return value. -} + request :: (Monad m) => a' -> p a' a b' b m a + + {-| 'respond' with an output for downstream and bind downstream's next + 'request' + + @respond b@ satisfies a downstream 'request' by supplying the value @b@. + 'respond' blocks until downstream 'request's a new value and binds the + argument of type @b'@ from the next 'request' as its return value. -} + respond :: (Monad m) => b -> p a' a b' b m b' + + {-| Compose two proxies blocked on a 'respond', generating a new proxy + blocked on a 'respond' + + Begins from the downstream end and satisfies every 'request' with a + 'respond' -} + (>->) + :: (Monad m) + => (b' -> p a' a b' b m r) + -> (c' -> p b' b c' c m r) + -> (c' -> p a' a c' c m r) + + {-| Compose two proxies blocked on a 'request', generating a new proxy + blocked on a 'request' + + Begins from the upstream end and satisfies every 'respond' with a + 'request' -} + (>~>) + :: (Monad m) + => (a -> p a' a b' b m r) + -> (b -> p b' b c' c m r) + -> (a -> p a' a c' c m r) + + {-| 'return_P' is identical to 'return', except with a more polymorphic + constraint. -} + return_P :: (Monad m) => r -> p a' a b' b m r + + {-| ('?>=') is identical to ('>>='), except with a more polymorphic + constraint. -} + (?>=) + :: (Monad m) + => p a' a b' b m r -> (r -> p a' a b' b m r') -> p a' a b' b m r' + + {-| 'lift_P' is identical to 'lift', except with a more polymorphic + constraint. -} + lift_P :: (Monad m) => m r -> p a' a b' b m r + + {-| 'hoist_P' is identical to 'hoist', except with a more polymorphic + constraint. -} + hoist_P + :: (Monad m) + => (forall r . m r -> n r) -> (p a' a b' b m r' -> p a' a b' b n r') + +{-| 'idT' forwards requests followed by responses + +> idT = request >=> respond >=> idT +-} +idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r +idT = go where + go a' = + request a' ?>= \a -> + respond a ?>= \a'2 -> + go a'2 +-- idT = foreverK $ request >=> respond + +{-| 'coidT' forwards responses followed by requests + +> coidT = respond >=> request >=> coidT +-} +coidT :: (Monad m, Proxy p) => a -> p a' a a' a m r +coidT = go where + go a = + respond a ?>= \a' -> + request a' ?>= \a2 -> + go a2 +-- coidT = foreverK $ respond >=> request + +{-| Compose two proxies blocked on a 'respond', generating a new proxy blocked + on a 'respond' + + Begins from the downstream end and satisfies every 'request' with a + 'respond' -} +(<-<) + :: (Monad m, Proxy p) + => (c' -> p b' b c' c m r) + -> (b' -> p a' a b' b m r) + -> (c' -> p a' a c' c m r) +p1 <-< p2 = p2 >-> p1 + +{-| Compose two proxies blocked on a 'request', generating a new proxy blocked + on a 'request' + + Begins from the upstream end and satisfies every 'respond' with a 'request' + + You don't need to use this. I include it only for symmetry. -} +(<~<) + :: (Monad m, Proxy p) + => (b -> p b' b c' c m r) + -> (a -> p a' a b' b m r) + -> (a -> p a' a c' c m r) +p1 <~< p2 = p2 >~> p1 + +-- | Two extra Proxy categories of theoretical interest +class Interact p where + -- | @f \\>\\ g@ replaces all 'request's in 'g' with 'f'. + (\>\) :: (Monad m) + => (b' -> p a' a x' x m b) + -> (c' -> p b' b x' x m c) + -> (c' -> p a' a x' x m c) + + -- | @f \/>\/ g@ replaces all 'respond's in 'f' with 'g'. + (/>/) :: (Monad m) + => (a -> p x' x b' b m a') + -> (b -> p x' x c' c m b') + -> (a -> p x' x c' c m a') + +-- | @f \/<\/ g@ replaces all 'request's in 'f' with 'g'. +(/ (c' -> p b' b x' x m c) + -> (b' -> p a' a x' x m b) + -> (c' -> p a' a x' x m c) +p1 /\ p1 + +-- | @f \\<\\ g@ replaces all 'respond's in 'g' with 'f'. +(\<\) :: (Monad m, Interact p) + => (b -> p x' x c' c m b') + -> (a -> p x' x b' b m a') + -> (a -> p x' x c' c m a') +p1 \<\ p2 = p2 />/ p1 + +{- $laws + The 'Proxy' class defines an interface to all core proxy capabilities that + all proxy-like types must implement. + + First, all proxies must support a bidirectional flow of information, defined + by: + + * ('>->') + + * ('>~>') + + * 'request' + + * 'respond' + + Intuitively, both @p1 >-> p2@ and @p1 >~> p2@ pair each 'request' in @p2@ + with a 'respond' in @p1@. ('>->') accepts proxies blocked on 'respond' and + begins from the downstream end, whereas ('>~>') accepts proxies blocked on + 'request' and begins from the upstream end. + + Second, all proxies are monads, defined by: + + * 'return_P' + + * ('?>=') + + These must satify the monad laws using @(>>=) = (?>=)@ and + @return = return_P@. + + Third, all proxies are monad transformers, defined by: + + * 'lift_P' + + This must satisfy the monad transformer laws, using @lift = lift_P@. + + Fourth, all proxies are functors in the category of monads, defined by: + + * 'hoist_P' + + This must satisfy the functor laws, using @hoist = hoist_P@. + + All 'Proxy' instances must satisfy these additional laws: + * ('>->') and 'idT' form a category: -> idT >-> f = f +> Define: idT = request >=> respond >=> idT > -> f >-> idT = f +> idT >-> p = p > -> (f >-> g) >-> h = f >-> (g >-> h) +> p >-> idT = p +> +> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) - Minimal complete definition: + * ('>~>') and 'coidT' form a category: - * 'idT' +> Define: coidT = respond >=> request >=> coidT +> +> coidT >~> p = p +> +> p >~> coidT = p +> +> (p1 >~> p2) >~> p3 = p1 >~> (p2 >~> p3) - * ('>->') or ('<-<'). --} -class Channel p where - {-| 'idT' acts like a \'T\'ransparent proxy, passing all requests further - upstream, and passing all responses further downstream. -} - idT :: (Monad m) => a' -> p a' a a' a m r + * @(hoistK f)@ defines a functor between proxy categories: - {-| Compose two proxies, satisfying all requests from downstream with - responses from upstream. -} - (>->) :: (Monad m) - => (b' -> p a' a b' b m r) - -> (c' -> p b' b c' c m r) - -> (c' -> p a' a c' c m r) - p1 >-> p2 = p2 <-< p1 +> Define: hoistK f = (hoist f .) +> +> hoistK f (p1 >-> p2) = hoistK f p1 >-> hoistK p2 +> +> hoistK f idT = idT +> +> hoistK f (p1 >~> p2) = hoistK f p1 >~> hoistK p2 +> +> hoistK f coidT = coidT - {-| Compose two proxies, satisfying all requests from downstream with - responses from upstream. -} - (<-<) :: (Monad m) - => (c' -> p b' b c' c m r) - -> (b' -> p a' a b' b m r) - -> (c' -> p a' a c' c m r) - p1 <-< p2 = p2 >-> p1 + Also, all proxies must satisfy the following 'Proxy' laws: -{-| The 'Interact' class defines the ability to: +> -- Define: liftK = (lift .) +> +> p1 >-> liftK f = liftK f +> +> p1 >-> (liftK f >=> respond >=> p2) = liftK f >=> respond >=> (p1 >-> p2) +> +> (liftK g >=> respond >=> p1) >-> (liftK f >=> request >=> liftK h >=> p2) +> = liftK (f >=> g >=> h) >=> (p1 >-> p2) +> +> (liftK g >=> request >=> p1) >-> (liftK f >=> request >=> p2) +> = liftK (f >=> g) >=> request >=> (p1 >~> p2) +> +> liftK f >~> p2 = liftK f +> +> (liftK f >=> request >=> p1) >~> p2 = liftK f >=> request >=> (p1 >~> p2) +> +> (liftK f >=> respond >=> liftK h >=> p1) >~> (liftK g >=> request >=> p2) +> = liftK (f >=> g >=> h) >=> (p1 >~> p2) +> +> (liftK f >=> respond >=> p1) >~> (liftK g >=> respond >=> p2) +> = liftK (f >=> g) >=> (p1 >-> p2) - * Request input using the 'request' command + The 'Interact' class exists primarily for theoretical interest and to + justify some of the functor laws for the 'ProxyTrans' type class. You will + probably never use it. + The 'Interact' class defines the ability to: + * Replace existing 'request' commands using ('\>\') - * Respond with output using the 'respond' command - * Replace existing 'respond' commands using ('/>/') Laws: @@ -87,56 +323,130 @@ > > (f />/ g) />/ h = f />/ (g />/ h) - Minimal complete definition: + Additionally, ('\>\') and ('/>/') distribute in one direction over Kleisli + composition: - * 'request', +> a \>\ (b >=> c) = (a \>\ b) >=> (a \>\ c) +> +> a \>\ return = return - * ('\>\') or ('/ (b >=> c) />/ a = (b />/ a) >=> (c />/ a) +> +> return />/ a = return +-} - * 'respond', and +{- $poly + Many of these type classes contain methods which copy methods from more + familiar type classes. These duplicate methods serve two purposes. - * ('/>/') or ('\<\'). --} -class Interact p where - {-| 'request' input from upstream, passing an argument with the request + First, this library requires type class instances that would otherwise be + impossible to define without providing higher-kinded constraints. Rather + than use the following illegal polymorphic constraint: - @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 to its own return value. -} - request :: (Monad m) => a' -> p a' a x' x m a +> instance (forall a' a b' b . MonadTrans (p a' a b' b)) => ... - -- | @f \\>\\ g@ replaces all 'request's in 'g' with 'f'. - (\>\) :: (Monad m) - => (b' -> p a' a x' x m b) - -> (c' -> p b' b x' x m c) - -> (c' -> p a' a x' x m c) - p1 \>\ p2 = p2 / (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 +> instance (MonadTransP p) => ... - {-| '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 from the next 'request' as its return value. -} - respond :: (Monad m) => a -> p x' x a' a m a' + Second, these type classes don't require the @FlexibleContexts@ extension + to use and substantially clean up constraints in type signatures. They + convert messy constraints like this: - -- | @f \/>\/ g@ replaces all 'respond's in 'f' with 'g'. - (/>/) :: (Monad m) - => (a -> p x' x b' b m a') - -> (b -> p x' x c' c m b') - -> (a -> p x' x c' c m a') - p1 />/ p2 = p2 \<\ p1 +> p :: (MonadP (p a' a b' b m), MonadTrans (p a' a b' b)) => ... - -- | @f \\<\\ g@ replaces all 'respond's in 'g' with 'f'. - (\<\) :: (Monad m) - => (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 + .. into cleaner and more general constraints like this: + +> P :: (Proxy p) => ... + + These type classes exist solely for internal plumbing and you should never + directly use the duplicate methods from them. Instead, you can use all the + original type classes as long as you embed your proxy code within at least + one proxy transformer (or 'IdentityP' if don't use any transformers). The + type-class machinery will then automatically convert the messier and less + polymorphic constraints to the simpler and more general constraints. + + For example, consider the following almost-correct definition for @mapMD@ + (from "Control.Proxy.Prelude.Base"): + +> import Control.Monad.Trans.Class +> import Control.Proxy +> +> mapMD f = foreverK $ \a' -> do +> a <- request a' +> b <- lift (f a) +> respond b + + The compiler infers the following messy constraint: + +> mapMD +> :: (Monad m, Monad (p x a x b m), MonadTrans (p x a x b), Proxy p) +> => (a -> m b) -> x -> p x a x b m r + + Instead, you can embed the code in the @IdentityP@ proxy transformer by + wrapping it in 'runIdentityK': + +> -- |difference| +> mapMD f = runIdentityK $ foreverK $ \a' -> do +> a <- request a' +> b <- lift (f a) +> respond b + + ... and now the compiler collapses all the constraints into the 'Proxy' + constraint: + +> mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r + + You do not incur any performance penalty for writing polymorphic code or + embedding it in 'IdentityP'. This library employs several rewrite @RULES@ + which transform your polymorphic code into the equivalent type-specialized + hand-tuned code. These rewrite rules fire very robustly and they do not + require any assistance on your part from compiler pragmas like @INLINE@, + @NOINLINE@ or @SPECIALIZE@. + + If you nest proxies within proxies: + +> example () = do +> request () +> lift $ request () +> lift $ lift $ request () + + ... then you can still keep the nice constraints using: + +> example () = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ do +> request () +> lift $ request () +> lift $ lift $ request () + + You don't need to use 'runIdentityP' \/ 'runIdentityK' if you use any other + proxy transformers (In fact you can't, it's a type error). The following + code example illustrates this, where the 'throw' command (from the 'EitherP' + proxy transformer) suffices to guide the compiler to the cleaner type + signature: + +> import Control.Monad +> import Control.Proxy +> import qualified Control.Proxy.Trans.Either as E +> +> example :: (Monad m, Proxy p) => () -> Producer (EitherP String p) Char m () +> example () = do +> c <- request () +> when (c == ' ') $ E.throw "Error: received space" +> respond c +-} + +{-| The @(MonadPlusP p)@ constraint is equivalent to the following constraint: + +> (forall a' a b' b m . (Monad m) => MonadPlus (p a' a b' b m)) => ... +-} +class (Proxy p) => MonadPlusP p where + mzero_P :: (Monad m) => p a' a b' b m r + mplus_P + :: (Monad m) => p a' a b' b m r -> p a' a b' b m r -> p a' a b' b m r + +{-| The @(MonadIOP p)@ constraint is equivalent to the following constraint: + +> (forall a' a b' b m . (MonadIO m) => MonadIO (p a' a b' b m)) => ... +-} +class (Proxy p) => MonadIOP p where + liftIO_P :: (MonadIO m) => IO r -> p a' a b' b m r diff --git a/Control/Proxy/Core.hs b/Control/Proxy/Core.hs --- a/Control/Proxy/Core.hs +++ b/Control/Proxy/Core.hs @@ -1,217 +1,45 @@ -{-| A 'Proxy' 'request's input from upstream and 'respond's with output to - downstream. - - For an extended tutorial, consult "Control.Proxy.Tutorial". -} +-- | Default imports for the "Control.Proxy" hierarchy module Control.Proxy.Core ( - -- * Types - Proxy(..), - C, - Server, - Client, - Session, - -- * Run Sessions - -- $run - runProxy, - runProxyK, - runSession, - runSessionK, - -- * Utility Proxies - -- $utility - discard, - ignore + -- * Modules + -- $modules + module Control.Proxy.Class, + module Control.Proxy.Synonym, + module Control.Proxy.Prelude, + module Control.Proxy.Trans, + module Control.Proxy.Trans.Identity, + module Control.Monad, + module Control.Monad.Trans.Class, + module Control.MFunctor ) where -import Control.Applicative (Applicative(pure, (<*>))) -import Control.Monad (ap, forever, liftM, (>=>)) -import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.MFunctor (MFunctor(hoist)) +import Control.Monad (forever, (>=>), (<=<)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class ( - Channel(idT, (<-<)), Interact(request, (/ Proxy a' a b' b m r ) - | Respond b (b' -> Proxy a' a b' b m r ) - | M (m (Proxy a' a b' b m r)) - | Pure r - -instance (Monad m) => Functor (Proxy a' a b' b m) where - fmap f p0 = go p0 where - go p = case p of - Request a' fa -> Request a' (\a -> go (fa a )) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure r -> Pure (f r) - -instance (Monad m) => Applicative (Proxy a' a b' b m) where - pure = Pure - pf <*> px = go pf where - go p = case p of - Request a' fa -> Request a' (\a -> go (fa a )) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure f -> fmap f px - -instance (Monad m) => Monad (Proxy a' a b' b m) where - return = Pure - p0 >>= f = go p0 where - go p = case p of - Request a' fa -> Request a' (\a -> go (fa a)) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure r -> f r - -instance MonadTrans (Proxy a' a b' b) where - lift = M . liftM Pure - -instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where - liftIO = M . liftIO . liftM Pure - -instance Channel Proxy where - idT = \a' -> Request a' $ \a -> Respond a idT - k1 <-< k2_0 = \c' -> k1 c' |-< k2_0 where - p1 |-< k2 = case p1 of - Request b' fb -> fb <-| k2 b' - Respond c fc' -> Respond c (\c' -> fc' c' |-< k2) - M m -> M (m >>= \p1' -> return (p1' |-< k2)) - Pure r -> Pure r - fb <-| p2 = case p2 of - Request a' fa -> Request a' (\a -> fb <-| fa a) - Respond b fb' -> fb b |-< fb' - M m -> M (m >>= \p2' -> return (fb <-| p2')) - Pure r -> Pure r - -instance Interact Proxy where - request a' = Request a' Pure - k1 / go (k1 a') where - go p = case p of - Request b' fb -> k2 b' >>= \b -> go (fb b) - Respond x fx' -> Respond x (\x' -> go (fx' x')) - M m -> M (m >>= \p' -> return (go p')) - Pure a -> Pure a - respond a = Respond a Pure - k1 \<\ k2 = \a' -> go (k2 a') where - go p = case p of - Request x' fx -> Request x' (\x -> go (fx x)) - Respond b fb' -> k1 b >>= \b' -> go (fb' b') - M m -> M (m >>= \p' -> return (go p')) - Pure a -> Pure a - -instance MFunctor (Proxy a' a b' b) where - mapT nat p0 = go p0 where - go p = case p of - Request a' fa -> Request a' (\a -> go (fa a )) - Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (nat (m >>= \p' -> return (go p'))) - Pure r -> Pure r - -{-| @Server req resp@ receives requests of type @req@ and sends responses of - type @resp@. - - 'Server's only 'respond' and never 'request' anything. -} -type Server req resp = Proxy C () req resp - -{-| @Client req resp@ sends requests of type @req@ and receives responses of - type @resp@. - - 'Client's only 'request' and never 'respond' to anything. -} -type Client req resp = Proxy req resp () C - -{-| A self-contained 'Session', ready to be run by 'runSession' - - 'Session's never 'request' anything or 'respond' to anything. -} -type Session = Proxy C () () C - -{- $run - I provide two ways to run proxies: - - * 'runProxy', which discards unhandled output from either end - - * 'runSession', which type restricts its argument to ensure no loose ends - - Both functions require that the input to each end is trivially satisfiable, - (i.e. @()@). - - I recommend 'runProxy' for most use cases since it is more convenient. - - 'runSession' only accepts sessions that do not send unhandled data flying - off each end, which provides the following benefits: - - * It prevents against accidental data loss. - - * It protects against silent failures - - * It prevents wastefully draining a scarce resource by gratuitously - driving it to completion - - However, this restriction means that you must either duplicate every utility - function to specialize them to the end-point positions (which I do not do), - or explicitly close loose ends using the 'discard' and 'ignore' proxies: +import Control.Proxy.Class +import Control.Proxy.Synonym +import Control.Proxy.Trans +import Control.Proxy.Trans.Identity +import Control.Proxy.Prelude -> runSession $ discard <-< p <-< ignore +{- $modules + "Control.Proxy.Class" defines the 'Proxy' type class that lets you program + generically over proxy implementations and their transformers. - Use the \'@K@\' versions of each command if you are running sessions nested - within sessions. They provide a Kleisli arrow as their result suitable to - be passed to another 'runProxy' / 'runSession' command. --} + "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. -{-| Run a self-sufficient 'Proxy' Kleisli arrow, converting it back to the base - monad -} -runProxy :: (Monad m) => (() -> Proxy 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 + "Control.Proxy.Prelude" provides a standard library of proxies. -{-| Run a self-sufficient 'Proxy' Kleisli arrow, converting it back to a Kleisli - arrow in the base monad -} -runProxyK :: (Monad m) => (() -> Proxy a () () b m r) -> (() -> m r) -runProxyK p = \() -> runProxy p + "Control.Proxy.Trans" defines the 'ProxyTrans' type class that lets you + write your own proxy extensions. -{-| Run a self-contained 'Session' Kleisli arrow, converting it back to the base - monad -} -runSession :: (Monad m) => (() -> Session m r) -> m r -runSession = runProxy + "Control.Proxy.Trans.Identity" exports 'runIdentityP', which substantially + eases writing completely polymorphic proxies. -{-| Run a self-contained 'Session' Kleisli arrow, converting it back to a - Kleisli arrow in the base monad -} -runSessionK :: (Monad m) => (() -> Session m r) -> (() -> m r) -runSessionK = runProxyK + "Control.Monad" exports 'forever', ('>=>'), and ('<=<'). -{- $utility - 'discard' provides a fallback client that gratuitously 'request's input - from a server, but discards all responses. + "Control.Monad.Trans.Class" exports 'lift'. - 'ignore' provides a fallback server that trivially 'respond's with output - to a client, but ignores all request parameters. + "Control.MFunctor" exports 'hoist'. -} - --- | Discard all responses -discard :: (Monad m) => () -> Proxy () a () C m r -discard _ = go where - go = Request () (\_ -> go) - --- | Ignore all requests -ignore :: (Monad m) => a -> Proxy C () a () m r -ignore _ = go where - go = Respond () (\_ -> go) diff --git a/Control/Proxy/Core/Correct.hs b/Control/Proxy/Core/Correct.hs new file mode 100644 --- /dev/null +++ b/Control/Proxy/Core/Correct.hs @@ -0,0 +1,186 @@ +{-| This module provides the correct proxy implementation which strictly + enforces the monad transformer laws. You can safely import this module + without violating any laws or invariants. + + However, I advise that you stick to the 'Proxy' type class API rather than + import this module so that your code works with both 'Proxy' implementations + and also works with all proxy transformers. -} + +module Control.Proxy.Core.Correct ( + -- * Types + ProxyCorrect(..), + ProxyF(..), + + -- * Run Sessions + -- $run + runProxy, + runProxyK, + runPipe + ) where + +import Control.Applicative (Applicative(pure, (<*>))) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.MFunctor (MFunctor(hoist)) +import Control.Proxy.Class +import Control.Proxy.Synonym (C) + +{-| A 'ProxyCorrect' communicates with an upstream interface and a downstream + interface. + + The type variables of @ProxyCorrect req_a' resp_a req_b' resp_b m r@ + signify: + + * @req_a'@ - The request supplied to the upstream interface + + * @resp_a@ - The response provided by the upstream interface + + * @req_b'@ - The request supplied by the downstream interface + + * @resp_b@ - The response provided to the downstream interface + + * @m @ - The base monad + + * @r @ - The final return value -} +data ProxyCorrect a' a b' b m r = + Proxy { unProxy :: m (ProxyF a' a b' b r (ProxyCorrect a' a b' b m r)) } + +-- | The base functor for the 'ProxyCorrect' type +data ProxyF a' a b' b r x + = Request a' (a -> x) + | Respond b (b' -> x) + | Pure r + +instance (Monad m) => Functor (ProxyCorrect a' a b' b m) where + fmap f p0 = go p0 where + go p = Proxy (do + x <- unProxy p + return (case x of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure (f r) ) ) + +instance (Monad m) => Applicative (ProxyCorrect a' a b' b m) where + pure r = Proxy (return (Pure r)) + pf <*> px = go pf where + go p = Proxy (do + x <- unProxy p + case x of + Request a' fa -> return (Request a' (\a -> go (fa a ))) + Respond b fb' -> return (Respond b (\b' -> go (fb' b'))) + Pure f -> unProxy (fmap f px) ) + +instance (Monad m) => Monad (ProxyCorrect a' a b' b m) where + return = \r -> Proxy (return (Pure r)) + p0 >>= f = go p0 where + go p = Proxy (do + x <- unProxy p + case x of + Request a' fa -> return (Request a' (\a -> go (fa a ))) + Respond b fb' -> return (Respond b (\b' -> go (fb' b'))) + Pure r -> unProxy (f r) ) + +instance MonadTrans (ProxyCorrect a' a b' b) where + lift = lift_P + +instance (MonadIO m) => MonadIO (ProxyCorrect a' a b' b m) where + liftIO m = Proxy (liftIO (m >>= \r -> return (Pure r))) + -- liftIO = Proxy . liftIO . liftM Pure + +instance MonadIOP ProxyCorrect where + liftIO_P = liftIO + +instance Proxy ProxyCorrect where + fb'_0 >-> fc' = \c' -> fb'_0 >-| fc' c' where + fb' >-| p1 = Proxy (do + x <- unProxy p1 + case x of + Request b' fb -> unProxy (fb' b' |-> fb) + Respond c fc' -> return (Respond c (\c' -> fb' >-| fc' c')) + Pure r -> return (Pure r) ) + p2 |-> fb = Proxy (do + x <- unProxy p2 + case x of + Request a' fa -> return (Request a' (\a -> fa a |-> fb)) + Respond b fb' -> unProxy (fb' >-| fb b) + Pure r -> return (Pure r) ) + + fa_0 >~> fb_0 = \a -> fa_0 a |-> fb_0 where + fb' >-| p1 = Proxy (do + x <- unProxy p1 + case x of + Request b' fb -> unProxy (fb' b' |-> fb) + Respond c fc' -> return (Respond c (\c' -> fb' >-| fc' c')) + Pure r -> return (Pure r) ) + p2 |-> fb = Proxy (do + x <- unProxy p2 + case x of + Request a' fa -> return (Request a' (\a -> fa a |-> fb)) + Respond b fb' -> unProxy (fb' >-| fb b) + Pure r -> return (Pure r) ) + + request a' = Proxy (return (Request a' (\a -> Proxy (return (Pure a ))))) + respond b = Proxy (return (Respond b (\b' -> Proxy (return (Pure b'))))) + + return_P = return + (?>=) = (>>=) + + lift_P m = Proxy (m >>= \r -> return (Pure r)) + + hoist_P = hoist + +instance Interact ProxyCorrect where + k2 \>\ k1 = \a' -> go (k1 a') where + go p = Proxy (do + x <- unProxy p + case x of + Request b' fb -> unProxy (k2 b' >>= \b -> go (fb b)) + Respond x fx' -> return (Respond x (\x' -> go (fx' x'))) + Pure a -> return (Pure a) ) + k2 />/ k1 = \a' -> go (k2 a') where + go p = Proxy (do + x <- unProxy p + case x of + Request x' fx -> return (Request x' (\x -> go (fx x))) + Respond b fb' -> unProxy (k1 b >>= \b' -> go (fb' b')) + Pure a -> return (Pure a) ) + +instance MFunctor (ProxyCorrect a' a b' b) where + hoist nat p0 = go p0 where + go p = Proxy (nat (do + x <- unProxy p + return (case x of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + Pure r -> Pure r ))) + +{- $run + The following commands run self-sufficient proxies, converting them back to + the base monad. + + These are the only functions specific to the 'ProxyCorrect' type. + Everything else programs generically over the 'Proxy' type class. + + Use 'runProxyK' if you are running proxies nested within proxies. It + provides a Kleisli arrow as its result that you can pass to another + 'runProxy' / 'runProxyK' command. -} + +{-| Run a self-sufficient 'ProxyCorrect' Kleisli arrow, converting it back to + the base monad -} +runProxy :: (Monad m) => (() -> ProxyCorrect a' () () b m r) -> m r +runProxy k = go (k ()) where + go p = do + x <- unProxy p + case x of + Request _ fa -> go (fa ()) + Respond _ fb' -> go (fb' ()) + Pure r -> return r + +{-| Run a self-sufficient 'ProxyCorrect' Kleisli arrow, converting it back to a + Kleisli arrow in the base monad -} +runProxyK :: (Monad m) => (() -> ProxyCorrect a' () () b m r) -> (() -> m r) +runProxyK p = \() -> runProxy p + +-- | Run the 'Pipe' monad transformer, converting it back to the base monad +runPipe :: (Monad m) => ProxyCorrect a' () () b m r -> m r +runPipe p = runProxy (\_ -> p) diff --git a/Control/Proxy/Core/Fast.hs b/Control/Proxy/Core/Fast.hs new file mode 100644 --- /dev/null +++ b/Control/Proxy/Core/Fast.hs @@ -0,0 +1,238 @@ +{-| This is an internal module, meaning that it is unsafe to import unless you + understand the risks. + + This module provides the fast proxy implementation, which achieves its speed + by weakening the monad transformer laws. These laws do not hold if you can + pattern match on the constructors, as the following counter-example + illustrates: + +> lift . return = M . return . Pure +> +> return = Pure +> +> lift . return /= return + + These laws only hold when viewed through certain safe observation functions, + like 'runProxy' and 'observe'. + + Also, you really should not use the constructors anyway, let alone the + concrete type and instead you should stick to the 'Proxy' type class API. + This not only ensures that your code does not violate the monad transformer + laws, but also guarantees that it works with the other proxy implementations + and with any proxy transformers. -} + +module Control.Proxy.Core.Fast ( + -- * Types + ProxyFast(..), + + -- * Run Sessions + -- $run + runProxy, + runProxyK, + runPipe, + + -- * Safety + observe + ) where + +import Control.Applicative (Applicative(pure, (<*>))) +-- import Control.Monad (ap, forever, liftM, (>=>)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.MFunctor (MFunctor(hoist)) +import Control.Proxy.Class +import Control.Proxy.Synonym (C) + +{-| A 'ProxyFast' communicates with an upstream interface and a downstream + interface. + + The type variables of @ProxyFast req_a' resp_a req_b' resp_b m r@ signify: + + * @req_a'@ - The request supplied to the upstream interface + + * @resp_a@ - The response provided by the upstream interface + + * @req_b'@ - The request supplied by the downstream interface + + * @resp_b@ - The response provided to the downstream interface + + * @m @ - The base monad + + * @r @ - The final return value -} +data ProxyFast a' a b' b m r + = Request a' (a -> ProxyFast a' a b' b m r ) + | Respond b (b' -> ProxyFast a' a b' b m r ) + | M (m (ProxyFast a' a b' b m r)) + | Pure r + +instance (Monad m) => Functor (ProxyFast a' a b' b m) where + fmap f p0 = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> Pure (f r) + +instance (Monad m) => Applicative (ProxyFast a' a b' b m) where + pure = Pure + pf <*> px = go pf where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure f -> fmap f px + +instance (Monad m) => Monad (ProxyFast a' a b' b m) where + return = Pure + (>>=) = _bind + +_bind + :: (Monad m) + => ProxyFast a' a b' b m r + -> (r -> ProxyFast a' a b' b m r') + -> ProxyFast a' a b' b m r' +p0 `_bind` f = go p0 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a)) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (m >>= \p' -> return (go p')) + Pure r -> f r + +-- | Only satisfies laws modulo 'observe' +instance MonadTrans (ProxyFast a' a b' b) where + lift = _lift + +_lift :: (Monad m) => m r -> ProxyFast a' a b' b m r +_lift m = M (m >>= \r -> return (Pure r)) +-- _lift = M . liftM Pure + +{- These never fire, for some reason, but keep them until I figure out how to + get them to work. -} +{-# RULES + "_lift m ?>= f" forall m f . + _bind (_lift m) f = M (m >>= \r -> return (f r)) + #-} + +instance (MonadIO m) => MonadIO (ProxyFast a' a b' b m) where + liftIO m = M (liftIO (m >>= \r -> return (Pure r))) + -- liftIO = M . liftIO . liftM Pure + +instance MonadIOP ProxyFast where + liftIO_P = liftIO + +instance Proxy ProxyFast where + fb'_0 >-> fc'_0 = \c' -> fb'_0 >-| fc'_0 c' where + p1 |-> fb = case p1 of + Request a' fa -> Request a' (\a -> fa a |-> fb) + Respond b fb' -> fb' >-| fb b + M m -> M (m >>= \p1' -> return (p1' |-> fb)) + Pure r -> Pure r + fb' >-| p2 = case p2 of + Request b' fb -> fb' b' |-> fb + Respond c fc' -> Respond c (\c' -> fb' >-| fc' c') + M m -> M (m >>= \p2' -> return (fb' >-| p2')) + Pure r -> Pure r + + fa_0 >~> fb_0 = \a -> fa_0 a |-> fb_0 where + p1 |-> fb = case p1 of + Request a' fa -> Request a' (\a -> fa a |-> fb) + Respond b fb' -> fb' >-| fb b + M m -> M (m >>= \p1' -> return (p1' |-> fb)) + Pure r -> Pure r + fb' >-| p2 = case p2 of + Request b' fb -> fb' b' |-> fb + Respond c fc' -> Respond c (\c' -> fb' >-| fc' c') + M m -> M (m >>= \p2' -> return (fb' >-| p2')) + Pure r -> Pure r + + request a' = Request a' Pure + respond b = Respond b Pure + + return_P = return + (?>=) = _bind + + lift_P = _lift + + hoist_P = hoist + +{-# RULES + "_bind (Request a' Pure) f" forall a' f . + _bind (Request a' Pure) f = Request a' f; + "_bind (Respond b Pure) f" forall b f . + _bind (Respond b Pure) f = Respond b f + #-} + +instance Interact ProxyFast where + k2 \>\ k1 = \a' -> go (k1 a') where + go p = case p of + Request b' fb -> k2 b' >>= \b -> go (fb b) + Respond x fx' -> Respond x (\x' -> go (fx' x')) + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a + k2 />/ k1 = \a' -> go (k2 a') where + go p = case p of + Request x' fx -> Request x' (\x -> go (fx x)) + Respond b fb' -> k1 b >>= \b' -> go (fb' b') + M m -> M (m >>= \p' -> return (go p')) + Pure a -> Pure a + +instance MFunctor (ProxyFast a' a b' b) where + hoist nat p0 = go (observe p0) where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (nat (m >>= \p' -> return (go p'))) + Pure r -> Pure r + +{- $run + The following commands run self-sufficient proxies, converting them back to + the base monad. + + These are the only functions specific to the 'ProxyFast' type. Everything + else programs generically over the 'Proxy' type class. + + Use 'runProxyK' if you are running proxies nested within proxies. It + provides a Kleisli arrow as its result that you can pass to another + 'runProxy' / 'runProxyK' command. -} + +{-| Run a self-sufficient 'ProxyFast' Kleisli arrow, converting it back to the + base monad -} +runProxy :: (Monad m) => (() -> ProxyFast a' () () b m r) -> m r +runProxy k = go (k ()) where + go p = case p of + Request _ fa -> go (fa ()) + Respond _ fb' -> go (fb' ()) + M m -> m >>= go + Pure r -> return r + +{-| Run a self-sufficient 'ProxyFast' Kleisli arrow, converting it back to a + Kleisli arrow in the base monad -} +runProxyK :: (Monad m) => (() -> ProxyFast a' () () b m r) -> (() -> m r) +runProxyK p = \() -> runProxy p + +-- | Run the 'Pipe' monad transformer, converting it back to the base monad +runPipe :: (Monad m) => ProxyFast a' () () b m r -> m r +runPipe p = runProxy (\_ -> p) + +{-| The monad transformer laws are correct when viewed through the 'observe' + function: + +> observe (lift (return r)) = observe (return r) +> +> observe (lift (m >>= f)) = observe (lift m >>= lift . f) + + This correctness comes at a moderate cost to performance, so use this + function sparingly or else you would be better off using + "Control.Proxy.Core.Correct". + + You do not need to use this function if you use the safe API exported from + "Control.Proxy", which does not export any functions or constructors that + can violate the monad transformer laws. +-} +observe :: (Monad m) => ProxyFast a' a b' b m r -> ProxyFast a' a b' b m r +observe p = M (go p) where + go p = case p of + M m' -> m' >>= go + Pure r -> return (Pure r) + Request a' fa -> return (Request a' (\a -> observe (fa a ))) + Respond b fb' -> return (Respond b (\b' -> observe (fb' b'))) diff --git a/Control/Proxy/Pipe.hs b/Control/Proxy/Pipe.hs --- a/Control/Proxy/Pipe.hs +++ b/Control/Proxy/Pipe.hs @@ -1,90 +1,197 @@ -{-| This module provides an API compatible with "Control.Pipe" +{-# LANGUAGE KindSignatures #-} - Consult "Control.Pipe.Core" for more extensive documentation and - "Control.Pipe.Tutorial" for an extended tutorial. -} +{-| This module provides an API similar to "Control.Pipe" for those who prefer + the classic 'Pipe' API. + This module differs slightly from "Control.Pipe" in order to promote + seamless interoperability with both pipes and proxies. See the \"Upgrade + Pipes to Proxies\" section below for details. -} module Control.Proxy.Pipe ( - -- * Types - Pipe, - Producer, - Consumer, - Pipeline, -- * Create Pipes await, yield, pipe, + -- * Compose Pipes (<+<), (>+>), idP, - -- * Run Pipes - runPipe - ) where -import Control.Proxy.Core -import Control.Proxy.Class -import Data.Closed (C) - -{-| The type variables of @Pipe a b m r@ signify: - - * @a@ - The type of input received from upstream pipes - - * @b@ - The type of output delivered to downstream pipes - - * @m@ - The base monad - - * @r@ - The type of the return value -} -type Pipe a b = Proxy () a () b + -- * Synonyms + Pipeline, --- | A pipe that produces values -type Producer b = Pipe () b + -- * Run Pipes + -- $run --- | A pipe that consumes values -type Consumer a = Pipe a C + -- * Upgrade Pipes to Proxies + -- $upgrade + ) where --- | A self-contained pipeline that is ready to be run -type Pipeline = Pipe () C +import Control.Monad (forever) +import Control.Proxy.Class (Proxy(request, respond, (>->), (?>=))) +import Control.Proxy.Synonym (Pipe, Consumer, Producer, C) +import Control.Proxy.Trans.Identity (runIdentityP) {-| Wait for input from upstream - 'await' blocks until input is available -} -await :: (Monad m) => Pipe a b m a + 'await' blocks until input is available from upstream. -} +await :: (Monad m, Proxy p) => Pipe p a b m a await = request () -{-# INLINE await #-} --- | Convert a pure function into a pipe -pipe :: (Monad m) => (a -> b) -> Pipe a b m r -pipe f = go where - go = Request () (\a -> Respond (f a) (\() -> go)) - {-| Deliver output downstream - 'yield' restores control back downstream and binds the result to 'await'. -} -yield :: (Monad m) => b -> Pipe a b m () -yield = respond -{-# INLINE yield #-} + 'yield' restores control back downstream and binds its value to 'await'. -} +yield :: (Monad m, Proxy p) => b -> p a' a b' b m () +yield b = runIdentityP $ do + respond b + return () +-- | Convert a pure function into a pipe +pipe :: (Monad m, Proxy p) => (a -> b) -> Pipe p a b m r +pipe f = runIdentityP $ forever $ do + a <- request () + respond (f a) + infixr 9 <+< infixl 9 >+> -- | Corresponds to ('<<<')/('.') from @Control.Category@ -(<+<) :: (Monad m) => Pipe b c m r -> Pipe a b m r -> Pipe a c m r -p1 <+< p2 = ((\() -> p1) <-< (\() -> p2)) () +(<+<) + :: (Monad m, Proxy p) => Pipe p b c m r -> Pipe p a b m r -> Pipe p a c m r +p1 <+< p2 = p2 >+> p1 -- | Corresponds to ('>>>') from @Control.Category@ -(>+>) :: (Monad m) => Pipe a b m r -> Pipe b c m r -> Pipe a c m r -(>+>) = flip (<+<) +(>+>) + :: (Monad m, Proxy p) => Pipe p a b m r -> Pipe p b c m r -> Pipe p a c m r +p1 >+> p2 = ((\() -> p1) >-> (\() -> p2)) () -- | Corresponds to 'id' from @Control.Category@ -idP :: (Monad m) => Pipe a a m r -idP = go where - go = Request () (\a -> Respond a (\() -> go)) +idP :: (Monad m, Proxy p) => Pipe p a a m r +idP = runIdentityP $ forever $ do + a <- request () + respond a --- | Run the 'Pipe' monad transformer, converting it back to the base monad -runPipe :: (Monad m) => Pipeline m r -> m r -runPipe p' = go p' where - go p = case p of - Request _ fa -> go (fa ()) - Respond _ fb' -> go (fb' ()) - M m -> m >>= go - Pure r -> return r +{-| A self-contained 'Pipeline' that is ready to be run + + 'Pipeline's never 'request' nor 'respond'. -} +type Pipeline (p :: * -> * -> * -> * -> (* -> *) -> * -> *) = p C () () C + +{- $run + The "Control.Proxy.Core.Fast" and "Control.Proxy.Core.Correct" modules + provide their corresponding 'runPipe' functions, specialized to their own + 'Proxy' implementations. + + Each implementation must supply its own 'runPipe' function since it is + the only non-polymorphic 'Pipe' function and the compiler uses it to + select which underlying proxy implementation to use. -} + +{- $upgrade + You can upgrade classic 'Pipe' code to work with the proxy ecosystem in + steps. Each change enables greater interoperability with proxy utilities + and transformers and if time permits you should implement the entire upgrade + for your libraries if you want to take advantage of proxy standard + libraries. + + First, import "Control.Proxy" and "Control.Proxy.Pipe" instead of + "Control.Pipe". Then, add 'ProxyFast' after every 'Pipe', 'Producer', or + 'Consumer' in any type signature. For example, you would convert this: + +> import Control.Pipe +> +> fromList :: (Monad m) => [b] -> Producer b m () +> fromList xs = mapM_ yield xs + + ... to this: + +> import Control.Proxy +> import Control.Proxy.Pipe -- transition import +> +> fromList :: (Monad m) => [b] -> Producer ProxyFast b m () +> fromList xs = mapM_ yield xs + + The change ensures that all your code now works in the 'ProxyFast' monad, + which is the faster of the two proxy implementations. + + Second, modify all your 'Pipe's to take an empty '()' as their final + argument, and translate the following functions: + + * ('<+<') to ('<-<') + + * 'runPipe' to 'runProxy' + + For example, you would convert this: + +> import Control.Proxy +> import Control.Proxy.Pipe +> +> fromList :: (Monad m) => [b] -> Producer ProxyFast b m () +> fromList xs = mapM_ yield xs + + ... to this: + +> import Control.Proxy +> import Control.Proxy.Pipe +> +> fromList :: (Monad m) => [b] -> () -> Producer ProxyFast b m () +> fromList xs () = mapM_ yield xs + + Now when you call these within a @do@ block you must supplying an + additional @()@ argument: + +> examplePipe () = do +> a <- request () +> fromList [1..a] () + + This change lets you switch from pipe composition, ('<+<'), to proxy + composition, ('<-<'), so that you can mix proxy utilities with pipes. + + Third, wrap your pipe's implementation in 'runIdentityP' (which + "Control.Proxy" exports): + +> import Control.Proxy +> import Control.Proxy.Pipe +> +> fromList xs () = runIdentityP $ mapM_ yield xs + + Then replace the 'ProxyFast' in the type signature with a type variable @p@ + constrained by the 'Proxy' type class: + +> fromList :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () + + This change upgrades your 'Pipe' to work natively within proxies and proxy + transformers, without any manual conversion or lifting. You can now compose + or sequence your 'Pipe' within any feature set transparently. + + Finally, replace each 'await' with @request ()@ and each 'yield' with + 'respond'. Also, replace every 'Pipeline' with 'Session'. This lets you + drop the "Control.Proxy.Pipe" import: + +> import Control.Proxy +> +> fromList :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () +> fromList xs () = runIdentityP $ mapM_ respond xs + + Also, I encourage you to continue using the 'Pipe', 'Consumer' and + 'Producer' type synonyms to simplify type signatures. The following + examples show how they cleanly mix with proxies and their extensions: + +> import Control.Proxy +> import Control.Proxy.Trans.Either as E +> import Control.Proxy.Trans.State +> +> -- A Producer enriched with pipe-local state +> example1 :: (Monad m, Proxy p) => () -> Producer (StateP Int p) Int m r +> example1 () = forever $ do +> n <- get +> respond n +> put (n + 1) +> +> -- A Consumer enriched with error-handling +> example2 :: (Proxy p) => () -> Consumer (EitherP String p) Int IO () +> example2 () = do +> n <- request () +> if (n == 0) +> then E.throw "Error: received 0" +> else lift $ print n + +-} diff --git a/Control/Proxy/Prelude.hs b/Control/Proxy/Prelude.hs --- a/Control/Proxy/Prelude.hs +++ b/Control/Proxy/Prelude.hs @@ -1,6 +1,7 @@ -- | Entry point for the Control.Proxy.Prelude hierarchy module Control.Proxy.Prelude ( + -- * Modules -- $modules module Control.Proxy.Prelude.Base, module Control.Proxy.Prelude.IO, @@ -17,5 +18,4 @@ "Control.Proxy.Prelude.IO" provides proxies for simple 'IO'. "Control.Proxy.Prelude.Kleisli" provides convenience functions for working - with Kleisli arrows. --} + with Kleisli arrows. -} diff --git a/Control/Proxy/Prelude/Base.hs b/Control/Proxy/Prelude/Base.hs --- a/Control/Proxy/Prelude/Base.hs +++ b/Control/Proxy/Prelude/Base.hs @@ -2,15 +2,19 @@ module Control.Proxy.Prelude.Base ( -- * Maps - mapB, mapD, mapU, - mapMB, + mapB, mapMD, mapMU, - execB, + mapMB, + useD, + useU, + useB, execD, execU, + execB, + -- * Filters takeB, takeB_, @@ -22,45 +26,94 @@ dropWhileU, filterD, filterU, + -- * Lists fromListS, fromListC, + -- * Enumerations enumFromS, enumFromC, enumFromToS, - enumFromToC - ) where + enumFromToC, -import Control.Monad (replicateM_, void, when, (>=>)) -import Control.Monad.Trans.Class (lift) -import Control.Proxy.Class (request, respond, idT) -import Control.Proxy.Core (Proxy(..), Server, Client) -import Control.Proxy.Prelude.Kleisli (foreverK, replicateK) + -- * 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', -{-| @(mapB f g)@ applies @f@ to all values going downstream and @g@ to all - values going upstream. + -- * Zips and Merges + zipD, + mergeD, - Mnemonic: map \'@B@\'idirectional + -- * Closed Adapters + -- $open + unitD, + unitU, -> mapB f1 g1 >-> mapB f2 g2 = mapB (f2 . f1) (g1 . g2) -> -> mapB id id = idT --} -mapB :: (Monad m) => (a -> b) -> (b' -> a') -> b' -> Proxy a' a b' b m r -mapB f g = go where - go b' = Request (g b') (\a -> Respond (f a) go) --- mapB f g = foreverK $ request . g >=> respond . f + -- * Modules + -- $modules + module Control.Monad.Trans.State.Strict, + module Control.Monad.Trans.Writer.Strict, + module Data.Monoid + ) where +import Control.MFunctor (hoist) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Writer.Strict ( + WriterT(runWriterT), execWriterT, runWriter, tell ) +import Control.Monad.Trans.State.Strict ( + StateT(runStateT), execStateT, runState, execState, get, put ) +import Control.Proxy.Class +import Control.Proxy.Synonym +import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK) +import Data.Monoid ( + Monoid, + Endo(Endo, appEndo), + All(All, getAll), + Any(Any, getAny), + Sum(Sum, getSum), + Product(Product, getProduct), + First(First, getFirst), + Last(Last, getLast) ) + {-| @(mapD f)@ applies @f@ to all values going \'@D@\'ownstream. > mapD f1 >-> mapD f2 = mapD (f2 . f1) > > mapD id = idT -} -mapD :: (Monad m) => (a -> b) -> x -> Proxy x a x b m r -mapD f = go where - go x = Request x (\a -> Respond (f a) go) +mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r +mapD f = runIdentityK go where + go x = do + a <- request x + x2 <- respond (f a) + go x2 -- mapD f = foreverK $ request >=> respond . f {-| @(mapU g)@ applies @g@ to all values going \'@U@\'pstream. @@ -69,26 +122,30 @@ > > mapU id = idT -} -mapU :: (Monad m) => (b' -> a') -> b' -> Proxy a' x b' x m r -mapU g = go where - go b' = Request (g b') (\x -> Respond x go) +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 -{-| @(mapMB f g)@ applies the monadic function @f@ to all values going - downstream and the monadic function @g@ to all values going upstream. +{-| @(mapB f g)@ applies @f@ to all values going downstream and @g@ to all + values going upstream. -> mapMB f1 g1 >-> mapMB f2 g2 = mapMB (f1 >=> f2) (g2 >=> g1) + Mnemonic: map \'@B@\'idirectional + +> mapB f1 g1 >-> mapB f2 g2 = mapB (f2 . f1) (g1 . g2) > -> mapMB return return = idT +> mapB id id = idT -} -mapMB :: (Monad m) => (a -> m b) -> (b' -> m a') -> b' -> Proxy a' a b' b m r -mapMB f g = go where - go b' = - M (g b' >>= \a' -> return ( - Request a' (\a -> - M (f a >>= \b -> return ( - Respond b go ))))) --- mapMB f g = foreverK $ lift . g >=> request >=> lift . f >=> respond +mapB :: (Monad m, Proxy p) => (a -> b) -> (b' -> a') -> b' -> p a' a b' b m r +mapB f g = runIdentityK go where + go b' = do + a <- request (g b') + b'2 <- respond (f a ) + go b'2 +-- mapB f g = foreverK $ request . g >=> respond . f {-| @(mapMD f)@ applies the monadic function @f@ to all values going downstream @@ -96,13 +153,14 @@ > > mapMD return = idT -} -mapMD :: (Monad m) => (a -> m b) -> x -> Proxy x a x b m r -mapMD f = go where - go x = - Request x (\a -> - M (f a >>= \b -> return ( - Respond b go ))) --- mapMDf = foreverK $ request >=> lift . f >=> respond +mapMD :: (Monad m, Proxy p) => (a -> m b) -> x -> p x a x b m r +mapMD f = runIdentityK go where + go x = do + a <- request x + b <- lift (f a) + x2 <- respond b + go x2 +-- mapMD f = foreverK $ request >=> lift . f >=> respond {-| @(mapMU g)@ applies the monadic function @g@ to all values going upstream @@ -110,92 +168,166 @@ > > mapMU return = idT -} -mapMU :: (Monad m) => (b' -> m a') -> b' -> Proxy a' x b' x m r -mapMU g = go where - go b' = - M (g b' >>= \a' -> return ( - Request a' (\x -> - Respond x go ))) +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 -{-| @(execB md mu)@ executes @mu@ every time values flow upstream through it, - and executes @md@ every time values flow downstream through it. +{-| @(mapMB f g)@ applies the monadic function @f@ to all values going + downstream and the monadic function @g@ to all values going upstream. -> execB md1 mu1 >-> execB md2 mu2 = execB (md1 >> md2) (mu2 >> mu1) +> mapMB f1 g1 >-> mapMB f2 g2 = mapMB (f1 >=> f2) (g2 >=> g1) > -> execB (return ()) = idT +> mapMB return return = idT -} -execB :: (Monad m) => m () -> m () -> a' -> Proxy a' a a' a m r -execB md mu = go where - go a' = - M (mu >>= \_ -> return ( - Request a' (\a -> - M (md >>= \_ -> return ( - Respond a go ))))) -{- execB md mu = foreverK $ \a' -> do - lift mu - a <- request a' - lift md - respond a -} +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 -{-| @execD md)@ executes @md@ every time values flow downstream through it. +{-| @(useD f)@ executes the monadic function @f@ on all values flowing + \'@D@\'ownstream +> useD f1 >-> useD f2 = useD (\a -> f1 a >> f2 a) +> +> useD (\_ -> return ()) = idT +-} +useD :: (Monad m, Proxy p) => (a -> m r1) -> x -> p x a x a m r +useD f = runIdentityK go where + go x = do + a <- request x + lift $ f a + x2 <- respond a + go x2 + +{-| @(useU g)@ executes the monadic function @g@ on all values flowing + \'@U@\'pstream + +> useU g1 >-> useU g2 = useU (\a' -> g2 a' >> g1 a') +> +> useU (\_ -> return ()) = idT +-} +useU :: (Monad m, Proxy p) => (a' -> m r2) -> a' -> p a' x a' x m r +useU g = runIdentityK go where + go a' = do + lift $ g a' + x <- request a' + a'2 <- respond x + go a'2 + +{-| @(useB f g)@ executes the monadic function @f@ on all values flowing + downstream and the monadic function @g@ on all values flowing upstream + +> useB f1 g1 >-> useB f2 g2 = useB (\a -> f1 a >> f2 a) (\a' -> g2 a' >> g1 a') +> +> useB (\_ -> return ()) (\_ -> return ()) = idT +-} +useB + :: (Monad m, Proxy p) => (a -> m r1) -> (a' -> m r2) -> a' -> p a' a a' a m r +useB f g = runIdentityK go where + go a' = do + lift $ g a' + a <- request a' + lift $ f a + a'2 <- respond a + go a'2 + +{-| @(execD md)@ executes @md@ every time values flow downstream through it. + > execD md1 >-> execD md2 = execD (md1 >> md2) > > execD (return ()) = idT -} -execD :: (Monad m) => m () -> a' -> Proxy a' a a' a m r -execD md = go where - go a' = - Request a' (\a -> - M (md >>= \_ -> return ( - Respond a go ))) +execD :: (Monad m, Proxy p) => m r1 -> a' -> p a' a a' a m r +execD md = runIdentityK go where + go a' = do + a <- request a' + lift md + a'2 <- respond a + go a'2 {- execD md = foreverK $ \a' -> do a <- request a' lift md respond a -} -{-| @execU mu)@ executes @mu@ every time values flow upstream through it. +{-| @(execU mu)@ executes @mu@ every time values flow upstream through it. > execU mu1 >-> execU mu2 = execU (mu2 >> mu1) > > execU (return ()) = idT -} -execU :: (Monad m) => m () -> a' -> Proxy a' a a' a m r -execU mu = go where - go a' = - M (mu >>= \_ -> return ( - Request a' (\a -> - Respond a go ))) +execU :: (Monad m, Proxy p) => m r2 -> a' -> p a' a a' a m r +execU mu = runIdentityK go where + go a' = do + lift mu + a <- request a' + a'2 <- respond a + go a'2 {- execU mu = foreverK $ \a' -> do lift mu a <- request a' respond a -} +{-| @(execB md mu)@ executes @mu@ every time values flow upstream through it, + and executes @md@ every time values flow downstream through it. + +> execB md1 mu1 >-> execB md2 mu2 = execB (md1 >> md2) (mu2 >> mu1) +> +> execB (return ()) = idT +-} +execB :: (Monad m, Proxy p) => m r1 -> m r2 -> a' -> p a' a a' a m r +execB md mu = runIdentityK go where + go a' = do + lift mu + a <- request a' + lift md + a'2 <- respond a + go a'2 +{- execB md mu = foreverK $ \a' -> do + lift mu + a <- request a' + lift md + respond a -} + {-| @(takeB n)@ allows @n@ upstream/downstream roundtrips to pass through > takeB n1 >=> takeB n2 = takeB (n1 + n2) -- n1 >= 0 && n2 >= 0 > > takeB 0 = return -} -takeB :: (Monad m) => Int -> a' -> Proxy a' a a' a m a' -takeB n0 = go n0 where +takeB :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m a' +takeB n0 = runIdentityK (go n0) where go n - | n <= 0 = Pure - | otherwise = \a' -> Request a' (\a -> Respond a (go (n - 1))) + | n <= 0 = return + | otherwise = \a' -> do + a <- request a' + a'2 <- respond a + go (n - 1) a'2 -- takeB n = replicateK n $ request >=> respond -- | 'takeB_' is 'takeB' with a @()@ return value, convenient for composing -takeB_ :: (Monad m) => Int -> a' -> Proxy a' a a' a m () -takeB_ n0 = go n0 where +takeB_ :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m () +takeB_ n0 = runIdentityK (go n0) where go n - | n <= 0 = \_ -> Pure () - | otherwise = \a' -> Request a' (\a -> Respond a (go (n - 1))) - + | n <= 0 = \_ -> return () + | otherwise = \a' -> do + a <- request a' + a'2 <- respond a + go (n - 1) a'2 -- takeB_ n = fmap void (takeB n) -{-| @takeWhileD p@ allows values to pass downstream so long as they satisfy the - predicate @p@. +{-| @(takeWhileD p)@ allows values to pass downstream so long as they satisfy + the predicate @p@. > -- Using the "All" monoid over functions: > mempty = \_ -> True @@ -205,41 +337,32 @@ > > takeWhileD mempty = idT -} -takeWhileD :: (Monad m) => (a -> Bool) -> a' -> Proxy a' a a' a m () -takeWhileD p = go where - go a' = - Request a' (\a -> - if (p a) - then Respond a go - else Pure () ) -{- go a' = do +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 () -} + then do + a'2 <- respond a + go a'2 + else return () -{-| @takeWhileU p@ allows values to pass upstream so long as they satisfy the +{-| @(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) => (a' -> Bool) -> a' -> Proxy a' a a' a m () -takeWhileU p = go where +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 Request a' (\a -> Respond a go) - else Pure () -{- go a' = - if (p a') - then do - a <- request a' - a'2 <- respond a - go a'2 - else return () -} + then do + a <- request a' + a'2 <- respond a + go a'2 + else return_P () {-| @(dropD n)@ discards @n@ values going downstream @@ -247,11 +370,13 @@ > > dropD 0 = idT -} -dropD :: (Monad m) => Int -> () -> Proxy () a () a m r -dropD n0 = \() -> go n0 where +dropD :: (Monad m, Proxy p) => Int -> () -> Pipe p a a m r +dropD n0 = \() -> runIdentityP (go n0) where go n | n <= 0 = idT () - | otherwise = Request () (\_ -> go (n - 1)) + | otherwise = do + request () + go (n - 1) {- dropD n () = do replicateM_ n $ request () idT () -} @@ -262,21 +387,15 @@ > > dropU 0 = idT -} -dropU :: (Monad m) => Int -> a' -> Proxy a' () a' () m r -dropU n0 - | n0 <= 0 = idT - | otherwise = go (n0 - 1) where - go n - | n <= 0 = \_ -> Respond () idT - | otherwise = \_ -> Respond () (go (n - 1)) -{- dropU n a' - | n <= 0 = idT a' - | otherwise = do - replicateM_ (n - 1) $ respond () - a'2 <- respond () - idT a'2 -} +dropU :: (Monad m, Proxy p) => Int -> a' -> CoPipe p a' a' m r +dropU n0 = runIdentityK (go n0) where + go n + | n <= 0 = idT + | otherwise = \_ -> do + a' <- respond () + go (n - 1) a' -{-| @(dropWhileD p)@ discards values going upstream until one violates the +{-| @(dropWhileD p)@ discards values going downstream until one violates the predicate @p@. > -- Using the "Any" monoid over functions: @@ -287,33 +406,31 @@ > > dropWhileD mempty = idT -} -dropWhileD :: (Monad m) => (a -> Bool) -> () -> Proxy () a () a m r -dropWhileD p () = go where - go = Request () (\a -> if (p a) then go else Respond a idT) -{- go = do +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 - respond a - idT () -} + then go + else do + x <- respond a + idT x -{-| @(dropWhileU p)@ discards values going downstream until one violates the +{-| @(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) => (a' -> Bool) -> a' -> Proxy a' () a' () m r -dropWhileU p = go where - go a' = if (p a') then Respond () go else idT a' -{- go a' = +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 - a'2 <- respond () - go a'2 - else idT a' -} + then do + a2 <- respond () + go a2 + else idT a' {-| @(filterD p)@ discards values going downstream if they fail the predicate @p@ @@ -326,13 +443,15 @@ > > filterD mempty = idT -} -filterD :: (Monad m) => (a -> Bool) -> () -> Proxy () a () a m r -filterD p = \() -> go where - go = Request () (\a -> if (p a) then Respond a (\_ -> go) else go) -{- go = do +filterD :: (Monad m, Proxy p) => (a -> Bool) -> () -> Pipe p a a m r +filterD p = \() -> runIdentityP go where + go = do a <- request () - when (p a) $ respond a - go -} + if (p a) + then do + respond a + go + else go {-| @(filterU p)@ discards values going upstream if they fail the predicate @p@ @@ -340,65 +459,346 @@ > > filterU mempty = idT -} -filterU :: (Monad m) => (a' -> Bool) -> a' -> Proxy a' () a' () m r -filterU p a'0 = go a'0 where +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 Request a' (\_ -> Respond () go) - else Respond () go -{- go a' = do - when (p a') $ request a' - a'2 <- respond () - go a'2 -} + then do + request a' + a'2 <- respond () + go a'2 + else do + a'2 <- respond () + go a'2 -{-| Convert a list into a 'Server' +{-| Convert a list into a 'Producer' > fromListS xs >=> fromListS ys = fromListS (xs ++ ys) > > fromListS [] = return -} -fromListS :: (Monad m) => [a] -> () -> Proxy x' x () a m () -fromListS xs = \_ -> foldr (\e a -> Respond e (\_ -> a)) (Pure ()) xs -{-# INLINE fromListS #-} +fromListS :: (Monad m, Proxy p) => [b] -> () -> Producer p b m () +fromListS xs = \_ -> foldr (\e a -> respond e ?>= \_ -> a) (return_P ()) xs -- fromListS xs _ = mapM_ respond xs -{-| Convert a list into a 'Client' +{-| Convert a list into a 'CoProducer' > fromListC xs >=> fromListC ys = fromListC (xs ++ ys) > > fromListC [] = return -} -fromListC :: (Monad m) => [a] -> () -> Proxy a x () y m () -fromListC xs = \_ -> foldr (\e a -> Request e (\_ -> a)) (Pure ()) xs -{-# INLINE fromListC #-} +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 --- | 'Server' version of 'enumFrom' -enumFromS :: (Enum a, Monad m) => a -> y' -> Proxy x' x y' a m r -enumFromS a0 = \_ -> go a0 where - go a = Respond a (\_ -> go (succ a)) -{- go a = do - _ <- respond a - go (succ a) -} +-- | '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) --- | 'Client' version of 'enumFrom' -enumFromC :: (Enum a, Monad m) => a -> y' -> Proxy a x y' y m r -enumFromC a0 = \_ -> go a0 where - go a = Request a (\_ -> go (succ a)) -{- go a = do - _ <- request a - go (succ a) -} +-- | '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') --- | 'Server' version of 'enumFromTo' -enumFromToS :: (Enum a, Ord a, Monad m) => a -> a -> y' -> Proxy x' x y' a m () -enumFromToS a1 a2 _ = go a1 where - go n - | n > a2 = Pure () - | otherwise = Respond n (\_ -> go (succ n)) +-- | '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) --- | 'Client' version of 'enumFromTo' -enumFromToC :: (Enum a, Ord a, Monad m) => a -> a -> y' -> Proxy a x y' y m () -enumFromToC a1 a2 _ = go a1 where +-- | '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 = Pure () - | otherwise = Request n (\_ -> go (succ n)) + | n > a2 = return () + | otherwise = do + request n + go (succ n) + +{-| Fold values flowing \'@D@\'ownstream + +> foldD f >-> foldD g = foldD (f <> g) +> +> foldD mempty = idT +-} +foldD + :: (Monad m, Proxy p, Monoid w) => (a -> w) -> x -> p x a x a (WriterT w m) r +foldD f = runIdentityK go where + go x = do + a <- request x + lift $ tell $ f a + x2 <- respond a + go x2 + +{-| Fold values flowing \'@U@\'pstream + +> foldU f >-> foldU g = foldU (g <> f) +> +> foldU mempty = idT +-} +foldU + :: (Monad m, Proxy p, Monoid w) + => (a' -> w) -> a' -> p a' x a' x (WriterT w m) r +foldU f = runIdentityK go where + go a' = do + lift $ tell $ f a' + x <- request a' + a'2 <- respond x + go a'2 + +{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the + predicate -} +allD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) r +allD pred = foldD (All . pred) + +{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the + predicate -} +allU + :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) r +allU pred = foldU (All . pred) + +{-| Fold that returns whether 'All' values flowing \'@D@\'ownstream satisfy the + predicate + + 'allD_' terminates on the first value that fails the predicate -} +allD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT All m) () +allD_ pred = runIdentityK go where + go x = do + a <- request x + if (pred a) + then do + x2 <- respond a + go x2 + else lift $ tell $ All False + +{-| Fold that returns whether 'All' values flowing \'@U@\'pstream satisfy the + predicate + + 'allU_' terminates on the first value that fails the predicate -} +allU_ + :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT All m) () +allU_ pred = runIdentityK go where + go a' = + if (pred a') + then do + x <- request a' + a'2 <- respond x + go a'2 + else lift $ tell $ All False + +{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies + the predicate -} +anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r +anyD pred = foldD (Any . pred) + +{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies + the predicate -} +anyU + :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) r +anyU pred = foldU (Any . pred) + +{-| Fold that returns whether 'Any' value flowing \'@D@\'ownstream satisfies the + predicate + + 'anyD_' terminates on the first value that satisfies the predicate -} +anyD_ :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) () +anyD_ pred = runIdentityK go where + go x = do + a <- request x + if (pred a) + then lift $ tell $ Any True + else do + x2 <- respond a + go x2 + +{-| Fold that returns whether 'Any' value flowing \'@U@\'pstream satisfies the + predicate + + 'anyU_' terminates on the first value that satisfies the predicate -} +anyU_ + :: (Monad m, Proxy p) => (a' -> Bool) -> a' -> p a' x a' x (WriterT Any m) () +anyU_ pred = runIdentityK go where + go a' = + if (pred a') + then lift $ tell $ Any True + else do + x <- request a' + a'2 <- respond x + go a'2 + +-- | Compute the 'Sum' of all values that flow \'@D@\'ownstream +sumD :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Sum a) m) r +sumD = foldD Sum + +-- | Compute the 'Sum' of all values that flow \'@U@\'pstream +sumU :: (Monad m, Proxy p, Num a') => a' -> p a' x a' x (WriterT (Sum a') m) r +sumU = foldU Sum + +-- | Compute the 'Product' of all values that flow \'@D@\'ownstream +productD + :: (Monad m, Proxy p, Num a) => x -> p x a x a (WriterT (Product a) m) r +productD = foldD Product + +-- | Compute the 'Product' of all values that flow \'@U@\'pstream +productU + :: (Monad m, Proxy p, Num a') => a' -> p a' x a' x (WriterT (Product a') m) r +productU = foldU Product + +-- | Count how many values flow \'@D@\'ownstream +lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r +lengthD = foldD (\_ -> Sum 1) + +-- | Count how many values flow \'@U@\'pstream +lengthU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Sum Int) m) r +lengthU = foldU (\_ -> Sum 1) + +-- | Retrieve the first value going \'@D@\'ownstream +headD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) r +headD = foldD (First . Just) + +{-| Retrieve the first value going \'@D@\'ownstream + + 'headD_' terminates on the first value it receives -} +headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () +headD_ x = runIdentityP $ do + a <- request x + lift $ tell $ First (Just a) + +-- | Retrieve the first value going \'@U@\'pstream +headU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) r +headU = foldU (First . Just) + +{-| Retrieve the first value going \'@U@\'pstream + + 'headU_' terminates on the first value it receives -} +headU_ :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (First a') m) () +headU_ a' = runIdentityP $ lift $ tell $ First (Just a') + +-- | Retrieve the last value going \'@D@\'ownstream +lastD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Last a) m) r +lastD = foldD (Last . Just) + +-- | Retrieve the last value going \'@U@\'pstream +lastU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT (Last a') m) r +lastU = foldU (Last . Just) + +-- | Fold the values flowing \'@D@\'ownstream into a list +toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r +toListD = foldD (\x -> [x]) + +-- | Fold the values flowing \'@U@\'pstream into a list +toListU :: (Monad m, Proxy p) => a' -> p a' x a' x (WriterT [a'] m) r +toListU = foldU (\x -> [x]) + +{-| Fold equivalent to 'foldr' + + To see why, consider this isomorphic type for 'foldr': + +> foldr :: (a -> b -> b) -> [a] -> Endo b +-} +foldrD + :: (Monad m, Proxy p) => (a -> b -> b) -> x -> p x a x a (WriterT (Endo b) m) r +foldrD step = foldD (Endo . step) + +-- | Fold equivalent to 'foldr' +foldrU + :: (Monad m, Proxy p) + => (a' -> b -> b) -> a' -> p a' x a' x (WriterT (Endo b) m) r +foldrU step = foldU (Endo . step) + +-- | Left strict fold over \'@D@\'ownstream values +foldlD' + :: (Monad m, Proxy p) => (b -> a -> b) -> x -> p x a x a (StateT b m) r +foldlD' f = runIdentityK go where + go x = do + a <- request x + lift $ do + b <- get + put $! f b a + x2 <- respond a + go x2 + +-- | Left strict fold over \'@U@\'pstream values +foldlU' + :: (Monad m, Proxy p) => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r +foldlU' f = runIdentityK go where + go a' = do + lift $ do + b <- get + put $! f b a' + x <- request a' + a'2 <- respond x + go a'2 + +-- | Zip values flowing downstream +zipD + :: (Monad m, Proxy p1, Proxy p2, Proxy p3) + => () -> Consumer p1 a (Consumer p2 b (Producer p3 (a, b) m)) r +zipD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where + go = do + a <- request () + lift $ do + b <- request () + lift $ respond (a, b) + go + +-- | Interleave values flowing downstream using simple alternation +mergeD + :: (Monad m, Proxy p1, Proxy p2, Proxy p3) + => () -> Consumer p1 a (Consumer p2 a (Producer p3 a m)) r +mergeD () = runIdentityP $ hoist (runIdentityP . hoist runIdentityP) go where + go = do + a1 <- request () + lift $ do + lift $ respond a1 + a2 <- request () + lift $ respond a2 + go + +{- $open + Use the @unit@ functions when you need to embed a proxy with a closed end + within an open proxy. For example, the following code will not type-check + because @fromListS [1..]@ is a 'Producer' and has a closed upstream end, + which conflicts with the 'request' statement preceding it: + +> p () = do +> request () +> fromList [1..] () + + You fix this by composing 'unitD' upstream of it, which replaces its closed + upstream end with an open polymorphic end: + +> p () = do +> request () +> (fromList [1..] <-< unitD) () + +-} + +-- | Compose 'unitD' with a closed upstream end to create a polymorphic end +unitD :: (Monad m, Proxy p) => y' -> p x' x y' () m r +unitD _ = runIdentityP go where + go = do + respond () + go + +-- | Compose 'unitU' with a closed downstream end to create a polymorphic end +unitU :: (Monad m, Proxy p) => y' -> p () x y' y m r +unitU _ = runIdentityP go where + go = do + request () + go + +{- $modules + These modules help you build, run, and extract folds +-} diff --git a/Control/Proxy/Prelude/IO.hs b/Control/Proxy/Prelude/IO.hs --- a/Control/Proxy/Prelude/IO.hs +++ b/Control/Proxy/Prelude/IO.hs @@ -3,8 +3,7 @@ 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. --} + dependencies. -} module Control.Proxy.Prelude.IO ( -- * Standard I/O @@ -25,45 +24,46 @@ promptC, -- * Handle I/O -- ** Input - hGetLineD, - hGetLineU, + hGetLineS, + hGetLineC, -- ** Output hPrintB, hPrintD, hPrintU, hPutStrLnB, hPutStrLnD, - hPutStrLnU + hPutStrLnU, ) where import Control.Monad (forever) import Control.Monad.Trans.Class (lift) import Control.Proxy.Prelude.Kleisli (foreverK) -import Control.Proxy.Core (Proxy, Client, Server) -import Control.Proxy.Class (request, respond) -import System.IO (Handle, hGetLine, hPutStr, hPutStrLn, hPrint, stdin, stdout) +import Control.Proxy.Class (Proxy(request, respond)) +import Control.Proxy.Trans.Identity (runIdentityP, runIdentityK) +import Control.Proxy.Synonym (Client, Server, Producer, CoProducer) +import qualified System.IO as IO --- | Get input from 'stdin' one line at a time and send \'@D@\'ownstream -getLineS :: y' -> Proxy x' x y' String IO r -getLineS _ = forever $ do +-- | 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 --- | Get input from 'stdin' one line at a time and send \'@U@\'pstream -getLineC :: y' -> Proxy String x y' y IO r -getLineC _ = forever $ do +-- | A 'CoProducer' that sends lines from 'stdin' upstream +getLineC :: (Proxy p) => () -> CoProducer p String IO r +getLineC () = runIdentityP $ forever $ do str <- lift getLine request str -- | 'read' input from 'stdin' one line at a time and send \'@D@\'ownstream -readLnS :: (Read a) => y' -> Proxy x' x y' a IO r -readLnS _ = forever $ do +readLnS :: (Read b, Proxy p) => () -> Producer p b IO r +readLnS () = runIdentityP $ forever $ do a <- lift readLn respond a -- | 'read' input from 'stdin' one line at a time and send \'@U@\'pstream -readLnC :: (Read a) => y' -> Proxy a x y' y IO r -readLnC _ = forever $ do +readLnC :: (Read a', Proxy p) => () -> CoProducer p a' IO r +readLnC () = runIdentityP $ forever $ do a <- lift readLn request a @@ -71,8 +71,8 @@ Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" -} -printB :: (Show a, Show a') => a' -> Proxy a' a a' a IO r -printB = foreverK $ \a' -> do +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' @@ -83,15 +83,15 @@ respond a -- | 'print's all values flowing \'@D@\'ownstream to 'stdout' -printD :: (Show a) => x -> Proxy x a x a IO r -printD = foreverK $ \x -> do +printD :: (Show a, Proxy p) => x -> p x a x a IO r +printD = runIdentityK $ foreverK $ \x -> do a <- request x lift $ print a respond a -- | 'print's all values flowing \'@U@\'pstream to 'stdout' -printU :: (Show a') => a' -> Proxy a' x a' x IO r -printU = foreverK $ \a' -> do +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 @@ -100,8 +100,8 @@ Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" -} -putStrLnB :: String -> Proxy String String String String IO r -putStrLnB = foreverK $ \a' -> do +putStrLnB :: (Proxy p) => String -> p String String String String IO r +putStrLnB = runIdentityK $ foreverK $ \a' -> do lift $ do putStr "U: " putStrLn a' @@ -112,72 +112,84 @@ respond a -- | 'putStrLn's all values flowing \'@D@\'ownstream to 'stdout' -putStrLnD :: x -> Proxy x String x String IO r -putStrLnD = foreverK $ \x -> do +putStrLnD :: (Proxy p) => x -> p x String x String IO r +putStrLnD = runIdentityK $ foreverK $ \x -> do a <- request x lift $ putStrLn a respond a -- | 'putStrLn's all values flowing \'@U@\'pstream to 'stdout' -putStrLnU :: String -> Proxy String x String x IO r -putStrLnU = foreverK $ \a' -> do +putStrLnU :: (Proxy p) => String -> p String x String x IO r +putStrLnU = runIdentityK $ foreverK $ \a' -> do lift $ putStrLn a' x <- request a' respond x -- | Convert 'stdin'/'stdout' into a line-based 'Server' -promptS :: String -> Proxy x' x String String IO r -promptS = foreverK $ \send -> do +promptS :: (Proxy p) => String -> Server p String String IO r +promptS = runIdentityK $ foreverK $ \send -> do recv <- lift $ do putStrLn send getLine respond recv -- | Convert 'stdin'/'stdout' into a line-based 'Client' -promptC :: y' -> Proxy String String y' y IO r -promptC _ = forever $ do +promptC :: (Proxy p) => () -> Client p String String IO r +promptC () = runIdentityP $ forever $ do send <- lift getLine recv <- request send lift $ putStrLn recv --- | Get input from a handle one line at a time and send \'@D@\'ownstream -hGetLineD :: Handle -> y' -> Proxy x' x y' String IO r -hGetLineD h _ = forever $ do - str <- lift $ hGetLine h - respond str +-- | 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 --- | Get input from a handle one line at a time and send \'@U@\'pstream -hGetLineU :: Handle -> y' -> Proxy String x y' y IO r -hGetLineU h _ = forever $ do - str <- lift $ hGetLine h - request str +-- | A 'CoProducer' that sends lines from a 'Handle' upstream +hGetLineC :: (Proxy p) => IO.Handle -> () -> CoProducer p String IO () +hGetLineC h () = runIdentityP go where + go = do + eof <- lift $ IO.hIsEOF h + if eof + then return () + else do + str <- lift $ IO.hGetLine h + request str + go {-| 'print's all values flowing through it to a 'Handle' Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" -} -hPrintB :: (Show a, Show a') => Handle -> a' -> Proxy a' a a' a IO r -hPrintB h = foreverK $ \a' -> do +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 - hPutStr h "U: " - hPrint h a' + IO.hPutStr h "U: " + IO.hPrint h a' a <- request a' lift $ do - hPutStr h "D: " - hPrint h a + IO.hPutStr h "D: " + IO.hPrint h a respond a -- | 'print's all values flowing \'@D@\'ownstream to a 'Handle' -hPrintD :: (Show a) => Handle -> x -> Proxy x a x a IO r -hPrintD h = foreverK $ \x -> do +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 $ hPrint h a + lift $ IO.hPrint h a respond a -- | 'print's all values flowing \'@U@\'pstream to a 'Handle' -hPrintU :: (Show a') => Handle -> a' -> Proxy a' x a' x IO r -hPrintU h = foreverK $ \a' -> do - lift $ hPrint h a' +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 @@ -185,27 +197,28 @@ Prefixes upstream values with \"@U: @\" and downstream values with \"@D: @\" -} -hPutStrLnB :: Handle -> String -> Proxy String String String String IO r -hPutStrLnB h = foreverK $ \a' -> do +hPutStrLnB + :: (Proxy p) => IO.Handle -> String -> p String String String String IO r +hPutStrLnB h = runIdentityK $ foreverK $ \a' -> do lift $ do - hPutStr h "U: " - hPutStrLn h a' + IO.hPutStr h "U: " + IO.hPutStrLn h a' a <- request a' lift $ do - hPutStr h "D: " - hPutStrLn h a + IO.hPutStr h "D: " + IO.hPutStrLn h a respond a -- | 'putStrLn's all values flowing \'@D@\'ownstream to a 'Handle' -hPutStrLnD :: Handle -> x -> Proxy x String x String IO r -hPutStrLnD h = foreverK $ \x -> do +hPutStrLnD :: (Proxy p) => IO.Handle -> x -> p x String x String IO r +hPutStrLnD h = runIdentityK $ foreverK $ \x -> do a <- request x - lift $ hPutStrLn h a + lift $ IO.hPutStrLn h a respond a -- | 'putStrLn's all values flowing \'@U@\'pstream to a 'Handle' -hPutStrLnU :: Handle -> String -> Proxy String x String x IO r -hPutStrLnU h = foreverK $ \a' -> do - lift $ hPutStrLn h a' +hPutStrLnU :: (Proxy p) => IO.Handle -> String -> p String x String x IO r +hPutStrLnU h = runIdentityK $ foreverK $ \a' -> do + lift $ IO.hPutStrLn h a' x <- request a' respond x diff --git a/Control/Proxy/Prelude/Kleisli.hs b/Control/Proxy/Prelude/Kleisli.hs --- a/Control/Proxy/Prelude/Kleisli.hs +++ b/Control/Proxy/Prelude/Kleisli.hs @@ -1,36 +1,36 @@ +{-# LANGUAGE Rank2Types #-} + -- | Utility functions for Kleisli arrows module Control.Proxy.Prelude.Kleisli ( -- * Core utility functions - -- $utility foreverK, replicateK, - mapK + liftK, + hoistK, + raiseK, ) where -import Control.Monad (forever, (>=>)) +import Control.MFunctor (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Proxy.Class (Interact(request, respond)) -import Data.Closed (C) -{- $utility - Use 'foreverK' to abstract away the following common pattern: +{-| 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 avoid the manual recursion: + Using 'foreverK', you can instead write: > p = foreverK $ \a -> do > ... > respond b -} - --- | Compose a \'@K@\'leisli arrow with itself forever foreverK :: (Monad m) => (a -> m a) -> (a -> m b) -foreverK k = let r = k >=> r in r +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 -} @@ -40,14 +40,48 @@ go n | n < 1 = return | n == 1 = k - | otherwise = k >=> go (n - 1) + | otherwise = \a -> k a >>= go (n - 1) {-| Convenience function equivalent to @(lift .)@ -> mapK f >=> mapK g = mapK (f >=> g) +> liftK f >=> liftK g = liftK (f >=> g) > -> mapK return = return +> liftK return = return -} -mapK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b) -mapK = (lift .) -{-# INLINABLE mapK #-} +liftK :: (Monad m, MonadTrans t) => (a -> m b) -> (a -> t m b) +liftK k a = lift (k a) +-- liftK = (lift .) + +{-| Convenience function equivalent to @(hoist f .)@ + +> hoistK f p1 >-> hoistK f p2 = hoistK f (p1 >-> p2) +> +> hoistK f idT = idT + +> hoistK f p1 >=> hoistK f p2 = hoistK f (p1 >=> p2) +> +> hoistK f return = return + +> hoistK f . hoistK g = hoistK (f . g) +> +> hoistK id = id +-} +hoistK + :: (Monad m, MFunctor t) + => (forall a . m a -> n a) -> ((b' -> t m b) -> (b' -> t n b)) +hoistK k p a' = hoist k (p a') +-- hoistK k = (hoist k .) + +{-| Convenience function equivalent to @(hoist lift .)@ + +> raiseK p1 >-> raiseK p2 = raiseK (p1 >-> p2) +> +> raiseK idT = idT + +> raiseK p1 >=> raiseK p2 = raiseK (p1 >=> p2) +> +> raiseK return = return +-} +raiseK + :: (Monad m, MFunctor t1, MonadTrans t2) => (q -> t1 m r) -> (q -> t1 (t2 m) r) +raiseK = (hoist lift .) diff --git a/Control/Proxy/Synonym.hs b/Control/Proxy/Synonym.hs new file mode 100644 --- /dev/null +++ b/Control/Proxy/Synonym.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE KindSignatures #-} + +{-| These type synonyms simplify type signatures when proxies do not use all + their type variables. -} + +module Control.Proxy.Synonym ( + -- * Synonyms + Pipe, + Producer, + Consumer, + CoPipe, + CoProducer, + CoConsumer, + Client, + Server, + Session, + + -- * Closed + C + ) where + +-- | A unidirectional 'Proxy'. +type Pipe (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a b = p () a () b + +{-| A 'Pipe' that produces values + + 'Producer's never 'request'. -} +type Producer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b = p C () () b + +{-| A 'Pipe' that consumes values + + 'Consumer's never 'respond'. -} +type Consumer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a = p () a () C + +-- | A 'Pipe' where everything flows upstream +type CoPipe (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' b' = p a' () b' () + +{-| A 'CoPipe' that produces values flowing upstream + + 'CoProducer's never 'respond'. -} +type CoProducer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' = p a' () () C + +{-| A 'CoConsumer' that consumes values flowing upstream + + 'CoConsumer's never 'request'. -} +type CoConsumer (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b' = p C () b' () + +{-| @Server b' b@ receives requests of type @b'@ and sends responses of type + @b@. + + 'Server's never 'request'. -} +type Server (p :: * -> * -> * -> * -> (* -> *) -> * -> *) b' b = p C () b' b + +{-| @Client a' a@ sends requests of type @a'@ and receives responses of + type @a@. + + 'Client's never 'respond'. -} +type Client (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' a = p a' a () C + +{-| A self-contained 'Session', ready to be run by 'runSession' + + 'Session's never 'request' or 'respond'. -} +type Session (p :: * -> * -> * -> * -> (* -> *) -> * -> *) = p C () () C + +-- | The empty type, denoting a \'@C@\'losed end +data C = C -- Constructor not exported, but I include it to avoid EmptyDataDecls diff --git a/Control/Proxy/Trans.hs b/Control/Proxy/Trans.hs --- a/Control/Proxy/Trans.hs +++ b/Control/Proxy/Trans.hs @@ -1,38 +1,71 @@ -{-| You can define your own extensions to the 'Proxy' type by writing your own - \"proxy transformers\". Proxy transformers are monad transformers that - correctly lift 'Proxy' composition from the base monad. Stack multiple - proxy transformers to chain features together. -} +{-| You can define your own proxy extensions by writing your own \"proxy + transformers\". Proxy transformers are monad transformers that also + correctly lift all proxy operations from the base proxy type to the + extended proxy type. Stack multiple proxy transformers to chain features + together. +-} module Control.Proxy.Trans ( -- * Proxy Transformers - ProxyTrans(..) - )where + ProxyTrans(..), + mapP + -- * Laws + -- $laws + ) where + import Control.Proxy.Class -{-| 'mapP' defines a functor that preserves 'Proxy' composition and Kleisli - composition. +-- | Uniform interface to lifting proxies +class ProxyTrans t where + liftP :: (Monad m, Proxy p) => p a' a b' b m r -> t p a' a b' b m r +{-| Lift a 'Proxy' Kleisli arrow + +> mapP = (lift .) +-} +mapP :: (Monad m, Proxy p, ProxyTrans t) + => (q -> p a' a b' b m r) -> (q -> t p a' a b' b m r) +mapP = (liftP .) + +{- $laws + 'mapP' defines a functor that preserves five categories: + + * Kleisli category + + * The two Proxy categories + + * \"request\" category + + * \"respond\" category + Laws: * Functor between 'Proxy' categories -> mapP (f <-< g) = mapP f <-< mapP g +> mapP (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 - Minimal complete definition: 'mapP' or 'liftP'. Defining 'liftP' is more - efficient. --} -class ProxyTrans t where - liftP :: (Monad (p b c d e m), Channel p) - => p b c d e m r -> t p b c d e m r - liftP f = mapP (\() -> f) () + * Functor between \"request\" categories - mapP :: (Monad (p b c d e m), Channel p) - => (a -> p b c d e m r) -> (a -> t p b c d e m r) - mapP = (liftP .) +> mapP (f / +> mapP request = request + + * Functor between \"respond\" categories + +> mapP (f \<\ g) = mapP f \<\ mapP g -- when \<\ is defined +> +> mapP respond = respond +-} diff --git a/Control/Proxy/Trans/Either.hs b/Control/Proxy/Trans/Either.hs --- a/Control/Proxy/Trans/Either.hs +++ b/Control/Proxy/Trans/Either.hs @@ -1,6 +1,6 @@ -- | This module provides the proxy transformer equivalent of 'EitherT'. -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.Either ( -- * EitherP @@ -17,11 +17,12 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class (Channel(idT, (>->))) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) import Prelude hiding (catch) @@ -29,59 +30,114 @@ newtype EitherP e p a' a b' b (m :: * -> *) r = EitherP { runEitherP :: p a' a b' b m (Either e r) } -instance (Monad (p a' a b' b m)) => Functor (EitherP e p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (EitherP e p a' a b' b m) where + fmap f p = EitherP ( + runEitherP p ?>= \e -> + return_P (case e of + Left l -> Left l + Right r -> Right (f r) ) ) + -- fmap f = EitherP . liftM (fmap f) . runEitherP -instance (Monad (p a' a b' b m)) => Applicative (EitherP e p a' a b' b m) where - pure = return - (<*>) = ap +instance (Proxy p, Monad m) + => Applicative (EitherP e p a' a b' b m) where + pure = return + fp <*> xp = EitherP ( + runEitherP fp ?>= \e1 -> + case e1 of + Left l -> return_P (Left l) + Right f -> + runEitherP xp ?>= \e2 -> + return_P (case e2 of + Left l -> Left l + Right x -> Right (f x) ) ) + -- fp <*> xp = EitherP ((<*>) <$> (runEitherP fp) <*> (runEitherP xp)) -instance (Monad (p a' a b' b m)) => Monad (EitherP e p a' a b' b m) where - return = right - m >>= f = EitherP $ do - e <- runEitherP m - runEitherP $ case e of - Left l -> left l - Right r -> f r +instance (Proxy p, Monad m) + => Monad (EitherP e p a' a b' b m) where + return = return_P + (>>=) = (?>=) -instance (MonadPlus (p a' a b' b m)) - => Alternative (EitherP e p a' a b' b m) where +instance (MonadPlusP p, Monad m) + => Alternative (EitherP e p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlus (p a' a b' b m)) - => MonadPlus (EitherP e p a' a b' b m) where - mzero = EitherP mzero - mplus m1 m2 = EitherP $ mplus (runEitherP m1) (runEitherP m2) +instance (MonadPlusP p ) + => MonadPlusP (EitherP e p) where + mzero_P = EitherP mzero_P + mplus_P m1 m2 = EitherP (mplus_P (runEitherP m1) (runEitherP m2)) -instance (MonadTrans (p a' a b' b)) => MonadTrans (EitherP e p a' a b' b) where - lift = EitherP . lift . liftM Right +instance (MonadPlusP p, Monad m) + => MonadPlus (EitherP e p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) => MonadIO (EitherP e p a' a b' b m) where - liftIO = EitherP . liftIO . liftM Right +instance (Proxy p ) + => MonadTrans (EitherP e p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (EitherP e p a' a b' b) where - mapT nat = EitherP . mapT nat . runEitherP +instance (MonadIOP p ) + => MonadIOP (EitherP e p) where + liftIO_P m = EitherP (liftIO_P (m >>= \x -> return (Right x))) + -- liftIO = EitherP . liftIO . liftM Right -instance (Channel p) => Channel (EitherP e p) where - idT = EitherP . idT - p1 >-> p2 = (EitherP .) $ runEitherP . p1 >-> runEitherP . p2 +instance (MonadIOP p, MonadIO m) + => MonadIO (EitherP e p a' a b' b m) where + liftIO = liftIO_P +instance (Proxy p ) + => MFunctor (EitherP e p a' a b' b) where + hoist = hoist_P + +instance (Proxy p ) + => Proxy (EitherP e p) where + p1 >-> p2 = \c'1 -> EitherP ( + ((\b' -> runEitherP (p1 b')) >-> (\c'2 -> runEitherP (p2 c'2))) c'1 ) + -- p1 >-> p2 = (EitherP .) $ runEitherP . p1 >-> runEitherP . p2 + + p1 >~> p2 = \c'1 -> EitherP ( + ((\b' -> runEitherP (p1 b')) >~> (\c'2 -> runEitherP (p2 c'2))) c'1 ) + -- p1 >~> p2 = (EitherP .) $ runEitherP . p1 >~> runEitherP . p2 + + request = \a' -> EitherP (request a' ?>= \a -> return_P (Right a )) + respond = \b -> EitherP (respond b ?>= \b' -> return_P (Right b')) + + return_P = right + m ?>= f = EitherP ( + runEitherP m ?>= \e -> + runEitherP (case e of + Left l -> left l + Right r -> f r ) ) + + lift_P m = EitherP (lift_P (m >>= \x -> return (Right x))) + -- lift = EitherP . lift . liftM Right + + hoist_P nat p = EitherP (hoist_P nat (runEitherP p)) + -- hoist nat = EitherP . hoist nat . runEitherP + instance ProxyTrans (EitherP e) where - liftP = EitherP . liftM Right + liftP p = EitherP (p ?>= \x -> return_P (Right x)) + -- liftP = EitherP . liftM Right +instance PFunctor (EitherP e) where + hoistP nat = EitherP . nat . runEitherP + -- | Run an 'EitherP' \'@K@\'leisi arrow, returning either a 'Left' or 'Right' runEitherK :: (q -> EitherP e p a' a b' b m r) -> (q -> p a' a b' b m (Either e r)) -runEitherK = (runEitherP .) +runEitherK p q = runEitherP (p q) +-- runEitherK = (runEitherP .) -- | Abort the computation and return a 'Left' result -left :: (Monad (p a' a b' b m)) => e -> EitherP e p a' a b' b m r -left = EitherP . return . Left +left :: (Monad m, Proxy p) => e -> EitherP e p a' a b' b m r +left e = EitherP (return_P (Left e)) +-- left = EitherP . return . Left -- | Synonym for 'return' -right :: (Monad (p a' a b' b m)) => r -> EitherP e p a' a b' b m r -right = EitherP . return . Right +right :: (Monad m, Proxy p) => r -> EitherP e p a' a b' b m r +right r = EitherP (return_P (Right r)) +-- right = EitherP . return . Right {- $symmetry 'EitherP' forms a second symmetric monad over the left type variable. @@ -100,29 +156,26 @@ -} -- | Synonym for 'left' -throw :: (Monad (p a' a b' b m)) => e -> EitherP e p a' a b' b m r +throw :: (Monad m, Proxy p) => e -> EitherP e p a' a b' b m r throw = left -- | Resume from an aborted operation catch - :: (Monad (p a' a b' b m)) + :: (Monad m, Proxy p) => EitherP e p a' a b' b m r -- ^ Original computation -> (e -> EitherP f p a' a b' b m r) -- ^ Handler -> EitherP f p a' a b' b m r -- ^ Handled computation -catch m f = EitherP $ do - e <- runEitherP m - runEitherP $ case e of +catch m f = EitherP ( + runEitherP m ?>= \e -> + runEitherP (case e of Left l -> f l - Right r -> right r + Right r -> right r )) -- | 'catch' with the arguments flipped handle - :: (Monad (p a' a b' b m)) + :: (Monad m, Proxy p) => (e -> EitherP f p a' a b' b m r) -- ^ Handler -> EitherP e p a' a b' b m r -- ^ Original computation -> EitherP f p a' a b' b m r -- ^ Handled computation -handle f m = EitherP $ do - e <- runEitherP m - runEitherP $ case e of - Left l -> f l - Right r -> right r +handle f m = catch m f +-- handle = flip catch 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 @@ -1,70 +1,136 @@ -- | This module provides the proxy transformer equivalent of 'IdentityT'. -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.Identity ( - -- * IdentityP + -- * Identity Proxy Transformer IdentityP(..), + identityK, runIdentityK ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class ( - Channel(idT , (>->)), - Interact(request, (\>\), respond, (/>/)) ) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Identity' proxy transformer -newtype IdentityP p a' a b' b (m :: * -> *) r - = IdentityP { runIdentityP :: p a' a b' b m r } +newtype IdentityP p a' a b' b (m :: * -> *) r = + IdentityP { runIdentityP :: p a' a b' b m r } -instance (Monad (p a' a b' b m)) => Functor (IdentityP p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (IdentityP p a' a b' b m) where + fmap f p = IdentityP ( + runIdentityP p ?>= \x -> + return_P (f x) ) + -- fmap = liftM -instance (Monad (p a' a b' b m)) => Applicative (IdentityP p a' a b' b m) where - pure = return - (<*>) = ap +instance (Proxy p, Monad m) + => Applicative (IdentityP p a' a b' b m) where + pure = return -instance (Monad (p a' a b' b m)) => Monad (IdentityP p a' a b' b m) where - return = IdentityP . return - m >>= f = IdentityP $ runIdentityP m >>= runIdentityP . f + fp <*> xp = IdentityP ( + runIdentityP fp ?>= \f -> + runIdentityP xp ?>= \x -> + return_P (f x) ) + -- fp <*> xp = ap -instance (MonadPlus (p a' a b' b m)) - => Alternative (IdentityP p a' a b' b m) where +instance (Proxy p, Monad m) + => Monad (IdentityP p a' a b' b m) where + return = return_P + (>>=) = (?>=) + +instance (MonadPlusP p, Monad m) + => Alternative (IdentityP p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlus (p a' a b' b m)) - => MonadPlus (IdentityP p a' a b' b m) where - mzero = IdentityP mzero - mplus m1 m2 = IdentityP $ mplus (runIdentityP m1) (runIdentityP m2) +instance (MonadPlusP p ) + => MonadPlusP (IdentityP p) where + mzero_P = IdentityP mzero_P + mplus_P m1 m2 = IdentityP (mplus_P (runIdentityP m1) (runIdentityP m2)) -instance (MonadTrans (p a' a b' b)) => MonadTrans (IdentityP p a' a b' b) where - lift = IdentityP . lift +instance (MonadPlusP p, Monad m) + => MonadPlus (IdentityP p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) => MonadIO (IdentityP p a' a b' b m) where - liftIO = IdentityP . liftIO +instance (Proxy p ) + => MonadTrans (IdentityP p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (IdentityP p a' a b' b) where - mapT nat = IdentityP . mapT nat . runIdentityP +instance (MonadIOP p ) + => MonadIOP (IdentityP p) where + liftIO_P m = IdentityP (liftIO_P m) + -- liftIO = IdentityP . liftIO -instance (Channel p) => Channel (IdentityP p) where - idT = IdentityP . idT - p1 >-> p2 = (IdentityP .) $ runIdentityP . p1 >-> runIdentityP . p2 +instance (MonadIOP p, MonadIO m) + => MonadIO (IdentityP p a' a b' b m) where + liftIO = liftIO_P -instance (Interact p) => Interact (IdentityP p) where - request = IdentityP . request - p1 \>\ p2 = (IdentityP .) $ runIdentityP . p1 \>\ runIdentityP . p2 - respond = IdentityP . respond - p1 />/ p2 = (IdentityP .) $ runIdentityP . p1 />/ runIdentityP . p2 +instance (Proxy p ) + => MFunctor (IdentityP p a' a b' b) where + hoist = hoist_P +instance (Proxy p ) + => Proxy (IdentityP p) where + p1 >-> p2 = \c'1 -> IdentityP ( + ((\c'2 -> runIdentityP (p1 c'2)) + >-> (\b' -> runIdentityP (p2 b' )) ) c'1 ) + -- p1 >-> p2 = (IdentityP .) $ runIdentityP . p1 >-> runIdentityP . p2 + + p1 >~> p2 = \c'1 -> IdentityP ( + ((\c'2 -> runIdentityP (p1 c'2)) + >~> (\b' -> runIdentityP (p2 b' )) ) c'1 ) + -- p1 >~> p2 = (IdentityP .) $ runIdentityP . p1 >~> runIdentityP . p2 + + request = \a' -> IdentityP (request a') + -- request = P . request + + respond = \b -> IdentityP (respond b) + -- respond = P . respond + + return_P = \r -> IdentityP (return_P r) + -- return = P . return + + m ?>= f = IdentityP ( + runIdentityP m ?>= \x -> + runIdentityP (f x) ) + + lift_P m = IdentityP (lift_P m) + -- lift = P . lift + + hoist_P nat p = IdentityP (hoist_P nat (runIdentityP p)) + -- hoist nat = IdentityP . hoist nat . runIdentityP + +instance (Interact p ) + => Interact (IdentityP p) where + p1 \>\ p2 = \c'1 -> IdentityP ( + ((\b' -> runIdentityP (p1 b' )) + \>\ (\c'2 -> runIdentityP (p2 c'2)) ) c'1 ) + -- p1 \>\ p2 = (IdentityP .) $ runIdentityP . p1 \>\ runIdentityP . p2 + + p1 />/ p2 = \a1 -> IdentityP ( + ((\a2 -> runIdentityP (p1 a2)) + />/ (\b -> runIdentityP (p2 b )) ) a1 ) + -- p1 />/ p2 = (IdentityP .) $ runIdentityP . p1 />/ runIdentityP . p2 + instance ProxyTrans IdentityP where liftP = IdentityP --- | Run an 'IdentityP' \'@K@\'leisli arrow +instance PFunctor IdentityP where + hoistP nat = IdentityP . nat . runIdentityP + +-- | Wrap a \'@K@\'leisli arrow in 'IdentityP' +identityK :: (q -> p a' a b' b m r) -> (q -> IdentityP p a' a b' b m r) +identityK k q = IdentityP (k q) +-- identityK = (IdentityP .) + +-- | Run an 'P' \'@K@\'leisli arrow runIdentityK :: (q -> IdentityP p a' a b' b m r) -> (q -> p a' a b' b m r) -runIdentityK = (runIdentityP .) +runIdentityK k q = runIdentityP (k q) +-- runIdentityK = (runIdentityP .) 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 @@ -1,6 +1,6 @@ -- | This module provides the proxy transformer equivalent of 'MaybeT'. -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.Maybe ( -- * MaybeP @@ -12,68 +12,125 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class (Channel(idT, (>->))) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Maybe' proxy transformer newtype MaybeP p a' a b' b (m :: * -> *) r = MaybeP { runMaybeP :: p a' a b' b m (Maybe r) } -instance (Monad (p a' a b' b m)) => Functor (MaybeP p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (MaybeP p a' a b' b m) where + fmap f p = MaybeP ( + runMaybeP p ?>= \m -> + return_P (case m of + Nothing -> Nothing + Just x -> Just (f x) ) ) + -- fmap f = MaybeP . fmap (fmap f) . runMaybeP -instance (Monad (p a' a b' b m)) => Applicative (MaybeP p a' a b' b m) where - pure = return - (<*>) = ap +instance (Proxy p, Monad m) + => Applicative (MaybeP p a' a b' b m) where + pure = return -instance (Monad (p a' a b' b m)) => Monad (MaybeP p a' a b' b m) where - return = MaybeP . return . Just - m >>= f = MaybeP $ do - ma <- runMaybeP m - runMaybeP $ case ma of - Nothing -> nothing - Just a -> f a + fp <*> xp = MaybeP ( + runMaybeP fp ?>= \m1 -> + case m1 of + Nothing -> return_P Nothing + Just f -> + runMaybeP xp ?>= \m2 -> + case m2 of + Nothing -> return_P Nothing + Just x -> return_P (Just (f x)) ) + -- fp <*> xp = MaybeP ((<*>) <$> (runMaybeP fp) <*> (runMaybeP xp)) -instance (Monad (p a' a b' b m)) => Alternative (MaybeP p a' a b' b m) where +instance (Proxy p, Monad m) + => Monad (MaybeP p a' a b' b m) where + return = return_P + (>>=) = (?>=) + +instance (Proxy p, Monad m) + => Alternative (MaybeP p a' a b' b m) where empty = mzero (<|>) = mplus -instance (Monad (p a' a b' b m)) => MonadPlus (MaybeP p a' a b' b m) where - mzero = nothing - mplus m1 m2 = MaybeP $ do - ma <- runMaybeP m1 - runMaybeP $ case ma of +instance (Proxy p ) + => MonadPlusP (MaybeP p) where + mzero_P = nothing + mplus_P m1 m2 = MaybeP ( + runMaybeP m1 ?>= \ma -> + runMaybeP (case ma of Nothing -> m2 - Just a -> just a + Just a -> just a ) ) -instance (MonadTrans (p a' a b' b)) => MonadTrans (MaybeP p a' a b' b) where - lift = MaybeP . lift . liftM Just +instance (Proxy p, Monad m) + => MonadPlus (MaybeP p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) => MonadIO (MaybeP p a' a b' b m) where - liftIO = MaybeP . liftIO . liftM Just +instance (Proxy p ) + => MonadTrans (MaybeP p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (MaybeP p a' a b' b) where - mapT nat = MaybeP . mapT nat . runMaybeP +instance (MonadIOP p ) + => MonadIOP (MaybeP p) where + liftIO_P m = MaybeP (liftIO_P (m >>= \x -> return (Just x))) + -- liftIO = MaybeP . liftIO . liftM Just -instance (Channel p) => Channel (MaybeP p) where - idT = MaybeP . idT - p1 >-> p2 = (MaybeP .) $ runMaybeP . p1 >-> runMaybeP . p2 +instance (MonadIOP p, MonadIO m) + => MonadIO (MaybeP p a' a b' b m) where + liftIO = liftIO_P +instance (Proxy p ) + => MFunctor (MaybeP p a' a b' b) where + hoist = hoist_P + +instance (Proxy p ) + => Proxy (MaybeP p) where + p1 >-> p2 = \c'1 -> MaybeP ( + ((\b' -> runMaybeP (p1 b')) >-> (\c'2 -> runMaybeP (p2 c'2))) c'1 ) + -- p1 >-> p2 = (MaybeP .) $ runMaybeP . p1 >-> runMaybeP . p2 + + p1 >~> p2 = \c'1 -> MaybeP ( + ((\b' -> runMaybeP (p1 b')) >~> (\c'2 -> runMaybeP (p2 c'2))) c'1 ) + -- p1 >~> p2 = (MaybeP .) $ runMaybeP . p1 >~> runMaybeP . p2 + + request = \a' -> MaybeP (request a' ?>= \a -> return_P (Just a )) + respond = \b -> MaybeP (respond b ?>= \b' -> return_P (Just b')) + + return_P = just + m ?>= f = MaybeP ( + runMaybeP m ?>= \ma -> + runMaybeP (case ma of + Nothing -> nothing + Just a -> f a ) ) + + lift_P m = MaybeP (lift_P (m >>= \x -> return (Just x))) + -- lift = MaybeP . lift . liftM Just + + hoist_P nat p = MaybeP (hoist_P nat (runMaybeP p)) + -- hoist nat = MaybeP . hoist nat . runMaybeP + instance ProxyTrans MaybeP where - liftP = MaybeP . liftM Just + liftP p = MaybeP (p ?>= \x -> return_P (Just x)) + -- liftP = MaybeP . liftM Just +instance PFunctor MaybeP where + hoistP nat = MaybeP . nat . runMaybeP + -- | Run a 'MaybeP' \'@K@\'leisli arrow, returning the result or 'Nothing' runMaybeK :: (q -> MaybeP p a' a b' b m r) -> (q -> p a' a b' b m (Maybe r)) -runMaybeK = (runMaybeP .) +runMaybeK p q = runMaybeP (p q) +-- runMaybeK = (runMaybeP .) -- | A synonym for 'mzero' -nothing :: (Monad (p a' a b' b m)) => MaybeP p a' a b' b m r -nothing = MaybeP $ return Nothing +nothing :: (Monad m, Proxy p) => MaybeP p a' a b' b m r +nothing = MaybeP (return_P Nothing) -- | A synonym for 'return' -just :: (Monad (p a' a b' b m)) => r -> MaybeP p a' a b' b m r -just = return +just :: (Monad m, Proxy p) => r -> MaybeP p a' a b' b m r +just r = MaybeP (return_P (Just r)) diff --git a/Control/Proxy/Trans/Reader.hs b/Control/Proxy/Trans/Reader.hs --- a/Control/Proxy/Trans/Reader.hs +++ b/Control/Proxy/Trans/Reader.hs @@ -1,6 +1,6 @@ -- | This module provides the proxy transformer equivalent of 'ReaderT'. -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.Reader ( -- * ReaderP @@ -15,91 +15,139 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class ( - Channel(idT, (>->)), - Interact(request, (\>\), respond, (/>/)) ) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) -- | The 'Reader' proxy transformer newtype ReaderP i p a' a b' b (m :: * -> *) r = ReaderP { unReaderP :: i -> p a' a b' b m r } -instance (Monad (p a' a b' b m)) => Functor (ReaderP i p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (ReaderP i p a' a b' b m) where + fmap f p = ReaderP (\i -> + unReaderP p i ?>= \x -> + return_P (f x) ) -instance (Monad (p a' a b' b m)) => Applicative (ReaderP i p a' a b' b m) where - pure = return - (<*>) = ap +instance (Proxy p, Monad m) + => Applicative (ReaderP i p a' a b' b m) where + pure = return + p1 <*> p2 = ReaderP (\i -> + unReaderP p1 i ?>= \f -> + unReaderP p2 i ?>= \x -> + return_P (f x) ) -instance (Monad (p a' a b' b m)) => Monad (ReaderP i p a' a b' b m) where - return a = ReaderP $ \_ -> return a - m >>= f = ReaderP $ \i -> do - a <- unReaderP m i - unReaderP (f a) i +instance (Proxy p, Monad m) + => Monad (ReaderP i p a' a b' b m) where + return = return_P + (>>=) = (?>=) -instance (MonadPlus (p a' a b' b m)) - => Alternative (ReaderP i p a' a b' b m) where +instance (MonadPlusP p, Monad m) + => Alternative (ReaderP i p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlus (p a' a b' b m)) - => MonadPlus (ReaderP i p a' a b' b m) where - mzero = ReaderP $ \_ -> mzero - mplus m1 m2 = ReaderP $ \i -> mplus (unReaderP m1 i) (unReaderP m2 i) +instance (MonadPlusP p ) + => MonadPlusP (ReaderP i p) where + mzero_P = ReaderP (\_ -> mzero_P) + mplus_P m1 m2 = ReaderP (\i -> mplus_P (unReaderP m1 i) (unReaderP m2 i)) -instance (MonadTrans (p a' a b' b)) => MonadTrans (ReaderP i p a' a b' b) where - lift m = ReaderP $ \_ -> lift m +instance (MonadPlusP p, Monad m) + => MonadPlus (ReaderP i p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) => MonadIO (ReaderP i p a' a b' b m) where - liftIO m = ReaderP $ \_ -> liftIO m +instance (Proxy p ) + => MonadTrans (ReaderP i p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (ReaderP i p a' a b' b) where - mapT nat = ReaderP . fmap (mapT nat) . unReaderP +instance (MonadIOP p ) + => MonadIOP (ReaderP i p) where + liftIO_P m = ReaderP (\_ -> liftIO_P m) -instance (Channel p) => Channel (ReaderP i p) where - idT a = ReaderP $ \_ -> idT a - (p1 >-> p2) a = ReaderP $ \i -> - ((`unReaderP` i) . p1 >-> (`unReaderP` i) . p2) a +instance (MonadIOP p, MonadIO m) + => MonadIO (ReaderP i p a' a b' b m) where + liftIO = liftIO_P -instance (Interact p) => Interact (ReaderP i p) where - request a = ReaderP $ \_ -> request a - (p1 \>\ p2) a = ReaderP $ \i -> - ((`unReaderP` i) . p1 \>\ (`unReaderP` i) . p2) a - respond a = ReaderP $ \_ -> respond a - (p1 />/ p2) a = ReaderP $ \i -> - ((`unReaderP` i) . p1 />/ (`unReaderP` i) . p2) a +instance (Proxy p ) + => MFunctor (ReaderP i p a' a b' b) where + hoist = hoist_P +instance (Proxy p ) + => Proxy (ReaderP i p) where + p1 >-> p2 = \c'1 -> ReaderP (\i -> + ((\b' -> unReaderP (p1 b' ) i) + >-> (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) + {- p1 >-> p2 = \c' -> ReaderP $ \i -> + ((`unReaderP` i) . p1 >-> (`unReaderP` i) . p2) c' -} + + p1 >~> p2 = \c'1 -> ReaderP (\i -> + ((\b' -> unReaderP (p1 b' ) i) + >~> (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) + {- p1 >~> p2 = \c' -> ReaderP $ \i -> + ((`unReaderP` i) . p1 >~> (`unReaderP` i) . p2) c' -} + + return_P = \r -> ReaderP (\_ -> return_P r) + m ?>= f = ReaderP (\i -> + unReaderP m i ?>= \a -> + unReaderP (f a) i ) + + request = \a -> ReaderP (\_ -> request a) + respond = \a -> ReaderP (\_ -> respond a) + + lift_P m = ReaderP (\_ -> lift_P m) + + hoist_P nat p = ReaderP (\i -> hoist_P nat (unReaderP p i)) + -- hoist_P nat = ReaderP . fmap (hoist_P nat) . unReaderP + +instance (Interact p) + => Interact (ReaderP i p) where + p1 \>\ p2 = \c'1 -> ReaderP (\i -> + ((\b' -> unReaderP (p1 b' ) i) + \>\ (\c'2 -> unReaderP (p2 c'2) i) ) c'1 ) + {- p1 \>\ p2 = \c' -> ReaderP $ \i -> + ((`unReaderP` i) . p1 \>\ (`unReaderP` i) . p2) c' -} + + p1 />/ p2 = \a1 -> ReaderP (\i -> + ((\b -> unReaderP (p1 b ) i) + />/ (\a2 -> unReaderP (p2 a2) i) ) a1 ) + {- p1 />/ p2 = \a -> ReaderP $ \i -> + ((`unReaderP` i) . p1 />/ (`unReaderP` i) . p2) a -} + instance ProxyTrans (ReaderP i) where - liftP m = ReaderP $ \_ -> m + liftP m = ReaderP (\_ -> m) +instance PFunctor (ReaderP i) where + hoistP nat = ReaderP . (nat .) . unReaderP + -- | Run a 'ReaderP' computation, supplying the environment runReaderP :: i -> ReaderP i p a' a b' b m r -> p a' a b' b m r runReaderP i m = unReaderP m i -- | Run a 'ReaderP' \'@K@\'leisli arrow, supplying the environment runReaderK :: i -> (q -> ReaderP i p a' a b' b m r) -> (q -> p a' a b' b m r) -runReaderK i = (runReaderP i .) +runReaderK i p q = runReaderP i (p q) +-- runReaderK i = (runReaderP i .) -- | Modify a computation's environment (a more general version of 'local') withReaderP - :: (Monad (p a' a b' b m)) - => (j -> i) -> ReaderP i p a' a b' b m r -> ReaderP j p a' a b' b m r -withReaderP f r = ReaderP $ unReaderP r . f + :: (j -> i) -> ReaderP i p a' a b' b m r -> ReaderP j p a' a b' b m r +withReaderP f p = ReaderP (\i -> unReaderP p (f i)) +-- withReaderP f p = ReaderP $ unReaderP p . f -- | Get the environment -ask :: (Monad (p a' a b' b m)) => ReaderP i p a' a b' b m i -ask = ReaderP return +ask :: (Proxy p, Monad m) => ReaderP i p a' a b' b m i +ask = ReaderP return_P -- | Get a function of the environment -asks :: (Monad (p a' a b' b m)) => (i -> r) -> ReaderP i p a' a b' b m r -asks f = ReaderP (return . f) +asks :: (Proxy p, Monad m) => (i -> r) -> ReaderP i p a' a b' b m r +asks f = ReaderP (\i -> return_P (f i)) -- | Modify a computation's environment (a specialization of 'withReaderP') local - :: (Monad (p a' a b' b m)) - => (i -> i) -> ReaderP i p a' a b' b m r -> ReaderP i p a' a b' b m r + :: (i -> i) -> ReaderP i p a' a b' b m r -> ReaderP i p a' a b' b m r local = withReaderP diff --git a/Control/Proxy/Trans/State.hs b/Control/Proxy/Trans/State.hs --- a/Control/Proxy/Trans/State.hs +++ b/Control/Proxy/Trans/State.hs @@ -1,8 +1,6 @@ -{-| This module provides the proxy transformer equivalent of 'StateT'. - - Sequencing of computations is strict. -} +-- | This module provides the proxy transformer equivalent of 'StateT'. -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.State ( -- * StateP @@ -21,98 +19,148 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class (Channel(idT, (>->))) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) --- | The strict 'State' proxy transformer +-- | The 'State' proxy transformer newtype StateP s p a' a b' b (m :: * -> *) r = StateP { unStateP :: s -> p a' a b' b m (r, s) } -instance (Monad (p a' a b' b m)) => Functor (StateP s p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (StateP s p a' a b' b m) where + fmap f p = StateP (\s0 -> + unStateP p s0 ?>= \(x, s1) -> + return_P (f x, s1) ) -instance (Monad (p a' a b' b m)) => Applicative (StateP s p a' a b' b m) where - pure = return - (<*>) = ap +{- As far as I can tell, there is no way to write this using an Applicative + context -} +instance (Proxy p, Monad m) + => Applicative (StateP s p a' a b' b m) where + pure = return + p1 <*> p2 = StateP (\s0 -> + unStateP p1 s0 ?>= \(f, s1) -> + unStateP p2 s1 ?>= \(x, s2) -> + return_P (f x, s2) ) -instance (Monad (p a' a b' b m)) => Monad (StateP s p a' a b' b m) where - return a = StateP $ \s -> return (a, s) - m >>= f = StateP $ \s -> do - (a, s') <- unStateP m s - unStateP (f a) s' +instance (Proxy p, Monad m) + => Monad (StateP s p a' a b' b m) where + return = return_P + (>>=) = (?>=) -instance (MonadPlus (p a' a b' b m)) - => Alternative (StateP s p a' a b' b m) where +instance (MonadPlusP p, Monad m) + => Alternative (StateP s p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlus (p a' a b' b m)) => MonadPlus (StateP s p a' a b' b m) where - mzero = StateP $ \_ -> mzero - mplus m1 m2 = StateP $ \s -> mplus (unStateP m1 s) (unStateP m2 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 (MonadTrans (p a' a b' b)) => MonadTrans (StateP s p a' a b' b) where - lift m = StateP $ \s -> lift $ liftM (\r -> (r, s)) m +instance (MonadPlusP p, Monad m) + => MonadPlus (StateP s p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) => MonadIO (StateP s p a' a b' b m) where - liftIO m = StateP $ \s -> liftIO $ liftM (\r -> (r, s)) m +instance (Proxy p ) + => MonadTrans (StateP s p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (StateP s p a' a b' b) where - mapT nat = StateP . fmap (mapT nat) . unStateP +instance (MonadIOP p ) + => MonadIOP (StateP s p) where + liftIO_P m = StateP (\s -> liftIO_P (m >>= \r -> return (r, s))) -instance (Channel p) => Channel (StateP s p) where - idT a = StateP $ \_ -> idT a - (p1 >-> p2) a = StateP $ \s -> - ((`unStateP` s) . p1 >-> (`unStateP` s) . p2) a +instance (MonadIOP p, MonadIO m) + => MonadIO (StateP s p a' a b' b m) where + liftIO = liftIO_P +instance (Proxy p ) + => MFunctor (StateP s p a' a b' b) where + hoist = hoist_P + +instance (Proxy p ) + => Proxy (StateP s p) where + p1 >-> p2 = \c'1 -> StateP (\s -> + ((\b' -> unStateP (p1 b') s) >-> (\c'2 -> unStateP (p2 c'2) s)) c'1 ) + {- (p1 >-> p2) = \c' -> StateP $ \s -> + ((`unStateP` s) . p1 >-> (`unStateP` s) . p2) c' -} + + p1 >~> p2 = \c'1 -> StateP (\s -> + ((\b' -> unStateP (p1 b') s) >~> (\c'2 -> unStateP (p2 c'2) s)) c'1 ) + {- (p1 >~> p2) = \c' -> StateP $ \s -> + ((`unStateP` s) . p1 >~> (`unStateP` s) . p2) c' -} + + request = \a' -> StateP (\s -> request a' ?>= \a -> return_P (a , s)) + respond = \b -> StateP (\s -> respond b ?>= \b' -> return_P (b', s)) + + return_P = \r -> StateP (\s -> return_P (r, s)) + m ?>= f = StateP (\s -> + unStateP m s ?>= \(a, s') -> + unStateP (f a) s' ) + + lift_P m = StateP (\s -> lift_P (m >>= \r -> return (r, s))) + + hoist_P nat p = StateP (\s -> hoist_P nat (unStateP p s)) + -- hoist nat = StateP . fmap (hoist nat) . unStateP + instance ProxyTrans (StateP s) where - liftP m = StateP $ \s -> liftM (\r -> (r, s)) m + liftP m = StateP (\s -> m ?>= \r -> return_P (r, s)) +instance PFunctor (StateP s) where + hoistP nat = StateP . (nat .) . unStateP + -- | Run a 'StateP' computation, producing the final result and state runStateP :: s -> StateP s p a' a b' b m r -> p a' a b' b m (r, s) runStateP s m = unStateP m s -- | Run a 'StateP' \'@K@\'leisli arrow, procuding the final result and state runStateK :: s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m (r, s)) -runStateK s = (runStateP s .) +runStateK s k q = unStateP (k q) s +-- runStateK s = (runStateP s .) -- | Evaluate a 'StateP' computation, but discard the final state evalStateP - :: (Monad (p a' a b' b m)) => s -> StateP s p a' a b' b m r -> p a' a b' b m r -evalStateP s = liftM fst . runStateP s + :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m r +evalStateP s p = unStateP p s ?>= \x -> return_P (fst x) +-- evalStateP s = liftM fst . runStateP s -- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final state evalStateK - :: (Monad (p a' a b' b m)) + :: (Proxy p, Monad m) => s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m r) -evalStateK s = (evalStateP s .) +evalStateK s k q = evalStateP s (k q) +-- evalStateK s = (evalStateP s .) -- | Evaluate a 'StateP' computation, but discard the final result execStateP - :: (Monad (p a' a b' b m)) => s -> StateP s p a' a b' b m r -> p a' a b' b m s -execStateP s = liftM snd . runStateP s + :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m r -> p a' a b' b m s +execStateP s p = unStateP p s ?>= \x -> return_P (snd x) +-- execStateP s = liftM snd . runStateP s -- | Evaluate a 'StateP' \'@K@\'leisli arrow, but discard the final result execStateK - :: (Monad (p a' a b' b m)) + :: (Proxy p, Monad m) => s -> (q -> StateP s p a' a b' b m r) -> (q -> p a' a b' b m s) -execStateK s = (execStateP s .) +execStateK s k q = execStateP s (k q) +-- execStateK s = (execStateP s .) -- | Get the current state -get :: (Monad (p a' a b' b m)) => StateP s p a' a b' b m s -get = StateP $ \s -> return (s, s) +get :: (Proxy p, Monad m) => StateP s p a' a b' b m s +get = StateP (\s -> return_P (s, s)) -- | Set the current state -put :: (Monad (p a' a b' b m)) => s -> StateP s p a' a b' b m () -put s = StateP $ \_ -> return ((), s) +put :: (Proxy p, Monad m) => s -> StateP s p a' a b' b m () +put s = StateP (\_ -> return_P ((), s)) -- | Modify the current state using a function -modify :: (Monad (p a' a b' b m)) => (s -> s) -> StateP s p a' a b' b m () -modify f = StateP $ \s -> return ((), f s) +modify :: (Proxy p, Monad m) => (s -> s) -> StateP s p a' a b' b m () +modify f = StateP (\s -> return_P ((), f s)) -- | Get the state filtered through a function -gets :: (Monad (p a' a b' b m)) => (s -> r) -> StateP s p a' a b' b m r -gets f = StateP $ \s -> return (f s, s) +gets :: (Proxy p, Monad m) => (s -> r) -> StateP s p a' a b' b m r +gets f = StateP (\s -> return_P (f s, s)) diff --git a/Control/Proxy/Trans/Tutorial.hs b/Control/Proxy/Trans/Tutorial.hs deleted file mode 100644 --- a/Control/Proxy/Trans/Tutorial.hs +++ /dev/null @@ -1,415 +0,0 @@ --- | This module provides the tutorial for the "Control.Proxy.Trans" hierarchy - -module Control.Proxy.Trans.Tutorial ( - -- * Motivation - -- $motivation - - -- * Proxy Transformers - -- $proxytrans - - -- * Compatibility - -- $compatibility - - -- * Proxy Transformer Stacks - -- $stacks - ) where - -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import Control.Proxy -import Control.Proxy.Trans.Either -import Control.Proxy.Trans.State - -{- $motivation - In a 'Session', all composed proxies share effects within the base monad. - To see how, consider the following simple 'Session': - -> client1 :: () -> Client () () (StateT Int IO) r -> client1 () = forever $ do -> s <- lift get -> lift $ lift $ putStrLn $ "Client: " ++ show s -> lift $ put (s + 1) -> request () -> -> server1 :: () -> Server () () (StateT Int IO) r -> server1 () = forever $ do -> s <- lift get -> lift $ lift $ putStrLn $ "Server: " ++ show s -> lift $ put (s + 1) -> respond () - ->>> (`evalStateT` 0) $ runProxy $ client1 <-< server1 -Client: 0 -Server: 1 -Client: 2 -Server: 3 -Client: 4 -Server: 5 -... - - The client and server share the same state, which is sometimes not what we - want. We can easily solve this by running each 'Proxy' with its own local - state by changing the order of the 'Proxy' and 'StateT' monad transformers: - -> client2 :: () -> StateT Int (Client () () IO) r -> client2 () = forever $ do -> s <- get -> lift $ lift $ putStrLn $ "Client: " ++ show s -> put (s + 1) -> lift $ request () -> -> server2 :: () -> StateT Int (Server () () IO) r -> server2 () = forever $ do -> s <- get -> lift $ lift $ putStrLn $ "Server: " ++ show s -> put (s + 1) -> lift $ respond () - - ... but then we can no longer compose them directly. We have to first - unwrap each one with 'evalStateT' before composing: - ->>> runProxy $ (`evalStateT` 0) . client2 <-< (`evalStateT` 0) . server2 -Client: 0 -Server: 0 -Client: 1 -Server: 1 -Client: 2 -Server: 2 -... - - Here's another example: suppose we want to handle errors within proxies. We - could try adding 'EitherT' to the base monad like so: - -> import Control.Error -> -> client3 :: () -> Client () () (EitherT String IO) () -> client3 () = forM_ [1..] $ \i -> do -> lift $ lift $ print i -> request () -> -> server3 :: (Monad m) => () -> Server () () (EitherT String m) r -> server3 () = lift $ left "ERROR" - ->>> runEithert $ runProxy $ client2 <-< server2 -1 -Left "ERROR" - - Unfortunately, we can't modify @server2@ to 'catchT' that error because we - cannot access the inner 'EitherT' monad transformer until we run the - 'Session'. We'd really prefer to place the 'EitherT' monad transformer - /outside/ the 'Proxy' monad transformer so that we can catch and handle - errors locally within a 'Proxy' without disturbing other proxies: - -> client4 :: () -> EitherT String (Client () () IO) () -> client4 () = forM_ [1..] $ \i -> do -> lift $ lift $ print i -> lift $ request () -> -> server4 :: () -> EitherT String (Server () () IO) () -> server4 () = (forever $ do -> lift $ respond () -> throwT "Error" ) -> `catchT` (\str -> do -> lift $ lift $ putStrLn $ "Caught: " ++ str -> server4 () ) - - However, this solution similarly requires unwrapping the client and server - using 'runEitherT' before composing them: - ->>> runProxy $ runEitherT . client4 <-< runEitherT . server4 -1 -Caught: Error -2 -Caught: Error -3 -Caught: Error -... - --} - -{- $proxytrans - We need some way to layer monad transformers /outside/ the proxy type - without interfering with 'Proxy' composition. To do this, we overload - 'Proxy' composition using the 'Channel' type class from - "Control.Proxy.Class": - -> class Channel p where -> idT :: (Monad) m => a' -> p a' a a' a m r -> (>->) -> :: (Monad m) -> => (b' -> p a' a b' b m r) -> -> (c' -> p b' b c' c m r) -> -> (c' -> p a' a c' c m r) - - Obviously, 'Proxy' implements this class: - -> instance Channel Proxy where ... - - ... but we would also like our monad transformers layered outside the - 'Proxy' type to also implement the 'Channel' class so that we could compose - them directly without unwrapping. Unfortunately, these monad transformers - do not fit the signature of the 'Channel' class. - - Fortunately, the "Control.Proxy.Trans" hierarchy provides several common - monad transformers which have been upgraded to fit the 'Channel' type class. - I call these \"proxy transformers\". - - For example, "Control.Proxy.Trans.State" provides a proxy transformer - equivalent to @Control.Monad.Trans.State@. Similarly, - "Control.Proxy.Trans.Either" provides a proxy transformer equivalent to - @Control.Monad.Trans.Either@. - - Let's use a working code example to demonstrate how to use them: - -> import Control.Proxy.Trans.State -> -> client5 :: () -> StateP Int Proxy () () () C IO r -> client5 () = forever $ do -> s <- get -> liftP $ lift $ putStrLn $ "Client: " ++ show s -> put (s + 1) -> liftP $ request () -> -> server5 :: () -> StateP Int Proxy C () () () IO r -> server5 () = forever $ do -> s <- get -> liftP $ lift $ putStrLn $ "Server: " ++ show s -> put (s + 1) -> liftP $ respond () - - You'll see that our type signatures changed. Now we use 'StateP' instead of - 'StateT'. However, 'StateP' does not transform monads, but instead - transforms proxies. - - To see this, let's first study the kind of 'StateT'. If we first define: - -> kind MonadKind = * -> * - - Then @StateT s@ takes a monad, and returns a new monad: - -> StateT s :: MonadKind -> MonadKind - - Now consider the kind of a 'Proxy'-like type constructor suitable for the - 'Channel' type class: - -> kind ProxyKind = * -> * -> * -> * -> (* -> *) -> * -> * - - Then @StateP s@ takes a 'Proxy'-like and returns a new 'Proxy'-like type: - -> StateP s :: ProxyKind -> ProxyKind - - This is why I call these \"proxy transformers\" and not monad transformers. - They all take some 'Proxy'-like type that implements 'Channel' and transform - it into a new 'Proxy'-like type that also implements 'Channel'. For - example, 'StateP' implement the following instance: - -> instance (Channel p) => Channel (StateP s p) where ... - - All proxy transformers guarantee that if the base proxy implements the - 'Channel' type class, then the transformed proxy also implements the - 'Channel' type class. This means that you can build a proxy transformer - stack, just like you might build a monad transformer stack. - - Unfortunately, in order to use proxy transformers, you must expand out the - 'Client' and 'Server' type synonyms, which are not compatible with proxy - transformers. Sorry! This is why there are no 'Server' or 'Client' type - synonyms in the types of our new client and server and I had to write out - all the inputs and outputs. - - Notice how the outermost 'lift' statements in our client and server have - changed to 'liftP'. 'liftP' replaces 'lift' for proxy transformers, and it - lifts any action in the base proxy to an action in the transformed proxy. - In the previous example, the base proxy was 'Proxy' and the transformed - proxy was @StateP s Proxy@, so 'liftP's type got specialized to: - -> liftP :: Proxy a' a b' b m r -> StateP s Proxy a' a b' b m r - - The 'ProxyTrans' class defines 'liftP', and all proxy transformers implement - the 'ProxyTrans' class. Since proxies are still monads, 'liftP' must - behave just like 'lift' and obey the monad transformer laws: - -> (liftP .) return = return -> -> (liftP .) (f >=> g) = (liftP .) f >=> (liftP .) g - - But, unlike 'lift', 'liftP' obeys one extra set of laws that guarantee it - also lifts composition sensibly: - -> (liftP .) idT = idT -> -> (liftP .) (f >-> g) = (liftP .) f >-> (liftP .) g - - In fact, this @(liftP .)@ pattern is so ubiquitous, that the 'ProxyTrans' - class provides the additional 'mapP' method for convenience: - -> mapP = (liftP .) - - Proxy transformers automatically derive how to lift composition correctly - and also guarantee that the derived composition obeys the category laws if - the base composition obeyed the category laws. Since 'Proxy' composition - obeys the category laws, any proxy transformer stack built on top of it - automatically derives a composition operation that is correct by - construction. - - Let's prove this by directly composing our 'StateP'-extended proxies without - unwrapping them: - -> :t client5 <-< server5 :: () -> StateP Int Proxy C () () C IO r - - However, we still have to unwrap the final 'StateP' 'Session' before we can - pass it to 'runProxy'. We use 'runStateK' for this purpose: - ->>> runProxy $ runStateK 0 $ client5 <-< server5 -Client: 0 -Server: 0 -Client: 1 -Server: 1 -Client: 2 -Server: 2 -Client: 3 -Server: 3 -... - - Keep in mind that 'runStateK' takes the initial state as its first argument, - unlike 'runStateT'. I break from the @transformers@ convention for - syntactic convenience. - - We can similarly fix our 'EitherT' example, using 'EitherP' from - "Control.Proxy.Trans.Either": - -> import Control.Proxy.Trans.Either as E -> -> client6 :: () -> EitherP String Proxy () () () C IO () -> client6 () = forM_ [1..] $ \i -> do -> liftP $ lift $ print i -> liftP $ request () -> -> server6 :: () -> EitherP String Proxy C () () () IO () -> server6 () = (forever $ do -> liftP $ respond () -> E.throw "Error" ) -> `E.catch` (\str -> do -> liftP $ lift $ putStrLn $ "Caught: " ++ str -> server6 () ) - ->>> runProxy $ runEitherK $ client6 <-< server6 -1 -Caught: Error -2 -Caught: Error -3 -Caught: Error -... - --} - -{- $compatibility - Proxy transformers do more than just lift composition. They automatically - promote proxies written in the base monad. For example, what if I wanted to - use the 'takeB_' proxy from "Control.Proxy.Prelude.Base" to cap the number - of results? I can't compose it directly because it uses the 'Proxy' type: - -> takeB_ :: (Monad m) => Int -> a' -> Proxy a' a a' a m () - - ... whereas @client6@ and @server6@ use @EitherP String Proxy@. However, - this doesn't matter because we can automatically lift 'takeB_' to be - compatible with them using 'mapP': - ->>> runProxy $ runEitherK $ client6 <-< mapP (takeB_ 2) <-< server6 -1 -Caught: Error -2 -Caught:Error - - 'mapP' promotes any proxy written using the base proxy type to automatically - be compatible with proxies written using the extended proxy type. This - means you can safely write utility proxies using the smallest feature set - they require and promote them as necessary to work with more extended - feature sets. This ensures that any proxies you write always remain - forwards-compatible as people write new extensions. --} - -{- $stacks - You can stack proxy transformers to combine their effects, such as in the - following example, which combines everything we've used so far: - -> client7 :: () -> EitherP String (StateP Int Proxy) () Int () C IO r -> client7 () = do -> n <- liftP get -> liftP $ liftP $ lift $ print n -> n' <- liftP $ liftP $ request () -> liftP $ put n' -> E.throw "ERROR" - ->>> runProxy $ runStateK 0 $ runEitherK $ client7 <-< mapP (mapP (enumFromS 1)) -0 -(Left "Error", 1) - - But that's still not the full story! For calls to the base monad (i.e. 'IO' - in this case), you don't need to precede them with all those 'liftP's. - Every proxy transformer also correctly derives 'MonadTrans', so you can dig - straight to the base monad by just calling 'lift' at the outer-most level: - -> client7 :: () -> EitherP String (StateP Int Proxy) () Int () C IO r -> client7 () = do -> n <- liftP get -> lift $ print n -- Much better! -> n' <- liftP $ liftP $ request () -> liftP $ put n' -> E.throw "ERROR" - - Also, you can combine multiple proxy transformers into a single proxy - transformer, just like you would with monad transformers: - -> newtype BothP e s p a' a b' b m r = -> BothP { unBothP :: EitherP e (StateP s p) a' a b' b m r } -> deriving (Functor, Applicative, Monad, MonadTrans, Channel) -> -> instance ProxyTrans (BothP e s) where -> liftP = BothP . liftP . liftP -> -> runBoth -> :: (Monad m) -> => s -> -> (b' -> BothP e s p a' a b' b m r) -> -> (b' -> p a' a b' b m (Either e r, s)) -> runBoth s = runStateK s . runEitherK . fmap unBothP -> -> get' :: (Monad (p a' a b' b m), Channel p) -> => BothP e s p a' a b' b m s -> get' = BothP $ liftP get -> -> put' :: (Monad (p a' a b' b m), Channel p) -> => s -> BothP e s p a' a b' b m () -> put' x = BothP $ liftP $ put x -> -> throw' :: (Monad (p a' a b' b m), Channel p) -> => e -> BothP e s p a' a b' b m r -> throw' e = BothP $ E.throw e - - Then we can write proxies using this new proxy transformer of ours: - -> client8 :: () -> BothP String Int Proxy () Int () C IO r -> client8 () = do -> n <- get' -> lift $ print n -> n' <- liftP $ request () -> put' n' -> throw' "ERROR" - ->>> runProxy $ runBoth 0 $ client8 <-< mapP (enumFromS 1) -0 -(Left "ERROR",1) - - Note that 'request' and 'respond' are not automatically liftable, because of - technical limitations with Haskell type classes. When I resolve these - issues they will also be automatically promoted by proxy transformers. For - now, you must lift them manually using 'liftP': - -> request = (liftP .) request -> respond = (liftP .) respond - - The left 'request' and 'respond' in the above equations are what the lifted - definitions would be for each proxy transformer if Haskell's type class - system didn't get in my way. --} 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 @@ -6,7 +6,7 @@ The underlying implementation uses the state monad to avoid quadratic blowup from left-associative binds. -} -{-# LANGUAGE FlexibleContexts, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} module Control.Proxy.Trans.Writer ( -- * WriterP @@ -21,11 +21,12 @@ ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (liftM, ap, MonadPlus(mzero, mplus)) +import Control.Monad (MonadPlus(mzero, mplus)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.MFunctor (MFunctor(mapT)) -import Control.Proxy.Class (Channel(idT, (>->))) +import Control.MFunctor (MFunctor(hoist)) +import Control.PFunctor (PFunctor(hoistP)) +import Control.Proxy.Class import Control.Proxy.Trans (ProxyTrans(liftP)) import Data.Monoid (Monoid(mempty, mappend)) @@ -33,51 +34,88 @@ newtype WriterP w p a' a b' b (m :: * -> *) r = WriterP { unWriterP :: w -> p a' a b' b m (r, w) } -instance (Monad (p a' a b' b m)) - => Functor (WriterP w p a' a b' b m) where - fmap = liftM +instance (Proxy p, Monad m) + => Functor (WriterP w p a' a b' b m) where + fmap f p = WriterP (\w0 -> + unWriterP p w0 ?>= \(x, w1) -> + return_P (f x, w1) ) -instance (Monad (p a' a b' b m)) - => Applicative (WriterP w p a' a b' b m) where - pure = return - (<*>) = ap +instance (Proxy p, Monad m) + => Applicative (WriterP w p a' a b' b m) where + pure = return + fp <*> xp = WriterP (\w0 -> + unWriterP fp w0 ?>= \(f, w1) -> + unWriterP xp w1 ?>= \(x, w2) -> + return_P (f x, w2) ) + -- (<*>) = ap -instance (Monad (p a' a b' b m)) - => Monad (WriterP w p a' a b' b m) where - return a = WriterP $ \w -> return (a, w) - m >>= f = WriterP $ \w -> do - (a, w') <- unWriterP m w - unWriterP (f a) w' +instance (Proxy p, Monad m) + => Monad (WriterP w p a' a b' b m) where + return = return_P + (>>=) = (?>=) -instance (MonadPlus (p a' a b' b m)) - => Alternative (WriterP w p a' a b' b m) where +instance (MonadPlusP p, Monad m) + => Alternative (WriterP w p a' a b' b m) where empty = mzero (<|>) = mplus -instance (MonadPlus (p a' a b' b m)) - => MonadPlus (WriterP w p a' a b' b m) where - mzero = WriterP $ \_ -> mzero - mplus m1 m2 = WriterP $ \w -> mplus (unWriterP m1 w) (unWriterP m2 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 (MonadTrans (p a' a b' b)) - => MonadTrans (WriterP w p a' a b' b) where - lift m = WriterP $ \w -> lift $ liftM (\r -> (r, w)) m +instance (MonadPlusP p, Monad m) + => MonadPlus (WriterP w p a' a b' b m) where + mzero = mzero_P + mplus = mplus_P -instance (MonadIO (p a' a b' b m)) - => MonadIO (WriterP w p a' a b' b m) where - liftIO m = WriterP $ \w -> liftIO $ liftM (\r -> (r, w)) m +instance (Proxy p ) + => MonadTrans (WriterP w p a' a b' b) where + lift = lift_P -instance (MFunctor (p a' a b' b)) => MFunctor (WriterP w p a' a b' b) where - mapT nat = WriterP . fmap (mapT nat) . unWriterP +instance (MonadIOP p ) + => MonadIOP (WriterP w p) where + liftIO_P m = WriterP (\w -> liftIO_P (m >>= \r -> return (r, w))) -instance (Channel p) => Channel (WriterP w p) where - idT a = WriterP $ \_ -> idT a - (p1 >-> p2) a = WriterP $ \w -> - ((`unWriterP` w) . p1 >-> (`unWriterP` w) . p2) a +instance (MonadIOP p, MonadIO m) + => MonadIO (WriterP w p a' a b' b m) where + liftIO = liftIO_P -instance (Monoid w) => ProxyTrans (WriterP w) where - liftP m = WriterP $ \w -> liftM (\r -> (r, w)) m +instance (Proxy p ) + => MFunctor (WriterP w p a' a b' b) where + hoist = hoist_P +instance (Proxy p ) + => Proxy (WriterP w p) where + p1 >-> p2 = \c'1 -> WriterP (\w -> + ((\b' -> unWriterP (p1 b') w) >-> (\c'2 -> unWriterP (p2 c'2) w)) c'1 ) + {- p1 >-> p2 = \c' -> WriterP $ \w -> + ((`unWriterP` w) . p1 >-> (`unWriterP` w) . p2) c' -} + + p1 >~> p2 = \c'1 -> WriterP (\w -> + ((\b' -> unWriterP (p1 b') w) >~> (\c'2 -> unWriterP (p2 c'2) w)) c'1 ) + {- p1 >~> p2 = \c' -> WriterP $ \w -> + ((`unWriterP` w) . p1 >~> (`unWriterP` w) . p2) c' -} + + request = \a' -> WriterP (\w -> request a' ?>= \a -> return_P (a, w)) + respond = \b -> WriterP (\w -> respond b ?>= \b' -> return_P (b', w)) + + return_P = \r -> WriterP (\w -> return_P (r, w)) + m ?>= f = WriterP (\w -> + unWriterP m w ?>= \(a, w') -> + unWriterP (f a) w' ) + + lift_P m = WriterP (\w -> lift_P (m >>= \r -> return (r, w))) + + hoist_P nat p = WriterP (\w -> hoist_P nat (unWriterP p w)) + -- hoist_P nat = WriterP . fmap (hoist_P nat) . unWriterP + +instance ProxyTrans (WriterP w) where + liftP m = WriterP (\w -> m ?>= \r -> return_P (r, w)) + +instance PFunctor (WriterP w) where + hoistP nat = WriterP . (nat .) . unWriterP + -- | Run a 'WriterP' computation, producing the final result and monoid runWriterP :: (Monoid w) => WriterP w p a' a b' b m r -> p a' a b' b m (r, w) runWriterP p = unWriterP p mempty @@ -86,26 +124,31 @@ runWriterK :: (Monoid w) => (q -> WriterP w p a' a b' b m r) -> (q -> p a' a b' b m (r, w)) -runWriterK = (runWriterP . ) +runWriterK k q = runWriterP (k q) +-- runWriterK = (runWriterP . ) -- | Evaluate a 'WriterP' computation, but discard the final result execWriterP - :: (Monad (p a' a b' b m), Monoid w) + :: (Proxy p, Monad m, Monoid w) => WriterP w p a' a b' b m r -> p a' a b' b m w -execWriterP m = liftM snd $ runWriterP m +execWriterP m = runWriterP m ?>= \(_, w) -> return_P w +-- execWriterP m = liftM snd $ runWriterP m -- | Evaluate a 'WriterP' \'@K@\'leisli arrow, but discard the final result execWriterK - :: (Monad (p a' a b' b m), Monoid w) + :: (Proxy p, Monad m, Monoid w) => (q -> WriterP w p a' a b' b m r) -> (q -> p a' a b' b m w) -execWriterK = (execWriterP .) +execWriterK k q= execWriterP (k q) -- | Add a value to the monoid -tell :: (Monad (p a' a b' b 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 ((), w'') +tell :: (Proxy p, Monad m, Monoid w) => w -> WriterP w p a' a b' b m () +tell w' = WriterP (\w -> let w'' = mappend w w' in w'' `seq` return_P ((), w'')) -- | Modify the result of a writer computation censor - :: (Monad (p a' a b' b m), Monoid w) + :: (Proxy p, Monad m, Monoid w) => (w -> w) -> WriterP w p a' a b' b m r -> WriterP w p a' a b' b m r -censor f = WriterP . fmap (liftM (\(a, w) -> (a, f w))) . unWriterP +censor f p = WriterP (\w0 -> + unWriterP p w0 ?>= \(r, w1) -> + return_P (r, f w1) ) +-- censor f = WriterP . fmap (liftM (\(r, w) -> (r, f w))) . unWriterP diff --git a/Control/Proxy/Tutorial.hs b/Control/Proxy/Tutorial.hs --- a/Control/Proxy/Tutorial.hs +++ b/Control/Proxy/Tutorial.hs @@ -1,550 +1,1890 @@ --- | This module provides the tutorial for "Control.Proxy" - -module Control.Proxy.Tutorial ( - -- * Basics - -- $basics - - -- * Types - -- $types - - -- * Composition - -- $composition - - -- * Idioms - -- $idioms - - -- * Reusability - -- $reuse - - -- * Mixing monads and composition - -- $monads - - -- * Utility proxies - -- $utility - - -- * Pipe compatibility - -- $pipes - ) where - -import Control.Monad.Trans.Class -import Control.Proxy - -{- $basics - The 'Proxy' type models composable chains of client-server interactions. - - A 'Proxy' is a monad transformer that extends the base monad with the - ability to 'request' input from upstream and 'respond' with output to - downstream. - - For example, consider the following toy remote procedure call - 'Server': - -> import Control.Proxy -> import Control.Monad.Trans -> -> incrementer :: Int -> Server Int Int IO r -> incrementer question = do -> lift $ putStrLn $ "Server received : " ++ show question -> let answer = question + 1 -> lift $ putStrLn $ "Server responded: " ++ show answer -> nextQuestion <- respond answer -> incrementer nextQuestion - - We can understand what the 'Server' does just by looking at the type: - -> | Question | Answer | Base monad | Return value -> Server Int Int IO r - - Our 'Server' receives questions about 'Int's, and responds with answers that - are 'Int's. The base monad is 'IO' because our 'Server' 'lift's two - 'putStrLn' statements to chat out loud. The return value is polymorphic - because our 'Server' never terminates. - - Note that the base monad doesn't always need to be 'IO'. Unlike typical - servers, these kinds of 'Server's are pure syntax trees with no side - effects unless you call 'lift'. - - Now we can write a 'Client' that interacts with our 'Server': - -> import Control.Monad -> -> oneTwoThree :: () -> Client Int Int IO () -> oneTwoThree () = forM_ [1, 2, 3] $ \question -> do -> lift $ putStrLn $ "Client requested: " ++ show question -> answer <- request question -> lift $ putStrLn $ "Client received : " ++ show answer -> lift $ putStrLn "*" - - Again, the type explains what the 'Client' does: - -> | Question | Answer | Base monad | Return value -> Client Int | Int | IO | () - - Our 'Client' asks questions about 'Int's and receives answers that are - 'Int's. The 'Client' also uses 'IO' as the base monad. - - We can then compose the 'Client' and 'Server' into a 'Session' using the - ('<-<') operator: - -> session :: () -> Session IO () -> session = oneTwoThree <-< incrementer - - The 'Session' type indicates that we have a self-contained session that we - can run in the 'IO' monad. We run it using the the 'runProxy' function: - ->>> runProxy session :: IO () -Client requested: 1 -Server received : 1 -Server responded: 2 -Client received : 2 -* -Client requested: 2 -Server received : 2 -Server responded: 3 -Client received : 3 -* -Client requested: 3 -Server received : 3 -Server responded: 4 -Client received : 4 -* - - Now, let's add an intermediate 'Proxy' between the 'Client' and 'Server' - that subtly tampers with the stream going through it: - -> malicious :: Int -> Proxy Int Int Int Int IO r -> malicious question = do -> question' <- if (question > 2) -> then do -> lift $ putStrLn "MUAHAHAHA!" -> return (question + 1) -> else return question -> answer <- request question' -> nextQuestion <- respond answer -> malicious nextQuestion - - The type tells us what our 'Proxy' does: - -> | Upstream (Server) | Downstream (Client) | -> | Question | Answer | Question | Answer | Base monad | Return value -> Proxy Int Int Int Int IO r - - A 'Proxy' bridges two separate interfaces. The first two parameters define - the upstream interface (i.e. in the 'Server' direction) and the second two - parameters define the downstream interface (i.e. in the 'Client' direction). - - We can see if our proxy does its job correctly: - ->>> runProxy $ oneTwoThree <-< malicious <-< incrementer -Client requested: 1 -Server received : 1 -Server responded: 2 -Client received : 2 -* -Client requested: 2 -Server received : 2 -Server responded: 3 -Client received : 3 -* -Client requested: 3 -MUAHAHAHA! -Server received : 4 -Server responded: 5 -Client received : 5 -* - - We can also add more proxies as we see fit: - ->>> runProxy $ oneTwoThree <-< malicious <-< malicious <-< incrementer -Client requested: 1 -Server received : 1 -Server responded: 2 -Client received : 2 -* -Client requested: 2 -Server received : 2 -Server responded: 3 -Client received : 3 -* -Client requested: 3 -MUAHAHAHA! -MUAHAHAHA! -Server received : 5 -Server responded: 6 -Client received : 6 -* --} - -{- $types - You probably noticed something odd: ('<-<') seems to be composing values of - different types. Sometimes it composes a 'Server' or a 'Client' or a - 'Proxy'. In reality, though, both 'Server' and 'Client' are just type - synonyms for special cases of 'Proxy': - -> type Server arg ret = Proxy C () arg ret -> type Client arg ret = Proxy arg ret () C - - A 'Server' is just a 'Proxy' that has no upstream interface, and a 'Client' - is just a 'Proxy' that has no downstream interface. In fact, 'Session' is - also a 'Proxy', one with both ends closed: - -> type Session = Proxy C () () C - - The 'Proxy' is the unifying type that all other types derive from and - ('<-<') always composes two 'Proxy's and returns a new 'Proxy' of the - correct type. - - You also probably noticed another odd thing: we parametrize every 'Proxy' - on its initial argument: - -> +- Initial Arg -> | -> v -> incrementer :: Int -> Server Int Int IO r -> malicious :: Int -> Proxy Int Int Int Int IO r -> oneTwoThree :: () -> Client Int Int IO () -> -> session :: () -> Session IO () - - This input initializes each 'Proxy' and corresponds to the input on the - downstream interface. I will expand the 'Server' and 'Client' type synonyms - to show this: - -> +- Initial Arg = This -+ -> | | -> v v -> incrementer :: Int -> Proxy C () Int Int IO r -> malicious :: Int -> Proxy Int Int Int Int IO r -> oneTwoThree :: () -> Proxy Int Int () C IO () -> -> session :: () -> Proxy C () () C IO () - - Composition supplies the first request through this initial parameter - and all subsequent requests are bound to 'respond' statements. - - This means that the actual types you compose are all of the form: - -> proxy :: req_b -> Proxy req_a resp_a req_b resp_b m r --} - -{- $composition - 'Proxy' composition posseses an identity 'Proxy' that is completely - transparent to anything upstream or downstream of it: - -> idT :: (Monad m) => req -> Proxy req resp req resp m r -> idT question = do -> answer <- request question -> nextQuestion <- respond answer -> idT nextQuestion - - Transparency means that: - -> idT <-< p = p -> -> p <-< idT = p - - Also, 'Proxy' composition has the nice property that it behaves exactly the - same way no matter how you group components: - -> (p1 <-< p2) <-< p3 = p1 <-< (p2 <-< p3) - - This means that ('<-<') and 'idT' define a category, and the above equations - are the category laws. These laws guarantee the following nice - properties of components: - - * You can reason about each component's behavior independently of other - components - - * You don't encounter boundary cases between components - - * You don't encounter edge cases at the 'Server' or 'Client' ends - - The semantics of 'Proxy' composition are simple: - - * 'request' blocks until it receives a response from upstream - - * 'respond' blocks until it receives a new request from downstream - - * If any 'Proxy' in the chain terminates, the entire chain terminates --} - -{- $idioms - We frequently encounter the following recurring pattern when writing - 'Proxy's: - -> someProxy arg = do -> ... -> nextArg <- respond x -> someProxy nextArg - - "Control.Proxy" provides the 'foreverK' utility function which abstracts - away this manual recursion: - -> foreverK f = f >=> foreverK f - - Using 'foreverK', we can simplify the definition of 'incrementer': - -> incrementer = foreverK $ \question -> do -> lift $ putStrLn $ "Server received : " ++ show question -> let answer = question + 1 -> lift $ putStrLn $ "Server responded: " ++ show answer -> respond answer - - ... which looks exactly like the way you might write server code in another - programming language. - - We can similarly simplify 'malicious' this way: - -> malicious = foreverK $ \question -> do -> question' <- if (question > 2) -> then do -> lift $ putStrLn "MUAHAHAHA!" -> return (question + 1) -> else return question -> answer <- request question' -> respond answer - - ... or 'idT': - -> idT = foreverK $ \question -> do -> answer <- request question -> respond answer -> -> -- or: idT = foreverK (request >=> respond) -> -- = request >=> respond >=> request >=> respond >=> ... --} - -{- $reuse - We can mix and match different components to rapidly define emergent - behaviors from a resuable set of core primitives. For example, we could - replace our client with a command line prompt where the user provides the - input to the server: - -> inputPrompt :: (Read a, Show b) => () -> Client a b IO r -> inputPrompt () = forever $ do -> str <- lift $ getLine -> let a = read str -> b <- request a -> lift $ print b -> lift $ putStrLn "*" - ->>> runProxy $ inputPrompt <-< incrementer -42 -Server received : 42 -Server responded: 43 -43 -* -666 -Server received : 666 -Server responded: 667 -667 -* - - Oh no, we lost our useful client diagnostic messages! No worries, we can - abstract that functionality away into its own component: - -> diagnoseClient :: (Show a, Show b) => a -> Proxy a b a b IO r -> diagnoseClient = foreverK $ \a -> do -> lift $ putStrLn $ "Client requested: " ++ show a -> b <- request a -> lift $ putStrLn $ "Client received : " ++ show b -> respond b - ->>> runProxy $ inputPrompt <-< diagnoseClient <-< incrementer -42 -Client requested: 42 -Server received : 42 -Server responded: 43 -Client received : 43 -43 -* -666 -Client requested: 666 -Server received : 666 -Server responded: 667 -Client received : 667 -667 -* - - Because of associativity, we can bundle @inputPrompt@ and @diagnoseClient@ - into a single black box and not worry that the abstraction will leak due to - grouping issues: - -> verboseInput :: (Read a, Show b, Show a) => () -> Client a b IO r -> verboseInput = inputPrompt <-< diagnoseClient - ->>> runProxy $ verboseInput <-< incrementer - - - Or what if I want to cache the results coming out of @incrementer@? I can - define a 'Proxy' to cache all requests going through it: - -> import qualified Data.Map as M -> -> cache :: (Ord a) => a -> Proxy a b a b IO r -> cache = cache' M.empty -> -> cache' m a = -> case M.lookup a m of -> Nothing -> do -> b <- request a -> a' <- respond b -> cache' (M.insert a b m) a' -> Just b -> do -> lift $ putStrLn "Used cache!" -> a' <- respond b -> cache' m a' - ->>> runProxy $ verboseInput <-< cache <-< incrementer -42 -Client requested: 42 -Server received : 42 -Server responded: 43 -Client received : 43 -43 -* -42 -Client requested: 42 -Used cache! -Client received : 43 -43 -* - - Note that I don't distinguish between a \"reverse proxy\" or a \"forward - proxy\" since composition doesn't distinguish either. You can attach the - @cache@ 'Proxy' to a 'Client': - -> client' = client <-< cache - - ... or to a 'Server': - -> server' = cache <-< server - - ... or anywhere in between. It's completely up to you! --} - -{- $monads - All the previous examples use a single composition chain, but you need not - restrict yourself to that design pattern. Remember that the result of - composition is a 'Proxy' itself (parametrized by an input), and 'Proxy's are - 'Monad's, so you can bind the result of composition directly within another - @do@ block to generate complex behaviors: - -> mixedClient :: () -> Client Int Int IO r -> mixedClient () = do -> oneTwoThree () -> -- Here we bind composition within a larger do block -> (inputPrompt <-< cache) () -> -> -- or: mixedClient = oneTwoThree >=> (inputPrompt <-< cache) - ->>> runProxy $ mixedClient <-< incrementer -Client requested: 1 -Server received : 1 -Server responded: 2 -Client received : 2 -* -Client requested: 2 -Server received : 2 -Server responded: 3 -Client received : 3 -* -Client requested: 3 -Server received : 3 -Server responded: 4 -Client received : 4 -* -42 -Server received : 42 -Server responded: 43 -43 -* -42 -Used cache! -43 -* - - So feel free to use your imagination! Up until the moment you call - 'runProxy', you can freely mix composition or @do@ notation within each - other. --} - -{- $utility - This library features several utility proxies to get you started. They all - reside under the "Control.Proxy.Prelude" hierarchy and they are imported by - default when you import "Control.Proxy". - - For example, if you wanted to print the first 3 natural numbers, you would - use: - ->>> runProxy $ printD <-< enumFromToS 1 3 -1 -2 -3 - - The utility functions follow a systematic naming convention that uses the - last letter: - - * @D@: Only interacts with values going \'@D@\'ownstream towards the - 'Client' - - * @U@: Only interacts with values going \'@U@\'pstream towards the 'Server' - - * @B@: Interacts with values going \'@B@\'oth ways - - * @C@: Belongs in the \'@C@\'lient position - - * @S@: Belongs in the \'@S@\'server position - - Many utility proxies auto-forward values they receive, such as 'printD'. - This means we can easily combine multiple handling stages for processing - values: - -> import Control.Proxy -> import System.IO -> -> main = do -> h <- openFile "test.txt" WriteMode -> runProxy $ hPrintD h <-< printD <-< enumFromToS 1 3 -> hClose h - ->>> main -1 -2 -3 - - The above program also wrote the same output to the file "test.txt": - -> $ cat test.txt -> 1 -> 2 -> 3 - - 'runProxy' discards any output that goes past the endpoints of the session, - so you don't need to worry about closing off each end. - - This library does not provide 'ByteString' or 'Text' utilities in order to - reduce the number of dependencies of the main package. These will be - released in a separate package in the near future. --} - -{- $pipes - 'Proxy's generalize 'Pipe's by permitting communication upstream. - Fortunately, though, you don't need to rewrite your code if you have already - used 'Pipe's. "Control.Proxy" formulates all of the 'Pipe' types and - primitives in terms of the 'Proxy' type. - - This means that if you wish to upgrade your 'Pipe' code to take advantage of - upstream communication, you only need to import "Control.Proxy" instead - of "Control.Pipe" and everything will still work out of the box. Then you - can selectively upgrade certain components to communicate upstream as - necessary. - - To understand how 'Pipe's map onto 'Proxy's, just check out the 'Pipe' - definition in "Control.Proxy.Pipe": - -> type Pipe a b = Proxy () a () b - - In other words, a 'Pipe' is just a 'Proxy' where you never pass any - information upstream. +{-| This module provides a brief introductory tutorial in the \"Introduction\" + section followed by a lengthy discussion of the library's design and idioms. +-} + +module Control.Proxy.Tutorial ( + -- * Introduction + -- $intro + + -- * Bidirectionality + -- $bidir + + -- * Type Synonyms + -- $synonyms + + -- * Request and Respond + -- $interact + + -- * Composition + -- $composition + + -- * The Proxy Class + -- $class + + -- * Interleaving Effects + -- $interleave + + -- * Mixing Base Monads + -- $hoist + + -- * Utilities + -- $utilities + + -- * Mix Monads and Composition + -- $mixmonadcomp + + -- * Folds + -- $folds + + -- * Resource Management + -- $resource + + -- * Extensions + -- $extend + + -- * Error handling + -- $error + + -- * Local state + -- $state + + -- * Branching, zips, and merges + -- $branch + + -- * Proxy Transformers + -- $proxytrans + + -- * Conclusion + -- $conclusion + ) where + +-- For documentation +import Control.Category +import Control.Monad.Trans.Class +import Control.MFunctor +import Control.PFunctor +import Control.Proxy +import Control.Proxy.Core.Correct (ProxyCorrect) +import Control.Proxy.Trans.Either +import Prelude hiding (catch) + +{- $intro + The @pipes@ library replaces lazy 'IO' with a safe, elegant, and + theoretically principled alternative. Use this library if you: + + * want to write high-performance streaming programs + + * believe that lazy 'IO' was a bad idea + + * enjoy composing modular and reusable components + + * love theory and elegant code + + This library unifies many kinds of streaming abstractions, all of which are + special cases of \"proxies\" (The @pipes@ name is a legacy of one such + abstraction). + + Let's begin with the simplest 'Proxy': a 'Producer'. The following + 'Producer' lazily streams lines from a 'Handle' + +> import Control.Monad +> import Control.Proxy +> import System.IO +> +> -- Produces Strings ---+----------+ +> -- | | +> -- v v +> lines' :: (Proxy p) => Handle -> () -> Producer p String IO r +> lines' h () = runIdentityP loop where +> loop = do +> eof <- lift $ hIsEOF h +> if eof +> then return () +> else do +> str <- lift $ hGetLine h +> respond str -- Produce the string +> loop +> +> -- Ignore the 'runIdentityP' and '()' for now + + But why limit ourselves to streaming lines from some file? Why not lazily + generate values from an industrious user? + +> -- Uses 'IO' as the base monad --+ +> -- | +> -- v +> promptInt :: (Proxy p) => () -> Producer p Int IO r +> promptInt () = runIdentityP $ forever $ do +> lift $ putStrLn "Enter an Integer:" +> n <- lift readLn -- 'lift' invokes an action in the base monad +> respond n + + Now we need to hook our 'Producer's up to a 'Consumer'. The following + 'Consumer' endlessly 'request's a stream of 'Show'able values and 'print's + them: + +> -- Consumes 'a's ---+----------+ +-- Never terminates, so +> -- | | | the return value is +> -- v v v polymorphic +> printer :: (Proxy p, Show a) => () -> Consumer p a IO r +> printer () = runIdentityP $ forever $ do +> a <- request () -- Consume a value +> lift $ putStrLn "Received a value:" +> lift $ print a + + You can compose a 'Producer' and a 'Consumer' using ('>->'), which produces + a runnable 'Session': + +> -- Self-contained session ---+ +--+-- These must match +> -- | | | each component +> -- v v v +> promptInt >-> printer :: (Proxy p) => () -> Session p IO r +> +> lines' h >-> printer :: (Proxy p) => () -> Session p IO () + + ('>->') connects each 'request' in @printer@ with a 'respond' in + @lines'@ or @promptInt@. + + Finally, you use 'runProxy' to run the 'Session' and convert it back to the + base monad. First we'll try our @lines'@ 'Producer', which will stream + lines from the following file: + +> $ cat test.txt +> Line 1 +> Line 2 +> Line 3 + + The following program never brings more than a single line into memory (not + that it matters for such a small file): + +>>> withFile "test.txt" $ \h -> runProxy $ lines' h >-> printer +Received a value: +"Line 1" +Received a value: +"Line 2" +Received a value: +"Line 3" + + Similarly, we can lazily stream user input, requesting values from the user + only when we need them: + +>>> runProxy $ promptInt >-> printer :: IO r +Enter an Integer: +1 +Received a value: +1 +Enter an Integer: +5 +Received a value: +5 +... + + The last example proceeds endlessly until we hit @Ctrl-C@ to interrupt it. + + We would like to limit the number of iterations, so lets define an + intermediate 'Proxy' that behaves like a verbose 'take'. I will call it a + 'Pipe' (this library's namesake) since values flow through it: + +> 'a's flow in ---+ +--- 'a's flow out +> | | +> v v +> take' :: (Proxy p) => Int -> () -> Pipe p a a IO () +> take' n () = runIdentityP $ do +> replicateM_ n $ do +> a <- request () +> respond a +> lift $ putStrLn "You shall not pass!" + + This 'Pipe' forwards the first @n@ values it receives undisturbed, then it + outputs a cute message. You can compose it between the 'Producer' and + 'Consumer' using ('>->'): + +>>> runProxy $ promptInt >-> take' 2 >-> printer :: IO () +Enter an Integer: +9 +Received a value: +9 +Enter an Integer: +2 +Received a value: +2 +You shall not pass! + + When @take' 2@ terminates, it brings down every 'Proxy' composed with it. + + Notice how @promptInt@ behaves lazily and only 'respond's with as many + values as we 'request'. We 'request'ed exactly two values, so it only + prompts the user twice. + + We can already spot several improvements upon traditional lazy 'IO': + + * You can define your own lazy components that have nothing to do with files + + * @pipes@ never uses 'unsafePerformIO' or violates referential transparency. + + * You don't need strictness hacks to ensure the proper ordering of effects + + * You can interleave effects in downstream stages, too + + However, this library can offer even more than that! +-} + +{- $bidir + So far we've only defined proxies that send information downstream in the + direction of the ('>->') arrow. However, we don't need to limit ourselves + to unidirectional communication and we can enhance these proxies with the + ability to send information upstream with each 'request' that determines + how upstream stages 'respond'. + + For example, 'Client's generalize 'Consumer's because they can supply an + argument other than @()@ with each 'request'. The following 'Client' + sends three 'request's upstream, each of which provides an 'Int' @argument@ + and expects a 'Bool' @result@: + +> Sends out 'Int's ---+ +-- Receives back 'Bool's +> | | +> v v +> threeReqs :: (Proxy p) => () -> Client p Int Bool IO () +> threeReqs () = runIdentityP $ forM_ [1, 3, 1] $ \argument -> do +> lift $ putStrLn $ "Client Sends: " ++ show (argument :: Int) +> result <- request argument +> lift $ putStrLn $ "Client Receives:" ++ show (result :: Bool) +> lift $ putStrLn "*" + + Notice how 'Client's use \"@request argument@\" instead of + \"@request ()@\". This sends \"@argument@\" upstream to parametrize the + 'request'. + + 'Server's similarly generalize 'Producer's because they receive arguments + other than @()@. The following 'Server' receives 'Int' 'request's and + 'respond's with 'Bool' values: + +> Receives 'Int's ---+ +--- Replies with 'Bool's +> | | +> v v +> comparer :: (Proxy p) => Int -> Server p Int Bool IO r +> comparer = runIdentityK loop where +> loop argument = do +> lift $ putStrLn $ "Server Receives:" ++ show (argument :: Int) +> let result = argument > 2 +> lift $ putStrLn $ "Server Sends: " ++ show (result :: Bool) +> nextArgument <- respond result +> loop nextArgument + + Notice how 'Server's receive their first argument as a parameter and bind + each subsequent argument using 'respond'. This library provides a + combinator which abstracts away this common pattern: + +> foreverK :: (Monad m) => (a -> m a) -> a -> m b +> foreverK f = loop where +> loop argument = do +> nextArgument <- f argument +> loop nextArgument +> +> -- or: foreverK f = f >=> foreverK f +> -- = f >=> f >=> f >=> f >=> ... + + We can use this to simplify the @comparer@ 'Server': + +> comparer = runIdentityK $ foreverK $ \argument -> do +> lift $ putStrLn $ "Server Receives:" ++ show argument +> let result = argument > 2 +> lift $ putStrLn $ "Server Sends: " ++ show result +> respond result + + ... which looks just like the way you might write a server's main loop in + another programming language. + + You can compose a 'Server' and 'Client' using ('>->'), and this also returns + a runnable 'Session': + +> comparer >-> threeReqs :: (Proxy p) => () -> Session p IO () + + Running this executes the client-server session: + +>>> runProxy $ comparer >-> threeReqs :: IO () +Client Sends: 1 +Server Receives: 1 +Server Sends: False +Client Receives: False +* +Client Sends: 3 +Server Receives: 3 +Server Sends: True +Client Receives: True +* +Client Sends: 1 +Server Receives: 1 +Server Sends: False +Client Receives: False +* + + 'Proxy's generalize 'Pipe's because they allow information to flow upstream. + The following 'Proxy' caches 'request's to reduce the load on the 'Server' + if the request matches a previous one: + +> import qualified Data.Map as M +> +> -- 'p' is the Proxy, as the (Proxy p) constraint indicates +> +> cache :: (Proxy p, Ord key) => key -> p key val key val IO r +> cache = runIdentityK (loop M.empty) where +> loop _map key = case M.lookup key _map of +> Nothing -> do +> val <- request key +> key2 <- respond val +> loop (M.insert key val _map) key2 +> Just val -> do +> lift $ putStrLn "Used cache!" +> key2 <- respond val +> loop _map key2 + + You can compose the @cache@ 'Proxy' between the 'Server' and 'Client' using + ('>->'): + +>>> runProxy $ comparer >-> cache >-> threeReqs +Client Sends: 1 +Server Receives: 1 +Server Sends: False +Client Receives: False +* +Client Sends: 3 +Server Receives: 3 +Server Sends: True +Client Receives: True +* +Client Sends: 1 +Used cache! +Client Receives: False +* + + This bidirectional flow of information separates @pipes@ from other + streaming libraries which are unable to model 'Client's, 'Server's, or + 'Proxy's. Using @pipes@ you can define interfaces to RPC interfaces, REST + architectures, message buses, chat clients, web servers, network protocols + ... you name it! +-} + +{- $synonyms + You might wonder why ('>->') accepts 'Producer's, 'Consumer's, 'Pipe's, + 'Client's, 'Server's, and 'Proxy's. It turns out that these type-check + because they are all type synonyms that expand to the following central + type: + +> (Proxy p) => p a' a b' b m r + + Like the name suggests, a 'Proxy' exposes two interfaces: an upstream + interface and a downstream interface. Each interface can both send and + receive values: + +> Upstream | Downstream +> +---------+ +> | | +> a' <== <== b' +> | Proxy | +> a ==> ==> b +> | | +> +---------+ + + Proxies are monad transformers that enrich the base monad with the ability + to send or receive values upstream or downstream: + +> | Sends | Receives | Receives | Sends | Base | Return +> | Upstream | Upstream | Downstream | Downstream | Monad | Value +> p a' a b' b m r + + We can selectively close certain inputs or outputs to generate specialized + proxies. + + For example, a 'Producer' is a 'Proxy' that can only output values to its + downstream interface: + +> Upstream | Downstream +> +----------+ +> | | +> C <== <== () +> | Producer | +> () ==> ==> b +> | | +> +----------+ +> +> type Producer p b m r = p C () () b m r +> +> -- The 'C' type is uninhabited, so it 'C'loses an output end + + A 'Consumer' is a 'Proxy' that can only receive values on its upstream + interface: + +> Upstream | Downstream +> +----------+ +> | | +> () <== <== () +> | Consumer | +> a ==> ==> C +> | | +> +----------+ +> +> type Consumer p a m r = p () a () C m r + + A 'Pipe' is a 'Proxy' that can only receive values on its upstream interface + and send values on its downstream interface: + +> Upstream | Downstream +> +--------+ +> | | +> () <== <== () +> | Pipe | +> a ==> ==> b +> | | +> +--------+ +> +> type Pipe p a b m r = p () a () b m r + + When we compose proxies, the type system ensures sure that their input and + output types match: + +> promptInt >-> take' 2 >-> printer +> +> +-----------+ +---------+ +---------+ +> | | | | | | +> C <== <== () <== <== () <== <== () +> | | | | | | +> | promptInt | | take' 2 | | printer | +> | | | | | | +> () ==> ==> Int ==> ==> Int ==> ==> C +> | | | | | | +> +-----------+ +---------+ +---------+ + + Composition fuses these into a new 'Proxy' that has both ends closed, which + is a 'Session': + +> +-----------------------------------+ +> | | +> C <== <== () +> | | +> | promptInt >-> take' 2 >-> printer | +> | | +> () ==> ==> C +> | | +> +-----------------------------------+ +> +> type Session p m r = p C () () C m r + + A 'Client' is a 'Proxy' that only uses its upstream interface: + +> Upstream | Downstream +> +----------+ +> | | +> a' <== <== () +> | Client | +> a ==> ==> C +> | | +> +----------+ +> +> type Client p a' a m r = p a' a () C m r + + A 'Server' is a 'Proxy' that only uses its downstream interface: + + +> Upstream | Downstream +> +----------+ +> | | +> C <== <== b' +> | Server | +> () ==> ==> b +> | | +> +----------+ +> +> type Server p b' b m r = p C () b' b m r + + The compiler ensures that the types match when we compose 'Server's, + 'Proxy's, and 'Client's. + +> comparer >-> cache >-> threeReqs +> +> +----------+ +-------+ +-----------+ +> | | | | | | +> C <== <== Int <== <== Int <== <== () +> | | | | | | +> | comparer | | cache | | threeReqs | +> | | | | | | +> () ==> ==> Bool ==> ==> Bool ==> ==> C +> | | | | | | +> +----------+ +-------+ +-----------+ + + This similarly fuses into a 'Session': + +> +----------------------------------+ +> | | +> C <== <== () +> | | +> | comparer >-> cache >-> threeReqs | +> | | +> () ==> ==> C +> | | +> +----------------------------------+ + + @pipes@ encourages substantial code reuse by implementing all abstractions + as type synonyms on top of a single type class: 'Proxy'. This makes your + life easier because: + + * You only use one composition operator: ('>->') + + * You can mix multiple abstractions together as long as the types match +-} + +{- $interact + There are only two ways to interact with other proxies: 'request' and + 'respond'. Let's examine their type signatures to understand how they + work: + +> request :: (Monad m, Proxy p) => a' -> p a' a b' b m a +> ^ ^ +> | | +> Argument --+ Result --+ + + 'request' sends an argument of type @a'@ upstream, and binds a result of + type @a@. Whenever you 'request', you block until upstream 'respond's with + a value. + + +> respond :: (Monad m, Proxy p) => b -> p a' a b' b m b' +> ^ ^ +> | | +> Result --+ Next Argument --+ + + 'respond' replies with a result of type @b@, and then binds the /next/ + argument of type @b'@. Whenever you 'respond', you block until downstream + 'request's a new value. + + Wait, if 'respond' always binds the /next/ argument, where does the /first/ + argument come from? Well, it turns out that every 'Proxy' receives this + initial argument as an ordinary parameter, as if they all began blocked on + a 'respond' statement. + + We can see this if we take all the previous proxies we defined and fully + expand every type synonym. The initial argument of each 'Proxy' matches + the type parameter corresponding to the return value of 'respond': + +> These +> +-- Columns ---+ +> | Match | +> v v +> promptInt :: (Proxy p) => () -> p C () () Int IO r +> printer :: (Proxy p, Show a) => () -> p () a () C IO r +> take' :: (Proxy p) => Int -> () -> p () a () a IO () +> comparer :: (Proxy p) => Int -> p C () Int Bool IO r +> cache :: (Proxy p, Ord key) => key -> p key val key val IO r + + You can also study the type of composition, which follows this same pattern. + Composition requires two 'Proxy's blocked on a 'respond', and produces a new + 'Proxy' similarly blocked on a 'respond': + +> (>->) :: (Monad m, Proxy p) +> => (b' -> p a' a b' b m r) +> -> (c' -> p b' b c' c m r) +> -> (c' -> p a' a c' c m r) +> ^ ^ +> | These | +> +---Match----+ + + This is why 'Producer's, 'Consumer's, and 'Client's all take @()@ as their + initial argument, because their corresponding 'respond' commands all have a + return value of @()@. + + This library also provides ('>~>'), which is the dual of the ('>->') + composition operator. ('>~>') composes two 'Proxy's blocked on a 'request' + and returns a new 'Proxy' blocked on a 'request': + +> (>~>) +> :: (Monad m, Proxy p) +> => (a -> p a' a b' b m r) +> -> (b -> p b' b c' c m r) +> -> (a -> p a' a c' c m r) + + Conceptually, ('>->') composes pull-based systems and ('>~>') composes + push-based systems. + + In fact, if you went back through the previous code and systematically + replaced every: + + * ('>->') with ('>~>'), + + * 'respond' with 'request', and + + * 'request' with 'respond' + + ... then everything would still work and produce identical behavior, except + the compiler would now infer the symmetric types with all interfaces + reversed. We can therefore conclude the obvious: pull-based systems are + symmetric to push-based systems. + + Since these two composition operators are perfectly symmetric, I arbitrarily + standardize on using ('>->') and I provide all standard library proxies + blocked on 'respond' so that they work with ('>->'). This gives behavior + more familiar to Haskell programmers that work with lazy pull-based + functions. I only include the ('>~>') composition operator for theoretical + completeness. +-} + +{- $composition + When we compose @(p1 >-> p2)@, composition ensures that @p1@'s downstream + interface matches @p2@'s upstream interface. This follows from the type of + ('>->'): + +> (>->) :: (Monad m, Proxy p) +> => (b' -> p a' a b' b m r) +> -> (c' -> p b' b c' c m r) +> -> (c' -> p a' a c' c m r) + + Diagramatically, this looks like: + +> p1 >-> p2 +> +> +--------+ +--------+ +> | | | | +> a' <== <== b' <== <== c' +> | p1 | | p2 | +> a ==> ==> b ==> ==> c +> | | | | +> +--------+ +--------+ + + @p1@'s downstream @(b', b)@ interface matches @p2@'s upstream @(b', b)@ + interface, so composition connects them on this shared interface. This + fuses away the @(b', b)@ interface, leaving behind @p1@'s upstream @(a', a)@ + interface and @p2@'s downstream @(c', c)@ interface: + +> +-----------------+ +> | | +> a' <== <== c' +> | p1 >-> p2 | +> a ==> ==> c +> | | +> +-----------------+ + + Proxy composition has the very nice property that it is associative, meaning + that it behaves the exact same way no matter how you group composition: + +> (p1 >-> p2) >-> p3 = p1 >-> (p2 >-> p3) + + ... so you can safely elide the parentheses: + +> p1 >-> p2 >-> p3 + + Also, we can define a \'@T@\'ransparent 'Proxy' that auto-forwards values + both ways: + +> idT :: (Monad m, Proxy p) => a' -> p a' a a' a m r +> idT = runIdentityK loop where +> loop a' = do +> a <- request a' +> a'2 <- respond a +> loop a'2 +> +> -- or: idT = runIdentityK $ foreverK $ request >=> respond +> -- = runIdentityK $ request >=> respond >=> request >=> respond ... + + Diagramatically, this looks like: + +> +-----+ +> | | +> a' <======== a' <- All values pass +> | idT | straight through +> a ========> a <- immediately +> | | +> +-----+ + + Transparency means that: + +> idT >-> p = p +> +> p >-> idT = p + + In other words, 'idT' is an identity of composition. + + This means that proxies form a true 'Category' where ('>->') is composition + and 'idT' is the identity. The associativity law and the two + identity laws are just the 'Category' laws. The objects of the category are + the 'Proxy' interfaces. + + These 'Category' laws guarantee the following important properties: + + * You can reason about each proxy's behavior independently of other proxies + + * You don't encounter weird behavior at the interface between two components + + * You don't encounter corner cases at the 'Server' or 'Client' ends of a + 'Session' +-} + +{- $class + All the proxy code we wrote was generic over the 'Proxy' type class, which + defines the three central operations of this library's API: + + * ('>->'): Proxy composition + + * 'request': Request input from upstream + + * 'respond': Respond with output to downstream + + @pipes@ defines everything in terms of these three operations, which is + why all the library's utilities are polymorphic over the 'Proxy' type class. + + Let's look at some example instances of the 'Proxy' type class: + +> instance Proxy ProxyFast -- Fastest implementation +> instance Proxy ProxyCorrect -- Strict monad transformer laws + + These two types provide the two alternative base implementations: + + * 'ProxyFast': This runs significantly faster on pure code segments and + employs several rewrite rules to optimize your code into the equivalent + hand-tuned code. + + * 'ProxyCorrect': This uses a monad transformer implementation that is + correct by construction, but runs about 8x slower on pure code segments. + However, for 'IO'-bound code, the performance gap is small. + + These two implementations differ only in the 'runProxy' function that they + export, which is how the compiler selects which 'Proxy' implementation to + use. + + "Control.Proxy" automatically selects the fast implementation for you, but + you can always choose the correct implementation instead by replacing + "Control.Proxy" with the following two imports: + +> import Control.Proxy.Core -- Everything except the base implementation +> import Control.Proxy.Core.Correct -- The alternative base implementation + + These are not the only instances of the 'Proxy' type class! This library + also provides several \"proxy transformers\", which are like monad + transformers except that they also correctly lift the 'Proxy' type class: + +> instance (Proxy p) => Proxy (IdentityP p) +> instance (Proxy p) => Proxy (EitherP e p) +> instance (Proxy p) => Proxy (MaybeP p) +> instance (Proxy p) => Proxy (ReaderP i p) +> instance (Proxy p) => Proxy (StateP s p) +> instance (Proxy p) => Proxy (WriterP w p) + + All of the 'Proxy' code we wrote so far also works seamlessly with all of + these proxy transformers. The 'Proxy' class abstracts over the + implementation details and extensions so that you can reuse the same library + code for any feature set. + + This polymorphism comes at a price: you must embed your 'Proxy' code in at + least one proxy transformer if you want clean type class constraints. If + you don't use extensions then you embed your code in the identity proxy + transformer: 'IdentityP'. This is why all the examples use 'runIdentityP' + or 'runIdentityK' to embed their code in 'IdentityP'. "Control.Proxy.Class" + provides a longer discussion on this subject. + + Without this 'IdentityP' embedding, the compiler infers uglier constraints, + which are also significantly less polymorphic. We can show this by + removing the 'runIdentityP' call from @promptInt@ and see what type the + compiler infers: + +> promptInt () = forever $ do +> lift $ putStrLn "Enter an Integer:" +> n <- lift readLn +> respond n + +>>> :t promptInt -- I've substantially cleaned up the inferred type +promptInt + :: (Monad (Producer p Int IO), MonadTrans (Producer p Int), Proxy p) => + () -> Producer p Int IO r + + All 'Proxy' instances are already monads and monad transformers, but the + compiler cannot infer that without the 'IdentityP' embedding. When we embed + @promptInt@ in 'IdentityP', the compiler collapses the 'Monad' and + 'MonadTrans' constraints into the 'Proxy' constraint. + + Fortunately, you do not pay any performance price for this 'IdentityP' + embedding or the type class polymorphism. Your polymorphic code will still + run very rapidly, as fast as if you had specialized it to a concrete + 'Proxy' instance without the 'IdentityP' embedding. I've taken great care + to ensure that all optimizations and rewrite rules always see through these + abstractions without any assistance on your part. +-} + +{- $interleave + When you compose two proxies, you interleave their effects in the base + monad. The following two proxies demonstrate this interleaving of effects: + +> downstream :: (Proxy p) => Consumer p () IO () +> downstream () = runIdentityP $ do +> lift $ print 1 +> request () -- Switch to upstream +> lift $ print 3 +> request () -- Switch to upstream +> +> upstream :: (Proxy p) => Producer p () IO () +> upstream () = runIdentityP $ do +> lift $ print 2 +> respond () -- Switch to downstraem +> lift $ print 4 + + "Control.Proxy.Class" enumerates the 'Proxy' laws, which equationally + define how all 'Proxy' instances must behave. These laws require that + @(upstream >-> downstream)@ must reduce to the following: + +> upstream >-> downstream -- This is true no matter what feature +> = -- set or 'Proxy' instance you select +> \() -> lift $ do +> print 1 +> print 2 +> print 3 +> print 4 + + Conceptually, 'runProxy' just applies this to @()@ and removes the 'lift': + +> runProxy $ upstream >-> downstream +> = +> do print 1 +> print 2 +> print 3 +> print 4 + + Let's test this: + +>>> runProxy $ upstream >-> downstream +1 +2 +3 +4 + + The 'Proxy' laws let you reason about how proxies interleave effects without + knowing any specifics about the underlying implementation. Intuitively, the + 'Proxy' laws say that: + + * 'request' blocks until upstream 'respond's + + * 'respond' blocks until downstream 'request's + + * If a 'Proxy' terminates, it terminates every 'Proxy' composed with it + + Several of the utilities in "Control.Proxy.Prelude.Base" use these + equational laws to rigorously prove things about their behavior. For + example, consider the 'mapD' proxy, which applies a function @f@ to all + values flowing downstream: + +> mapD :: (Monad m, Proxy p) => (a -> b) -> x -> p x a x b m r +> mapD f = runIdentityK loop where +> loop x = do +> a <- request x +> x2 <- respond (f a) +> loop x2 +> +> -- or: mapD f = runIdentityK $ foreverK $ request >=> respond . f + + We can use the 'Proxy' laws to prove that: + +> mapD f >-> mapD g = mapD (g . f) +> +> mapD id = idT + + ... which is what we expect. We can fuse two consecutive 'mapD's into one + by composing their functions, and mapping 'id' does nothing at all, just + like the identity proxy: 'idT'. + + In fact, these are just the functor laws in disguise, where 'mapD' defines a + functor between the category of Haskell function composition and the + category of 'Proxy' composition. "Control.Proxy.Prelude.Base" is full of + utilities like this that are simultaneously practical and theoretically + elegant. +-} + +{- $hoist + Composition can't interleave two proxies if their base monads do not + match. For instance, I might try to modify @promptInt@ to use + @EitherT String@ to report the error instead of using exceptions: + +> import Control.Monad.Trans.Either -- from the "either" package +> import Safe (readMay) +> +> promptInt2 :: (Proxy p) => () -> Producer p Int (EitherT String IO) r +> promptInt2 () = runIdentityP $ forever $ do +> str <- lift $ lift $ do +> putStrLn "Enter an Integer:" +> getLine +> case readMay str of +> Nothing -> lift $ left "Could not read Integer" +> Just n -> respond n + + However, if I try to compose it with @printer@, I receive a type error: + +>>> runEitherT $ runProxy $ promptInt2 >-> printer +:2:40: + Couldn't match expected type `EitherT String IO' + with actual type `IO' + ... + + The type error says that @promptInt2@ uses @(EitherT String IO)@ for its + base monad, but @printer@ uses 'IO' for its base monad, so composition can't + interleave their effects. + + You can easily fix this using the 'hoist' function from the 'MFunctor' type + class in "Control.MFunctor", which transforms the base monad of any monad + transformer, including the 'Proxy' monad transformer. "Control.MFunctor" + really belongs in the @transformers@ package, however it currently resides + here because it requires the @Rank2Types@ extension. + + You will commonly use 'hoist' to 'lift' one proxy's base monad to match + another proxy's base monad, like so: + +>>> runEitherT $ runProxy $ promptInt2 >-> (hoist lift . printer) +Enter an Integer: +Hello +Left "Could not read Integer" + + This library provides three syntactic conveniences for making this easier to + write. + + First, ('.') has higher precedence than ('>->'), so you can drop the + parentheses: + +>>> runEitherT $ runProxy $ promptInt2 >-> hoist lift . printer +... + + Second, "lift" is such a common argument to 'hoist' that "Control.MFunctor" + provides the 'raise' function: + +> raise = hoist lift + +>>> runEitherT $ runProxy $ promptInt2 >-> raise . printer +... + + Third, "Control.Proxy.Prelude.Kleisli" provides the 'hoistK' and 'raiseK' + functions in case you think composition looks ugly: + +> hoistK f = (hoist f .) +> +> raiseK = (raise .) + +>>> runEitherT $ runProxy $ promptInt2 >-> raiseK printer +... + + Note that "Control.MFunctor" also provides 'MFunctor' instances for all the + monad transformers in the @transformers@ package. This means that you can + fix any incompatibility between two monad transformer stacks just using + various combinations of 'hoist' and 'lift'. + + To see how, consider the following contrived pathological example where I + want to mix two very different monad transformer stacks: + +> m1 :: StateT s (ReaderT i IO) r +> m2 :: MaybeT (WriterT w IO) r + + I can interleave their transformers through judicious use of 'hoist' and + 'lift' + +> mBoth :: StateT s (MaybeT (ReaderT i (WriterT w IO))) r +> mBoth = do +> hoist (lift . hoist lift) m1 +> lift (hoist lift m2) +-} + +{- $utilities + The "Control.Proxy.Prelude" heirarchy provides several utility functions + for common tasks. We can redefine the previous example functions just by + composing these utilities. + + For example, 'readLnS' reads values from user input, so we can read 'Int's + just by specializing its type: + +> readLnS :: (Proxy p, Read a) => () -> Producer p a IO r +> +> readIntS :: (Proxy p) => () -> Producer p Int IO r +> readIntS = readLnS + + The @S@ suffix indicates that it belongs in the \'@S@\'erver position. + + @(takeB_ n)@ allows at most @n@ value to pass through it in \'@B@\'oth + directions: + +> takeB_ :: (Monad m, Proxy p) => Int -> a' -> p a' a a' a m () + + 'takeB_' has a more general type than @take'@ because it allows any type of + value to flow upstream. + + 'printD' prints all values flowing \'@D@\'ownstream: + +> printD :: (Proxy p, Show a) => x -> p x a x a IO r + + 'printD' has a more general type than our original @printer@ because it + forwards all values further downstream after 'print'ing them. This means + that you could use it as an intermediate stage as well. However, 'printD' + still type-checks as the most downstream stage, too, since 'runProxy' just + discards any unused outbound values. + + These utilities do not clash with the Prelude namespace or common libraries + because they all end with a capital letter suffix that indicates their + directionality: + + * \'@D@\' suffix: interacts with values flowing \'@D@\'ownstream + + * \'@U@\' suffix: interacts with values flowing \'@U@\'pstream + + * \'@B@\' suffix: interacts with values flowing \'@B@\'oth ways (or: + \'@B@\'idirectional) + + * \'@S@\' suffix: belongs furthest upstream in the \'@S@\'erver position + + * \'@C@\' suffix: belongs furthest downstream in the \'@C@\'lient position + + We can assemble these functions into a silent version of our previous + 'Session': + +>>> runProxy $ readIntS >-> takeB_ 2 >-> printD +4 +4 +39 +39 + + Fortunately, we don't have to give up our previous useful diagnostics. + We can use 'execU', which executes an action each time values flow upstream + through it, and 'execD', which executes an action each time values flow + downstream through it: + +> promptInt :: (Proxy p) => () -> Producer p Int IO r +> promptInt = readLnS >-> execU (putStrLn "Enter an Integer:") +> +> printer :: (Proxy p, Show a) => x -> p x a x a IO r +> printer = execD (putStrLn "Received a value:") >-> printD + + Similarly, we can build our old @take'@ on top of 'takeB_': + +> take' :: (Proxy p) => Int -> a' -> p a' a a' a m () +> take' n a' = runIdentityP $ do -- Remember, we need 'runIdentityP' if +> takeB_ n a' -- we use 'do' notation or 'lift' +> lift $ putStrLn "You shall not pass!" + +>>> runProxy $ promptInt >-> take' 2 >-> printer + + + Or perhaps I want to skip user input for testing and mock @promptInt@ by + replacing it with a predefined set of values: + +>>> runProxy $ fromListS [4, 37, 1] >-> take'2 >-> printer +Received a value: +4 +Received a value: +37 + + What about our original @lines@ function? That's just 'hGetLineS': + +> hGetLineS :: (Proxy p) => Handle -> () -> Producer p String IO () + + You could hand-write loops that accomplish these same tasks, but proxies let + you: + + * Rapidly swap in and out components for testing, debugging, and fast + prototyping + + * Factor out common patterns into modular components + + * Mix and match simple stages to build sophisticated programs + + This compositional programming style emphasizes building a library of + reusable components and connecting them like Unix pipes to assemble the + desired streaming program. +-} + +{- $mixmonadcomp + Composition isn't the only way to assemble proxies. You can also sequence + predefined proxies using @do@ notation to generate more elaborate behaviors. + + Most commonly, you will sequence two sources to combine their outputs, very + similar to how the Unix @cat@ utility behaves: + +> threeSources () = do +> source1 () +> source2 () +> source3 () +> +> -- or: threeSources = source1 >=> source2 >=> source3 + + As a concrete example, we could create a 'Producer' where our first source + presets the first few values and then we let the user take over to generate + the remaining values: + +> source1 :: (Proxy p) => () -> Producer p Int IO r +> source1 () = runIdentityP $ do +> fromListS [4, 4] () -- Source 1 +> readLnS () -- Source 2 +> +> -- or: source1 = runIdentityK (fromListS [4, 4] >=> readLnS) + +>>> runProxy $ source1 >-> printD +4 +4 +70 +70 +34 +34 +... + + What if we only want the user to provide three values? We can + selectively throttle it with 'takeB_': + +> source2 :: (Proxy p) => () -> Producer p Int IO () +> source2 () = runIdentityP $ do +> fromListS [4, 4] () +> (readLnS >-> takeB_ 3) () -- You can compose inside a do block! +> +> -- or: source2 = runIdentityK (fromListS [4, 4] >=> (readLnS >-> takeB_ 3)) + + Notice that composition works inside of a @do@ block! This is a very handy + trick! + +>>> runProxy $ source2 >-> printD +4 +4 +56 +56 +41 +41 +80 +80 + + You can also concatenate sinks, too: + +> sink1 :: (Proxy p) => () -> Consumer p Int IO () +> sink1 () = do +> (takeB_ 3 >-> printD) () -- Sink 1 +> (takeWhileD (< 4) >-> printD) () -- Sink 2 +> +> -- or: sink1 = (takeB_ 3 >-> printD) >=> (takeWhileD (< 4) >-> printD) + +>>> runProxy $ source2 >-> sink1 +4 -- The first sink +4 -- handles these +68 -- +68 +1 -- The second sink +1 -- handles these +5 -- + + ... but the above example is gratuitous because you can simply concatenate + the intermediate stages: + +> sink2 :: (Proxy p) => () -> Consumer p Int IO () +> sink2 () = intermediate >-> printD where +> intermediate () = do +> takeB_ 3 () -- Intermediate stage 1 +> takeWhileD (< 4) -- Intermediate stage 2 +> +> -- or: sink2 = (takeB_ 3 >=> takeWhileD (< 4)) >-> printD + +>>> runProxy $ source2 >-> sink2 + + + These examples demonstrate the two principal ways to combine proxies: + + * \"Vertical\" composition, using ('>=>') from the Kleisli category + + * \"Horizontal\" composition: using ('>->') from the Proxy category + + You assemble most proxies simply by composing them in one or both of these + two categories. +-} + +{- $folds + You can fold a stream of values in two ways, both of which use the base + monad: + + * Use 'WriterT' in the base monad and 'tell' the values to fold + + * Use 'StateT' in the base monad and 'put' strict values + + 'WriterT' is more elegant in principle but leaks space for a large number of + values to fold. 'StateT' does not leak space if you keep the accumulator + strict, but is less elegant and doesn't guarantee write-only behavior. To + remedy this, I am currently working on a stricter 'WriterT' implementation + that does not leak space to add to the @transformers@ package. + + "Control.Proxy.Prelude.Base" provides several common folds using 'WriterT' + as the base monad, such as: + + * 'lengthD': Count how many values flow downstream + +> lengthD :: (Monad m, Proxy p) => x -> p x a x a (WriterT (Sum Int) m) r + + * 'toListD': Fold the values flowing downstream into a list. + +> toListD :: (Monad m, Proxy p) => x -> p x a x a (WriterT [a] m) r + + * 'anyD': Determine whether any values satisfy the predicate + +> anyD :: (Monad m, Proxy p) => (a -> Bool) -> x -> p x a x a (WriterT Any m) r + + These 'WriterT' versions demonstrate how the elegant approach should work in + principle and they should be okay for folding a medium number of values + until I release the fixed 'WriterT'. If space leaks cause problems, you can + temporarily rewrite the 'WriterT' folds using the following two strict + 'StateT' folds: + + * 'foldlD'': Strictly fold values flowing downstream + +> foldlD' +> :: (Monad m, Proxy p) => (b -> a -> b) -> x -> p x a x a (StateT b m) r + + * 'foldlU'': Strictly fold values flowing upstream + +> foldU' +> :: (Monad m, Proxy p) => (b -> a' -> b) -> a' -> p a' x a' x (StateT b m) r + + Now, let's try these folds out and see if we can build a list from user + input: + +>>> runWriterT $ runProxy $ raiseK promptInt >-> takeB_ 3 >-> toListD +Enter an Integer: +1 +Enter an Integer: +66 +Enter an Integer: +5 +((), [1, 66, 5]) + + Notice that @promptInt@ uses 'IO' as its base monad, but 'toListD' uses + @(WriterT [Int] m)@ as its base monad, so I use 'raiseK' to get the base + monads to match. + + You can insert these folds anywhere in the middle of a pipeline and they + still work: + +>>> runWriterT $ runProxy $ fromListS [5, 7, 4] >-> lengthD >-> raiseK printD +5 +7 +4 +((), Sum 3) + + You can also run multiple folds at the same time just by adding more + 'WriterT' layers to your base monad: + +>>> runWriterT $ runWriterT $ fromListS [9, 10] >-> anyD even >-> raiseK sumD +(((), Any {getAny = True},Sum {getSum = 19}) + + I designed certain special folds to terminate the 'Session' early if they + can compute their result prematurely, in order to draw as little input as + possible. These folds end with an underscore, such as 'headD_', which + terminates the stream once it receives an input: + +> headD_ :: (Monad m, Proxy p) => x -> p x a x a (WriterT (First a) m) () + +>>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD_ +3 +((), First {getFirst = Just 3}) + + Compare this to 'headD' without underscore, which folds the entire input: + +>>> runWriterT $ runProxy $ fromListS [3, 4, 9] >-> raiseK printD >-> headD +3 +4 +9 +((), First {getFirst = Just 3}) + + Use the versions that don't prematurely terminate if you are running + multiple folds or if you want to continue to use the rest of the input when + the fold is done. Use the versions that do prematurely terminate if + collecting that single fold is the entire purpose of the session. +-} + +{- $resource + This core library provides utilities for lazily streaming from resources, + but does not provide utilities for lazily managing resource allocation and + deallocation. To frame the problem, let's assume that we try to be clever + and write a streaming utility that lazily opens a file only in response to + a 'request', such as the following 'Producer': + +> readFile' :: FilePath -> () -> Producer p String IO +> readFile' file () = runIdentityP $ do +> h <- lift $ openFile file ReadMode +> lift $ putStrLn "Opening file" +> hGetLineS h () +> lift $ putStrLn "Closing file" +> lift $ hClose h + + This works well if we fully demand the file: + +>>> runProxy $ readFile' "test.txt" >-> printD +Opening file +"Line 1" +"Line 2" +"Line 3" +Closing file + + This also works well if we never demand the file at all, in which case we + never open it: + +>>> runProxy $ readFile' "test.txt" >-> return +-- Outputs nothing + + But it gives exactly the wrong behavior if we partially demand the file: + +>>> runProxy $ readFile' "test.txt" >-> takeB_ 1 >-> printD +Opening file +"Line 1" + + Notice that this does not close the file, because once @takeB_ 1@ terminates + it terminates the entire 'Session' and @readFile'@ does not get a chance to + finalize the file. + + I will release a separate library in the near future that offers lazy + resource management, too, but in the meantime I advise that you use one of + the following two strategies to guarantee deterministic resource + deallocation. + + The first approach opens all resources before running the session and close + them all afterward. For example, if I wanted to emulate the Unix @cp@ + command, streaming one line at a time, I would write: + +> import System.IO +> +> cp :: FilePath -> FilePath -> IO () +> cp inFile outFile = +> withFile file1 ReadMode $ \hIn -> +> withFile file2 WriteMode $ \hOut -> +> runProxy $ hGetLineS hIn >-> hPutLineS hOut2 + + The advantage of this approach is that it: + + * is straightforward, + + * requires no special integration with existing libraries, and + + * is exception safe. + + The disadvantage is that this does not lazily allocate resources, nor does + this promptly deallocate them. + + The second approach is to use something like 'ResourceT' (from the + @resourceT@ package) to register finalizers and ensure they get released + deterministically. You may prefer this approach if you have previously used + the @conduit@ library, which uses 'ResourceT' in its base monad to offer + resource determinism. You can use 'ResourceT' with @pipes@, too, just by + including it in the base monad. + + I plan to release a lazy resource management library very soon built on top + of @pipes@ that behaves similarly to 'ResourceT'. The main advantages of + this upcoming implementation will be that it: + + * uses a simpler and pure implementation + + * obeys several useful theoretical laws + + * requires no dependencies other than @pipes@ + + However, if you don't need this extra power, then just stick to the former + simpler approach. I plan to release all standard libraries to be agnostic + of the finalization approach to let you use which one you prefer. +-} + +{- $extend + This library provides several extensions that add features on top of the + base 'Proxy' API. These extensions behave like monad transformers, except + that they also lift the 'Proxy' class through the extension so that the + extended proxy can still 'request', 'respond', compose with other proxies: + +> instance (Proxy p) => Proxy (IdentityP p) -- Equivalent to IdentityT +> instance (Proxy p) => Proxy (EitherP e p) -- Equivalent to EitherT +> instance (Proxy p) => Proxy (MaybeP p) -- Equivalent to MaybeT +> instance (Proxy p) => Proxy (StateP s p) -- Equivalent to StateT +> instance (Proxy p) => Proxy (WriterP w p) -- Equivalent to WriterT + + Each of these proxy transformers provides the same API as the equivalent + monad transformer (sometimes even more). The following sections show some + common problems that these proxy transformers solve. +-} + +{- $error + + Our previous @promptInt@ example suffered from one major flaw: + +> promptInt2 :: (Proxy p) => () -> Producer p Int (EitherT String IO) r +> promptInt2 () = runIdentityP $ forever $ do +> str <- lift $ lift $ do +> putStrLn "Enter an Integer:" +> getLine +> case readMay str of +> Nothing -> lift $ left "Could not read Integer" +> Just n -> respond n + + There is no way to recover from the error and resume streaming data. You + can only handle 'Left' value after using 'runProxy', but by then it is too + late. + + We can solve this by switching the order of the two monad transformers, but + using 'EitherP' this time instead of 'EitherT': + +> import qualified Control.Proxy.Trans.Either as E +> +> -- Proxy transformers play +> -- nice with type synonyms --+ +> -- | +> -- v +> promptInt3 :: (Proxy p) => () -> Producer (E.EitherP String p) Int IO r +> -- i.e. (Proxy p) => () -> EitherP String p C () () Int IO r +> +> promptInt3 () = forever $ do +> str <- lift $ do +> putStrLn "Enter an Integer:" +> getLine +> case readMay str of +> Nothing -> E.throw "Could not read Integer" +> Just n' -> respond n + + This example does not need 'runIdentityP' (nor would that type-check) + because the 'EitherP' proxy transformer gives the compiler enough + information to generalize the constraints. + + We've swapped the order of the transformers, so now we use 'runEitherK' + first to unwrap the 'EitherP' followed by 'runProxy'. + +> runEitherK +> :: (q -> EitherP p a' a b' b m r) -> (q -> p a' a b' b m (Either e r)) + +>>> runProxy $ runEitherK $ promptInt3 >-> printer :: IO (Either String r) +Enter an Integer: +Hello +Left "Could not read Integer" + + Notice how we can directly compose @printer@ with @promptInt@. + This works because @printer@'s base proxy type is completely polymorphic + over the 'Proxy' type class and doesn't use any features specific to any + proxy transformers: + +> 'p' type-checks as anything --+ +> that implements 'Proxy' | +> v +> printer :: (Proxy p, Show a) => () -> Consumer p a IO r + + This means that you can compose @printer@ with anything that implements the + 'Proxy' type class, including 'EitherP', without any lifting. + + 'EitherP' lets us catch and handle errors locally without disturbing other + proxies. For example, I can define a heartbeat function that just restarts + a given proxy each time it raises an error: + +> heartbeat +> :: (Proxy p) +> => E.EitherP String p a' a b' b IO r +> -> E.EitherP String p a' a b' b IO r +> heartbeat p = p `E.catch` \err -> do +> lift $ putStrLn err -- Print the error +> heartbeat p -- Restart 'p' + + This uses the 'catch' function from "Control.Proxy.Trans.Either", which + lets you catch and handle errors locally without disturbing other proxies. + +>>> runProxy $ E.runEitherK $ (heartbeat . promptInt3) >-> takeB_ 2 >-> printer +Enter an Integer: +Hello +Could not read Integer +Enter an Integer +8 +Received a value: +8 +Enter an Integer +0 +Received a value: +0 + + It's very easy to prove that 'EitherP' has only a local effect. In fact, + we can run it entirely locally like so: + +>>> runProxy $ (E.runEitherK $ heartbeat . promptInt3) >-> takeB_ 2 >-> printer + + Proxy transformers do not use the base monad at all, so you can use them to + isolate effects from other proxies, as the next section demonstrates. +-} + +{- $state + The 'StateP' proxy lets you embed local state into any 'Proxy' computation. + For example, we might want to gratuitously use state to generate successive + numbers: + +> import qualified Control.Proxy.Trans.State as S +> +> increment :: (Monad m, Proxy p) => () -> Producer (S.StateP Int p) Int m r +> increment () = forever $ do +> n <- S.get +> respond n +> S.put (n + 1) + + We could then embed it locally into any 'Proxy', such as the following one: + +> numbers :: (Monad m, Proxy p) => () -> Producer p Int m () +> numbers () = runIdentityP $ do +> (takeB_ 5 <-< S.evalStateK 10 increment) () +> S.evalStateK 1 (takeB_ 3 <-< increment) () -- This works, too! + +>>> runProxy $ numbers >-> printD +10 +11 +12 +13 +14 +1 +2 +3 + + We can also prove the effect is local even when you directly compose two + 'StateP' proxies before running them. Let's define a stateful consumer: + +> increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r +> increment2 () = forever $ do +> nOurs <- S.get +> nTheirs <- request () +> lift $ print (nTheirs, nOurs) +> S.put (nOurs + 2) + + .. and hook it up directly to @increment@: + +>>> runProxy $ S.evalStateK 0 $ increment >-> takeB_ 3 >-> increment2 +(0, 0) +(1, 2) +(2, 4) + + They each share the same initial state, but they isolate their own side + effects completely from each other. +-} + +{- $branch + So far we've only considered linear chains of proxies, but @pipes@ allows + you to branch these chains and generate more sophisticated topologies. The + trick is to simply nest the 'Proxy' monad transformer within itself. + + For example, if I want to zip two inputs, I can just define the following + triply nested proxy: + +> zipD +> :: (Monad m, Proxy p1, Proxy p2, Proxy p3) +> => () -> Consumer p1 a (Consumer p2 b (Consumer p3 (a, b) m)) r +> zipD = runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do +> -- Yes, this 'runIdentityP' mess is necessary. Sorry! +> +> a <- request () -- Request from the outer 'Consumer' +> b <- lift $ request () -- Request from the inner 'Consumer' +> lift $ lift $ respond (a, b) -- Respond to the 'Producer' + + 'zipD' behaves analogously to a curried function. We partially apply it to + each layer using composition and 'runProxyK' or 'runProxy': + +> -- 1st application +> p1 = runProxyK $ zipD <-< fromListS [1..3] +> +> -- 2nd application +> p2 = runProxyK $ p1 <-< fromListS [4..] +> +> -- 3rd application +> p3 = runProxy $ printD <-< p2 + +>>> p3 +(1, 4) +(2, 5) +(3, 6) + + You can use this trick to fork output, too: + +> fork +> :: (Monad m, Proxy p1, Proxy p2, Proxy p3) +> => () -> Consumer p1 a (Producer p2 a (Producer p3 a m)) r +> fork () = +> runIdentityP . hoist (runIdentityP . hoist runIdentityP) $ forever $ do +> a <- request () -- Request output from the 'Consumer' +> lift $ respond a -- Send output to the outer 'Producer' +> lift $ lift $ respond a -- Send output to the inner 'Producer' + + Again, we just keep partially applying it until it is fully applied: + +> -- 1st application +> p1 = runProxyK $ fork <-< fromListS [1..3] +> +> -- 2nd application +> p2 = runProxyK $ raiseK printD <-< mapD (> 2) <-< p1 +> +> -- 3rd application +> p3 = runProxy $ printD <-< mapD show <-< p2 + +>>> p3 +False +"1" +False +"2" +True +"3" + + You can even merge or fork proxies that use entirely different feature sets: + +> p1 = runProxyK $ S.evalStateK 0 $ fork <-< increment +> +> p2 = runProxyK $ raiseK printD <-< mapD (+ 10) <-< p1 +> +> p3 = runProxy $ E.runEitherK $ printD <-< (takeB_ 3 >=> E.throw) <-< p2 + +>>> p3 +10 +0 +11 +1 +12 +2 +Left () + + We just forked a @(StateP p1)@ proxy and read out the result in both a + generic @p2@ proxy and an @(EitherP p3)@ proxy. That's pretty crazy, but it + gives you a sense of how versatile and robust proxies can be. + + You can implement arbitrary branching topologies using this trick. However, + I want to mention a few caveats: + + * The intermediate partially applied type signatures will be ugly as sin. + I warned you. + + * You cannot implement cyclic topologies (and cyclic topologies do not make + sense for proxies anyway) + + * You cannot use this trick to implement a polymorphic zip function of the + following form: + +> zip' -- You can't define this +> :: (Monad m, Proxy p) +> => (() -> Producer p a m r) +> -> (() -> Producer p b m r) +> -> (() -> Producer p (a, b) m r) + + Partial application requires selecting a 'Proxy' instance, which is why you + cannot define @zip'@. You /can/ define a @zip'@ specialized to a concrete + 'Proxy' instance, but I don't really recommend doing that since you should + always strive to write polymorphic proxies to avoid locking your user into + a particular feature set. + + With those caveats out of the way, this approach affords many indispensable + features that other approaches do not allow: + + * It does not require extending the 'Proxy' type class + + * It handles almost every branching scenario, including more complicated + situations like concurrent interleavings + + * You can branch and merge mixtures of 'Server's, 'Client's, and 'Proxy's + + * You can branch and merge heterogeneous feature sets + + * It is completely polymorphic over the 'Proxy' class and uses no + implementation-specific details +-} + +{- $proxytrans + There is one last scenario that you will eventually encounter: mixing + proxies that have incompatible proxy transformer stacks. You solve this the + exact same way you mix different monad transformer stacks, except that + instead of using 'lift' and 'hoist' you use 'liftP' and 'hoistP'. + + For example, we might want to mix @promptInt3@ and @increment2@: + +> promptInt3 :: (Proxy p) => () -> Producer (E.EitherP String p) Int IO r +> +> increment2 :: (Proxy p) => () -> Consumer (S.StateP Int p) Int IO r + + Unfortunately, they use two different feature sets so neither one is fully + polymorphic over the 'Proxy' class and we cannot directly compose them. + + Fortunately, all proxy transformers implement the 'ProxyTrans' class, + analogous to the 'MonadTrans' class for transformers: + +> class ProxyTrans t where +> liftP +> :: (Monad m, Proxy p) +> => p a' a b' b m r -> t p a' a b' b m r +> +> -- mapP is slightly more elegant +> mapP +> :: (Monad m, Proxy p) +> => (q -> p a' a b' b m r) -> (q -> t p a' a b' b m r) +> mapP = (liftP . ) + + It's very easy to use. Just use 'mapP' (equivalent to @(liftP .)@ to lift + one proxy transformer to match another one. For example, we can 'mapP' + @increment2@ to match @promptInt3@: + +> promptInt3 >-> mapP increment2 +> :: (Proxy p) => () -> Session (EitherP String (StateP Int p)) IO r + +>>> runProxy $ S.evalStateK 0 $ E.runEitherK $ promptInt3 >-> mapP increment2 +Enter an Integer: +4 +(4, 0) +Enter an Integer: +5 +(5, 2) +Enter an Integer: +Hello +Left "Could not read Integer" + + ... or we could instead 'mapP' @promptInt3@ to match @increment2@ and switch + the order of the two proxy transformers: + +> mapP promptInt3 >-> increment2 +> :: (Proxy p) => () -> Session (StateP Int (EitherP String p)) IO r + +>>> runProxy $ E.runEitherK $ S.evalStateK 0 $ mapP promptInt3 >-> increment2 +Enter an Integer: +4 +(4, 0) +Enter an Integer: +5 +(5, 2) +Enter an Integer: +Hello +Left "Could not read Integer" + + Like monad transformers, proxy transformers lift a base 'Monad' instance + to an extended 'Monad' instance. 'liftP' exactly mirrors the 'lift' + function from 'MonadTrans'. 'liftP' takes some base proxy, @p@, that + implements 'Monad' and \"lift\"s it to an extended proxy, @(t p)@, that also + implements 'Monad'. + + So for example, I could do something like: + +> do liftP $ actionInBaseProxy +> actionInExtendedProxy + + Monad transformers impose certain laws to ensure that this lifting is + correct. These are known as the monad transformer laws; + +> (lift .) (f >=> g) = (lift .) f >=> (lift .) g +> +> (lift .) return = return + + If you convert these laws to @do@ notation, they just say: + +> do x <- lift m = lift $ do x <- m +> lift (f x) f x +> +> lift (return r) = return r + + Proxy transformers require the exact same laws to ensure that they lift the + base monad to the extended monad correctly. Just replace 'lift' with + 'liftP': + +> (liftP .) (f >=> g) = (liftP .) f >=> (liftP .) g +> +> (liftP .) return = return + + The only difference is that I also include 'mapP' in the 'ProxyTrans' type + class for convenience, which sweetens these laws a little bit: + +> mapP = (lift .) +> +> mapP (f >=> g) = mapP f >=> mapP g -- These are functor laws! +> +> mapP return = return + + However, proxy transformers do one extra thing above and beyond ordinary + monad transformers. Proxy transformers lift the 'Proxy' type class, meaning + that if the base type implements 'Proxy', so does the extended type. + + This means that we need a set of laws that guarantee that the proxy + transformer lifts the 'Proxy' instance correctly. I call these laws the + \"proxy transformer laws\": + +> mapP (f >-> g) = mapP f >-> mapP g -- These are functor laws, too! +> +> mapP idT = idT + + In other words, a proxy transformer defines a functor from the base + composition to the extended composition! Neat! + + But we're not even done, because proxies actually form three other + categories, only one of which I have mentioned so far, and proxy + transformers lift these three other categories, too: + +> -- The push-based category +> +> mapP (f >~> g) = mapP f >~> mapP g +> +> mapP coidT = coidT + +> -- The "request" category +> +> mapP (f \>\ g) = mapP f \>\ mapP g +> +> mapP request = request + +> -- The "respond" category +> +> mapP (f />/ g) = mapP f />/ mapP g +> +> mapP respond = respond + + I never even mentioned those last two categories because they are more + exotic and you probably never need to use them. However, even if we never + use those categories they still guarantee two really important laws that we + should remember: + +> mapP request = request +> +> mapP respond = respond + + We can translate those to 'liftP' to get: + +> liftP $ request a' = request a' +> +> liftP $ respond b = respond b + + In other words, 'request' and 'respond' in the extended proxy must behave + exactly the same as lifting 'request' and 'respond' from the base proxy. + + All the proxy transformers in this library obey the proxy transformer laws, + which ensure that 'liftP' / 'mapP' always do \"the right thing\". + + Proxy transformers also implement 'hoistP' from the 'PFunctor' class in + "Control.PFunctor". This exactly parallels 'hoist' for monad transformers. + + Just like monad transformers, we can mix two completely exotic proxy + transformer stacks using a combination of 'liftP' and 'hoistP'. Here's the + proxy transformer equivalent of the previous example I gave: + +> p1 :: (Proxy p) => a' -> StateP s (ReaderP i p) a' a a' a m r +> p2 :: (Proxy p) => a' -> MaybeP (WriterP w p) a' a a' a m r + + As before, I can interleave their proxy transformers through judicious use + of 'hoistP' and 'liftP' + +> pSequence +> :: (Proxy p) => StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a r +> pSequence a' = do +> hoistP (liftP . hoistP liftP) (p1 a') +> liftP (hoistP liftP (p2 a')) + + ... but unlike ordinary monad transformers I could instead mix them by + composition, too! + +> pCompose +> :: (Proxy p) => StateP s (MaybeP (ReaderP i (WriterP w p))) a' a a' a r +> pCompose = +> hoistP (liftP . hoistP liftP) . p1 +> >-> liftP . hoistP liftP . p2 +-} + +{- $conclusion + The @pipes@ library emphasizes the reuse of a small set of core abstractions + grounded in theory to implement all functionality: + + * Monads + + * Proxies: ('>->'), 'request', and 'respond' + + * Monad Transformers and Functors on Monads: 'lift' and 'hoist' + + * Proxy Transformers and Functors on Proxies: 'liftP' and 'hoistP' + + However, I don't expect everybody to immediately understand how so few + primitives can implement such a wide variety of features. This tutorial + gives a taste of how many interesting ways you can combine these few + abstractions, but these examples barely scratch the surface, despite this + tutorial's length. So if you don't know how to implement something using + @pipes@, just ask me and I will be happy to help. -} diff --git a/Data/Closed.hs b/Data/Closed.hs deleted file mode 100644 --- a/Data/Closed.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-| An empty type that gives cleaner type signatures. -} - -module Data.Closed ( - -- * Closed - C - ) where - --- | The empty type, denoting a \'@C@\'losed end -data C = C -- Not exported, but I write it to keep the library Haskell98 diff --git a/pipes.cabal b/pipes.cabal --- a/pipes.cabal +++ b/pipes.cabal @@ -1,5 +1,5 @@ Name: pipes -Version: 2.5.0 +Version: 3.0.0 Cabal-Version: >=1.14.0 Build-Type: Simple License: BSD3 @@ -7,40 +7,33 @@ Copyright: 2012 Gabriel Gonzalez Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com -Stability: Experimental Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues Synopsis: Compositional pipelines Description: - \"Iteratees done right\". This library implements - iteratees\/enumerators\/enumeratees simply and elegantly, using different - naming conventions. + \"Coroutines done right\". This library generalizes + iteratees\/enumerators\/enumeratees simply and elegantly. . - Advantages over traditional iteratee implementations: + Advantages over traditional iteratee\/coroutine implementations: . - * /Concise API/: This library uses a few simple abstractions with a very high - power-to-weight ratio to reduce adoption time. + * /Concise API/: Use three simple commands: ('>->'), 'request', and 'respond' . - * /Bidirectionality/: The library offers bidirectional communication + * /Bidirectionality/: Implement duplex channels . - * /Blazing fast/: Currently the fastest iteratee implementation + * /Blazing fast/: Implementation tuned for speed . - * /Clear semantics/: All abstractions are grounded in category theory, which - leads to intuitive behavior (and fewer bugs, if any!). + * /Elegant semantics/: Use practical category theory . - * /Extension Framework/: You can elegantly mix and match extensions to the - base type and easily create your own! + * /Extension Framework/: Mix and match extensions and create your own . + * /Lightweight Dependency/: @pipes@ depends only on @transformers@ and + compiles rapidly + . * /Extensive Documentation/: Second to none! . - I recommend you begin by reading "Control.Pipe.Tutorial" which introduces the - basic concepts using the simpler unidirectional 'Pipe' API. Then move on to - "Control.Proxy.Tutorial", which introduces the 'Proxy' type which forms the - core abstraction of this library. To use extensions or define your own, check - out "Control.Proxy.Trans.Tutorial". + Import "Control.Proxy" to use the library. . - I will soon replace "Control.Frame" with a superior resource-management - solution, so new users of the library should avoid using it. -Category: Control, Pipe, Proxies + Read "Control.Proxy.Tutorial" for a really extensive tutorial. +Category: Control, Pipes, Proxies Tested-With: GHC ==7.4.1 Source-Repository head Type: git @@ -49,32 +42,28 @@ Library Build-Depends: base >= 4 && < 5, - index-core, transformers >= 0.2.0.0 Exposed-Modules: - Control.Frame, - Control.Frame.Tutorial, - Control.IMonad.Trans.Free, Control.MFunctor, + Control.PFunctor, + Control.Pipe, Control.Proxy, - Control.Proxy.Core, Control.Proxy.Class, + Control.Proxy.Core, + Control.Proxy.Core.Fast, + Control.Proxy.Core.Correct, Control.Proxy.Pipe, + Control.Proxy.Synonym, Control.Proxy.Trans, Control.Proxy.Trans.Either, Control.Proxy.Trans.Identity, Control.Proxy.Trans.Maybe, Control.Proxy.Trans.Reader, Control.Proxy.Trans.State, - Control.Proxy.Trans.Tutorial, Control.Proxy.Trans.Writer, Control.Proxy.Tutorial, Control.Proxy.Prelude, Control.Proxy.Prelude.Base, Control.Proxy.Prelude.IO, - Control.Proxy.Prelude.Kleisli, - Control.Pipe, - Control.Pipe.Core, - Control.Pipe.Tutorial, - Data.Closed + Control.Proxy.Prelude.Kleisli Default-Language: Haskell98