module Data.Conduit.Internal
(
Pipe (..)
, Source
, Sink
, Conduit
, Finalize (..)
, pipeClose
, pipe
, pipeResume
, runPipe
, sinkToPipe
, await
, yield
, hasInput
, transPipe
, mapOutput
, runFinalize
, addCleanup
) where
import Control.Applicative (Applicative (..), (<$>))
import Control.Monad ((>=>), liftM, ap)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Base (MonadBase (liftBase))
import Data.Void (Void, absurd)
import Data.Monoid (Monoid (mappend, mempty))
import Control.Monad.Trans.Resource
data Finalize m r = FinalizePure r
| FinalizeM (m r)
instance Monad m => Functor (Finalize m) where
fmap f (FinalizePure r) = FinalizePure (f r)
fmap f (FinalizeM mr) = FinalizeM (liftM f mr)
instance Monad m => Applicative (Finalize m) where
pure = FinalizePure
(<*>) = ap
instance Monad m => Monad (Finalize m) where
return = FinalizePure
FinalizePure x >>= f = f x
FinalizeM mx >>= f = FinalizeM $ mx >>= \x ->
case f x of
FinalizePure y -> return y
FinalizeM my -> my
instance MonadTrans Finalize where
lift = FinalizeM
instance MonadThrow m => MonadThrow (Finalize m) where
monadThrow = lift . monadThrow
instance MonadIO m => MonadIO (Finalize m) where
liftIO = lift . liftIO
instance MonadResource m => MonadResource (Finalize m) where
allocate a = lift . allocate a
register = lift . register
release = lift . release
resourceMask = lift . resourceMask
data Pipe i o m r =
HaveOutput (Pipe i o m r) (Finalize m r) o
| NeedInput (i -> Pipe i o m r) (Pipe i o m r)
| Done (Maybe i) r
| PipeM (m (Pipe i o m r)) (Finalize m r)
type Source m a = Pipe Void a m ()
type Sink i m r = Pipe i Void m r
type Conduit i m o = Pipe i o m ()
pipeClose :: Monad m => Pipe i o m r -> Finalize m r
pipeClose (HaveOutput _ c _) = c
pipeClose (NeedInput _ p) = pipeClose p
pipeClose (Done _ r) = FinalizePure r
pipeClose (PipeM _ c) = c
pipePush :: Monad m => i -> Pipe i o m r -> Pipe i o m r
pipePush i (HaveOutput p c o) = HaveOutput (pipePush i p) c o
pipePush i (NeedInput p _) = p i
pipePush i (Done _ r) = Done (Just i) r
pipePush i (PipeM mp c) = PipeM (pipePush i `liftM` mp) c
instance Monad m => Functor (Pipe i o m) where
fmap f (HaveOutput p c o) = HaveOutput (f <$> p) (f `liftM` c) o
fmap f (NeedInput p c) = NeedInput (fmap f . p) (f <$> c)
fmap f (Done l r) = Done l (f r)
fmap f (PipeM mp mr) = PipeM ((fmap f) `liftM` mp) (f `liftM` mr)
instance Monad m => Applicative (Pipe i o m) where
pure = Done Nothing
Done Nothing f <*> px = f <$> px
Done (Just i) f <*> px = pipePush i $ f <$> px
HaveOutput p c o <*> px = HaveOutput (p <*> px) (c `ap` pipeClose px) o
NeedInput p c <*> px = NeedInput (\i -> p i <*> px) (c <*> px)
PipeM mp c <*> px = PipeM ((<*> px) `liftM` mp) (c `ap` pipeClose px)
instance Monad m => Monad (Pipe i o m) where
return = Done Nothing
Done Nothing x >>= fp = fp x
Done (Just i) x >>= fp = pipePush i $ fp x
HaveOutput p c o >>= fp = HaveOutput (p >>= fp) (c >>= pipeClose . fp) o
NeedInput p c >>= fp = NeedInput (p >=> fp) (c >>= fp)
PipeM mp c >>= fp = PipeM ((>>= fp) `liftM` mp) (c >>= pipeClose . fp)
instance MonadBase base m => MonadBase base (Pipe i o m) where
liftBase = lift . liftBase
instance MonadTrans (Pipe i o) where
lift mr = PipeM (Done Nothing `liftM` mr) (FinalizeM mr)
instance MonadIO m => MonadIO (Pipe i o m) where
liftIO = lift . liftIO
instance Monad m => Monoid (Pipe i o m ()) where
mempty = return ()
mappend = (>>)
pipe :: Monad m => Pipe a b m () -> Pipe b c m r -> Pipe a c m r
pipe l r = pipeResume l r >>= \(l', res) -> lift (runFinalize $ pipeClose l') >> return res
pipeResume :: Monad m => Pipe a b m () -> Pipe b c m r -> Pipe a c m (Pipe a b m (), r)
pipeResume left right =
case right of
Done leftoverr r ->
let (leftover, left', leftClose) =
case left of
Done leftoverl () -> (leftoverl, Done Nothing (), FinalizePure ())
_ -> (Nothing, left, pipeClose left)
left'' =
case leftoverr of
Just a -> HaveOutput left' leftClose a
Nothing -> left'
in Done leftover (left'', r)
PipeM mp c -> PipeM
(pipeResume left `liftM` mp)
(((,) left) `fmap` c)
HaveOutput p c o -> HaveOutput
(pipeResume left p)
(((,) left) `fmap` c)
o
NeedInput rp rc ->
case left of
HaveOutput lp _ a -> pipeResume lp $ rp a
NeedInput p c -> NeedInput
(\a -> pipeResume (p a) right)
(do
(left', res) <- pipeResume c right
lift $ runFinalize $ pipeClose left'
return (mempty, res)
)
Done l () -> ((,) mempty) `liftM` replaceLeftover l rc
PipeM mp c -> PipeM
((`pipeResume` right) `liftM` mp)
(fmap ((,) mempty) $ combineFinalize c $ pipeClose right)
combineFinalize :: Monad m => Finalize m () -> Finalize m r -> Finalize m r
combineFinalize (FinalizePure ()) f = f
combineFinalize (FinalizeM x) (FinalizeM y) = FinalizeM $ x >> y
combineFinalize (FinalizeM x) (FinalizePure y) = FinalizeM $ x >> return y
replaceLeftover :: Monad m => Maybe i -> Pipe i' o m r -> Pipe i o m r
replaceLeftover l (Done _ r) = Done l r
replaceLeftover l (HaveOutput p c o) = HaveOutput (replaceLeftover l p) c o
replaceLeftover l (NeedInput _ c) = replaceLeftover l c
replaceLeftover l (PipeM mp c) = PipeM (replaceLeftover l `liftM` mp) c
runPipe :: Monad m => Pipe Void Void m r -> m r
runPipe (HaveOutput _ c _) = runFinalize c
runPipe (NeedInput _ c) = runPipe c
runPipe (Done _ r) = return r
runPipe (PipeM mp _) = mp >>= runPipe
runFinalize :: Monad m => Finalize m r -> m r
runFinalize (FinalizePure r) = return r
runFinalize (FinalizeM mr) = mr
yield :: Monad m => o -> Pipe i o m ()
yield = HaveOutput (Done Nothing ()) (FinalizePure ())
await :: Pipe i o m (Maybe i)
await = NeedInput (Done Nothing . Just) (Done Nothing Nothing)
hasInput :: Pipe i o m Bool
hasInput = NeedInput (\i -> Done (Just i) True) (Done Nothing False)
sinkToPipe :: Monad m => Sink i m r -> Pipe i o m r
sinkToPipe (HaveOutput _ _ o) = absurd o
sinkToPipe (NeedInput p c) = NeedInput (sinkToPipe . p) (sinkToPipe c)
sinkToPipe (Done i r) = Done i r
sinkToPipe (PipeM mp c) = PipeM (liftM sinkToPipe mp) c
transPipe :: Monad m => (forall a. m a -> n a) -> Pipe i o m r -> Pipe i o n r
transPipe f (HaveOutput p c o) = HaveOutput (transPipe f p) (transFinalize f c) o
transPipe f (NeedInput p c) = NeedInput (transPipe f . p) (transPipe f c)
transPipe _ (Done i r) = Done i r
transPipe f (PipeM mp c) = PipeM (f $ liftM (transPipe f) mp) (transFinalize f c)
transFinalize :: (forall a. m a -> n a) -> Finalize m r -> Finalize n r
transFinalize _ (FinalizePure r) = FinalizePure r
transFinalize f (FinalizeM mr) = FinalizeM $ f mr
mapOutput :: Monad m => (o1 -> o2) -> Pipe i o1 m r -> Pipe i o2 m r
mapOutput f (HaveOutput p c o) = HaveOutput (mapOutput f p) c (f o)
mapOutput f (NeedInput p c) = NeedInput (mapOutput f . p) (mapOutput f c)
mapOutput _ (Done i r) = Done i r
mapOutput f (PipeM mp c) = PipeM (liftM (mapOutput f) mp) c
addCleanup :: Monad m
=> (Bool -> m ())
-> Pipe i o m r
-> Pipe i o m r
addCleanup cleanup (Done leftover r) = PipeM
(cleanup True >> return (Done leftover r))
(lift (cleanup True) >> return r)
addCleanup cleanup (HaveOutput src close x) = HaveOutput
(addCleanup cleanup src)
(lift (cleanup False) >> close)
x
addCleanup cleanup (PipeM msrc close) = PipeM
(liftM (addCleanup cleanup) msrc)
(lift (cleanup False) >> close)
addCleanup cleanup (NeedInput p c) = NeedInput
(addCleanup cleanup . p)
(addCleanup cleanup c)