Get Type-Functor of Initial F-algebra in Scala

PolyFunctor.scala

import scala.language.higherKinds

import shapeless._
import shapeless.ops.coproduct.IsCCons
import shapeless.ops.hlist.IsHCons

object PolyFunctor extends App {
  trait TypeFunctor[F[_]] {
    def map[A, B](fa: F[A])(f: A => B): F[B]
    def pure[A](a: A): F[A] //for debug & test
    override def toString: String = "type-functor"
  }

  trait PFunctor[T] {
    type F[_]
    def isPrimitive_? = false
    def functor: TypeFunctor[F] //F is a functor
  }

  object PFunctor {
    type Aux[T, H[_]] = PFunctor[T] {type F[A] = H[A]}
    def apply[A](implicit pf: PFunctor[A]): PFunctor[A] = pf

    //identify functor
    type Id[A] = A
    val idFunctor: TypeFunctor[Id] = new TypeFunctor[Id] {
      def pure[A](a: A): Id[A] = a
      def map[A, B](fa: Id[A])(f: (A) => B): Id[B] = f(fa)
      override def toString = "I"
    }
    //constant functor
    type Const[A, B] = A
    def const[A, B](a: A, b: B): Const[A, B] = a

    def constFunctor[T](default: T, tg: String = "[None]") =
      new TypeFunctor[({type λ[α] = Const[T, α]})#λ] {
        def pure[A](a: A): Const[T, A] = default
        def map[A, B](fa: Const[T, A])(f: (A) => B): Const[T, B] = fa
        override def toString = s"($tg <<)"
      }

    //product
    case class Pair[A, B](a: A, b: B) {
      def outl = a
      def outr = b
    }

    def mulFunctor[F[_]: TypeFunctor, G[_]: TypeFunctor] =
      new TypeFunctor[({type λ[α] = Pair[F[α], G[α]]})#λ] {
        val (f1, f2) = (implicitly[TypeFunctor[F]], implicitly[TypeFunctor[G]])
        def pure[A](a: A): Pair[F[A], G[A]] = Pair(f1.pure(a), f2.pure(a))

        def map[A, B](pa: Pair[F[A], G[A]])(f: (A) => B): Pair[F[B], G[B]] = {
          // f x g = <f . outl, g . outr>
          // Ff x Gf = <Ff . outl, Gf . outr> = <(map f) . outl, (map f) . outr>
          Pair(f1.map(pa.outl)(f), f2.map(pa.outr)(f))
        }
        override def toString = s"$f1 x $f2"
      }

    //coproduct
    sealed trait DSum[A, B]
    case class Inl[A, B](a: A) extends DSum[A, B]
    case class Inr[A, B](b: B) extends DSum[A, B]

    def sumFunctor[F[_]: TypeFunctor, G[_]: TypeFunctor] =
      new TypeFunctor[({type λ[α] = DSum[F[α], G[α]]})#λ] {
        val (f1, f2) = (implicitly[TypeFunctor[F]], implicitly[TypeFunctor[G]])

        def pure[A](a: A): DSum[F[A], G[A]] = Inr[F[A], G[A]](f2.pure(a)) // ???

        def map[A, B](fa: DSum[F[A], G[A]])(f: (A) => B): DSum[F[B], G[B]] = {
          // f + g = [inl . f, inr . g]
          // [f, g](inl a) = f a & [f, g](inr b) = g b
          fa match {
            case Inl(a) => Inl(f1.map(a)(f))
            case Inr(b) => Inr(f2.map(b)(f))
          }
        }
        override def toString = s"$f1 + $f2"
      }

    //to repr

    //or use (implicit tg: scala.reflect.runtime.universe.TypeTag[T])
    def pFunctorOfConst[T](default: T, tg: String = "[None]"): PFunctor[T] = new PFunctor[T] {
      type F[A] = Const[T, A]
      override def functor = constFunctor[T](default, tg)
      override def isPrimitive_? = true
    }

    implicit val intFunctor = pFunctorOfConst(0, "Int")
    implicit val charFunctor = pFunctorOfConst(' ', "Char")
    implicit val floatFunctor = pFunctorOfConst(0f, "Float")
    implicit val unitFunctor = pFunctorOfConst((), "1")

