Scala DataType à la carte

Alacarte.scala

object Alacarte {
  trait Functor[F[_]]{
    def map[A, B](fa: F[A])(f: A => B): F[B]
  }
  
  trait Eval[F[_]] {
    def F: Functor[F]
	
    def evalAlgebra(fa: F[Int]): Int 
  }
  
  trait coproduct[F[_], G[_]] {
    type or[H[_]] = coproduct[F, ({type f[x] = Either[G[x], H[x]]})#f]
    type ap[A] = Either[F[A], G[A]]
  }
  
  case class Val[A](v: Int)
  case class Add[A](l: A, r: A)
  case class Expr[F[_]](in: F[Expr[F]])
  
  implicit val valFunctor = new Functor[Val]{
    def map[A, B](fa: Val[A])(f: A => B): Val[B] = Val[B](fa.v)
  }
  
  implicit val addFunctor = new Functor[Add]{
    def map[A, B](fa: Add[A])(f: A => B): Add[B] = Add(f(fa.l), f(fa.r))
  }
  
  implicit def coprodFunctor[F[_], G[_]](implicit F: Functor[F], G: Functor[G]) = new Functor[coproduct[F, G]#ap]{
    def map[A, B](ea: Either[F[A], G[A]])(f: A => B): Either[F[B], G[B]] = ea match {
      case Left(fa)  => Left(F.map(fa)(f))
      case Right(ga) => Right(G.map(ga)(f))
    }
  }
  
  implicit def coprod3Functor[F[_], G[_], H[_]](implicit F: Functor[F], G: Functor[G], H: Functor[H]) = new Functor[coproduct[F, G]#or[H]#ap]{
    def map[A, B](ea: Either[F[A], Either[G[A], H[A]]])(f: A => B): Either[F[B], Either[G[B], H[B]]] = ea match {
      case Left(fa)         => Left(F.map(fa)(f))
      case Right(Left(ga))  => Right(Left(G.map(ga)(f)))
      case Right(Right(ha)) => Right(Right(H.map(ha)(f)))
    }
  }
  
  implicit val valEval = new Eval[Val]{
    def F = valFunctor
	
    def evalAlgebra(fa: Val[Int]) = fa.v
  }
  
  implicit val addEval = new Eval[Add]{
    def F = addFunctor
	
    def evalAlgebra(fa: Add[Int]) = fa.l + fa.r
  }
  
  implicit def coprod3Eval[F[_], G[_], H[_]](implicit F0: Eval[F], G: Eval[G], H: Eval[H]) = new Eval[coproduct[F, G]#or[H]#ap]{
    def F = coprod3Functor[F, G, H](F0.F, G.F, H.F)
	
    def evalAlgebra(ea: Either[F[Int], Either[G[Int], H[Int]]]): Int = ea match {
      case Left(fa)         => F0.evalAlgebra(fa)
      case Right(Left(ga))  => G.evalAlgebra(ga)
      case Right(Right(ha)) => H.evalAlgebra(ha)
    }
  }
  
  implicit def coprodEval[F[_], G[_]](implicit F0: Eval[F], G: Eval[G]) = new Eval[coproduct[F, G]#ap]{
    def F = coprodFunctor[F, G](F0.F, G.F)
	
    def evalAlgebra(ea: Either[F[Int], G[Int]]): Int = ea match {
      case Left(fa)  => F0.evalAlgebra(fa)
      case Right(ga) => G.evalAlgebra(ga)
    }
  }
  
  def foldExpr[F[_], A](e: Expr[F],  f: F[A] => A)(implicit F: Functor[F]): A = 
    f(F.map(e.in)(expr => foldExpr(expr, f)))
	
  def eval[F[_]](e: Expr[F])(implicit E: Eval[F]): Int = 
    foldExpr[F, Int](e, E.evalAlgebra)(E.F)
	
  // --------------------------
  
  trait Inject[F[_], G[_]]{
    def inj[A](sub: F[A]): G[A]
  }
  
  trait InjectInstances2 {
    implicit def reflexiveInject[F[_]](implicit F: Functor[F]): Inject[F, F] = new Inject[F, F]{
      def inj[A](sub: F[A]): F[A] = sub
    }
  }
  
  trait InjectInstances1 extends InjectInstances2 {
    implicit def leftKnown3Inject[F[_], G[_], H[_]](implicit F: Functor[F], G: Functor[G], H: Functor[H]): Inject[F, coproduct[F, G]#or[H]#ap] = new Inject[F, coproduct[F, G]#or[H]#ap]{
      def inj[A](sub: F[A]): Either[F[A], Either[G[A], H[A]]] = Left(sub)
    }
	
    implicit def leftKnownInject[F[_], G[_]](implicit F: Functor[F], G: Functor[G]): Inject[F, coproduct[F, G]#ap] = new Inject[F, coproduct[F, G]#ap]{
      def inj[A](sub: F[A]): Either[F[A], G[A]] = Left(sub)
    }
  }
  
