Skip to content

@ppetr /Feedback.hs
Last active

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Alternate approach to conduit's leftovers.
import Control.Monad
import Data.Conduit.Internal
import Data.Void
import Data.Sequence
type PipeF i o u m r = Pipe Void i (Either i o) u m r
-- | Implements feedback for a `PipeF`, converting it to `Pipe`.
-- Any leftover feedback not consumed by the pipe (or produced after its
-- upstream has finished) is discarded.
feedback :: (Monad m) => PipeF i o u m r -> Pipe Void i o u m r
feedback = f empty
where
f buf (HaveOutput next _ (Left i)) = f (buf |> i) next
f buf (HaveOutput next fin (Right o)) = HaveOutput (f buf next) fin o
f buf (NeedInput fi fu) =
case viewl buf of
x :< xs -> f xs (fi x)
EmptyL -> NeedInput (f empty . fi) (ignore . fu)
f buf (PipeM m) = PipeM $ liftM (f buf) m
f _ (Leftover _ l) = absurd l
-- | Ignore and discard any feedback produced by a `PipeF`.
ignore :: (Monad m) => PipeF i o u m r -> Pipe Void i o u m r
ignore (HaveOutput next _ (Left _)) = ignore next
ignore (HaveOutput next fin (Right o)) = HaveOutput (ignore next) fin o
ignore (NeedInput fi fu) = NeedInput (ignore . fi) (ignore . fu)
ignore (PipeM m) = PipeM $ liftM ignore m
ignore (Leftover _ l) = absurd l
newtype ConduitL i o u m r = ConduitL { unConduitL :: Pipe Void i o u m (Maybe i, r) }
instance Monad m => Monad (ConduitL i o u m) where
return = ConduitL . return . ((,) Nothing)
(ConduitL k) >>= f = ConduitL $ do
(lo, r) <- k
case lo of
Nothing -> unConduitL $ f r
Just i -> push i (unConduitL $ f r)
where
-- Pushes a leftover 'i' into a pipe:
push i = push'
where
push' (HaveOutput next fin o) = HaveOutput (push' next) fin o
push' (NeedInput next _) = next i
push' (Done (Nothing, r)) = Done (Just i, r)
-- throw away the old leftover if we have a new one;
-- this should not happen, if a pipe behaves correctly - always reading
-- before writing back a leftover; alternatively, we could use
-- Seq (or another FIFO) instead of Maybe to keep multiple leftovers.
push' d@(Done (Just _, _)) = d
push' (PipeM m) = PipeM (liftM push' m)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.