Higher order fix point types. Porting http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html

HFix.scala

import scalaz._
import scalaz.Scalaz._

trait HFunctor[F[_[_], _]] {
  def hfmap[M[_], N[_]](nt: M ~> N): F[M, ?] ~> F[N, ?]
}

object HFunctor {
  def apply[F[_[_], _]](implicit v: HFunctor[F]) = v

  final implicit class HFunctorOps[F[_[_], _], M[_], A](val fa: F[M, A])(implicit F: HFunctor[F]) {
    def hfmap[N[_]](nt: M ~> N): F[N, A] = F.hfmap(nt)(fa)
  }

  type HAlgebra[F[_[_], _], G[_]] = F[G, ?] ~> G
}

final case class HFix[F[_[_], _], I](unfix: Name[F[HFix[F, ?], I]])

object HFix {

  import HFunctor._

  def hfix[F[_[_], _], I](fa: => F[HFix[F, ?], I]): HFix[F, I] =
    HFix[F, I](Need(fa))

  def cataNT[F[_[_], _] : HFunctor, G[_]](alg: HAlgebra[F, G]): HFix[F, ?] ~> G =
    new (HFix[F, ?] ~> G) {
      self =>
      def apply[I](f: HFix[F, I]): G[I] = {
        alg.apply[I](f.unfix.value.hfmap[G](self))
      }
    }

  implicit class HFixOps[F[_[_], _], I](fa: HFix[F, I]) {
    def cata[G[_]](alg: HAlgebra[F, G])(implicit F: HFunctor[F]): G[I] =
      cataNT[F, G](alg)(F)(fa)
  }
}

sealed trait ExprF[F[_], A]

object ExprF {
  case class Const[F[_]](value: Int) extends ExprF[F, Int]
  case class Add[F[_]](left: F[Int], right: F[Int]) extends ExprF[F, Int]
  case class Multiply[F[_]](left: F[Int], right: F[Int]) extends ExprF[F, Int]

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

  def const(value: Int): Expr[Int] =
    HFix.hfix(Const[Expr](value))

  def add(left: Expr[Int], right: Expr[Int]): Expr[Int] =
    HFix.hfix(Add[Expr](left, right))

  def multiply(left: Expr[Int], right: Expr[Int]): Expr[Int] =
    HFix.hfix(Multiply[Expr](left, right))

  implicit val hfunctor: HFunctor[ExprF] = new HFunctor[ExprF] {
    override def hfmap[M[_], N[_]](nt: ~>[M, N]): ExprF[M, ?] ~> ExprF[N, ?] = new (ExprF[M, ?] ~> ExprF[N, ?]) {
      override def apply[A](fa: ExprF[M, A]): ExprF[N, A] = fa match {
        case Const(value) => Const(value)
        case Add(left, right) => Add(nt(left), nt(right))
        case Multiply(left, right) => Multiply(nt(left), nt(right))
      }
    }
  }

  def evaluator: HFunctor.HAlgebra[ExprF, Id.Id] = new HFunctor.HAlgebra[ExprF, Id.Id] {
    override def apply[A](fa: ExprF[Id.Id, A]): Id.Id[A] = fa match {
      case ExprF.Add(left, right) => (left |@| right)(_ + _)
      case ExprF.Multiply(left, right) => (left |@| right)(_ * _)
      case ExprF.Const(value) => value
    }
  }

  case class K[X, Y](unK: X)

  object K {
    implicit def applicative[Y]: Applicative[K[?, Y]] = new Applicative[K[?, Y]] {
      override def point[A](a: => A): K[A, Y] = K(a)
      override def ap[A, B](fa: =>K[A, Y])(f: =>K[A => B, Y]): K[B, Y] = K(f.unK(fa.unK))
    }
  }

  def printer: HFunctor.HAlgebra[ExprF, K[String, ?]] = new HFunctor.HAlgebra[ExprF, K[String, ?]] {
    override def apply[A](fa: ExprF[K[String, ?], A]): K[String, A] = fa match {
      case ExprF.Add(left, right) => (left |@| right)(_ + "+" + _)
      case ExprF.Multiply(left, right) => (left |@| right)(_ + "*" + _)
      case ExprF.Const(value) => K(value.toString)
    }
  }
}

object Program extends App {

  import ExprF._
  import HFix._

  val prg = multiply(add(const(1), const(2)), const(3))

  println(prg.cata(evaluator))
  println(prg.cata(printer).unK)

}