module Control.Proxy.Core (
ProxyF(..),
Proxy(..),
C,
Server,
Client,
Session,
runProxy,
runProxyK,
runSession,
runSessionK,
discard,
ignore
) where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad (ap, forever, liftM, (>=>))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Free (
FreeF(Free, Pure), FreeT(FreeT, runFreeT), liftF, hoistFreeT, wrap )
import Control.MFunctor (MFunctor(mapT))
import Control.Proxy.Class (
Channel(idT, (<-<)), Interact(request, (/</), respond, (/>/)) )
import Data.Closed (C)
data ProxyF a' a b' b x = Request a' (a -> x) | Respond b (b' -> x)
instance Functor (ProxyF a' a b' b) where
fmap f (Respond b fb') = Respond b (f . fb')
fmap f (Request a' fa ) = Request a' (f . fa )
newtype Proxy a' a b' b m r = Proxy { unProxy :: FreeT (ProxyF a' a b' b) m r }
instance (Monad m) => Functor (Proxy a' a b' b m) where
fmap = liftM
instance (Monad m) => Applicative (Proxy a' a b' b m) where
pure = return
(<*>) = ap
instance (Monad m) => Monad (Proxy a' a b' b m) where
return = Proxy . return
m >>= f = Proxy $ unProxy m >>= unProxy . f
instance MonadTrans (Proxy a' a b' b) where
lift = Proxy . lift
instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where
liftIO = Proxy . liftIO
instance Channel Proxy where
idT = Proxy . idT'
p1 <-< p2 = Proxy . ((unProxy . p1) <-<? (unProxy . p2))
idT' :: (Monad m) => a' -> FreeT (ProxyF a' a a' a) m r
idT' a' = wrap $ Request a' $ \a -> wrap $ Respond a idT'
(<-<?) :: (Monad m)
=> (c' -> FreeT (ProxyF b' b c' c) m r)
-> (b' -> FreeT (ProxyF a' a b' b) m r)
-> (c' -> FreeT (ProxyF a' a c' c) m r)
p1 <-<? p2 = \c' -> FreeT $ do
x1 <- runFreeT $ p1 c'
runFreeT $ case x1 of
Pure r -> return r
Free (Respond c fc') -> wrap $ Respond c (fc' <-<? p2)
Free (Request b' fb ) -> FreeT $ do
x2 <- runFreeT $ p2 b'
runFreeT $ case x2 of
Pure r -> return r
Free (Respond b fb') -> ((\_ -> fb b) <-<? fb') c'
Free (Request a' fa ) -> do
let p1' = \_ -> FreeT $ return x1
wrap $ Request a' $ \a -> (p1' <-<? (\_ -> fa a)) c'
instance Interact Proxy where
request a' = Proxy $ liftF $ Request a' id
p1 /</ p2 = (Proxy .) $ (unProxy . p1) /</? (unProxy . p2)
respond a = Proxy $ liftF $ Respond a id
p1 />/ p2 = (Proxy .) $ (unProxy . p1) />/? (unProxy . p2)
(/</?)
:: (Monad m)
=> (c' -> FreeT (ProxyF b' b x' x) m c)
-> (b' -> FreeT (ProxyF a' a x' x) m b)
-> (c' -> FreeT (ProxyF a' a x' x) m c)
f1 /</? f2 = \a' -> FreeT $ do
x1 <- runFreeT $ f1 a'
runFreeT $ case x1 of
Pure a -> return a
Free (Respond x fx') -> wrap $ Respond x $ fx' /</? f2
Free (Request b' fb ) -> (f2 >=> (fb /</? f2)) b'
(/>/?)
:: (Monad m)
=> (a -> FreeT (ProxyF x' x b' b) m a')
-> (b -> FreeT (ProxyF x' x c' c) m b')
-> (a -> FreeT (ProxyF x' x c' c) m a')
f1 />/? f2 = \a' -> FreeT $ do
x1 <- runFreeT $ f1 a'
runFreeT $ case x1 of
Pure a' -> return a'
Free (Respond b fb') -> (f2 >=> (fb' />/? f2)) b
Free (Request x' fx ) -> wrap $ Request x' $ fx />/? f2
instance MFunctor (Proxy a' a b' b) where
mapT nat = Proxy . hoistFreeT nat . unProxy
type Server req resp = Proxy C () req resp
type Client req resp = Proxy req resp () C
type Session = Proxy C () () C
runProxy :: (Monad m) => (() -> Proxy a () () b m r) -> m r
runProxy p = runProxyK p ()
runProxyK :: (Monad m) => (() -> Proxy a () () b m r) -> (() -> m r)
runProxyK p = runProxy' . unProxy . p
runProxy' :: (Monad m) => FreeT (ProxyF a () () b) m r -> m r
runProxy' p = do
x <- runFreeT p
case x of
Pure r -> return r
Free (Respond _ fb ) -> runProxy' $ fb ()
Free (Request _ fa') -> runProxy' $ fa' ()
runSession :: (Monad m) => (() -> Session m r) -> m r
runSession = runProxy
runSessionK :: (Monad m) => (() -> Session m r) -> (() -> m r)
runSessionK = runProxyK
discard :: (Monad m) => () -> Proxy () a () C m r
discard () = forever $ request ()
ignore :: (Monad m) => a -> Proxy C () a () m r
ignore _ = forever $ respond ()