module Control.Proxy.Core.Fast (
ProxyFast(..),
runProxy,
runProxyK,
observe
) where
import Control.Applicative (Applicative(pure, (<*>)))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Morph (MFunctor(hoist))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Proxy.Class (
Proxy(request, respond, (->>), (>>~), (>\\), (//>), turn),
ProxyInternal(return_P, (?>=), lift_P, liftIO_P, hoist_P, thread_P))
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 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
instance (MonadIO m) => MonadIO (ProxyFast a' a b' b m) where
liftIO m = M (liftIO (m >>= \r -> return (Pure r)))
instance ProxyInternal ProxyFast where
return_P = Pure
(?>=) = _bind
lift_P = _lift
liftIO_P = liftIO
hoist_P = hoist
thread_P p s = case p of
Request a' fa -> Request (a', s) (\(a , s') -> thread_P (fa a ) s')
Respond b fb' -> Respond (b, s) (\(b', s') -> thread_P (fb' b') s')
M m -> M (m >>= \p' -> return (thread_P p' s))
Pure r -> Pure (r, s)
instance Proxy ProxyFast where
fb' ->> p = case p of
Request b' fb -> fb' b' >>~ fb
Respond c fc' -> Respond c (\c' -> fb' ->> fc' c')
M m -> M (m >>= \p' -> return (fb' ->> p'))
Pure r -> Pure r
p >>~ fb = case p of
Request a' fa -> Request a' (\a -> fa a >>~ fb)
Respond b fb' -> fb' ->> fb b
M m -> M (m >>= \p' -> return (p' >>~ fb))
Pure r -> Pure r
request = \a' -> Request a' Pure
respond = \b -> Respond b Pure
(>\\) = _req
(//>) = _resp
turn = go
where
go p = case p of
Request a' fa -> Respond a' (\a -> go (fa a ))
Respond b fb' -> Request b (\b' -> go (fb' b'))
M m -> M (m >>= \p' -> return (go p'))
Pure r -> Pure r
_req
:: (Monad m)
=> (b' -> ProxyFast a' a x' x m b)
-> ProxyFast b' b x' x m c
-> ProxyFast a' a x' x m c
fb' `_req` p0 = go p0 where
go p = case p of
Request b' fb -> fb' 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
_resp
:: (Monad m)
=> ProxyFast x' x b' b m a'
-> (b -> ProxyFast x' x c' c m b')
-> ProxyFast x' x c' c m a'
p0 `_resp` fb = go p0 where
go p = case p of
Request x' fx -> Request x' (\x -> go (fx x))
Respond b fb' -> fb b >>= \b' -> go (fb' b')
M m -> M (m >>= \p' -> return (go p'))
Pure a -> Pure a
run :: (Monad m) => ProxyFast a' () () b m r -> m r
run p = case p of
Request _ fa -> run (fa ())
Respond _ fb' -> run (fb' ())
M m -> m >>= run
Pure r -> return r
runProxy :: (Monad m) => (() -> ProxyFast a' () () b m r) -> m r
runProxy k = run (k ())
runProxyK :: (Monad m) => (q -> ProxyFast a' () () b m r) -> (q -> m r)
runProxyK k q = run (k q)
observe :: (Monad m) => ProxyFast a' a b' b m r -> ProxyFast a' a b' b m r
observe p0 = M (go p0) 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')))