A straightforward translation of "Freer Monads, More Extensible Effects" to Scala

build.sbt

scalaOrganization := "org.typelevel"

scalaVersion := "2.11.8"

scalacOptions ++= Seq("-Ypartial-unification", "-Yliteral-types", "-feature", "-deprecation", "-language:implicitConversions", "-language:higherKinds")

resolvers += Resolver.sonatypeRepo("releases")

addCompilerPlugin("org.spire-math" %% "kind-projector" % "0.9.0")

// if your project uses multiple Scala versions, use this for cross building
addCompilerPlugin("org.spire-math" % "kind-projector" % "0.9.0" cross CrossVersion.binary)

// if your project uses both 2.10 and polymorphic lambdas
libraryDependencies ++= (scalaBinaryVersion.value match {
  case "2.10" =>
    compilerPlugin("org.scalamacros" % "paradise" % "2.1.0" cross CrossVersion.full) :: Nil
  case _ =>
    Nil
})

FreerMonads.scala

object freer {

  trait Functor[F[_]] {
    def map[A, B](fa: F[A], f: A => B): F[B]
  }
  object Functor {
    @inline
    def apply[F[_]](implicit f: Functor[F]): Functor[F] = f

    implicit class FunctorOps[A, F[_]: Functor](fa: F[A]) {
      def map[B](f: A => B): F[B] = Functor[F].map(fa, f)
    }
  }

  trait Monad[M[_]] {
    def unit[A](value: A): M[A]
    def flatMap[A, B](ma: M[A], f: A => M[B]): M[B]
  }
  object Monad {
    @inline
    def apply[M[_]](implicit m: Monad[M]): Monad[M] = m

    @inline
    def unit[A, M[_]: Monad](value: A): M[A] = implicitly[Monad[M]].unit(value)

    implicit class MonadOps[A, M[_]: Monad](ma: M[A]) {
      def flatMap[B](f: A => M[B]): M[B] = Monad[M].flatMap(ma, f)
      def >>=[B](f: A => M[B]): M[B] = Monad[M].flatMap(ma, f)
      def map[B](f: A => B): M[B] = Monad[M].flatMap(ma, f andThen Monad[M].unit)
    }

    implicit class KleisliOps[A, B, M[_]: Monad](ka: A => M[B]) {
      def >>>[C](kb: B => M[C]): A => M[C] = a => ka(a) flatMap kb
    }
  }
  import Monad._

  // section 2.1
  // -----------
  // the operational reader monad [1].
  object step1 {

    // --- Monads ---
    sealed trait It[I, A]
    case class Pure[I, A](value: A) extends It[I, A]
    case class Get[I, A](k: I => It[I, A]) extends It[I, A]

    object It {
      implicit def monad[I]: Monad[It[I, ?]] = new Monad[It[I, ?]] {
        def unit[A](value: A) = Pure(value)
        def flatMap[A, B](ma: It[I, A], f: A => It[I, B]) = ma match {
          case Pure(v) => f(v)
          case Get(k)  => Get[I, B](k >>> f)
        }
      }
    }


    // --- Programs ---
    def ask[I]: It[I, I] = Get(Pure.apply)

    def addGet(x: Int): It[Int, Int] = ask[Int] map { i => i + x }


    // --- Interpreters ---
    def runReader[I, A](i: I): It[I, A] => A = {
      case Pure(v) => v
      case Get(k)  => runReader(i)(k(i))
    }

    def feedAll[I, A](l: List[I]): It[I, A] => A = {
      case Pure(v) => v
      case Get(k) => l match {
        case Nil => sys error "end of stream"
        case i :: is => feedAll(is)(k(i))
      }
    }
  }

  // section 2.2
  // -----------
  // add Put as monadic action
  object step2 {
    sealed trait IT[I, O, A]
    case class Pure[I, O, A](value: A) extends IT[I, O, A]
    case class Get[I, O, A](k: I => IT[I, O, A]) extends IT[I, O, A]
    case class Put[I, O, A](out: O, k: () => IT[I, O, A]) extends IT[I, O, A]

    // monad instance and interpreters omitted
  }

  // section 2.3
  // -----------
  // pattern functor: replace recursive position by X
  //                  drop Pure, so also drop A
  object step3 {
    import Functor._
    import Monad._

    // Standard free monad
    sealed trait Free[F[_], A]
    case class Pure[F[_], A](value: A) extends Free[F, A]
    case class Impure[F[_], A](k: F[Free[F, A]]) extends Free[F, A]

    // we can write a generic monad instance for Free[F, ?] if F is a functor
    object Free {
      implicit def monad[F[_]: Functor]: Monad[Free[F, ?]] = new Monad[Free[F, ?]] {
        def unit[A](value: A) = Pure(value)
        def flatMap[A, B](ma: Free[F, A], f: A => Free[F, B]) = ma match {
          case Pure(v)   => f(v)
          case Impure(k) => Impure(k map { _ flatMap f })
        }
      }
    }

    sealed trait ReaderWriter[I, O, X]
    case class Get[I, O, X](k: I => X) extends ReaderWriter[I, O, X]
    case class Put[I, O, X](out: O, k: () => X) extends ReaderWriter[I, O, X]

