Permalink
Browse files

Modify PutbackPipe to work around loopP limitation (#3).

loopP can distinguish equivalent pipes that await in an error handler.

Using a composite pipe in a call to loopP can result in unexpected
behavior after upstream failure.

This commit works around the problem by modifying PutbackPipe so that
loopP is applied to a single pipe.
  • Loading branch information...
1 parent 53478eb commit d9bbb1bad15394b3511567594bbf1087f7b1219b @pcapriotti committed Apr 7, 2012
Showing with 8 additions and 7 deletions.
  1. +8 −7 pipes-extra/Control/Pipe/PutbackPipe.hs
@@ -1,20 +1,21 @@
module Control.Pipe.PutbackPipe (
- nonputback,
+ fromPipe,
putback,
yield,
await,
tryAwait,
runPutback
) where
+import Control.Monad
import Control.Monad.Trans
import qualified Control.Pipe as P
import Control.Pipe ((>+>), Pipe)
import qualified Control.Pipe.Combinators as PC
import Control.Pipe.Monoidal
newtype PutbackPipe a b m r = PutbackPipe {
- unPutback :: Pipe a (Either b a) m r
+ unPutback :: Pipe (Either a a) (Either b a) m r
}
instance Monad m => Monad (PutbackPipe a b m) where
@@ -24,8 +25,8 @@ instance Monad m => Monad (PutbackPipe a b m) where
instance MonadTrans (PutbackPipe a b) where
lift = PutbackPipe . lift
-nonputback :: Monad m => Pipe a b m r -> PutbackPipe a b m r
-nonputback p = PutbackPipe (p >+> P.pipe Left)
+fromPipe :: Monad m => Pipe a b m r -> PutbackPipe a b m r
+fromPipe p = PutbackPipe (joinP >+> p >+> P.pipe Left)
putback :: Monad m => a -> PutbackPipe a b m ()
putback = PutbackPipe . P.yield . Right
@@ -34,10 +35,10 @@ yield :: Monad m => b -> PutbackPipe a b m ()
yield = PutbackPipe . P.yield . Left
await :: Monad m => PutbackPipe a b m a
-await = PutbackPipe P.await
+await = PutbackPipe $ liftM (either id id) P.await
tryAwait :: Monad m => PutbackPipe a b m (Maybe a)
-tryAwait = PutbackPipe PC.tryAwait
+tryAwait = PutbackPipe $ liftM (fmap (either id id)) PC.tryAwait
runPutback :: Monad m => PutbackPipe a b m r -> Pipe a b m r
-runPutback pb = loopP (joinP >+> unPutback pb)
+runPutback = loopP . unPutback

0 comments on commit d9bbb1b

Please sign in to comment.