module Data.SouSiT.Sink (
Sink(..),
SinkStatus(..),
closeSink,
inputOr,
input,
skip,
appendSink,
(=||=),
feedList,
liftSink,
contSink,
doneSink,
doneSink',
actionSink,
openCloseActionSink,
maybeSink,
) where
import Data.Monoid
import Control.Applicative
import Control.Monad
data Sink i m r = Sink { sinkStatus :: m (SinkStatus i m r) }
data SinkStatus i m r = Cont (i -> Sink i m r) (m r)
| Done (m r)
instance Monad m => Functor (Sink i m) where
fmap f (Sink st) = Sink (liftM mp st)
where mp (Done r) = Done (liftM f r)
mp (Cont nf cf) = Cont (fmap f . nf) (liftM f cf)
instance Monad m => Monad (Sink i m) where
return a = doneSink $ return a
(Sink st) >>= f = Sink (st >>= mp)
where mp (Done r) = liftM f r >>= sinkStatus
mp (Cont nf cf) = return $ Cont ((>>= f) . nf) (cf >>= closeSink . f)
instance Monad m => Applicative (Sink i m) where
pure = return
af <*> s = do f <- af
v <- s
return (f v)
noResult :: Monad m => m a
noResult = fail "no result: not enough input"
closeSink :: Monad m => Sink i m r -> m r
closeSink (Sink st) = st >>= handle
where handle (Done r) = r
handle (Cont _ r) = r
inputOr :: Monad m => m a -> Sink a m a
inputOr = contSink doneSink'
input :: Monad m => Sink a m a
input = inputOr noResult
skip :: (Eq n, Num n, Monad m) => n -> Sink a m ()
skip 0 = doneSink (return ())
skip n = contSink f (return ())
where f _ = skip (n1)
(=||=) :: (Monad m, Monoid r) => Sink a m r -> Sink a m r -> Sink a m r
(=||=) = appendSink
infixl 3 =||=
appendSink :: (Monad m, Monoid r) => Sink a m r -> Sink a m r -> Sink a m r
appendSink s1 s2 = do r1 <- s1
r2 <- s2
return $ mappend r1 r2
feedList :: Monad m => [i] -> Sink i m r -> Sink i m r
feedList [] !s = s
feedList (x:xs) !s = Sink (sinkStatus s >>= step)
where step (Done r) = return $ Done r
step (Cont f _) = sinkStatus $ feedList xs $ f x
contSink :: Monad m => (i -> Sink i m r) -> m r -> Sink i m r
contSink next = Sink . return . Cont next
doneSink :: Monad m => m r -> Sink i m r
doneSink = Sink . return . Done
doneSink' :: Monad m => r -> Sink i m r
doneSink' = Sink . return . Done . return
actionSink :: Monad m => (i -> m ()) -> Sink i m ()
actionSink process = contSink f (return ())
where f i = Sink $ process i >> sinkStatus (actionSink process)
openCloseActionSink :: Monad m => m a -> (a -> m ()) -> (a -> i -> m ()) -> Sink i m ()
openCloseActionSink open close process = contSink first (return ())
where first i = Sink $ open >>= flip step i
step rs i = process rs i >> return (Cont (Sink . step rs) (close rs))
maybeSink :: Monad m => (i -> m (Maybe r)) -> Sink i m (Maybe r)
maybeSink f = contSink step (return Nothing)
where step i = Sink $ liftM cont (f i)
cont Nothing = Cont step (return Nothing)
cont result = Done $ return result
liftSink :: (Monad m, Monad m') => (forall x . m x -> m' x) -> Sink i m r -> Sink i m' r
liftSink t sink = Sink $ t (sinkStatus sink >>= trans)
where trans (Done r) = return $ Done (t r)
trans (Cont nf cf) = return $ Cont (liftSink t . nf) (t cf)