    implicit def readerWriterF[I, O]: Functor[ReaderWriter[I, O, ?]] = ???

    // recover as free monad
    type IT[I, O, A] = Free[ReaderWriter[I, O, ?], A]

    def ask[I]: IT[I, Nothing, I] = Impure(Get(i => Pure(i)))

    def addGet(x: Int): IT[Int, Nothing, Int] = ask[Int] map { i => i + x }
  }

  // section 2.4
  // -----------
  // move continuation into type of free
  object step4 {

    sealed trait Free[F[_], A]
    case class Pure[F[_], A](value: A) extends Free[F, A]
    case class Impure[F[_], A, X](value: F[X], k: X => Free[F, A]) extends Free[F, A]

    object Free {

      // no functor constraint is needed anymore!
      implicit def monad[F[_]]: Monad[Free[F, ?]] = new Monad[Free[F, ?]] {
        def unit[A](value: A) = Pure(value)
        def flatMap[A, B](ma: Free[F, A], f: A => Free[F, B]) = ma match {
          case Pure(v)   => f(v)

          // just aggregate the continuation, leave fx unchanged.
          case Impure(fx, k) => Impure(fx, k >>> f)
        }
      }
    }

    // Now X is only a phantom type (GADT) anymore.
    sealed trait ReaderWriter[I, O, X]
    case class Get[I, O]() extends ReaderWriter[I, O, I]
    case class Put[I, O](out: O) extends ReaderWriter[I, O, Unit]

    type IT[I, O, A] = Free[ReaderWriter[I, O, ?], A]
  }


  object typelevel {

    // type level list of typeconstructors
    sealed trait TList {
      type Apply[V]
    }
    sealed class TNil extends TList {
      type Apply[V] = Unit
    }
    sealed class TCons[F[_], R <: TList] extends TList {
      type Apply[V] = Either[F[V], R#Apply[V]]
    }

    object TList {
      type ::[F[_], R <: TList] = TCons[F, R]
    }
    import TList._

    case class Union[R <: TList, V](value: R#Apply[V])

    trait Member[F[_], R <: TList] {
      def inj[V](value: F[V]): Union[R, V]
      def prj[V](u: Union[R, V]): Option[F[V]]
    }
    object Member {
      type <<[F[_], R <: TList] = Member[F, R]
      def inj[F[_], R <: TList, V](value: F[V])(implicit m: F << R): Union[R, V] =
        m.inj(value)
      def prj[F[_], R <: TList, V](u: Union[R, V])(implicit m: F << R): Option[F[V]] =
        m.prj(u)

      def decomp[F[_], R <: TList, V](u: Union[F :: R, V]): Either[F[V], Union[R, V]] = u match {
        case Union(Left(v)) => Left(v)
        case Union(Right(u)) => Right(Union(u))
      }
    }
    import Member._

    implicit def memberHead[F[_], R <: TList]: F << (F :: R) = new (F << (F :: R)) {
      def inj[V](value: F[V]) = Union[F :: R, V](Left(value))
      def prj[V](u: Union[F :: R, V]) = u match {
        case Union(Left(fv)) => Some(fv)
        case _ => None
      }
    }
    implicit def memberTail[F[_], G[_], R <: TList](implicit ev: F << R): F << (G :: R) =
      new (F << (G :: R)) {
        def inj[V](fv: F[V]) = Union[G :: R, V](Right(ev.inj(fv).value))
        def prj[V](u: Union[G :: R, V]) = u match {
          case Union(Left(_)) => None
          case Union(Right(r)) => ev.prj(Union(r))
        }
      }

    // --- Some membership tests ---

    case class Foo[A](value: A)
    case class Bar[A](value: A)
    case class Baz[A](value: A)
    case class Boo[A](value: List[A])

    type T = Foo :: Baz :: Boo :: TNil

    implicitly[Foo << T]
    implicitly[Baz << T]
    implicitly[Boo << T]

    val b = Baz(42)

    val u: Union[T, Int] = implicitly[Member[Baz, T]].inj(b)
    val u2: Union[T, Int] = inj(b)
  }


  // section 2.5
  // -----------
  // use type level open unions.
  object step5 {
    import typelevel._
    import Member._
    import TList._

    sealed trait Free[R <: TList, A]
    case class Pure[R <: TList, A](value: A) extends Free[R, A]
    case class Impure[R <: TList, A, X](u: Union[R, X], k: X => Free[R, A]) extends Free[R, A]

    implicit def freeMonad[R <: TList]: Monad[Free[R, ?]] = ???

    sealed trait Reader[I, X]
    case class Get[I]() extends Reader[I, I]

    sealed trait Writer[O, X]
    case class Put[O](o: O) extends Writer[O, Unit]

    // sadly the type annotations in the implementation are necessary
    def ask[I, R <: TList : (Reader[I, ?] << ?)]: Free[R, I] =
      Impure(inj[Reader[I, ?], R, I](Get()), unit[I, Free[R, ?]])