    //HList - product
    implicit val hnilFunctor: PFunctor[HNil] = new PFunctor[HNil] {
      type F[A] = Const[Unit, A]
      override def functor = constFunctor[Unit]((), "1") //HNil iso ()
      override def isPrimitive_? = true
    }
    //for H :: HNil
    implicit def hlistFunctor[H](
      implicit
      hPFunctor: Lazy[PFunctor[H]],
      tPFunctor: PFunctor[HNil]
    ): PFunctor[H :: HNil] =
      if(!hPFunctor.value.isPrimitive_?) {
        new PFunctor[H :: HNil] {
          type F[A] = Id[A]
          override def isPrimitive_? = true
          override def functor = idFunctor
        }
      } else {
        new PFunctor[H :: HNil] {
          type F[A] = hPFunctor.value.F[A]
          override def isPrimitive_? = true
          override def functor = hPFunctor.value.functor
        }
      }
    //for H :: T ^ T = Head :: Tail
    implicit def hlistFunctor2[H, T <: HList, Head, Tail <: HList](
      implicit
      hPFunctor: Lazy[PFunctor[H]],
      tPFunctor: PFunctor[T],
      isHCons: IsHCons.Aux[T, Head, Tail]
    ): PFunctor[H :: T] =
      if(!hPFunctor.value.isPrimitive_?) {
        new PFunctor[H :: T] {
          type P[A] = Id[A]
          type G[A] = tPFunctor.F[A]
          type F[A] = Pair[P[A], G[A]]

          override def isPrimitive_? = false

          override def functor: TypeFunctor[({type λ[α] = Pair[P[α], G[α]]})#λ] =
            mulFunctor[P, G](idFunctor, tPFunctor.functor)
        }
      } else {
        new PFunctor[H :: T] {
          type P[A] = hPFunctor.value.F[A]
          type G[A] = tPFunctor.F[A]
          type F[A] = Pair[P[A], G[A]]

          override def isPrimitive_? = false

          override def functor: TypeFunctor[({type λ[α] = Pair[P[α], G[α]]})#λ] =
            mulFunctor[P, G](hPFunctor.value.functor, tPFunctor.functor)
        }
      }

    //bridge
    implicit def genericPFunctor[A, R](
      implicit
      gen: Generic.Aux[A, R],
      pf: Lazy[PFunctor[R]] //e.g for all Int :: String :: HNil => (Int <<) x (String <<)
    ): PFunctor[A] =
      new PFunctor[A] {
        type F[X] = pf.value.F[X]
        override def isPrimitive_? = pf.value.isPrimitive_?
        override def functor = pf.value.functor
      }

    //coproduct
    implicit val cnilPFunctor = new PFunctor[CNil] {
      override def functor = throw new Exception("error")
    }

    implicit def coproductPFunctor[H, T <: Coproduct](
      implicit
      hPFunctor: Lazy[PFunctor[H]],
      tPFunctor: PFunctor[T]
    ): PFunctor[H :+: CNil] =
      new PFunctor[H :+: CNil] {
        type F[A] = hPFunctor.value.F[A]
        def functor = hPFunctor.value.functor
        override def isPrimitive_? = true
      }

    implicit def coproductPFunctor2[H, T <: Coproduct, Head, Tail <: Coproduct](
      implicit
      hPFunctor: Lazy[PFunctor[H]],
      tPFunctor: PFunctor[T],
      isCCons: IsCCons.Aux[T, Head, Tail]
    ): PFunctor[H :+: T] =
      new PFunctor[H :+: T] {
        type P[A] = hPFunctor.value.F[A]
        type G[A] = tPFunctor.F[A]
        type F[A] = DSum[P[A], G[A]]
        def functor = sumFunctor[P, G](hPFunctor.value.functor, tPFunctor.functor)
        override def isPrimitive_? = false
      }
  }

  //Test
  import PFunctor._

  //test type-functor
  val r = idFunctor.map(1)(a => a + 1)
  println(r)

  val r2 = constFunctor(1).map(1)((a : Int) => a + 1)
  println(r2)

  val r22 = constFunctor(1).map(constFunctor(1).pure(2))((a : Int) => a + 1)
  println(r22)

  implicit val idF = idFunctor
  implicit val constIntF = constFunctor(1)
  val Id_x_Int_<< = mulFunctor[Id, ({type λ[α] = Const[Int, α]})#λ]
  val r3 = Id_x_Int_<<.map(PFunctor.Pair(1, 1))(a => a + 1)
  println(r3)

  val Id_sum_Int_<< = sumFunctor[Id, ({type λ[α] = Const[Int, α]})#λ]
  val r4 = Id_sum_Int_<<.map(Inl(1))(a => a + 1)
  val r5 = Id_sum_Int_<<.map(Inr[Int, Int](1))(a => a + 1)
  println(r4, r5)

  //ADT
  case class AX()
  case class AXX(a: Int)
  case class AXXX(a: Int, b: Char)

  sealed trait Bool
  case class True() extends Bool
  case class False() extends Bool

  val pf1 = PFunctor[AX]
  println(pf1.functor.map(().asInstanceOf[pf1.F[Unit]])(a => a))
  println(pf1.functor.map(pf1.functor.pure(1))(a => a + 1))
  val pf2 = PFunctor[AXX]
  println(pf2.functor.map(1.asInstanceOf[pf2.F[Int]])(a => a + 1))
  println(pf2.functor.map(pf2.functor.pure("1"))(a => a + 1))

  val pf3 = PFunctor[AXXX]
  println(pf1.isPrimitive_?, pf2.isPrimitive_?, pf3.isPrimitive_?)

  val pf4 = PFunctor[Bool]
  //test lexical order
  val gb = Generic[Bool]
  implicitly[gb.Repr =:= (False :+: True :+: CNil)]

  println(pf1.functor, pf2.functor, pf3.functor, pf4.functor)

  //test Nat
  sealed trait Nat
  case class Zero() extends Nat
  case class Succ(n: Nat) extends Nat

  val pf5 = PFunctor[Nat]
  println(pf5.isPrimitive_?, pf5.functor)
  println(pf5.functor.map(pf5.functor.pure(1))(a => a + 1))

  //test list
  sealed trait List[+T]
  case class Cons[T](hd: T, tl: List[T]) extends List[T]
  sealed trait Nil extends List[Nothing]
  case object Nil extends Nil

  val pf6 = PFunctor[List[Char]]
  println(pf6.isPrimitive_?, pf6.functor)
  //test Expr
  sealed trait Expr
  case class AConst(i: Int) extends Expr
  case class Add(expr1: Expr, expr2: Expr) extends Expr
  case class Mul(expr1: Expr, expr2: Expr) extends Expr

  val pf7 = PFunctor[Expr]
  println(pf7.isPrimitive_?, pf7.functor)
}