{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Free
-- Copyright   :  (C) 2008 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- See <http://wwwtcs.inf.tu-dresden.de/%7Evoigt/mpc08.pdf> for
-- the background on rep, abs and improve and their use. NB: the C type
-- in that paper is just the right Kan extension of a monad 
-- along itself, also known as the monad generated by a functor:
-- <http://www.tac.mta.ca/tac/volumes/10/19/10-19.ps>
----------------------------------------------------------------------------
module Control.Monad.Free 
	( module Control.Monad.Parameterized
	, PFree
	, Free
	, runFree
	, free
	, MonadFree(inFree)
	, RunMonadFree(cataFree)
	) where

import Prelude hiding ((.),id)
import Control.Category
import Control.Category.Cartesian
import Control.Functor
import Control.Functor.Algebra
import Control.Functor.Combinators.Biff
import Control.Functor.Fix
import Control.Monad.Parameterized
import Control.Monad.Identity
import Control.Monad.Reader

type Free f = Fix (PFree f)

runFree :: Free f a -> Either a (f (Free f a))
runFree = first runIdentity . runBiff . outB

free :: Either a (f (Free f a)) -> Free f a
free = InB . Biff . first Identity

class MonadFree f m => RunMonadFree f m | m -> f where
	cataFree :: (c -> a) -> Algebra f a -> m c -> a

instance Functor f => RunMonadFree f (Free f) where
	cataFree l r = (l . runIdentity ||| r . fmap (cataFree l r)) . runBiff . outB

class (Functor f, Monad m) => MonadFree f m | m -> f where
        inFree :: f (m a) -> m a

instance Functor f => MonadFree f (Free f) where
        inFree = InB . Biff . Right

instance MonadFree f m => MonadFree f (ReaderT e m) where
	inFree fma = ReaderT (\e -> inFree $ fmap (flip runReaderT e) fma)

-- instance (MonadFree f m, Traversable f) => MonadFree f (StateT e m) where