FreeT.scala

import scalaz._

object Tram {

  type Tram[A] = FreeT[Function0, Id.Id, A]

  implicit val instance: Monad[Tram] = FreeT.freeTMonad[Function0, Id.Id]

  def suspend[A](a: => Tram[A]): Tram[A] =
    instance.point(a).flatMap(conforms)

}

object Main extends App {
  import Tram._
  import std.function._

  def fib(n: Int): Tram[Int] =
    if (n < 2) Tram.instance.point(n)
    else Tram.instance.apply2(
      Tram.suspend(fib(n - 1)),
      Tram.suspend(fib(n - 2))
    )(_ + _)

  println(fib(15).iterT(_()): Int)
}

/** [[https://github.com/ekmett/free/blob/v4.5/src/Control/Monad/Trans/Free/Church.hs]]
 *
 * `newtype FT f m a = FT {runFT :: forall r. (a -> m r) -> (f (m r) -> m r) -> m r}`
 */
trait FreeT[F[_], M[_], A] { self =>

  def run[R]: (A => M[R]) => (F[M[R]] => M[R]) => M[R]

  // fmap f (FT k) = FT $ \a fr -> k (a . f) fr
  def map[B](f: A => B): FreeT[F, M, B] =
    new FreeT[F, M, B] {
      def run[R] =
        a => fr => self.run(f andThen a)(fr)
    }

  // instance Monad (FT f m) where
  //   FT fk >>= f = FT $ \b fr -> fk (\d -> runFT (f d) b fr) fr
  def flatMap[B](f: A => FreeT[F, M, B]): FreeT[F, M, B] =
    new FreeT[F, M, B] {
      def run[R] = {
        b => fr => self.run{ d =>
          f(d).run(b)(fr)
        }.apply(fr)
      }
    }

  // transFT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FT f m b -> FT g m b
  // transFT phi (FT m) = FT (\kp kf -> m kp (kf . phi))
  def transFT[G[_]](phi: F ~> G)(implicit M: Monad[M], G: Functor[G]): FreeT[G, M, A] =
    new FreeT[G, M, A] {
      import std.function._
      def run[R] =
        kp => kf => self.run(kp)(Profunctor[Function1].mapfst(kf)(phi))
    }

  // iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> FT f m a -> m a
  // iterT phi (FT m) = m return phi
  def iterT(phi: F[M[A]] => M[A])(implicit F: Functor[F], M: Monad[M]): M[A] =
    self.run(M.point(_))(phi)

}

object FreeT {

  implicit def freeTMonad[F[_], M[_]]: Monad[({type l[a] = FreeT[F, M, a]})#l] =
    new Monad[({type l[a] = FreeT[F, M, a]})#l] {
      def point[A](a: => A) =
        new FreeT[F, M, A] {
          def run[R] = f => _ => f(a)
        }

      override def map[A, B](fa: FreeT[F, M, A])(f: A => B) =
        fa map f

      def bind[A, B](fa: FreeT[F, M, A])(f: A => FreeT[F, M, B]): FreeT[F,M,B] =
        fa flatMap f
    }

  implicit def freeTMonadTrans[F[_]]: MonadTrans[({type l[x[_], a] = FreeT[F, x, a]})#l] =
    new MonadTrans[({type l[x[_], a] = FreeT[F, x, a]})#l] {
      implicit def apply[G[_]: Monad] =
        freeTMonad[F, G]

      def liftM[G[_], A](a: G[A])(implicit G: Monad[G]) =
        new FreeT[F, G, A] {
          def run[R] = f => _ => G.bind(a)(f)
        }
    }
}