Codensity FreeLike instance

FreeCodensity.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Codensity where

newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b }

abs :: Monad m => (a -> m b) -> Codensity m a -> m b
abs k (Codensity c) = c k

rep :: Monad m => m a -> Codensity m a
rep m = Codensity $ (m >>=)

instance Functor (Codensity f) where
  fmap f (Codensity p) = Codensity $ \h -> p (h . f)

instance Applicative (Codensity f) where
  pure a = Codensity $ \h -> h a
  Codensity p <*> Codensity q = Codensity $ (\f -> p (\g -> q (f . g)))
  
instance Monad (Codensity m) where
  return = pure
  (Codensity c) >>= f = Codensity $ \h -> c (\a -> case f a of Codensity q -> q h)
  
class (Functor f, Monad m) => FreeLike f m where
  wrap :: f (m a) -> m a
  
instance FreeLike f m => FreeLike f (Codensity m) where
  wrap t = Codensity $ \h -> wrap(fmap (\(Codensity p) -> p h) t)