Codensity homework

free.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, RankNTypes, FlexibleInstances, DeriveFunctor, DeriveFoldable, DeriveTraversable, UndecidableInstances #-}

module Free where

import Control.Monad.Trans
import Control.Monad
import Data.Traversable
import Data.Foldable

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Pure a)  = Pure (f a)
  fmap f (Free as) = Free $ fmap (fmap f) as


instance Functor f => Monad (Free f) where
  return = Pure
  Pure a  >>= f = f a
  Free as >>= f = Free $ fmap (f =<<) as
  
instance MonadTrans Free where
  lift = Free . liftM Pure
  
retract :: Monad f => Free f a -> f a
retract (Pure a)  = return a
retract (Free as) = as >>= retract

class MonadFree f m | m -> f where
  wrap :: f (m a) -> m a
  
instance MonadFree f (Free f) where
  wrap = Free

newtype Codensity f a = Codensity (forall r. (a -> f r) -> f r) 

runCodensity (Codensity m) = m

instance Functor (Codensity k) where
  fmap f (Codensity m) = Codensity (\k -> m (k . f))
  
instance Monad (Codensity f) where
  return x = Codensity (\k -> k x)
  (Codensity m) >>= f = Codensity (\k -> m (\a -> runCodensity (f a) k))
  
instance MonadTrans Codensity where
  lift m = Codensity (m >>=) 
  
lowerCodensity :: Monad m => Codensity m a -> m a
lowerCodensity (Codensity m) = m return

{-
data Bin a = Bin a a
  deriving (Functor Foldable, Traversable)
  
type Tree = Free Bin

bin :: MonadFree Bin m => m a -> m a -> m a
bin l r = wrap (Bin l r)
-}

instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where
  wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t))
  
improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a
improve m = lowerCodensity m