Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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...
commit d9bbb1bad15394b3511567594bbf1087f7b1219b 1 parent 53478eb
Paolo Capriotti authored
Showing with 8 additions and 7 deletions.
  1. +8 −7 pipes-extra/Control/Pipe/PutbackPipe.hs
15 pipes-extra/Control/Pipe/PutbackPipe.hs
View
@@ -1,5 +1,5 @@
module Control.Pipe.PutbackPipe (
- nonputback,
+ fromPipe,
putback,
yield,
await,
@@ -7,6 +7,7 @@ module Control.Pipe.PutbackPipe (
runPutback
) where
+import Control.Monad
import Control.Monad.Trans
import qualified Control.Pipe as P
import Control.Pipe ((>+>), Pipe)
@@ -14,7 +15,7 @@ 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
Please sign in to comment.
Something went wrong with that request. Please try again.