Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
shapeless-style derivation of a FunctorK (aka HFunctor) instance for an arbitrary product F-algebra
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))
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.