module Control.Proxy.Core.Fast (
ProxyFast(..),
runProxy,
runProxyK,
runPipe,
observe
) where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.MFunctor (MFunctor(hoist))
import Control.Proxy.Class
import Control.Proxy.Synonym (C)
data ProxyFast a' a b' b m r
= Request a' (a -> ProxyFast a' a b' b m r )
| Respond b (b' -> ProxyFast a' a b' b m r )
| M (m (ProxyFast a' a b' b m r))
| Pure r
instance (Monad m) => Functor (ProxyFast 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 (ProxyFast 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 (ProxyFast a' a b' b m) where
return = Pure
(>>=) = _bind
_bind
:: (Monad m)
=> ProxyFast a' a b' b m r
-> (r -> ProxyFast a' a b' b m r')
-> ProxyFast a' a b' b m r'
p0 `_bind` 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 (ProxyFast a' a b' b) where
lift = _lift
_lift :: (Monad m) => m r -> ProxyFast a' a b' b m r
_lift m = M (m >>= \r -> return (Pure r))
instance (MonadIO m) => MonadIO (ProxyFast a' a b' b m) where
liftIO m = M (liftIO (m >>= \r -> return (Pure r)))
instance MonadIOP ProxyFast where
liftIO_P = liftIO
instance Proxy ProxyFast where
fb'_0 >-> fc'_0 = \c' -> fb'_0 >-| fc'_0 c' where
p1 |-> fb = case p1 of
Request a' fa -> Request a' (\a -> fa a |-> fb)
Respond b fb' -> fb' >-| fb b
M m -> M (m >>= \p1' -> return (p1' |-> fb))
Pure r -> Pure r
fb' >-| p2 = case p2 of
Request b' fb -> fb' b' |-> fb
Respond c fc' -> Respond c (\c' -> fb' >-| fc' c')
M m -> M (m >>= \p2' -> return (fb' >-| p2'))
Pure r -> Pure r
fa_0 >~> fb_0 = \a -> fa_0 a |-> fb_0 where
p1 |-> fb = case p1 of
Request a' fa -> Request a' (\a -> fa a |-> fb)
Respond b fb' -> fb' >-| fb b
M m -> M (m >>= \p1' -> return (p1' |-> fb))
Pure r -> Pure r
fb' >-| p2 = case p2 of
Request b' fb -> fb' b' |-> fb
Respond c fc' -> Respond c (\c' -> fb' >-| fc' c')
M m -> M (m >>= \p2' -> return (fb' >-| p2'))
Pure r -> Pure r
request a' = Request a' Pure
respond b = Respond b Pure
return_P = return
(?>=) = _bind
lift_P = _lift
hoist_P = hoist
instance Interact ProxyFast where
k2 \>\ k1 = \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
k2 />/ k1 = \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 (ProxyFast a' a b' b) where
hoist nat p0 = go (observe 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
runProxy :: (Monad m) => (() -> ProxyFast 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) => (() -> ProxyFast a' () () b m r) -> (() -> m r)
runProxyK p = \() -> runProxy p
runPipe :: (Monad m) => ProxyFast a' () () b m r -> m r
runPipe p = runProxy (\_ -> p)
observe :: (Monad m) => ProxyFast a' a b' b m r -> ProxyFast a' a b' b m r
observe p = M (go p) where
go p = case p of
M m' -> m' >>= go
Pure r -> return (Pure r)
Request a' fa -> return (Request a' (\a -> observe (fa a )))
Respond b fb' -> return (Respond b (\b' -> observe (fb' b')))