shapeless-style derivation of a FunctorK (aka HFunctor) instance for an arbitrary product F-algebra

functork.scala

import scala.language.{ higherKinds, implicitConversions }

object Defns {
  type Id[T] = T
  type ApplyTo[T] = { type λ[F[_]] = F[T] }
  type Const1[T] = { type λ[F[_]] = T }

  // Natural transform
  trait ~>[F[_], G[_]] {
    def apply[T](ft: F[T]): G[T]
  }

  // Opaque types should make this go away
  case class Tuple2K1[F[_[_]], G[_[_]], A[_]](_1: F[A], _2: G[A])
  object Tuple2K1 {
    implicit def apply[F[_[_]], G[_[_]], A[_]](p: (F[A], G[A])): Tuple2K1[F, G, A] =
      new Tuple2K1(p._1, p._2)

    implicit def tuple2[F[_[_]], G[_[_]], A[_]](t: Tuple2K1[F, G, A]): (F[A], G[A]) =
      (t._1, t._2)
  }
}

import Defns._

// An extension to the current kind polymorphism proposal
// could make this go away
sealed trait Apply[O <: AnyKind, I <: AnyKind]
case class Apply0[T, I](value: T) extends Apply[T, I] {
  def kmap[U](f: T => U): Apply[U, I] = Apply0(f(value))
}
case class Apply1[F[_], I](value: F[I]) extends Apply[F, I] {
  def kmap[G[_]](f: F[I] => G[I]): Apply[G, I] = Apply1(f(value))
}
case class Apply11[F[_[_]], I[_]](value: F[I]) extends Apply[F, I] {
  def kmap[G[_[_]]](f: F[I] => G[I]): Apply[G, I] = Apply11(f(value))
}

object Apply extends ApplyLow {
  implicit def narrow0[T, I](aft: Apply[T, I]): Apply0[T, I] =
    aft match { case Apply0(t) => Apply0(t) }
  implicit def narrow1[F[_], I](afi: Apply[F, I]): Apply1[F, I] =
    afi match { case Apply1(fi) => Apply1(fi) }
  implicit def narrow11[F[_[_]], I[_]](afi: Apply[F, I]): Apply11[F, I] =
    afi match { case Apply11(fi) => Apply11(fi) }

  implicit def extract0[T, I](at: Apply[T, I]): T = at.value
  implicit def extract1[F[_], I](afi: Apply[F, I]): F[I] = afi.value
  implicit def extract11[F[_[_]], I[_]](afi: Apply[F, I]): F[I] = afi.value
}

trait ApplyLow {
  implicit def apply[T](t: T): Apply0[T, Unit] = Apply0(t)
  implicit def apply[F[_], I](fi: F[I]): Apply1[F, I] = Apply1(fi)
  implicit def apply11[F[_[_]], I[_]](fi: F[I]): Apply11[F, I] = Apply11(fi)
}

// Kind polymorphic Generic
trait Generic[G <: AnyKind, Repr <: AnyKind] {
  def to[I <: AnyKind](t: Apply[G, I]): Apply[Repr, I]
  def from[I <: AnyKind](t: Apply[Repr, I]): Apply[G, I]
}

object Generic {
  trait MkGeneric[G <: AnyKind] { type Repr <: AnyKind; val gen: Generic[G, Repr] }
  object MkGeneric {
    implicit def apply[G <: AnyKind, R <: AnyKind](implicit gen0: Generic[G, R]) =
      new MkGeneric[G] { type Repr = R ; val gen = gen0 }
    }
  def apply[G <: AnyKind](implicit mkgen: MkGeneric[G]): Generic[G, mkgen.Repr] = mkgen.gen
}

// Higher-order functor aka HFunctor
trait FunctorK[A[_[_]]] {
  def mapK[F[_], G[_]](af: A[F])(f: F ~> G): A[G]
}

object FunctorK {
  def apply[F[_[_]]](implicit ff: FunctorK[F]): FunctorK[F] = ff

  // Derivation for arbitrary product types ...

  implicit def applyToFunctor[T]: FunctorK[ApplyTo[T]#λ] =
    new FunctorK[ApplyTo[T]#λ] {
      def mapK[F[_], G[_]](ft: F[T])(f: F ~> G): G[T] = f(ft)
    }

  implicit def constFunctorK[T]: FunctorK[Const1[T]#λ] =
    new FunctorK[Const1[T]#λ] {
      def mapK[F[_], G[_]](t: T)(f: F ~> G): T = t
    }

  // Induction step for products
  implicit def product[T[_[_]], U[_[_]]]
    (implicit ft: FunctorK[T], fu: FunctorK[U]): FunctorK[({ type λ[f[_]] = Tuple2K1[T, U, f] })#λ] =
      new FunctorK[({ type λ[f[_]] = Tuple2K1[T, U, f] })#λ] {
        def mapK[F[_], G[_]](tuf: Tuple2K1[T, U, F])(f: F ~> G): Tuple2K1[T, U, G] = {
          (ft.mapK(tuf._1)(f), fu.mapK(tuf._2)(f))
        }
      }

  implicit def generic[T[_[_]], R[_[_]]]
    (implicit gen: Generic[T, R], fr: FunctorK[R]): FunctorK[T] =
      new FunctorK[T] {
        def mapK[F[_], G[_]](tf: T[F])(f: F ~> G): T[G] =
          gen.from(fr.mapK(gen.to(tf))(f))
      }
}

// A tiny F-algebra
case class Order[F[_]](
  item: F[String],
  quantity: F[Int]
)
object Order {
  // This would *not* be written by hand ...
  type OrderRepr[F[_]] = Tuple2K1[ApplyTo[String]#λ, ({ type λ[f[_]] = Tuple2K1[ApplyTo[Int]#λ, Const1[Unit]#λ, f] })#λ, F]

  implicit object OrderGeneric extends Generic[Order, OrderRepr] {
    def to[I <: AnyKind](t: Apply[Order, I]): Apply[OrderRepr, I] =
      t match {
        case Apply11(fi: Order[f]) => Apply11(to0[f](fi))
      }
    def from[I <: AnyKind](r: Apply[OrderRepr, I]): Apply[Order, I] =
      r match {
        case Apply11(fi: OrderRepr[f]) => Apply11(from0[f](fi))
      }

    def to0[F[_]](t: Order[F]): OrderRepr[F] =
      Tuple2K1[ApplyTo[String]#λ, ({ type λ[f[_]] = Tuple2K1[ApplyTo[Int]#λ, Const1[Unit]#λ, f] })#λ, F](
        t.item, Tuple2K1[ApplyTo[Int]#λ, Const1[Unit]#λ, F](t.quantity, ())
      )
    def from0[F[_]](r: OrderRepr[F]): Order[F] = Order(r._1, r._2._1)
  }
}

sealed trait OptionD[T]
case class Given[T](value: T) extends OptionD[T]
case class Default[T](value: T) extends OptionD[T]

object OptionD {
  object fold extends (OptionD ~> Id) {
    def apply[T](od: OptionD[T]): T =
      od match {
        case Given(t) => t
        case Default(t) => t
      }
  }
}

object Test extends App {
  val fko = FunctorK[Order]

  // Represent a partial order by indexing with OptionD
  val partialOrder: Order[OptionD] = Order(Given("fish"), Default(1))

  // Represent a complete order by indexing with Id
  // Use higher order functor to take partial to complete
  val completeOrder: Order[Id] = fko.mapK(partialOrder)(OptionD.fold)

  assert(completeOrder == Order[Id]("fish", 1))
}