{-# LANGUAGE Rank2Types #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Free.VanLaarhoven
-- Copyright   :  (C) 2016 Aaron Levin
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Aaron Levin <aaron.michael.benjamin.levin@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable (rank-2 polymorphism)
--
-- \"van Laarhoven encoded Free Monad\"
-----------------------------------------------------------------------------

module Control.Monad.Free.VanLaarhoven
  ( Free(..)
  ) where

import           Control.Arrow       ((&&&))

-- | The van Laarhoven-encoded Free Monad
newtype Free effect a =
  Free { runFree :: forall m. Monad m => effect m -> m a }

instance Functor (Free effect) where
  fmap f (Free run) = Free (fmap f . run)

instance Applicative (Free effect) where
  pure a = Free (const (pure a))
  (Free fab) <*> (Free a) =
    Free (\e -> fab e <*> a e)

instance Monad (Free effect) where
  (Free run) >>= f =
    Free (\e -> run e >>= \a -> runFree (f a) e)

-- | Lift an operation into the van Laarhoven Free Monad
lift :: (forall m. Monad m => effect m -> m a)
     -> Free effect a
lift = Free

-- | Tear down a 'Free' 'Monad' using the supplied value
iter :: Monad m
     => effect m
     -> Free effect a
     -> m a
iter phi program = runFree program phi