Instantly share code, notes, and snippets.

Embed
What would you like to do?
Wrapper for Free monads that (at least I thought) makes them more usable. Different languages can be composed at will (without manual lifting). Runners should have all the used types in the composed program, but they do not have to be in the same order.
package test
import scala.language.higherKinds
case class Program[F[_], A](free: Free[F, A]) {
import Coproduct.|
def flatMap[G[_], B](f: A => Program[G, B])(
implicit c: F | G): Program[c.Out, B] =
Program(free
.mapSuspension(c.transformLeft)
.flatMap(f andThen (_.free.mapSuspension(c.transformRight))))
def map[B](f: A => B): Program[F, B] =
Program(free.map(f))
def run[G[_]: Free.Monad](transform: F ~> G): G[A] =
free.foldMap(transform)
}
package test
import scala.language.higherKinds
trait Free[F[_], A] {
def flatMap[B](f: A => Free[F, B]): Free[F, B] =
this match {
case Apply(a) => f(a)
case FlatMap(i, k) =>
FlatMap(i, k andThen (_ flatMap f))
}
def map[B](f: A => B): Free[F, B] =
flatMap(a => Apply(f(a)))
def mapSuspension[G[_]](implicit transform: F ~> G): Free[G, A] =
this match {
case Apply(a) => Apply(a)
case FlatMap(i, k) =>
FlatMap(transform(i), k andThen (_.mapSuspension))
}
def foldMap[G[_]: Free.Monad](transform: F ~> G): G[A] = {
val G = Free.Monad[G]
this match {
case Apply(a) => G(a)
case FlatMap(fa, f) =>
G.flatMap(transform(fa), f andThen (_ foldMap transform))
}
}
}
object Free {
def apply[F[_], A](f: F[A]): Free[F, A] = FlatMap(f, Apply(_: A))
type Id[x] = x
trait Monad[F[_]] {
def apply[A](a: A): F[A]
def flatMap[A, B](a: F[A], f: A => F[B]): F[B]
}
object Monad {
def apply[F[_]: Monad]: Monad[F] = implicitly
type Id[x] = x
implicit val idMonad =
new Monad[Id] {
def apply[A](a: A) = a
def flatMap[A, B](a: Id[A], f: A => Id[B]) = f(a)
}
implicit def freeMonad[F[_]] =
new Monad[({ type T[x] = Free[F, x] })#T] {
def apply[A](a: A) = Apply(a)
def flatMap[A, B](fa: Free[F, A], f: A => Free[F, B]) = fa flatMap f
}
}
}
case class Apply[F[_], A](value: A) extends Free[F, A]
case class FlatMap[F[_], A, B](input: F[A], f: A => Free[F, B]) extends Free[F, B]
package test
import scala.language.higherKinds
import scala.language.implicitConversions
import scala.annotation.implicitNotFound
/*
* When we define this as Coproduct[F[_], G[_], x] implicit
* resolution falters in combination with partial application
* like this: ({type T[x] = Coproduct[F, G, x]})#T
*
* For nested Coproducts, the X[_] will not match the partially applied
* Coproduct.
*/
class Co[Head[_], Tail[_]] {
type T[x] = Product[x]
case class Product[x](value: Either[Head[x], Tail[x]])(
implicit ev: Coproduct.NotAtLeft[Head])
}
object Co {
def apply[Head[_], Tail[_]] = new Co[Head, Tail]
}
object Coproduct {
def apply[Head[_], Tail[_], x](value: Either[Head[x], Tail[x]])(
implicit ev: Coproduct.NotAtLeft[Head]) = Co[Head, Tail].Product(value)
trait Is[F[_]]
object Is {
implicit def coproduct[Head[_], Tail[_]]: Is[Co[Head, Tail]#Product] = null
}
@implicitNotFound("There can be no coproducts on the left, import Coproduct.proof._ if this is wrong, found: ${F}")
type NotAtLeft[F[_]] = IsNotCoproduct[F]
type IsNotCoproduct[F[_]] = IsNot[F]
trait IsNot[F[_]]
object IsNot {
/*
For types that are a coproduct we provide an ambigous IsNot
value, this makes the real one unusable
*/
implicit def isCoproduct[F[_]](implicit ev: Is[F]): IsNot[F] = null
implicit def isNotCoproduct[F[_]]: IsNot[F] = null
implicit def nothingIsNotCoproduct: IsNot[Nothing] = null
}
type ::[Head[_], Tail[_]] = Co[Head, Tail]
trait contains[List[_], Elem[_]]
object contains {
implicit def atHead[Head[_], Tail[_]]: (Head :: Tail)#T contains Head = null
implicit def inTail[Elem[_], Head[_], Tail[_]](
implicit ev: Tail contains Elem): (Head :: Tail)#T contains Elem = null
implicit def isElem[Elem[_]]: Elem contains Elem = null
}
trait union[Left[_], Right[_]] {
type Out[_]
}
trait LowestPriorityUnion {
implicit def pair[Left[_], Right[_]](
implicit ev: IsNotCoproduct[Left]): (Left union Right) {
type Out[x] = (Left :: Right)#T[x]
} = null
implicit def headNotInRight[Head[_], Tail[_], Right[_]](
implicit tailRightUnion: Tail union Right): ((Head :: Tail)#T union Right) {
type Out[x] = (Head :: tailRightUnion.Out)#T[x]
} = null
}
trait LowerPriorityUnion extends LowestPriorityUnion {
implicit def headInRight[Head[_], Tail[_], Right[_]](
implicit ev: Right contains Head,
tailRightUnion: Tail union Right): ((Head :: Tail)#T union Right) {
type Out[x] = tailRightUnion.Out[x]
} = null
}
object union extends LowerPriorityUnion {
// this crashes the compiler
//type Aux[Left[_], Right[_], O[_]] = (Left union Right) { type Out[x] = O[x] }
trait Aux[Left[_], Right[_], O[_]]
object Aux {
implicit def proxy[Left[_], Right[_]](
implicit u: Left union Right): Aux[Left, Right, u.Out] = null
}
implicit def leftContainsRight[Head[_], Tail[_], Right[_]](
implicit ev: (Head :: Tail)#T contains Right): ((Head :: Tail)#T union Right) {
type Out[x] = (Head :: Tail)#T[x]
} = null
implicit def rightContainsLeft[Left[_], Head[_], Tail[_]](
implicit ev: (Head :: Tail)#T contains Left): (Left union (Head :: Tail)#T) {
type Out[x] = (Head :: Tail)#T[x]
} = null
implicit def same[Elem[_]]: (Elem union Elem) {
type Out[x] = Elem[x]
} = null
}
trait IsIdentity[F[_]]
object IsIdentity {
type Id[x] = x
implicit def identity[F[_]](implicit ev: F[_] =:= Id[_]): IsIdentity[F] = null
}
trait IsNotIdentity[F[_]]
object IsNotIdentity {
implicit def identity[F[_]](implicit ev: IsIdentity[F]): IsNotIdentity[F] = null
implicit def notIdentity[F[_]]: IsNotIdentity[F] = null
}
trait LowerPriorityTransformations {
implicit def identity[Elem[_]](
implicit ev: IsNotIdentity[Elem]) =
new (Elem ~> Elem) {
def apply[x](elem: Elem[x]) = elem
}
implicit def atHead[Elem[_], Tail[_]](
implicit ev: IsNotCoproduct[Elem]) =
new (Elem ~> (Elem :: Tail)#T) {
def apply[x](elem: Elem[x]) =
new (Elem :: Tail).Product(Left(elem))
}
implicit def inTail[Elem[_], Head[_], Tail[_]](
implicit ev1: IsNotCoproduct[Elem],
ev2: IsNotCoproduct[Head],
transformTail: Elem ~> Tail) =
new (Elem ~> (Head :: Tail)#T) {
def apply[x](elem: Elem[x]) =
new (Head :: Tail).Product(Right(transformTail(elem)))
}
}
/*
trait ValueProjector[Elem[_], Target[_]] {
def project[x](target: Target[x]): Option[Elem[x]]
}
type <~[Elem[_], Target[_]] = ValueProjector[Elem, Target]
object ValueProjector {
implicit def same[Elem[_]] =
new (Elem <~ Elem) {
def project[x](target: Elem[x]) = Some(target)
}
implicit def atHead[Elem[_], Tail[_]] =
new (Elem <~ (Elem :: Tail)#T) {
def project[x](target: (Elem :: Tail)#T[x]) =
target.value.left.toOption
}
implicit def inTail[Elem[_], Head[_], Tail[_]](
tailProjector: Elem <~ Tail) =
new (Elem <~ (Head :: Tail)#T) {
def project[x](target: (Head :: Tail)#T[x]) = {
val tail = target.value.right.toOption
tail.flatMap(tailProjector.project)
}
}
}
*/
object Transformations extends LowerPriorityTransformations {
implicit def elemIsCoProduct[Elem[_], Tail[_], Target[_]](
implicit transformHead: Elem ~> Target,
transformTail: Tail ~> Target) =
new ((Elem :: Tail)#T ~> Target) {
def apply[x](elem: (Elem :: Tail)#T[x]) =
elem.value match {
case Left(head) => transformHead(head)
case Right(tail) => transformTail(tail)
}
}
implicit def transformSource[F[_], Target[_], G[_]](fToTarget: F ~> Target)(
implicit transform: G ~> F) =
new (G ~> Target) {
def apply[x](g: G[x]) = fToTarget(transform(g))
}
implicit def transformTarget[F[_], Source[_], G[_]](
implicit transform: F ~> G) =
(sourceToF: Source ~> F) =>
new (Source ~> G) {
def apply[x](g: Source[x]) = transform(sourceToF(g))
}
}
implicit class TranformationEnhancement[Tail[_], Target[_]](fg: Tail ~> Target) {
def or[T[_], Head[_]](hg: Head ~> T)(implicit ev: Head ~> T => Head ~> Target) =
new ((Head :: Tail)#T ~> Target) {
def apply[x](elem: (Head :: Tail)#T[x]) =
elem.value match {
case Left(head) => ev(hg) apply head
case Right(tail) => fg(tail)
}
}
}
type |[Left[_], Right[_]] = Combined[Left, Right]
trait Combined[Left[_], Right[_]] {
type Out[_]
def transformLeft: Left ~> Out
def transformRight: Right ~> Out
}
trait LowerPriorityCombined {
implicit def combine[Left[_], Right[_], O[_]](
implicit u: union.Aux[Left, Right, O],
l: Left ~> O,
r: Right ~> O) =
new (Left | Right) {
type Out[x] = O[x]
val transformLeft = l
val transformRight = r
}
}
object Combined extends LowerPriorityCombined {
implicit def single[Elem[_]] =
new (Elem | Elem) {
type Out[x] = Elem[x]
val transformLeft = Transformations.identity[Elem]
val transformRight = Transformations.identity[Elem]
}
}
}
package test
import scala.language.higherKinds
trait NaturalTransformation[-F[_], +G[_]] {
def apply[x](f: F[x]): G[x]
}
import scala.language.higherKinds
package object test {
type ~>[-F[_], +G[_]] = NaturalTransformation[F, G]
type <~[+G[_], -F[_]] = NaturalTransformation[F, G]
}
package test
import scala.language.higherKinds
import scala.language.implicitConversions
trait T1[A]
case class Test1(a: String) extends T1[String]
trait T2[A]
case class Test2(a: Int) extends T2[Int]
trait T3[A]
case class Test3(a: Boolean) extends T3[Boolean]
trait T4[A]
case class Test4(a: Double) extends T4[Double]
object test {
import Coproduct.Transformations._
import Coproduct.IsIdentity
import Coproduct.TranformationEnhancement
//implicit def toFree[F[_], A](f: F[A]) = Free(f)
implicit def toProgram[F[_], A](fa:F[A]):Program[F, A] =
Program(Free(fa))
type Id[x] = x
object T1Runner extends (T1 ~> Id) {
def apply[x](f: T1[x]) =
f match {
case Test1(x) => x
}
}
object T2Runner extends (T2 ~> Id) {
def apply[x](f: T2[x]) =
f match {
case Test2(x) => x
}
}
object T3Runner extends (T3 ~> Option) {
def apply[x](f: T3[x]) =
f match {
case Test3(x) => Some(x)
}
}
val t1 = Test1("a")
val t2 = Test2(2)
val t3 = Test3(true)
val program = for {
b <- t2
a <- t1
c <- t3
d <- t2
} yield a + b + c + d
implicit val optionToId =
new (Option ~> Id) {
def apply[x](o: Option[x]) = o.get
}
val runner = T1Runner or T2Runner or T3Runner
val result = program.run(runner)
}
@EECOLOR

This comment has been minimized.

Show comment
Hide comment
@EECOLOR

EECOLOR Jun 30, 2014

I think I can separate changing the suspention type (Free[F, A] to Free[X, B]) from the the flat map itself (Free[F, A] to Free[F, B)

Owner

EECOLOR commented Jun 30, 2014

I think I can separate changing the suspention type (Free[F, A] to Free[X, B]) from the the flat map itself (Free[F, A] to Free[F, B)

@EECOLOR

This comment has been minimized.

Show comment
Hide comment
@EECOLOR

EECOLOR Jun 30, 2014

Free is now a regular free monad.

Owner

EECOLOR commented Jun 30, 2014

Free is now a regular free monad.

@EECOLOR

This comment has been minimized.

Show comment
Hide comment
@EECOLOR

EECOLOR Jul 1, 2014

I am not sure if the result is actually more usable.

Owner

EECOLOR commented Jul 1, 2014

I am not sure if the result is actually more usable.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment