module Control.Proxy.Core (
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.MFunctor (MFunctor(mapT))
import Control.Proxy.Class (
Channel(idT, (<-<)), Interact(request, (/</), respond, (\<\)) )
import Data.Closed (C)
data Proxy a' a b' b m r
= Request a' (a -> Proxy a' a b' b m r )
| Respond b (b' -> Proxy a' a b' b m r )
| M (m (Proxy a' a b' b m r))
| Pure r
instance (Monad m) => Functor (Proxy a' a b' b m) where
fmap f p0 = go p0 where
go p = case p of
Request a' fa -> Request a' (\a -> go (fa a ))
Respond b fb' -> Respond b (\b' -> go (fb' b'))
M m -> M (m >>= \p' -> return (go p'))
Pure r -> Pure (f r)
instance (Monad m) => Applicative (Proxy a' a b' b m) where
pure = Pure
pf <*> px = go pf where
go p = case p of
Request a' fa -> Request a' (\a -> go (fa a ))
Respond b fb' -> Respond b (\b' -> go (fb' b'))
M m -> M (m >>= \p' -> return (go p'))
Pure f -> fmap f px
instance (Monad m) => Monad (Proxy a' a b' b m) where
return = Pure
p0 >>= f = go p0 where
go p = case p of
Request a' fa -> Request a' (\a -> go (fa a))
Respond b fb' -> Respond b (\b' -> go (fb' b'))
M m -> M (m >>= \p' -> return (go p'))
Pure r -> f r
instance MonadTrans (Proxy a' a b' b) where
lift = M . liftM Pure
instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where
liftIO = M . liftIO . liftM Pure
instance Channel Proxy where
idT = \a' -> Request a' $ \a -> Respond a idT
k1 <-< k2_0 = \c' -> k1 c' |-< k2_0 where
p1 |-< k2 = case p1 of
Request b' fb -> fb <-| k2 b'
Respond c fc' -> Respond c (\c' -> fc' c' |-< k2)
M m -> M (m >>= \p1' -> return (p1' |-< k2))
Pure r -> Pure r
fb <-| p2 = case p2 of
Request a' fa -> Request a' (\a -> fb <-| fa a)
Respond b fb' -> fb b |-< fb'
M m -> M (m >>= \p2' -> return (fb <-| p2'))
Pure r -> Pure r
instance Interact Proxy where
request a' = Request a' Pure
k1 /</ k2 = \a' -> go (k1 a') where
go p = case p of
Request b' fb -> k2 b' >>= \b -> go (fb b)
Respond x fx' -> Respond x (\x' -> go (fx' x'))
M m -> M (m >>= \p' -> return (go p'))
Pure a -> Pure a
respond a = Respond a Pure
k1 \<\ k2 = \a' -> go (k2 a') where
go p = case p of
Request x' fx -> Request x' (\x -> go (fx x))
Respond b fb' -> k1 b >>= \b' -> go (fb' b')
M m -> M (m >>= \p' -> return (go p'))
Pure a -> Pure a
instance MFunctor (Proxy a' a b' b) where
mapT nat p0 = go p0 where
go p = case p of
Request a' fa -> Request a' (\a -> go (fa a ))
Respond b fb' -> Respond b (\b' -> go (fb' b'))
M m -> M (nat (m >>= \p' -> return (go p')))
Pure r -> Pure r
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 k = go (k ()) where
go p = case p of
Request _ fa -> go (fa ())
Respond _ fb' -> go (fb' ())
M m -> m >>= go
Pure r -> return r
runProxyK :: (Monad m) => (() -> Proxy a () () b m r) -> (() -> m r)
runProxyK p = \() -> runProxy p
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 _ = go where
go = Request () (\_ -> go)
ignore :: (Monad m) => a -> Proxy C () a () m r
ignore _ = go where
go = Respond () (\_ -> go)