module Pipes.Fluid.Sync
( Sync(..)
) where
import Control.Lens
import Control.Monad
import Control.Monad.Trans.Class
import qualified Pipes as P
import qualified Pipes.Prelude as PP
newtype Sync m a = Sync
{ synchronously :: P.Producer a m ()
}
makeWrapped ''Sync
instance Monad m => Functor (Sync m) where
fmap f (Sync as) = Sync $ as P.>-> PP.map f
instance Monad m => Applicative (Sync m) where
pure = Sync . forever . P.yield
Sync xs <*> Sync ys = Sync $ go xs ys
go :: Monad m => P.Producer (t -> a) m r -> P.Producer t m r -> P.Proxy x' x () a m ()
go fs as = do
rf <- lift $ P.next fs
ra <- lift $ P.next as
case (rf, ra) of
(Left _, _) -> pure ()
(_, Left _) -> pure ()
(Right (f, fs'), Right (a, as')) -> do
P.yield $ f a
go fs' as'
instance Monad m => Monad (Sync m) where
Sync as >>= f = Sync $ do
ra <- lift $ P.next as
case ra of
Left _ -> pure ()
Right (a, as') -> do
rb <- lift . P.next . synchronously $ f a
case rb of
Left _ -> pure ()
Right (b, _) -> do
P.yield b
synchronously $ Sync as' >>= f