pipes 4.0.0 → 4.0.1
raw patch · 10 files changed
+859/−365 lines, 10 filesdep +QuickCheckdep +test-frameworkdep +test-framework-quickcheck2dep ~mtl
Dependencies added: QuickCheck, test-framework, test-framework-quickcheck2
Dependency ranges changed: mtl
Files
- benchmarks/LiftBench.hs +1/−33
- benchmarks/PreludeBench.hs +1/−1
- pipes.cabal +36/−4
- src/Pipes.hs +129/−43
- src/Pipes/Core.hs +51/−41
- src/Pipes/Internal.hs +37/−24
- src/Pipes/Lift.hs +135/−129
- src/Pipes/Prelude.hs +177/−89
- src/Pipes/Tutorial.hs +20/−1
- tests/Main.hs +272/−0
benchmarks/LiftBench.hs view
@@ -6,15 +6,13 @@ import Control.Monad.Identity import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as S-import qualified Control.Monad.Trans.Writer.Strict as W-import qualified Control.Monad.Trans.RWS.Strict as RWS import Criterion.Main import Data.Monoid import Pipes import Pipes.Lift defaultMax :: Int-defaultMax = 1000000+defaultMax = 10000 instance NFData a => NFData (Sum a) @@ -33,22 +31,9 @@ s_bench :: Int -> Effect (S.StateT Int Identity) Int s_bench = iter (\n -> S.get >>= (\a -> S.put $! a + n) >> return (n + 1)) -w_bench :: Int -> Effect (W.WriterT (Sum Int) Identity) Int-w_bench = iter (\n -> (W.tell $! Sum n) >> return (n + 1))- r_bench :: Int -> Effect (R.ReaderT Int Identity) Int r_bench = iter (\n -> R.ask >>= (\a -> return $ n + a)) -rwsp_bench :: Int -> Effect (RWS.RWST Int (Sum Int) Int Identity) Int-rwsp_bench = iter act- where- act n = do- x <- RWS.ask- RWS.tell (Sum n)- s <- RWS.get- RWS.put $! (s + n)- return $ n + x- -- Run before Proxy runB :: (a -> Effect Identity r) -> a -> r runB f a = runIdentity $ runEffect $ f a@@ -79,22 +64,5 @@ , bench "evalStateP_A" . whnf (runA (defT S.evalStateT) . s_bench) , bench "execStateP_B" . whnf (runB (execStateP 0) . s_bench) , bench "execStateP_A" . whnf (runA (defT S.execStateT) . s_bench)- ]- , bgroup "WriterT" $ applyBench- [- -- Running WriterP after runEffect will space leak.- bench "runWriterP_B" . nf (runB runWriterP . w_bench)- , bench "execWriterP_B" . nf (runB execWriterP . w_bench)- ]- , bgroup "RWSP" $- let defT f = (\d -> f d 1 0)- in applyBench- [- bench "runRWSP_B" . nf (runB (runRWSP 1 0) . rwsp_bench)- , bench "runRWSP_A" . nf (runA (defT RWS.runRWST) . rwsp_bench)- , bench "evalRWSP_B" . nf (runB (evalRWSP 1 0) . rwsp_bench)- , bench "evalRWSP_A" . nf (runA (defT RWS.evalRWST) . rwsp_bench)- , bench "execRWSP_B" . nf (runB (execRWSP 1 0) . rwsp_bench)- , bench "execRWSP_A" . nf (runA (defT RWS.execRWST) . rwsp_bench) ] ]
benchmarks/PreludeBench.hs view
@@ -9,7 +9,7 @@ import Prelude hiding (enumFromTo) defaultMax :: Int-defaultMax = 1000000+defaultMax = 10000 main :: IO () main = commonMain defaultMax preludeBenchmarks
pipes.cabal view
@@ -1,5 +1,5 @@ Name: pipes-Version: 4.0.0+Version: 4.0.1 Cabal-Version: >= 1.10 Build-Type: Simple License: BSD3@@ -39,14 +39,22 @@ Location: https://github.com/Gabriel439/Haskell-Pipes-Library Library- Default-Language: Haskell2010+ if !flag(haskell98)+ Default-Language: Haskell2010+ else+ Default-Language: Haskell98+ HS-Source-Dirs: src Build-Depends: base >= 4 && < 5 ,- mmorph >= 1.0.0 && < 1.1,- mtl >= 2.0.1.0 && < 2.2, transformers >= 0.2.0.0 && < 0.4, void < 0.7++ if !flag(haskell98)+ Build-Depends:+ mmorph >= 1.0.0 && < 1.1,+ mtl >= 2.0.1.0 && < 2.2+ Exposed-Modules: Pipes, Pipes.Core,@@ -56,6 +64,10 @@ Pipes.Tutorial GHC-Options: -O2 -Wall + if flag(haskell98)+ CPP-Options: -Dhaskell98++ Benchmark prelude-benchmarks Default-Language: Haskell2010 Type: exitcode-stdio-1.0@@ -69,6 +81,22 @@ mtl >= 2.0.1.0 && < 2.2, pipes >= 4.0.0 && < 4.1 +test-suite tests+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: tests+ Main-Is: Main.hs+ GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-missing-signatures++ Build-Depends:+ base >= 4 && < 5 ,+ pipes >= 4.0.0 && < 4.1 ,+ QuickCheck >= 2.4 && < 3 ,+ mtl >= 2.0.1 && < 2.2 ,+ test-framework >= 0.4 && < 1 ,+ test-framework-quickcheck2 >= 0.2.0 && < 0.4 ,+ transformers >= 0.2.0.0 && < 0.4+ Benchmark lift-benchmarks Default-Language: Haskell2010 Type: exitcode-stdio-1.0@@ -83,3 +111,7 @@ mtl >= 2.0.1.0 && < 2.2, pipes >= 4.0.0 && < 4.1, transformers >= 0.2.0.0 && < 0.4++Flag haskell98+ Description: Haskell98 compliant subset of pipes.+ Default: False
src/Pipes.hs view
@@ -4,79 +4,96 @@ library. -} -{-# LANGUAGE RankNTypes, CPP #-}+{-# LANGUAGE+ RankNTypes+ , CPP+ , FlexibleInstances+ , MultiParamTypeClasses+ , UndecidableInstances+ #-} +-- The rewrite RULES require the 'TrustWorthy' annotation #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif-{- The rewrite RULES require the 'TrustWorthy' annotation. -} module Pipes ( -- * The Proxy Monad Transformer- Proxy,- Effect,- Effect',- runEffect,+ Proxy+ , Effect+ , Effect'+ , runEffect -- ** Producers -- $producers- Producer,- Producer',- yield,- for,- (~>),- (<~),+ , Producer+ , Producer'+ , yield+ , for+ , (~>)+ , (<~) -- ** Consumers -- $consumers- Consumer,- Consumer',- await,- (>~),- (~<),+ , Consumer+ , Consumer'+ , await+ , (>~)+ , (~<) -- ** Pipes -- $pipes- Pipe,- cat,- (>->),- (<-<),+ , Pipe+ , cat+ , (>->)+ , (<-<) -- * ListT- ListT(..),- Enumerable(..),+ , ListT(..)+ , Enumerable(..) -- * Utilities- next,- each,- every,- discard,+ , next+ , each+ , every+ , discard -- * Re-exports -- $reexports- module Control.Monad.IO.Class,- module Control.Monad.Trans.Class,- module Control.Monad.Morph,- module Data.Foldable,- module Data.Void+ , module Control.Monad.IO.Class+ , module Control.Monad.Trans.Class+#ifndef haskell98+ , module Control.Monad.Morph+#endif+ , module Data.Foldable+ , module Data.Void ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) import Control.Monad (MonadPlus(mzero, mplus))-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.IO.Class (MonadIO(liftIO)) -- transformers+import Control.Monad.Trans.Class (MonadTrans(lift)) --transformers import Control.Monad.Trans.Error (ErrorT(runErrorT))-import Control.Monad.Trans.Identity (IdentityT(runIdentityT))-import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))+import Control.Monad.Trans.Identity (IdentityT(runIdentityT)) --transformers+import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) --transformers import Data.Foldable (Foldable) import qualified Data.Foldable as F+import Data.Monoid (Monoid(..)) import Data.Void (Void) import qualified Data.Void as V import Pipes.Internal (Proxy(..)) import Pipes.Core+#ifndef haskell98+import Control.Monad.Error (MonadError(..))+import Control.Monad.Reader (MonadReader(..))+import Control.Monad.State (MonadState(..))+import Control.Monad.Writer (MonadWriter(..))+#endif -- Re-exports+#ifndef haskell98 import Control.Monad.Morph (MFunctor(hoist))+#endif infixl 4 <~ infixr 4 ~>@@ -132,8 +149,6 @@ @ 'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r 'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r-'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Effect' m ()) -> 'Consumer' x m r-'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Producer' c m ()) -> 'Pipe' x c m r 'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r 'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r @@@ -148,13 +163,26 @@ {-# INLINABLE for #-} {-# RULES- "for cat f" forall f .+ "for (for p f) g" forall p f g . for (for p f) g = for p (\a -> for (f a) g)++ ; "for p yield" forall p . for p yield = p++ ; "for (yield x) f" forall x f . for (yield x) f = f x++ ; "for cat f" forall f . for cat f = let go = do x <- await f x go in go++ ; "f >~ (g >~ p)" forall f g p . f >~ (g >~ p) = (f >~ g) >~ p++ ; "await >~ p" forall p . await >~ p = p++ ; "p >~ await" forall p . p >~ await = p+ ; "m >~ cat" forall m . m >~ cat = let go = do@@ -169,8 +197,6 @@ @ ('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) ('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r)-('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Effect' m ()) -> (a -> 'Consumer' x m r)-('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Pipe' x c m r) ('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) ('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) @@@ -229,8 +255,6 @@ @ ('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c ('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c-('>~') :: 'Monad' m => 'Effect' m b -> 'Pipe' b y m c -> 'Producer' y m c-('>~') :: 'Monad' m => 'Consumer' a m b -> 'Pipe' b y m c -> 'Pipe' a y m c ('>~') :: 'Monad' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c ('>~') :: 'Monad' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c @@@ -320,6 +344,7 @@ instance (Monad m) => Monad (ListT m) where return a = Select (yield a) m >>= f = Select (for (enumerate m) (\a -> enumerate (f a)))+ fail _ = mzero instance MonadTrans ListT where lift m = Select (do@@ -339,9 +364,68 @@ mzero = empty mplus = (<|>) +#ifndef haskell98 instance MFunctor ListT where hoist morph = Select . hoist morph . enumerate+#endif +instance (Monad m) => Monoid (ListT m a) where+ mempty = empty+ mappend = (<|>)++#ifndef haskell98+instance (MonadState s m) => MonadState s (ListT m) where+ get = lift get++ put s = lift (put s)++#if MIN_VERSION_mtl(2,1,0)+ state f = lift (state f)+#endif++instance (MonadWriter w m) => MonadWriter w (ListT m) where+#if MIN_VERSION_mtl(2,1,0)+ writer = lift . writer+#endif++ tell w = lift (tell w)++ listen l = Select (go (enumerate l) mempty)+ where+ go p w = case p of+ Request a' fa -> Request a' (\a -> go (fa a ) w)+ Respond b fb' -> Respond (b, w) (\b' -> go (fb' b') w)+ M m -> M (do+ (p', w') <- listen m+ return (go p' $! mappend w w') )+ Pure r -> Pure r++ pass l = Select (go (enumerate l) mempty)+ where+ go p w = case p of+ Request a' fa -> Request a' (\a -> go (fa a ) w)+ Respond (b, f) fb' -> M (pass (return+ (Respond b (\b' -> go (fb' b') (f w)), \_ -> f w) ))+ M m -> M (do+ (p', w') <- listen m+ return (go p' $! mappend w w') )+ Pure r -> Pure r++instance (MonadReader i m) => MonadReader i (ListT m) where+ ask = lift ask++ local f l = Select (local f (enumerate l))++#if MIN_VERSION_mtl(2,1,0)+ reader f = lift (reader f)+#endif++instance (MonadError e m) => MonadError e (ListT m) where+ throwError e = lift (throwError e)++ catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e)))+#endif+ {-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful containers to 'ListT's. -}@@ -416,8 +500,10 @@ "Control.Monad.Trans.Class" re-exports 'MonadTrans'. +#ifndef haskell98 "Control.Monad.Morph" re-exports 'MFunctor'. +#endif "Data.Foldable" re-exports 'Foldable' (the class name only) "Data.Void" re-exports 'Void'.
src/Pipes/Core.hs view
@@ -15,76 +15,72 @@ {-# LANGUAGE CPP, RankNTypes #-} +-- The rewrite RULES require the 'TrustWorthy' annotation #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif-{- The rewrite RULES require the 'TrustWorthy' annotation. Their proofs are- pretty trivial since they are just inlining the definition of their- respective operators. GHC doesn't do this inlining automatically for these- functions because they are recursive.--} module Pipes.Core ( -- * Proxy Monad Transformer -- $proxy- Proxy,- runEffect,+ Proxy+ , runEffect -- * Categories -- $categories -- ** Respond -- $respond- respond,- (/>/),- (//>),+ , respond+ , (/>/)+ , (//>) -- ** Request -- $request- request,- (\>\),- (>\\),+ , request+ , (\>\)+ , (>\\) -- ** Push -- $push- push,- (>~>),- (>>~),+ , push+ , (>~>)+ , (>>~) -- ** Pull -- $pull- pull,- (>+>),- (+>>),+ , pull+ , (>+>)+ , (+>>) -- ** Reflect -- $reflect- reflect,+ , reflect -- * Concrete Type Synonyms- Effect,- Producer,- Pipe,- Consumer,- Client,- Server,+ , Effect+ , Producer+ , Pipe+ , Consumer+ , Client+ , Server -- * Polymorphic Type Synonyms- Effect',- Producer',- Consumer',- Client',- Server',+ , Effect'+ , Producer'+ , Consumer'+ , Client'+ , Server' -- * Flipped operators- (\<\),- (/</),- (<~<),- (~<<),- (<+<),- (<\\),- (//<),- (<<+)+ , (\<\)+ , (/</)+ , (<~<)+ , (~<<)+ , (<+<)+ , (<\\)+ , (//<)+ , (<<+) ) where import Data.Void (Void, absurd)@@ -131,8 +127,7 @@ Pure r -> return r {-# INLINABLE runEffect #-} -{-- * Keep proxy composition lower in precedence than function composition, which+{- * Keep proxy composition lower in precedence than function composition, which is 9 at the time of of this comment, so that users can write things like: @@ -832,3 +827,18 @@ -- ^ k <<+ p = p +>> k {-# INLINABLE (<<+) #-}++{-# RULES+ "(p //> f) //> g" forall p f g . (p //> f) //> g = p //> (\a -> f a //> g)++ ; "p //> respond" forall p . p //> respond = p++ ; "respond x //> f" forall x f . respond x //> f = f x++ ; "f >\\ (g >\\ p)" forall f g p . f >\\ (g >\\ p) = (\a -> f >\\ g a) >\\ p++ ; "request >\\ p" forall p . request >\\ p = p++ ; "f >\\ request x" forall f x . f >\\ request x = f x++ #-}
src/Pipes/Internal.hs view
@@ -25,23 +25,31 @@ , UndecidableInstances , CPP #-}++-- The rewrite RULES require the 'TrustWorthy' annotation+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ module Pipes.Internal ( -- * Internal- Proxy(..),- unsafeHoist,- observe,+ Proxy(..)+ , unsafeHoist+ , observe, ) where import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))-import Control.Monad (liftM, MonadPlus(..))+import Control.Monad (MonadPlus(..)) import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Trans.Class (MonadTrans(lift))+#ifndef haskell98+import Control.Monad.Morph (MFunctor(hoist)) import Control.Monad.Error (MonadError(..)) import Control.Monad.Reader (MonadReader(..)) import Control.Monad.State (MonadState(..)) import Control.Monad.Writer (MonadWriter(..)) import Data.Monoid (mempty,mappend)+#endif {-| A 'Proxy' is a monad transformer that receives and sends information on both an upstream and downstream interface.@@ -127,7 +135,9 @@ Respond b fb' -> Respond b (\b' -> go (fb' b')) M m -> M (nat (m >>= \p' -> return (go p'))) Pure r -> Pure r+{-# INLINABLE unsafeHoist #-} +#ifndef haskell98 instance MFunctor (Proxy a' a b' b) where hoist nat p0 = go (observe p0) where go p = case p of@@ -135,10 +145,12 @@ Respond b fb' -> Respond b (\b' -> go (fb' b')) M m -> M (nat (m >>= \p' -> return (go p'))) Pure r -> Pure r+#endif instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where liftIO m = M (liftIO (m >>= \r -> return (Pure r))) +#ifndef haskell98 instance (MonadReader r m) => MonadReader r (Proxy a' a b' b m) where ask = lift ask local f = go@@ -147,10 +159,9 @@ Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) Pure r -> Pure r- M m -> M (go `liftM` local f m)+ M m -> M (local f m >>= \r -> return (go r)) #if MIN_VERSION_mtl(2,1,0) reader = lift . reader-#else #endif instance (MonadState s m) => MonadState s (Proxy a' a b' b m) where@@ -158,31 +169,32 @@ put = lift . put #if MIN_VERSION_mtl(2,1,0) state = lift . state-#else #endif instance (MonadWriter w m) => MonadWriter w (Proxy a' a b' b m) where #if MIN_VERSION_mtl(2,1,0) writer = lift . writer-#else #endif tell = lift . tell- listen proxy = go proxy mempty- where- go p w = case p of- Request a' fa -> Request a' (\a -> go (fa a ) w)- Respond b fb' -> Respond b (\b' -> go (fb' b') w)- Pure r -> Pure (r, w)- M m -> M (- (\(p', w') -> go p' $! mappend w w') `liftM` listen m)+ listen p0 = go p0 mempty+ where+ go p w = case p of+ Request a' fa -> Request a' (\a -> go (fa a ) w)+ Respond b fb' -> Respond b (\b' -> go (fb' b') w)+ M m -> M (do+ (p', w') <- listen m+ return (go p' $! mappend w w') )+ Pure r -> Pure (r, w) - pass = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- M m -> M (go `liftM` m)- Pure (r, f) -> M (pass (return (Pure r, f)))+ pass p0 = go p0 mempty+ where+ go p w = case p of+ Request a' fa -> Request a' (\a -> go (fa a ) w)+ Respond b fb' -> Respond b (\b' -> go (fb' b') w)+ M m -> M (do+ (p', w') <- listen m+ return (go p' $! mappend w w') )+ Pure (r, f) -> M (pass (return (Pure r, \_ -> f w))) instance (MonadError e m) => MonadError e (Proxy a' a b' b m) where throwError = lift . throwError@@ -195,6 +207,7 @@ M m -> M ((do p' <- m return (go p') ) `catchError` (\e -> return (f e)) )+#endif instance (MonadPlus m) => Alternative (Proxy a' a b' b m) where empty = mzero
src/Pipes/Lift.hs view
@@ -7,47 +7,67 @@ module Pipes.Lift ( -- * ErrorT- errorP,- runErrorP,- catchError,- liftCatchError,+ errorP+#ifndef haskell98+ , runErrorP+ , catchError+#endif+ , liftCatchError -- * MaybeT- maybeP,- runMaybeP,+ , maybeP+#ifndef haskell98+ , runMaybeP+#endif -- * ReaderT- readerP,- runReaderP,+ , readerP+#ifndef haskell98+ , runReaderP+#endif -- * StateT- stateP,- runStateP,- evalStateP,- execStateP,+ , stateP+#ifndef haskell98+ , runStateP+ , evalStateP+ , execStateP+#endif -- * WriterT -- $writert- writerP,- runWriterP,- execWriterP,+ , writerP+#ifndef haskell98+ , runWriterP+ , execWriterP+#endif -- * RWST- rwsP,- runRWSP,- evalRWSP,- execRWSP+ , rwsP+#ifndef haskell98+ , runRWSP+ , evalRWSP+ , execRWSP++ -- * Utilities+ , distribute+#endif+ ) where -import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Class (lift, MonadTrans(..)) import qualified Control.Monad.Trans.Error as E import qualified Control.Monad.Trans.Maybe as M import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Strict as W import qualified Control.Monad.Trans.RWS.Strict as RWS-import Data.Monoid (Monoid(mempty, mappend))-import Pipes.Internal+import Data.Monoid (Monoid)+import Pipes.Internal (Proxy(..), unsafeHoist)+#ifndef haskell98+import Control.Monad.Morph (hoist, MFunctor(..))+import Pipes.Core (runEffect, request, respond, (//>), (>\\))+#endif -- | Wrap the base monad in 'E.ErrorT' errorP@@ -59,43 +79,27 @@ lift $ E.ErrorT (return x) {-# INLINABLE errorP #-} +#ifndef haskell98 -- | Run 'E.ErrorT' in the base monad runErrorP- :: (Monad m)- => Proxy a' a b' b (E.ErrorT e m) r -> Proxy a' a b' b m (Either e r)-runErrorP = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure (Right r)- M m -> M (do- x <- E.runErrorT m- return (case x of- Left e -> Pure (Left e)- Right p' -> go p' ) )+ :: (Monad m, E.Error e)+ => Proxy a' a b' b (E.ErrorT e m) r+ -> Proxy a' a b' b m (Either e r)+runErrorP = E.runErrorT . distribute {-# INLINABLE runErrorP #-} -- | Catch an error in the base monad catchError- :: (Monad m) + :: (Monad m, E.Error e) => Proxy a' a b' b (E.ErrorT e m) r -- ^- -> (e -> Proxy a' a b' b (E.ErrorT f m) r)+ -> (e -> Proxy a' a b' b (E.ErrorT e m) r) -- ^- -> Proxy a' a b' b (E.ErrorT f m) r-catchError p0 f = go p0- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M (E.ErrorT (do- x <- E.runErrorT m- return (Right (case x of- Left e -> f e- Right p' -> go p' )) ))+ -> Proxy a' a b' b (E.ErrorT e m) r+catchError e h = errorP . E.runErrorT $ + E.catchError (distribute e) (distribute . h) {-# INLINABLE catchError #-}+#endif -- | Catch an error using a catch function for the base monad liftCatchError@@ -128,22 +132,15 @@ lift $ M.MaybeT (return x) {-# INLINABLE maybeP #-} +#ifndef haskell98 -- | Run 'M.MaybeT' in the base monad runMaybeP :: (Monad m)- => Proxy a' a b' b (M.MaybeT m) r -> Proxy a' a b' b m (Maybe r)-runMaybeP = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure (Just r)- M m -> M (do- x <- M.runMaybeT m- return (case x of- Nothing -> Pure Nothing- Just p' -> go p' ) )+ => Proxy a' a b' b (M.MaybeT m) r+ -> Proxy a' a b' b m (Maybe r)+runMaybeP p = M.runMaybeT $ distribute p {-# INLINABLE runMaybeP #-}+#endif -- | Wrap the base monad in 'R.ReaderT' readerP@@ -154,20 +151,16 @@ unsafeHoist lift (k i) {-# INLINABLE readerP #-} +#ifndef haskell98 -- | Run 'R.ReaderT' in the base monad runReaderP :: (Monad m)- => i -> Proxy a' a b' b (R.ReaderT i m) r -> Proxy a' a b' b m r-runReaderP i = go- where- go p = case p of- Request a' fa -> Request a' (\a -> go (fa a ))- Respond b fb' -> Respond b (\b' -> go (fb' b'))- Pure r -> Pure r- M m -> M (do- p' <- R.runReaderT m i- return (go p') )+ => i+ -> Proxy a' a b' b (R.ReaderT i m) r+ -> Proxy a' a b' b m r+runReaderP r p = (`R.runReaderT` r) $ distribute p {-# INLINABLE runReaderP #-}+#endif -- | Wrap the base monad in 'S.StateT' stateP@@ -180,32 +173,34 @@ return r {-# INLINABLE stateP #-} +#ifndef haskell98 -- | Run 'S.StateT' in the base monad runStateP :: (Monad m)- => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m (r, s)-runStateP = go- where- go s p = case p of- Request a' fa -> Request a' (\a -> go s (fa a ))- Respond b fb' -> Respond b (\b' -> go s (fb' b'))- Pure r -> Pure (r, s)- M m -> M (do- (p', s') <- S.runStateT m s- return (go s' p') )+ => s+ -> Proxy a' a b' b (S.StateT s m) r+ -> Proxy a' a b' b m (r, s)+runStateP s p = (`S.runStateT` s) $ distribute p {-# INLINABLE runStateP #-} -- | Evaluate 'S.StateT' in the base monad evalStateP- :: (Monad m) => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m r-evalStateP s = fmap fst . runStateP s+ :: (Monad m)+ => s+ -> Proxy a' a b' b (S.StateT s m) r+ -> Proxy a' a b' b m r+evalStateP s p = fmap fst $ runStateP s p {-# INLINABLE evalStateP #-} -- | Execute 'S.StateT' in the base monad execStateP- :: (Monad m) => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m s-execStateP s = fmap snd . runStateP s+ :: (Monad m)+ => s+ -> Proxy a' a b' b (S.StateT s m) r+ -> Proxy a' a b' b m s+execStateP s p = fmap snd $ runStateP s p {-# INLINABLE execStateP #-}+#endif {- $writert Note that 'runWriterP' and 'execWriterP' will keep the accumulator in@@ -228,28 +223,23 @@ return r {-# INLINABLE writerP #-} +#ifndef haskell98 -- | Run 'W.WriterT' in the base monad runWriterP- :: (Monad m, Monoid w)- => Proxy a' a b' b (W.WriterT w m) r -> Proxy a' a b' b m (r, w)-runWriterP = go mempty- where- go w p = case p of- Request a' fa -> Request a' (\a -> go w (fa a ))- Respond b fb' -> Respond b (\b' -> go w (fb' b'))- Pure r -> Pure (r, w)- M m -> M (do- (p', w') <- W.runWriterT m- let wt = mappend w w'- wt `seq` return (go wt p') )+ :: (Monad m, Data.Monoid.Monoid w)+ => Proxy a' a b' b (W.WriterT w m) r+ -> Proxy a' a b' b m (r, w)+runWriterP p = W.runWriterT $ distribute p {-# INLINABLE runWriterP #-} -- | Execute 'W.WriterT' in the base monad execWriterP- :: (Monad m, Monoid w)- => Proxy a' a b' b (W.WriterT w m) r -> Proxy a' a b' b m w-execWriterP = fmap snd . runWriterP+ :: (Monad m, Data.Monoid.Monoid w)+ => Proxy a' a b' b (W.WriterT w m) r+ -> Proxy a' a b' b m w+execWriterP p = fmap snd $ runWriterP p {-# INLINABLE execWriterP #-}+#endif -- | Wrap the base monad in 'RWS.RWST' rwsP@@ -266,40 +256,56 @@ return r {-# INLINABLE rwsP #-} +#ifndef haskell98 -- | Run 'RWS.RWST' in the base monad-runRWSP :: (Monad m, Monoid w)- => i- -> s- -> Proxy a' a b' b (RWS.RWST i w s m) r- -> Proxy a' a b' b m (r, s, w)-runRWSP i = go mempty- where- go w s p = case p of- Request a' fa -> Request a' (\a -> go w s (fa a ))- Respond b fb' -> Respond b (\b' -> go w s (fb' b'))- Pure r -> Pure (r, s, w)- M m -> M (do- (p', s', w') <- RWS.runRWST m i s- let wt = mappend w w'- wt `seq` return (go w' s' p') )+runRWSP+ :: (Monad m, Monoid w)+ => r+ -> s+ -> Proxy a' a b' b (RWS.RWST r w s m) d+ -> Proxy a' a b' b m (d, s, w)+runRWSP i s p = (\b -> RWS.runRWST b i s) $ distribute p {-# INLINABLE runRWSP #-} -- | Evaluate 'RWS.RWST' in the base monad-evalRWSP :: (Monad m, Monoid w)- => i- -> s- -> Proxy a' a b' b (RWS.RWST i w s m) r- -> Proxy a' a b' b m (r, w)-evalRWSP i s = fmap go . runRWSP i s- where go (r, _, w) = (r, w)+evalRWSP+ :: (Monad m, Monoid w)+ => r+ -> s+ -> Proxy a' a b' b (RWS.RWST r w s m) d+ -> Proxy a' a b' b m (d, w)+evalRWSP i s p = fmap f $ runRWSP i s p+ where+ f x = let (r, _, w) = x in (r, w) {-# INLINABLE evalRWSP #-} -- | Execute 'RWS.RWST' in the base monad-execRWSP :: (Monad m, Monoid w)- => i- -> s- -> Proxy a' a b' b (RWS.RWST i w s m) r- -> Proxy a' a b' b m (s, w)-execRWSP i s = fmap go . runRWSP i s- where go (_, s', w) = (s', w)+execRWSP+ :: (Monad m, Monoid w)+ => r+ -> s+ -> Proxy a' a b' b (RWS.RWST r w s m) d+ -> Proxy a' a b' b m (s, w)+execRWSP i s p = fmap f $ runRWSP i s p+ where+ f x = let (_, s', w) = x in (s', w) {-# INLINABLE execRWSP #-}++-- | Distribute 'Proxy' over a monad transformer+distribute+ :: ( Monad m+ , MonadTrans t+ , MFunctor t+ , Monad (t m)+ , Monad (t (Proxy a' a b' b m))+ )+ => Proxy a' a b' b (t m) r+ -- ^ + -> t (Proxy a' a b' b m) r+ -- ^ +distribute p = runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond'+ where+ request' = lift . lift . request+ respond' = lift . lift . respond+{-# INLINABLE distribute #-}+#endif
src/Pipes/Prelude.hs view
@@ -15,117 +15,127 @@ 'Text' utilities for @pipes@ will preserve newlines. -} -{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, CPP #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +-- The rewrite RULES require the 'TrustWorthy' annotation+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ module Pipes.Prelude ( -- * Producers -- $producers- stdinLn,- readLn,- fromHandle,- replicateM,+ stdinLn+ , readLn+ , fromHandle+ , replicateM -- * Consumers -- $consumers- stdoutLn,- print,- toHandle,+ , stdoutLn+ , print+ , toHandle -- * Pipes -- $pipes- map,- mapM,- filter,- filterM,- take,- takeWhile,- drop,- dropWhile,- concat,- elemIndices,- findIndices,- scan,- scanM,- chain,- read,- show,+ , map+ , mapM+ , mapFoldable+ , filter+ , filterM+ , take+ , takeWhile+ , drop+ , dropWhile+ , concat+ , elemIndices+ , findIndices+ , scan+ , scanM+ , chain+ , read+ , show -- * Folds -- $folds- fold,- foldM,- all,- any,- and,- or,- elem,- notElem,- find,- findIndex,- head,- index,- last,- length,- maximum,- minimum,- null,- sum,- product,- toList,- toListM,+ , fold+ , foldM+ , all+ , any+ , and+ , or+ , elem+ , notElem+ , find+ , findIndex+ , head+ , index+ , last+ , length+ , maximum+ , minimum+ , null+ , sum+ , product+ , toList+ , toListM -- * Zips- zip,- zipWith,-+ , zip+ , zipWith+#ifndef haskell98 -- * Utilities- tee,- generalize+ , tee+ , generalize+#endif ) where import Control.Exception (throwIO, try) import Control.Monad (liftM, replicateM_, when, unless)-import Control.Monad.Trans.State.Strict (get, put) import Data.Functor.Identity (Identity, runIdentity) import Data.Void (absurd) import Foreign.C.Error (Errno(Errno), ePIPE) import qualified GHC.IO.Exception as G import Pipes-import Pipes.Core import Pipes.Internal-import Pipes.Lift (evalStateP) import qualified System.IO as IO import qualified Prelude+#ifndef haskell98+import Control.Monad.Trans.State.Strict (get, put)+import Pipes.Core+import Pipes.Lift (evalStateP)+#endif import Prelude hiding (- all,- and,- any,- concat,- drop,- dropWhile,- elem,- filter,- head,- last,- length,- map,- mapM,- maximum,- minimum,- notElem,- null,- or,- print,- product,- read,- readLn,- show,- sum,- take,- takeWhile,- zip,- zipWith )+ all+ , and+ , any+ , concat+ , drop+ , dropWhile+ , elem+ , filter+ , head+ , last+ , length+ , map+ , mapM+ , maximum+ , minimum+ , notElem+ , null+ , or+ , print+ , product+ , read+ , readLn+ , show+ , sum+ , take+ , takeWhile+ , zip+ , zipWith+ ) {- $producers Use 'for' loops to iterate over 'Producer's whenever you want to perform the@@ -211,15 +221,25 @@ {-# INLINABLE stdoutLn #-} -- | 'print' values to 'IO.stdout'-print :: (MonadIO m) => (Show a) => Consumer' a m r-print = for cat (liftIO . Prelude.print)+print :: (MonadIO m, Show a) => Consumer' a m r+print = for cat (\a -> liftIO (Prelude.print a)) {-# INLINABLE print #-} +{-# RULES+ "p >-> print" forall p .+ p >-> print = for p (\a -> liftIO (Prelude.print a))+ #-}+ -- | Write 'String's to a 'IO.Handle' using 'IO.hPutStrLn' toHandle :: (MonadIO m) => IO.Handle -> Consumer' String m r-toHandle handle = for cat $ \str -> liftIO (IO.hPutStrLn handle str)+toHandle handle = for cat (\str -> liftIO (IO.hPutStrLn handle str)) {-# INLINABLE toHandle #-} +{-# RULES+ "p >-> toHandle handle" forall p handle .+ p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str))+ #-}+ {- $pipes Use ('>->') to connect 'Producer's, 'Pipe's, and 'Consumer's: @@ -235,9 +255,17 @@ -- | Apply a function to all values flowing downstream map :: (Monad m) => (a -> b) -> Pipe a b m r-map f = for cat (yield . f)+map f = for cat (\a -> yield (f a)) {-# INLINABLE map #-} +{-# RULES+ "p >-> map f" forall p f . p >-> map f = for p (\a -> yield (f a))++ ; "map f >-> p" forall p f . map f >-> p = (do+ a <- await+ return (f a) ) >~ p+ #-}+ -- | Apply a monadic function to all values flowing downstream mapM :: (Monad m) => (a -> m b) -> Pipe a b m r mapM f = for cat $ \a -> do@@ -245,11 +273,39 @@ yield b {-# INLINABLE mapM #-} +{-# RULES+ "p >-> mapM f" forall p f . p >-> mapM f = for p (\a -> do+ b <- lift (f a)+ yield b )++ ; "mapM f >-> p" forall p f . mapM f >-> p = (do+ a <- await+ b <- lift (f a)+ return b ) >~ p+ #-}++{- | Apply a function to all values flowing downstream, and+ forward each element of the result.+-}+mapFoldable :: (Monad m, Foldable t) => (a -> t b) -> Pipe a b m r+mapFoldable f = for cat (\a -> each (f a))+{-# INLINABLE mapFoldable #-}++{-# RULES+ "p >-> mapFoldable f" forall p f .+ p >-> mapFoldable f = for p (\a -> each (f a))+ #-}+ -- | @(filter predicate)@ only forwards values that satisfy the predicate. filter :: (Monad m) => (a -> Bool) -> Pipe a a m r filter predicate = for cat $ \a -> when (predicate a) (yield a) {-# INLINABLE filter #-} +{-# RULES+ "p >-> filter predicate" forall p predicate.+ p >-> filter predicate = for p (\a -> when (predicate a) (yield a))+ #-}+ {-| @(filterM predicate)@ only forwards values that satisfy the monadic predicate -}@@ -259,6 +315,13 @@ when b (yield a) {-# INLINABLE filterM #-} +{-# RULES+ "p >-> filterM predicate" forall p predicate .+ p >-> filterM predicate = for p (\a -> do+ b <- lift (predicate a)+ when b (yield a) )+ #-}+ -- | @(take n)@ only allows @n@ values to pass through take :: (Monad m) => Int -> Pipe a a m () take n = replicateM_ n $ do@@ -308,6 +371,10 @@ concat = for cat each {-# INLINABLE concat #-} +{-# RULES+ "p >-> concat" forall p . p >-> concat = for p each+ #-}+ -- | Outputs the indices of all elements that match the given element elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r elemIndices a = findIndices (a ==)@@ -355,6 +422,18 @@ yield a {-# INLINABLE chain #-} +{-# RULES+ "p >-> chain f" forall p f .+ p >-> chain f = for p (\a -> do+ lift (f a)+ yield a )+ ; "chain f >-> p" forall p f .+ chain f >-> p = (do+ a <- await+ lift (f a)+ return a ) >~ p+ #-}+ -- | Parse 'Read'able values, only forwarding the value if the parse succeeds read :: (Monad m, Read a) => Pipe String a m r read = for cat $ \str -> case (reads str) of@@ -362,6 +441,13 @@ _ -> return () {-# INLINABLE read #-} +{-# RULES+ "p >-> read" forall p .+ p >-> read = for p (\str -> case (reads str) of+ [(a, "")] -> yield a+ _ -> return () )+ #-}+ -- | Convert 'Show'able values to 'String's show :: (Monad m, Show a) => Pipe a String m r show = map Prelude.show@@ -412,14 +498,14 @@ predicate. -} all :: (Monad m) => (a -> Bool) -> Producer a m () -> m Bool-all predicate p = null $ for p $ \a -> when (not $ predicate a) (yield a)+all predicate p = null $ p >-> filter (\a -> not (predicate a)) {-# INLINABLE all #-} {-| @(any predicate p)@ determines whether any element of @p@ satisfies the predicate. -} any :: (Monad m) => (a -> Bool) -> Producer a m () -> m Bool-any predicate p = liftM not $ null $ for p $ \a -> when (predicate a) (yield a)+any predicate p = liftM not $ null (p >-> filter predicate) {-# INLINABLE any #-} -- | Determines whether all elements are 'True'@@ -436,7 +522,7 @@ otherwise -} elem :: (Monad m, Eq a) => a -> Producer a m () -> m Bool-elem a = any (a ==) +elem a = any (a ==) {-# INLINABLE elem #-} {-| @(notElem a)@ returns 'False' if @p@ has an element equal to @a@, 'True'@@ -448,7 +534,7 @@ -- | Find the first element of a 'Producer' that satisfies the predicate find :: (Monad m) => (a -> Bool) -> Producer a m () -> m (Maybe a)-find predicate p = head $ for p $ \a -> when (predicate a) (yield a)+find predicate p = head (p >-> filter predicate) {-# INLINABLE find #-} {-| Find the index of the first element of a 'Producer' that satisfies the@@ -588,6 +674,7 @@ go p1' p2' {-# INLINABLE zipWith #-} +#ifndef haskell98 {-| Transform a 'Consumer' to a 'Pipe' that reforwards all values further downstream -}@@ -627,3 +714,4 @@ x <- respond a lift $ put x {-# INLINABLE generalize #-}+#endif
src/Pipes/Tutorial.hs view
@@ -1282,7 +1282,7 @@ * 'Effect'': marks both ends unused but still open -> type Effect' a m r = forall x' x y' y . Proxy x' x y' y m r+> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r > > Upstream | Downstream > +---------+@@ -1419,4 +1419,23 @@ Any time you get type errors like these you can work through them by expanding out the type synonyms and seeing which type variables do not match.++ You may also consult this table of type synonyms to more easily compare+ them:++> type Effect = Proxy Void () () Void+> type Producer b = Proxy Void () () b+> type Consumer a = Proxy () a () Void+> type Pipe a b = Proxy () a () b+>+> type Server b' b = Proxy Void () b' b +> type Client a' a = Proxy a' a () Void+>+> type Effect' m r = forall x' x y' y . Proxy x' x y' y m r+> type Producer' b m r = forall x' x . Proxy x' x () b m r+> type Consumer' a m r = forall y' y . Proxy () a y' y m r+>+> type Server' b' b m r = forall x' x . Proxy x' x b' b m r+> type Client' a' a m r = forall y' y . Proxy a' a y' y m r+ -}
+ tests/Main.hs view
@@ -0,0 +1,272 @@+module Main (main) where++import Data.Function (on)+import Data.List (intercalate)+import Control.Monad ((>=>))+import Control.Monad.Trans.Writer (Writer, runWriter, tell)+import Test.QuickCheck (Gen, Arbitrary(..), choose)+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Pipes+import Pipes.Core+import Prelude hiding (log)+++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+ [ testGroup "Kleisli Category" $ testCategory (>=>) return+ , testGroup "Respond Category" $ testCategory (/>/) respond+ ++ [ testProperty "Distributivity" prop_respond_Distributivity+ ]+ , testGroup "Request Category" $ testCategory (\>\) request+ ++ [ testProperty "Distributivity" prop_request_Distributivity+ , testProperty "Zero Law" prop_request_ZeroLaw+ ]+ , testGroup "Pull Category" $ testCategory (>+>) pull+ , testGroup "Push Category" $ testCategory (>~>) push+ , testGroup "Push/Pull"+ [ testProperty "Associativity" prop_pushPull_Associativity+ ]+ , testGroup "Duals"+ [ testGroup "Request"+ [ testProperty "Composition" prop_dual_RequestComposition+ , testProperty "Identity" prop_dual_RequestIdentity+ ]+ , testGroup "Respond"+ [ testProperty "Composition" prop_dual_RespondComposition+ , testProperty "Identity" prop_dual_RespondIdentity+ ]+ , testProperty "Distributivity" prop_dual_ReflectDistributivity+ , testProperty "Zero Law" prop_dual_ReflectZeroLaw+ , testProperty "Involution" prop_dual_Involution+ ]+ , testGroup "Functor Laws"+ [ testProperty "Identity" prop_FunctorIdentity+ ]+ ]++arbitraryBoundedEnum' :: (Bounded a, Enum a) => Gen a+arbitraryBoundedEnum' =+ do let mn = minBound+ mx = maxBound `asTypeOf` mn+ n <- choose (fromEnum mn, fromEnum mx)+ return (toEnum n `asTypeOf` mn)++data ClientStep+ = ClientRequest+ | ClientLog+ | ClientInc+ deriving (Enum, Bounded)++instance Arbitrary ClientStep where+ arbitrary = arbitraryBoundedEnum'+ shrink _ = []++instance Show ClientStep where+ show x = case x of+ ClientRequest -> "request"+ ClientLog -> "log"+ ClientInc -> "inc"++data ServerStep+ = ServerRespond+ | ServerLog+ | ServerInc+ deriving (Enum, Bounded)++instance Arbitrary ServerStep where+ arbitrary = arbitraryBoundedEnum'+ shrink _ = []++instance Show ServerStep where+ show x = case x of+ ServerRespond -> "respond"+ ServerLog -> "log"+ ServerInc -> "inc"++data ProxyStep+ = ProxyRequest+ | ProxyRespond+ | ProxyLog+ | ProxyInc deriving (Enum, Bounded)++instance Arbitrary ProxyStep where+ arbitrary = arbitraryBoundedEnum'+ shrink _ = []++instance Show ProxyStep where+ show x = case x of+ ProxyRequest -> "request"+ ProxyRespond -> "respond"+ ProxyLog -> "log"+ ProxyInc -> "inc"++log :: Int -> Proxy a' a b' b (Writer [Int]) Int+log n = do+ lift (tell [n])+ return n++inc :: (Monad m) => Int -> Proxy a' a b' b m Int+inc n = return (n + 1)++correct :: String -> String+correct str = case str of+ [] -> "return"+ _ -> str++newtype AClient = AClient { unAClient :: [ClientStep] }++instance Arbitrary AClient where+ arbitrary = fmap AClient arbitrary+ shrink = map AClient . shrink . unAClient++instance Show AClient where+ show = correct . intercalate " >=> " . map show . unAClient++aClient :: AClient -> Int -> Client Int Int (Writer [Int]) Int+aClient = foldr (>=>) return . map f . unAClient+ where+ f x = case x of+ ClientRequest -> request+ ClientLog -> log+ ClientInc -> inc++newtype AServer = AServer { unAServer :: [ServerStep] }++instance Arbitrary AServer where+ arbitrary = fmap AServer arbitrary+ shrink = map AServer . shrink . unAServer++instance Show AServer where+ show = correct . intercalate " >=> " . map show . unAServer++aServer :: AServer -> Int -> Server Int Int (Writer [Int]) Int+aServer = foldr (>=>) return . map f . unAServer+ where+ f x = case x of+ ServerRespond -> respond+ ServerLog -> log+ ServerInc -> inc++newtype AProxy = AProxy { unAProxy :: [ProxyStep] }++instance Arbitrary AProxy where+ arbitrary = fmap AProxy arbitrary+ shrink = map AProxy . shrink . unAProxy++instance Show AProxy where+ show = correct . intercalate " >=> " . map show . unAProxy++aProxy :: AProxy -> Int -> Proxy Int Int Int Int (Writer [Int]) Int+aProxy = foldr (>=>) return . map f . unAProxy+ where+ f x = case x of+ ProxyRequest -> request+ ProxyRespond -> respond+ ProxyLog -> log+ ProxyInc -> inc++type ProxyK = Int -> Proxy Int Int Int Int (Writer [Int]) Int+type Operation = ProxyK -> ProxyK -> ProxyK++infix 0 ===++(===) :: ProxyK -> ProxyK -> AServer -> AClient -> Bool+(===) pl pr p0 p1 =+ let sv = aServer p0+ cl = aClient p1+ f p = runWriter (runEffect (p 0))+ in on (==) f (sv >+> pl >+> cl) (sv >+> pr >+> cl)++gen_prop_RightIdentity, gen_prop_LeftIdentity+ :: Operation+ -> ProxyK -- right/left identity element+ -> AProxy -> AServer -> AClient -> Bool+gen_prop_RightIdentity (>>>) idt f' =+ let f = aProxy f'+ in (f >>> idt) === f++gen_prop_LeftIdentity (>>>) idt f' =+ let f = aProxy f'+ in (idt >>> f) === f++gen_prop_Associativity+ :: Operation+ -> AProxy -> AProxy -> AProxy -> AServer -> AClient -> Bool+gen_prop_Associativity (>>>) f' g' h' =+ let f = aProxy f'+ g = aProxy g'+ h = aProxy h'+ in f >>> (g >>> h) === (f >>> g) >>> h++testCategory :: Operation -> ProxyK -> [Test]+testCategory op idt =+ [ testProperty "Left Identity" $ gen_prop_LeftIdentity op idt+ , testProperty "Right Identity" $ gen_prop_RightIdentity op idt+ , testProperty "Associativity" $ gen_prop_Associativity op+ ]++-- Respond Category++prop_respond_Distributivity f' g' h' =+ let f = aProxy f'+ g = aProxy g'+ h = aProxy h'+ in (f >=> g) />/ h === (f />/ h) >=> (g />/ h)++-- Request Category++prop_request_Distributivity f' g' h' =+ let f = aProxy f'+ g = aProxy g'+ h = aProxy h'+ in f \>\ (g >=> h) === (f \>\ g) >=> (f \>\ h)++prop_request_ZeroLaw f' =+ let f = aProxy f'+ in (f \>\ return) === return++-- Push/Pull++prop_pushPull_Associativity f' g' h' =+ let f = aProxy f'+ g = aProxy g'+ h = aProxy h'+ in (f >+> g) >~> h === f >+> (g >~> h)++-- Duals++prop_dual_RequestComposition f' g' =+ let f = aProxy f'+ g = aProxy g'+ in reflect . (f \>\ g) === reflect . g />/ reflect . f++prop_dual_RequestIdentity = reflect . request === respond++prop_dual_RespondComposition f' g' =+ let f = aProxy f'+ g = aProxy g'+ in reflect . (f />/ g) === reflect . g \>\ reflect . f++prop_dual_RespondIdentity = reflect . respond === request++prop_dual_ReflectDistributivity f' g' =+ let f = aProxy f'+ g = aProxy g'+ in reflect . (f >=> g) === reflect . f >=> reflect . g++prop_dual_ReflectZeroLaw = reflect . return === return++prop_dual_Involution f' =+ let f = aProxy f'+ in (reflect . reflect) . f >=> return === f++-- Functor Laws++prop_FunctorIdentity p' =+ let p = aProxy p'+ in fmap id p === id p