fixing_GADTs.scala

package fixing_gadts

import fixing_gadts.ExprF.Expr

import scalaz.Id.Id
import scalaz.~>

final case class HFix[H[_[_], _], A](run: H[({type l[a] = HFix[H, a]})#l, A]){
  def cata[F[_]](f: ({type l[a] = H[F, a]})#l ~> F)(implicit F: HFunctor[H]): F[A] =
    f(
      F.hfmap[({type l[a] = HFix[H, a]})#l, F](
        new (({type l[a] = HFix[H, a]})#l ~> F){
          def apply[B](fa: HFix[H, B]) = fa.cata(f)
        }
      )(run)
    )
}

trait HFunctor[H[_[_], _]]{
  def hfmap[F[_], G[_]](f: F ~> G): ({type l[a] = H[F, a]})#l ~> ({type l[a] = H[G, a]})#l
}

sealed abstract class ExprF[F[_], A]{
  def hfmap[G[_]](f: F ~> G): ExprF[G, A]

  final def fold[B](
    const: F[Int] => B,
    add: (F[Int], F[Int]) => B,
    mul: (F[Int], F[Int]) => B,
    cond: (F[Boolean], F[A], F[A]) => B,
    isEq: (F[Int], F[Int]) => B
  ): B = this match {
    case value: Const[F] =>
      const(value.value)
    case value: Add[F] =>
      add(value.x, value.y)
    case value: Mul[F] =>
      mul(value.x, value.y)
    case value: Cond[F, A] =>
      cond(value.bool, value.x, value.y)
    case value: IsEq[F] =>
      isEq(value.x, value.y)
  }
}

final case class Const[R[_]](value: R[Int]) extends ExprF[R, Int]{
  override def hfmap[G[_]](f: R ~> G): ExprF[G, Int] =
    Const(f(value))
}
final case class Add[R[_]](x: R[Int], y: R[Int]) extends ExprF[R, Int] {
  override def hfmap[G[_]](f: R ~> G): ExprF[G, Int] =
    Add(f(x), f(y))
}
final case class Mul[R[_]](x: R[Int], y: R[Int]) extends ExprF[R, Int] {
  override def hfmap[G[_]](f: R ~> G): ExprF[G, Int] =
    Mul(f(x), f(y))
}
final case class Cond[R[_], A](bool: R[Boolean], x: R[A], y: R[A]) extends ExprF[R, A] {
  override def hfmap[G[_]](f: R ~> G): ExprF[G, A] =
    Cond[G, A](f(bool), f(x), f(y))
}
final case class IsEq[R[_]](x: R[Int], y: R[Int]) extends ExprF[R, Boolean] {
  override def hfmap[G[_]](f: R ~> G): ExprF[G, Boolean] =
    IsEq(f(x), f(y))
}

object ExprF {
  implicit val instance: HFunctor[ExprF] =
    new HFunctor[ExprF] {
      override def hfmap[F[_], G[_]](f: F ~> G) =
        new (({type l[a] = ExprF[F, a]})#l ~> ({type l[a] = ExprF[G, a]})#l) {
          override def apply[A](fa: ExprF[F, A]) = fa.hfmap(f)
        }
    }

  type Expr[A] = HFix[ExprF, A]

  def eval[A](expr: Expr[A]): A =
    expr.cata[Id](evalAlg)

  val evalAlg: ({type l[a] = ExprF[Id, a]})#l ~> Id =
    new (({type l[a] = ExprF[Id, a]})#l ~> Id){
      def apply[A](fa: ExprF[Id, A]) = fa match{
        case Const(value) =>
          value
        case Add(x, y) =>
          x + y
        case Mul(x, y) =>
          x * y
        case Cond(bool, x, y) =>
          if(bool) x else y
        case IsEq(x, y) =>
          x == y
      }
    }

  def const[F[_]](a: F[Int]): ExprF[F, Int] = Const(a)

  def constId(a: Int): ExprF[Id, Int] = Const[Id](a)
}

class Exprs[F[_]]{
  def const(a: F[Int]) = ???
  def add(x: F[Int], y: F[Int]): Expr[Int] = ???
  def mul(x: F[Int], y: F[Int]): Expr[Int] = ???
  def cond[A](bool: Boolean, x: A, y: A): Expr[A] = ???
  def isEq(x: Int, y: Int): Expr[Boolean] = ???
}

/**
 * [[http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html]]
 */
object Main {
  val x: Expr[Boolean] = ???
  val y: Expr[Int] = ???

  val pprInterpreter: ({type l[a] = ExprF[({type l[b] = String})#l, a]})#l ~> ({type l[a] = String})#l =
    new (({type l[a] = ExprF[({type l[b] = String})#l, a]})#l ~> ({type l[a] = String})#l) {
      override def apply[A](fa: ExprF[({type l[b] = String})#l, A]) =
        fa.fold(
          const = _.toString,
          add = (x, y) => s"($x + $y)",
          mul = (x, y) => s"($x * $y)",
          cond = (bool, x, y) => s"(if($bool) $x else $y)",
          isEq = (x, y) => s"($x == $y)"
        )
    }
}