  trait InjectInstances extends InjectInstances1 {
    implicit def larger2Inject[F[_], G[_], H[_], J[_]](implicit F: Functor[F], G: Functor[G], J: Functor[J], I: Inject[F, G]): Inject[F, coproduct[H, G]#or[J]#ap] = new Inject[F, coproduct[H, G]#or[J]#ap]{
      def inj[A](sub: F[A]): Either[H[A], Either[G[A], J[A]]] = Right(Left(I.inj(sub)))
    }
	
    implicit def larger3Inject[F[_], G[_], H[_], J[_]](implicit F: Functor[F], G: Functor[G], J: Functor[J], I: Inject[F, J]): Inject[F, coproduct[H, G]#or[J]#ap] = new Inject[F, coproduct[H, G]#or[J]#ap]{
      def inj[A](sub: F[A]): Either[H[A], Either[G[A], J[A]]] = Right(Right(I.inj(sub)))
    }
	
    implicit def largerInject[F[_], G[_], H[_]](implicit F: Functor[F], G: Functor[G], I: Inject[F, G]): Inject[F, coproduct[H, G]#ap] = new Inject[F, coproduct[H, G]#ap]{
      def inj[A](sub: F[A]): Either[H[A], G[A]] = Right(I.inj(sub))
    }
  }
  
  object Inject extends InjectInstances
  
  def inject[G[_], F[_]](ge: G[Expr[F]])(implicit I: Inject[G, F]): Expr[F] = Expr[F](I.inj(ge))
	
  def newVal[F[_]](n: Int)(implicit I: Inject[Val, F]): Expr[F] = inject[Val, F](Val(n))
  
  def plus[F[_]](l: Expr[F], r: Expr[F])(implicit I: Inject[Add, F]) = inject[Add, F](Add(l, r))
  
  // --------
  
  case class Mul[A](l: A, r: A)
  
  implicit val mulFunctor = new Functor[Mul]{
    def map[A, B](fa: Mul[A])(f: A => B): Mul[B] = Mul(f(fa.l), f(fa.r))
  }
  
  implicit val mulEval = new Eval[Mul]{
    def F = mulFunctor
	
    def evalAlgebra(fa: Mul[Int]) = fa.l * fa.r
  }
  
  def mul[F[_]](l: Expr[F], r: Expr[F])(implicit I: Inject[Mul, F]) = inject[Mul, F](Mul(l, r))
  
  // ------
  
  // Free monad
  trait Term[F[_], A] { 
    def fold[Z](pure: A => Z, impure: F[Term[F, A]] => Z): Z                                                                                           
    def map[B](f: A => B)(implicit F: Functor[F]): Term[F, B] = flatMap(a => Pure(f(a)))

    def flatMap[B](f: A => Term[F, B])(implicit F: Functor[F]): Term[F, B] = this match { 
      case Pure(a)    => f(a)
      case Impure(fa) => Impure[F, B](F.map(fa)(_ flatMap f))
    }
  }

  object Pure { 
    def unapply[F[_], A](t: Term[F, A]): Option[A] =
      t.fold(Some(_), _ => None)

    def apply[F[_], A](v: A): Term[F, A] = new Term[F, A]{ 
      def fold[Z](pure: A => Z, impure: F[Term[F, A]] => Z): Z = pure(v)
    }
  }

  object Impure { 
    def unapply[F[_], A](t: Term[F, A]): Option[F[Term[F, A]]] =
      t.fold(_ => None, Some(_))

    def apply[F[_], A](fa: F[Term[F, A]]): Term[F, A] = new Term[F, A]{ 
      def fold[Z](pure: A => Z, impure: F[Term[F, A]] => Z): Z = impure(fa)
    }
  }
  
  implicit def termFunctor[F[_]](implicit F: Functor[F]) = new Functor[({type f[x] = Term[F, x]})#f]{
    def map[A, B](fa: Term[F, A])(f: A => B): Term[F, B] = fa map f
  }
  
  case class Incr[A](i: Int, v: A)
  case class Recall[A](f: Int => A)
  
  implicit val incrFunctor = new Functor[Incr]{
     def map[A, B](fa: Incr[A])(f: A => B): Incr[B] = fa.copy(v = f(fa.v))
  }
  
  implicit val recFunctor = new Functor[Recall]{
    def map[A, B](fa: Recall[A])(k: A => B): Recall[B] = fa.copy(f = k compose fa.f)
  }
  
  def termInject[G[_], F[_], A](ge: G[Term[F, A]])(implicit I: Inject[G, F]): Term[F, A] =
    Impure[F, A](I.inj(ge))
	
  def incr[F[_]](i: Int)(implicit I: Inject[Incr, F]): Term[F, Unit] =
    termInject[Incr, F, Unit](Incr(i, Pure[F, Unit]()))
	
