public
Last active

Alternate approach to conduit's leftovers.

  • Download Gist
Feedback.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
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
leftovers.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.