stack safe Ideal Monad in Scala

README.md

• https://github.com/ekmett/category-extras/blob/f0f3ca38a3dfcb49d39aa2bb5b31b719f2a5b1ae/Control/Functor/Internal/Ideal.hs

build.sbt

scalaVersion := "2.11.5"

libraryDependencies += "org.scalaz" %% "scalaz-core" % "7.1.1"

licenses := Seq("MIT License" -> url("http://www.opensource.org/licenses/mit-license.php"))

Ideal.scala

import scala.annotation.tailrec
import scalaz._
import scalaz.Leibniz.===

object Ideal {
  private final case class Pure[F[_], A](a: A) extends Ideal[F, A]
  private final case class Suspend[F[_], A](fa: F[A]) extends Ideal[F, A]
  private sealed abstract case class Gosub[F[_], B]() extends Ideal[F, B] {
    type C
    val a: () => Ideal[F, C]
    val f: C => Ideal[F, B]
  }

  def pure[F[_], A](a: A): Ideal[F, A] = Pure(a)

  def ideal[F[_], A](fa: F[A]): Ideal[F, A] = Suspend(fa)

  def suspend[F[_], A](a: => Ideal[F, A]): Ideal[F, A] =
    Ideal.gosub[F, A, A](a)(Ideal.pure)

  def gosub[F[_], A, B](a0: => Ideal[F, A])(f0: A => Ideal[F, B]): Ideal[F, B] =
    new Gosub[F, B] {
      type C = A
      val a = () => a0
      val f = f0
    }

  implicit def idealInstance[F[_]]: Monad[({type l[a] = Ideal[F, a]})#l] =
    new Monad[({type l[a] = Ideal[F, a]})#l]{
      override def point[A](a: => A) =
        Pure(a)
      override def bind[A, B](fa: Ideal[F, A])(f: A => Ideal[F, B]) =
        fa flatMap f
    }

  type IdealTrampoline[A] = Ideal[Function0, A]
}

sealed abstract class Ideal[F[_], A] {
  import Ideal._

  final def flatMap[B](f: A => Ideal[F, B]): Ideal[F, B] =
    this match {
      case a @ Gosub() =>
        gosub(a.a())(x => gosub(a.f(x))(f))
      case a =>
        gosub(a)(f)
    }

  @tailrec final def resume(implicit F: MonadIdeal[F]): F[A] \/ A =
    this match {
      case Pure(a) =>
        \/-(a)
      case Suspend(t) =>
        -\/(t)
      case x @ Gosub() =>
        x.a() match {
          case Pure(a) =>
            x.f(a).resume
          case Suspend(t) =>
            -\/(F.idealize(F.map(t)(x.f)))
          case y @ Gosub() =>
            y.a().flatMap(z => y.f(z) flatMap x.f).resume
        }
    }

  final def foldMap[M[_]](f: F ~> M)(implicit S: MonadIdeal[F], M: Applicative[M]): M[A] =
    this.resume match {
      case -\/(s) =>
        f(s)
      case \/-(r) =>
        M.pure(r)
    }

  final def run(implicit ev: Ideal[F, A] === IdealTrampoline[A]): A = {
    import std.function._
    ev(this).foldMap(NaturalTransformation.refl).apply()
  }
}

IdealTrampoline.scala

import Ideal.IdealTrampoline
import scalaz._

object IdealTrampoline {

  def done[A](a: A): IdealTrampoline[A] =
    Ideal.pure(a)

  def delay[A](a: => A): IdealTrampoline[A] =
    suspend(done(a))

  def suspend[A](a: => IdealTrampoline[A]): IdealTrampoline[A] =
    Ideal.suspend[Function0, A](a)

  implicit val trampolineInstance: Monad[IdealTrampoline] =
    new Monad[IdealTrampoline] {
      override def point[A](a: => A) =
        Ideal.pure[Function0, A](a)
      def bind[A, B](ta: IdealTrampoline[A])(f: A => IdealTrampoline[B]) =
        ta flatMap f
    }
}

Main.scala

import Ideal.IdealTrampoline
import scalaz.Free.Trampoline
import scalaz.syntax.bind._

object Main {

  def freeTrampoline(x: Int): Int = {
    import scalaz.Trampoline._

    def fib(n: Int): Trampoline[Int] =
      if (n < 2) done(n)
      else for {
        x <- suspend(fib(n - 1))
        y <- suspend(fib(n - 2))
      } yield (x + y)

    fib(x).run
  }

  def idealTrampoline(x: Int): Int = {
    import IdealTrampoline._

    def fib(n: Int): IdealTrampoline[Int] =
      if (n < 2) done(n)
      else for {
        x <- suspend(fib(n - 1))
        y <- suspend(fib(n - 2))
      } yield (x + y)

    fib(x).run
  }

  def scalaStd(x: Int): Int = {
    import scala.util.control.TailCalls._

    def fib(n: Int): TailRec[Int] =
      if (n < 2) done(n)
      else for {
        x <- tailcall(fib(n - 1))
        y <- tailcall(fib(n - 2))
      } yield (x + y)

    fib(x).result
  }

  def time[A](label: String)(a: => A): A = {
    System.gc()
    val s = System.nanoTime
    val r = a
    println(label + " " + ((System.nanoTime - s) / 1000000.0))
    r
  }

  def main(args: Array[String]): Unit = {
    val x = 35

    val a = time("ideal")(idealTrampoline(x))
    val b = time("free")(freeTrampoline(x))
    val c = time("std")(scalaStd(x))
    assert(a == b && b == c)
  }
}

MonadIdeal.scala

import scalaz._

trait MonadIdeal[F[_]] extends Functor[F] {
  def idealize[A](fa: F[Ideal[F, A]]): F[A]
}

object MonadIdeal{

  def fromMonad[F[_]](implicit F: Monad[F]): MonadIdeal[F] =
    new MonadIdeal[F] {
      override def idealize[A](fa: F[Ideal[F, A]]) =
        F.bind(fa)(_.resume(this).map(F.point(_)).merge)
      override def map[A, B](fa: F[A])(f: A => B) =
        F.map(fa)(f)
    }

  implicit val function0MonadIdeal: MonadIdeal[Function0] =
    new MonadIdeal[Function0] {
      override def idealize[A](fa: () => Ideal[Function0, A]) =
        () => fa.apply().resume.leftMap(_.apply()).merge
      override def map[A, B](fa: () => A)(f: A => B) =
        std.function.function0Instance.map(fa)(f)
    }
}