  def recall[F[_]](implicit I: Inject[Recall, F]): Term[F, Int] =
    termInject[Recall, F, Int](Recall(i => Pure[F, Int](i)))
	
  def foldTerm[F[_], A, B](t: Term[F, A], pure: A => B, impure: F[B] => B)(implicit F: Functor[F]): B = t match {
    case Pure(a)    => pure(a)
    case Impure(fb) => impure(F.map(fb)(term => foldTerm(term, pure, impure)))
  }
  
  trait Run[F[_]]{
    def F: Functor[F]
	
    def runAlgebra[A](fa: F[(Int => (A, Int))], mem: Int): (A, Int)
  }
  
  implicit val incrRun = new Run[Incr]{
    def F = incrFunctor
	
    def runAlgebra[A](fa: Incr[(Int => (A, Int))], mem: Int): (A, Int) = fa match {
      case Incr(i, f) => f(i + mem)
    }
  }
  
  implicit val recallRun = new Run[Recall]{
    def F = recFunctor
	
    def runAlgebra[A](fa: Recall[(Int => (A, Int))], mem: Int): (A, Int) = fa match {
      case Recall(k) => k(mem)(mem)
    }
  }
  
  implicit def coprodRun[F[_], G[_]](implicit F0: Run[F], G: Run[G]) = new Run[coproduct[F, G]#ap]{
    def F = coprodFunctor[F, G](F0.F, G.F)

    def runAlgebra[A](ea: Either[F[Int => (A, Int)], G[Int => (A, Int)]], mem: Int): (A, Int) = ea match {
      case Left(fa)  => F0.runAlgebra(fa, mem)
      case Right(ga) => G.runAlgebra(ga, mem)
    }
  }
  
  implicit def coprod3Run[F[_], G[_], H[_]](implicit F0: Run[F], G: Run[G], H: Run[H]) = new Run[coproduct[F, G]#or[H]#ap]{
    def F = coprod3Functor[F, G, H](F0.F, G.F, H.F)
	
    def runAlgebra[A](ea: Either[F[Int => (A, Int)], Either[G[Int => (A, Int)], H[Int => (A, Int)]]], mem: Int): (A, Int) = ea match {
      case Left(fa)         => F0.runAlgebra(fa, mem)
      case Right(Left(ga))  => G.runAlgebra(ga, mem)
      case Right(Right(ha)) => H.runAlgebra(ha, mem)
    }
  }
  
  def run[F[_], A](t: Term[F, A], mem: Int)(implicit F: Run[F]): (A, Int) = 
    foldTerm[F, A, Int => (A, Int)](t, (a: A) => (b: Int) => (a, b), (fb: F[Int => (A, Int)]) => (i: Int) => F.runAlgebra[A](fb, i))(F.F).apply(mem)
  
  def main(args: Array[String]) = {
    val addExample: Expr[coproduct[Val, Add]#ap] = 
      Expr[coproduct[Val, Add]#ap](Right(Add(Expr[coproduct[Val, Add]#ap](Left(Val(118))), Expr[coproduct[Val, Add]#ap](Left(Val(1219))))))
	
    println(eval[coproduct[Val, Add]#ap](addExample)) // 1337
	
    val magic: Expr[coproduct[Add, Val]#ap] = plus[coproduct[Add, Val]#ap](newVal[coproduct[Add, Val]#ap](30000), plus[coproduct[Add, Val]#ap](newVal[coproduct[Add, Val]#ap](1330), newVal[coproduct[Add, Val]#ap](7)))
	
    println(eval[coproduct[Add, Val]#ap](magic)) //31337
	
    val anotherMagic: Expr[coproduct[Val, Add]#or[Mul]#ap] = 
      plus[coproduct[Val, Add]#or[Mul]#ap](mul[coproduct[Val, Add]#or[Mul]#ap](newVal[coproduct[Val, Add]#or[Mul]#ap](80), newVal[coproduct[Val, Add]#or[Mul]#ap](5)), newVal[coproduct[Val, Add]#or[Mul]#ap](4))
    
    println(eval[coproduct[Val, Add]#or[Mul]#ap](anotherMagic)) // 404
	
    val oneMore: Expr[coproduct[Val, Mul]#ap] =
      mul[coproduct[Val, Mul]#ap](newVal[coproduct[Val, Mul]#ap](6), newVal[coproduct[Val, Mul]#ap](7))
	  
    println(eval[coproduct[Val, Mul]#ap](oneMore)) // 42

    val tick: Term[coproduct[Recall, Incr]#ap, Int] = for { 
	y <- recall[coproduct[Recall, Incr]#ap]
	_ <- incr[coproduct[Recall, Incr]#ap](1)
      } yield y

    println(run[coproduct[Recall, Incr]#ap, Int](tick, 4)) // (4, 5)
  }
}