module Pipes.Fluid.Impulse
( Impulse(..)
, module Pipes.Fluid.Merge
) where
import Control.Applicative
import Control.Lens
import Control.Monad.Trans.Class
import Data.These
import qualified Pipes as P
import Pipes.Fluid.Merge
import qualified Pipes.Prelude as PP
newtype Impulse m a = Impulse
{ impulsively :: P.Producer a m ()
}
makeWrapped ''Impulse
instance Monad m =>
Functor (Impulse m) where
fmap f (Impulse as) = Impulse $ as P.>-> PP.map f
instance (Alternative m, Monad m) =>
Applicative (Impulse m) where
pure = Impulse . P.yield
fs <*> as =
Impulse $
P.for (impulsively $ merge fs as) $ \r ->
case r of
Coupled _ f a -> P.yield $ f a
LeftOnly _ _ -> lift empty
RightOnly _ _-> lift empty
instance (Alternative m, Monad m) => Merge (Impulse m) where
merge' px_ py_ (Impulse xs_) (Impulse ys_) = Impulse $ go px_ py_ xs_ ys_
where
go px py xs ys = do
r <- lift $ bothOrEither (P.next xs) (P.next ys)
case r
of
These (Left _) (Left _) -> pure ()
This (Left _) -> case px of
Nothing -> ys P.>-> PP.map (RightOnly OtherDead)
Just x -> ys P.>-> PP.map (Coupled (FromRight OtherDead) x)
That (Left _) -> case py of
Nothing -> xs P.>-> PP.map (LeftOnly OtherDead)
Just y -> xs P.>-> PP.map (\x -> Coupled (FromLeft OtherDead) x y)
This (Right (x, xs')) -> do
case py of
Nothing -> P.yield $ LeftOnly OtherLive x
Just y -> P.yield $ Coupled (FromLeft OtherLive) x y
go (Just x) py xs' ys
That (Right (y, ys')) -> do
case px of
Nothing -> P.yield $ RightOnly OtherLive y
Just x -> P.yield $ Coupled (FromRight OtherLive) x y
go px (Just y) xs ys'
These (Right (x, xs')) (Left _) ->
case py of
Nothing -> do
P.yield $ LeftOnly OtherDead x
xs' P.>-> PP.map (LeftOnly OtherDead)
Just y -> do
P.yield $ Coupled (FromLeft OtherDead) x y
xs' P.>-> PP.map (\x' -> Coupled (FromLeft OtherDead) x' y)
These (Left _) (Right (y, ys')) ->
case px of
Nothing -> do
P.yield $ RightOnly OtherDead y
ys' P.>-> PP.map (RightOnly OtherDead)
Just x -> do
P.yield $ Coupled (FromRight OtherDead) x y
ys' P.>-> PP.map (Coupled (FromRight OtherDead) x)
These (Right (x, xs')) (Right (y, ys')) -> do
P.yield $ Coupled FromBoth x y
go (Just x) (Just y) xs' ys'
bothOrEither :: Alternative f => f a -> f b -> f (These a b)
bothOrEither left right =
(These <$> left <*> right)
<|>
(This <$> left)
<|>
(That <$> right)