module Control.Monad.Trans.Codensity
( CodensityT(..)
, lowerCodensityT
, codensityTToAdjunction
, adjunctionToCodensityT
) where
import Control.Applicative
import Control.Monad (ap)
import Data.Functor.Adjunction
import Data.Functor.Apply
import Control.Monad.Trans.Class
newtype CodensityT m a = CodensityT { runCodensityT :: forall b. (a -> m b) -> m b }
instance Functor (CodensityT k) where
fmap f (CodensityT m) = CodensityT (\k -> m (k . f))
instance Apply (CodensityT f) where
(<.>) = ap
instance Applicative (CodensityT f) where
pure x = CodensityT (\k -> k x)
(<*>) = ap
instance Monad (CodensityT f) where
return x = CodensityT (\k -> k x)
m >>= k = CodensityT (\c -> runCodensityT m (\a -> runCodensityT (k a) c))
instance MonadTrans CodensityT where
lift m = CodensityT (m >>=)
lowerCodensityT :: Monad m => CodensityT m a -> m a
lowerCodensityT a = runCodensityT a return
codensityTToAdjunction :: Adjunction f g => CodensityT g a -> g (f a)
codensityTToAdjunction r = runCodensityT r unit
adjunctionToCodensityT :: Adjunction f g => g (f a) -> CodensityT g a
adjunctionToCodensityT f = CodensityT (\a -> fmap (rightAdjunct a) f)