module Tubes.Pump
( Pump(..)
, PumpF(..)
, pump
, recv
, send
, runPump
) where
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Free
import Control.Monad.Trans.Free.Church
import Control.Comonad
import Control.Comonad.Trans.Cofree
import Data.Functor.Identity
import Tubes.Core
type Pump a b = CofreeT (PumpF a b)
data PumpF a b k = PumpF
{ recvF :: (a , k)
, sendF :: (b -> k)
} deriving Functor
pump :: Comonad w
=> w a
-> (w a -> (b, w a))
-> (w a -> c -> w a)
-> Pump b c w a
pump x r s = coiterT cf x where
cf wa = PumpF (r wa) (s wa)
recv :: Comonad w => Pump a b w r -> (a, Pump a b w r)
recv p = recvF . unwrap $ p
send :: Comonad w => Pump a b w r -> b -> Pump a b w r
send p x = (sendF (unwrap p)) x
class (Functor f, Functor g) => Pairing f g | f -> g, g -> f where
pair :: (a -> b -> r) -> f a -> g b -> r
instance Pairing Identity Identity where
pair f (Identity a) (Identity b) = f a b
instance Pairing ((->) a) ((,) a) where
pair p f = uncurry (p . f)
instance Pairing ((,) a) ((->) a) where
pair p f g = p (snd f) (g (fst f))
pairEffect :: (Pairing f g, Comonad w, Monad m)
=> (a -> b -> r) -> CofreeT f w a -> FreeT g m b -> m r
pairEffect p s c = do
mb <- runFreeT c
case mb of
Pure x -> return $ p (extract s) x
Free gs -> pair (pairEffect p) (unwrap s) gs
instance Pairing (PumpF a b) (TubeF a b) where
pair p (PumpF ak bk) tb = runT tb (\ak' -> pair p ak ak')
(\bk' -> pair p bk bk')
runPump :: (Comonad w, Monad m)
=> (x -> y -> r) -> Pump a b w x -> Tube a b m y -> m r
runPump = pairEffect