Create a gist now

Instantly share code, notes, and snippets.

@ppetr /Feedback.hs
Last active Dec 14, 2015

What would you like to do?
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
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)
-- Pushes a leftover 'i' into a pipe:
push i = push'
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