module Control.Proxy.Trans.Codensity (
CodensityP,
runCodensityP,
runCodensityK
) where
import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))
import Control.Monad (MonadPlus(mzero, mplus))
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),
MonadPlusP(mzero_P, mplus_P) )
import Control.Proxy.Morph (PFunctor(hoistP))
import Control.Proxy.Trans (ProxyTrans(liftP))
newtype CodensityP p a' a b' b (m :: * -> *) r
= CodensityP { unCodensityP
:: forall x . (Monad m, Proxy p)
=> (r -> p a' a b' b m x) -> p a' a b' b m x }
instance (Monad m, Proxy p) => Functor (CodensityP p a' a b' b m) where
fmap f p = CodensityP (\k ->
unCodensityP p (\a ->
k (f a)) )
instance (Monad m, Proxy p) => Applicative (CodensityP p a' a b' b m) where
pure = return
fp <*> xp = CodensityP (\k ->
unCodensityP fp (\f ->
unCodensityP xp (\x ->
k (f x) ) ) )
instance (Monad m, Proxy p) => Monad (CodensityP p a' a b' b m) where
return = return_P
(>>=) = (?>=)
instance (Proxy p) => MonadTrans (CodensityP p a' a b' b) where
lift = lift_P
instance (Proxy p) => MFunctor (CodensityP p a' a b' b) where
hoist = hoist_P
instance (MonadIO m, Proxy p) => MonadIO (CodensityP p a' a b' b m) where
liftIO = liftIO_P
instance (Monad m, MonadPlusP p) => Alternative (CodensityP p a' a b' b m) where
empty = mzero
(<|>) = mplus
instance (Monad m, MonadPlusP p) => MonadPlus (CodensityP p a' a b' b m) where
mzero = mzero_P
mplus = mplus_P
instance (Proxy p) => ProxyInternal (CodensityP p) where
return_P = \r -> CodensityP (\k -> k r)
m ?>= f = CodensityP (\k ->
unCodensityP m (\a ->
unCodensityP (f a) k ) )
lift_P m = CodensityP (\k -> lift_P m ?>= k)
hoist_P nat p = CodensityP (\k ->
hoist_P nat (unCodensityP p return_P) ?>= k)
liftIO_P m = CodensityP (\k -> liftIO_P m ?>= k)
thread_P p s = CodensityP (\k -> thread_P (unCodensityP p return_P) s ?>= k)
instance (MonadPlusP p) => MonadPlusP (CodensityP p) where
mzero_P = CodensityP (\_ -> mzero_P)
mplus_P m1 m2 = CodensityP (\k ->
mplus_P (unCodensityP m1 k) (unCodensityP m2 k) )
instance (Proxy p) => Proxy (CodensityP p) where
fb' ->> p = CodensityP (\k ->
((\b' -> unCodensityP (fb' b') return_P) ->> unCodensityP p return_P)
?>= k )
p >>~ fb = CodensityP (\k ->
(unCodensityP p return_P >>~ (\b -> unCodensityP (fb b) return_P))
?>= k )
request = \a' -> CodensityP (\k -> request a' ?>= k)
respond = \b -> CodensityP (\k -> respond b ?>= k)
fb' >\\ p = CodensityP (\k ->
((\b' -> unCodensityP (fb' b') return_P) >\\ unCodensityP p return_P)
?>= k )
p //> fb = CodensityP (\k ->
(unCodensityP p return_P //> (\b -> unCodensityP (fb b) return_P))
?>= k )
turn p = CodensityP (\k -> turn (unCodensityP p return_P) ?>= k)
instance ProxyTrans CodensityP where
liftP p = CodensityP (\k -> p ?>= k)
instance PFunctor CodensityP where
hoistP nat p = CodensityP (\k -> nat (unCodensityP p return_P) ?>= k)
runCodensityP
:: (Monad m, Proxy p) => CodensityP p a' a b' b m r -> p a' a b' b m r
runCodensityP p = unCodensityP p return_P
runCodensityK
:: (Monad m, Proxy p)
=> (q -> CodensityP p a' a b' b m r) -> (q -> p a' a b' b m r)
runCodensityK k q = runCodensityP (k q)