Free Monad from scratch

April 27, 2017

Prerequisites

Natural transformation and Monad interfaces:

trait ~>[F[_], G[_]] {
  def apply[A](f: F[A]): G[A]
}

trait Monad[F[_]] {
  def pure[A](a: A): F[A]
  def bind[A,B](fa: F[A])(f: A => F[B]): F[B]
}

Free Monad

sealed trait Free[F[_], A] {

  import Free._

  def map[B](f: A => B): Free[F, B] = flatMap { a => pure(f(a)) }

  def flatMap[B](f: A => Free[F, B]): Free[F, B] = Bind(this, f)

  def foldMap[G[_]: Monad](nt: F ~> G): G[A] = this match {
    case Pure(a) => implicitly[Monad[G]].pure(a)
    case Suspend(fa) => nt(fa)
    case Bind(fa, f) => val mg = implicitly[Monad[G]]
                        val ga = fa.foldMap(nt)
                        mg.bind(ga)(f(_).foldMap(nt))
  }

}

object Free {

  def pure[F[_], A](a: A): Free[F, A] = Pure(a)

  def liftM[F[_], A](fa: F[A]): Free[F, A] = Suspend(fa)

  final case class Pure[F[_], A](a: A) extends Free[F, A]
  final case class Suspend[F[_], A](fa: F[A]) extends Free[F, A]
  final case class Bind[F[_], A, B]( fa: Free[F, A]
                                   , f: A => Free[F, B]
                                   ) extends Free[F, B]
}

Demo

type ID[A] = A

implicit object MonadID extends Monad[ID] {
  def pure[A](a: A): ID[A] = a
  def bind[A,B](fa: ID[A])(f: A => ID[B]): ID[B] = f(fa)
}

sealed trait Console[A]
case class Print(x: String) extends Console[Unit]
case object ReadLn extends Console[String]

val program: Free[Console, Unit] =
  for {
    _     <- Free.liftM(Print("First name: "))
    first <- Free.liftM(ReadLn)
    _     <- Free.liftM(Print("Last name: "))
    last  <- Free.liftM(ReadLn)
    _     <- Free.liftM(Print(s"Hello, $first $last!\n"))
  } yield ()

program.foldMap[ID](new ~>[Console, ID]{
  def apply[A](c: Console[A]): ID[A] =
    c match {
      case Print(x) => print(x)
      case ReadLn => readLine
    }
})