    // hey, but this one does not need any annotations! (not even the result type)
    def addGet[R <: TList : (Reader[Int, ?] << ?)](x: Int): Free[R, Int] =
      ask map { i => i + x }
  }



  // type aligned continuation queue:
  object typealigned {

    sealed trait TAView[M[_], A, B]
    case class Last[M[_], A, B](k: A => M[B]) extends TAView[M, A, B]
    case class <|[M[_], A, B, X](k: A => M[X], q: TAQueue[M, X, B]) extends TAView[M, A, B]

    trait TAQueue[M[_], A, B] {
      def :+[C](k: B => M[C]): TAQueue[M, A, C] = this ++ TAQueue(k)
      def ++[C](other: TAQueue[M, B, C]): TAQueue[M, A, C] = Node(this, other)
      def dequeue: TAView[M, A, B]
    }
    object TAQueue {
      def apply[M[_], A, B](k: A => M[B]): TAQueue[M, A, B] = Leaf(k)
    }
    case class Leaf[M[_], A, B](k: A => M[B]) extends TAQueue[M, A, B] {
      def dequeue = Last(k)
    }
    case class Node[M[_], A, B, X](q1: TAQueue[M, A, X], q2: TAQueue[M, X, B]) extends TAQueue[M, A, B] {
      def dequeue: TAView[M, A, B] = q1.dequeue match {
        case Last(k)  => <|(k, q2)
        case k <| q3  => <|(k, Node(q3, q2))
      }
    }
  }

  // section 3.1
  // -----------
  // Use a type aligned continuation queue
  object step6 {
    import typelevel._
    import Member._
    import TList._
    import typealigned._

    sealed trait Eff[R <: TList, A]
    case class Pure[R <: TList, A](a: A) extends Eff[R, A]
    case class Impure[R <: TList, A, X](u: Union[R, X], k: Arrs[R, X, A]) extends Eff[R, A]

    // an arrow in the kleisli category of effects
    type Arr[R <: TList, A, B] = A => Eff[R, B]
    type Arrs[R <: TList, A, B] = TAQueue[Eff[R, ?], A, B]

    implicit def monad[R <: TList]: Monad[Eff[R, ?]] = new Monad[Eff[R, ?]] {
      def unit[A](value: A) = Pure(value)
      def flatMap[A, B](ma: Eff[R, A], f: A => Eff[R, B]): Eff[R, B] = ma match {
        case Pure(a) => f(a)
        case Impure(fa, k) => Impure(fa, k :+ f)
      }
    }


    def singleK[R <: TList, A, B]: Arr[R, A, B] => Arrs[R, A, B] =
      Leaf.apply

    // applies x to the queue q and prefixes the new effects (if any)
    def qApp[R <: TList, B, W]: Arrs[R, B, W] => B => Eff[R, W] = q => x =>
      q.dequeue match {
        case Last(k) => k(x)
        case k <| q  => k(x) match {
          case Pure(y)      => qApp(q)(y)
          case Impure(u, k) => Impure(u, k ++ q)
        }
      }

    def qComp[R <: TList, R2 <: TList, A, B, C]:
      Arrs[R, A, B] => (Eff[R, B] => Eff[R2, C]) => Arr[R2, A, C] = g => h =>
        h compose qApp(g)

    implicit def send[F[_], A, R <: TList : (F << ?)](fa: F[A]): Eff[R, A] =
      Impure[R, A, A](inj(fa), TAQueue[Eff[R, ?], A, A](unit[A, Eff[R, ?]]))


    sealed trait Reader[I, X]
    case class Get[I]() extends Reader[I, I]

    sealed trait Writer[O, X]
    case class Put[O](o: O) extends Writer[O, Unit]

    // Even after resolving SI 2712 this cannot be inferred.
    def ask[I, R <: TList : (Reader[I, ?] << ?)]: Eff[R, I] =
      send[Reader[I, ?], I, R](Get())

    def addGet[R <: TList : (Reader[Int, ?] << ?)](x: Int): Eff[R, Int] =
      ask map { i => i + x }

    /// --- interpreters ---

    // peel of first effect, if it is reader.
    def runReader[I, R <: TList, A](i: I): Eff[Reader[I, ?] :: R, A] => Eff[R, A] = {
      case Pure(x)      => Pure(x)

      // this is unchecked, but necessary for the left branch
      case im: Impure[_, _, I] =>
        decomp(im.u) match {
          case Left(Get()) => runReader[I, R, A](i).apply(qApp(im.k)(i))
          case Right(u) => Impure(u, Leaf(qComp(im.k)(runReader(i))))
        }
    }

    def run[A]: Eff[TNil, A] => A = {
      case Pure(x) => x
      // scala type checker cannot figure out that this case can never happen.
      case Impure(_,_) => sys error "cannot happen"
    }

    def prog[R <: TList : (Reader[Int, ?] << ?)]: Eff[R, Int] =
      addGet[R](2) >>= addGet[R] >>= addGet[R] >>= addGet[R]

    // should yield (2 + 42 * 4) = 170
    println(run(runReader[Int, TNil, Int](42).apply(prog)))
  }
}