{-# LANGUAGE Rank2Types #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Free
-- Copyright   :  2008 Dan Doel, Edward Kmett
-- License     :  BSD3
-- 
-- Maintainer  :  dan.doel@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (rank-2 types)
--
-- An implementation of the free monad of a functor, used in (at the least)
-- futumorphisms and chronomorphisms in Control.Recursion
--
-----------------------------------------------------------------------------

module Control.Monad.Free 
       ( Free()
       , inFree
       , cataFree
       , distribFree
       ) where

import Control.Arrow ((|||), (+++), (>>>))
import Control.Applicative
import Control.Monad

-- | The free monad of a functor 'f', formally,
--
-- > Free F A = mu X. A + FX
newtype Free f a = Free { unFree :: Either a (f (Free f a)) }

instance (Functor f) => Functor (Free f) where
  fmap f = unFree >>> f +++ fmap (fmap f) >>> Free


instance (Functor f) => Applicative (Free f) where
  pure = return
  (<*>) = ap

instance (Functor f) => Monad (Free f) where
  return = Free . Left
  (Free e) >>= f = either f (inFree . fmap (>>= f)) e

-- | The catamorphism for the free monad
cataFree :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b
cataFree f g = unFree >>> f ||| g . fmap (cataFree f g)

inFree :: f (Free f a) -> Free f a
inFree = Free . Right

-- | Lifts a distributive law of @h@ over @f@ to a distributive
-- law of @Free h@ over @f@
distribFree :: (Functor f, Functor h) =>
               (forall a. h (f a) -> f (h a))
                 -> (forall a. Free h (f a) -> f (Free h a))
distribFree d = cataFree (fmap return) (fmap inFree . d)