module Data.Conduit.Types.Sink
( Sink (..)
, SinkPush
, SinkClose
) where
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad (liftM, ap)
import Control.Applicative (Applicative (..))
import Control.Monad.Base (MonadBase (liftBase))
type SinkPush input m output = input -> Sink input m output
type SinkClose m output = m output
data Sink input m output =
Processing (SinkPush input m output) (SinkClose m output)
| Done (Maybe input) output
| SinkM (m (Sink input m output))
instance Monad m => Functor (Sink input m) where
fmap f (Processing push close) = Processing (fmap f . push) (liftM f close)
fmap f (Done minput output) = Done minput (f output)
fmap f (SinkM msink) = SinkM (liftM (fmap f) msink)
instance Monad m => Applicative (Sink input m) where
pure = return
(<*>) = ap
instance Monad m => Monad (Sink input m) where
return = Done Nothing
Done Nothing x >>= f = f x
Done (Just leftover) x >>= f =
sinkPush (f x)
where
sinkPush (Processing push _) = push leftover
sinkPush (Done Nothing output) = Done (Just leftover) output
sinkPush (Done Just{} _) = error $ "Sink invariant violated: leftover input returned without any push"
sinkPush (SinkM msink) = SinkM (liftM sinkPush msink)
SinkM msink >>= f = SinkM (liftM (>>= f) msink)
Processing push close >>= f = Processing
(\input -> push input >>= f)
(close >>= sinkClose . f)
sinkClose :: Monad m => Sink input m output -> m output
sinkClose (Done _ output) = return output
sinkClose (Processing _ close) = close
sinkClose (SinkM msink) = msink >>= sinkClose
instance MonadBase base m => MonadBase base (Sink input m) where
liftBase = lift . liftBase
instance MonadTrans (Sink input) where
lift = SinkM . liftM return
instance MonadIO m => MonadIO (Sink input m) where
liftIO = lift . liftIO