Skip to content
Create a gist now

Instantly share code, notes, and snippets.

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

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
Something went wrong with that request. Please try again.