Compositional application architecture with reasonably priced monads

gistfile1.scala

sealed trait Interact[A]

case class Ask(prompt: String)
  extends Interact[String]

case class Tell(msg: String)
  extends Interact[Unit]

trait Monad[M[_]] {
  def pure[A](a: A): M[A]
  def flatMap[A,B](a: M[A])(f: A => M[B]): M[B]
}

object Monad {
  def apply[F[_]:Monad]: Monad[F] = implicitly[Monad[F]]
}

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

  def or[H[_]](f: H ~> G): ({ type f[x] = Coproduct[F, H, x]})#f ~> G =
    new (({type f[x] = Coproduct[F,H,x]})#f ~> G) {
      def apply[A](c: Coproduct[F,H,A]): G[A] = c.run match {
        case Left(fa) => self(fa)
        case Right(ha) => f(ha)
      }
    }
}

sealed trait Free[F[_],A] {
  def flatMap[B](f: A => Free[F,B]): Free[F,B] =
    this match {
      case Return(a) => f(a)
      case Bind(fx, g) =>
        Bind(fx, g andThen (_ flatMap f))
    }

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

  def foldMap[G[_]:Monad](f: F ~> G): G[A] =
    this match {
      case Return(a) => Monad[G].pure(a)
      case Bind(fx, g) =>
        Monad[G].flatMap(f(fx)) { a =>
	        g(a).foldMap(f)
        }
      }
}


case class Return[F[_],A](a: A)
  extends Free[F,A]

case class Bind[F[_],I,A](
  a: F[I],
  f: I => Free[F,A]) extends Free[F,A]

//implicit def lift[F[_],A](f: F[A]): Free[F,A] =
//  Bind(f, (a: A) => Return(a))

//val prg = for {
//  first <- Ask("What’s your first name?")
//  last  <- Ask("What's your last name?")
//  _     <- Tell(s"Hello, $first, $last!")
//} yield ()

type Id[A] = A

implicit val identityMonad: Monad[Id] = new Monad[Id] {
  def pure[A](a: A) = a
  def flatMap[A,B](a: A)(f: A => B) = f(a)
}

object Console extends (Interact ~> Id) {
  def apply[A](i: Interact[A]) = i match {
    case Ask(prompt) =>
      println(prompt)
      readLine
    case Tell(msg) =>
      println(msg)
  }
}

type Tester[A] =
  Map[String, String] => (List[String], A)

object TestConsole extends (Interact ~> Tester) {
  def apply[A](i: Interact[A]) = i match {
    case Ask(prompt) => m => (List(), m(prompt))
    case Tell(msg) => _ => (List(msg), ())
  }
}

implicit val testerMonad = new Monad[Tester] {
  def pure[A](a: A) = _ => (List(), a)
  def flatMap[A,B](t: Tester[A])(f: A => Tester[B]) =
    m => {
      val (o1, a) = t(m)
      val (o2, b) = f(a)(m)
      (o1 ++ o2, b)
    }
}

type UserID = String
type Password = String
type Permission = String
case class User(id: String)

sealed trait Auth[A]

case class Login(u: UserID, p: Password) extends Auth[Option[User]]

case class HasPermission(
  u: User, p: Permission) extends Auth[Boolean]

case class Coproduct[F[_],G[_],A](run: Either[F[A],G[A]])

sealed trait Inject[F[_],G[_]] {
  def inj[A](sub: F[A]): G[A]
  def prj[A](sup: G[A]): Option[F[A]]
}

object Inject {
  implicit def injRefl[F[_]] = new Inject[F,F] {
    def inj[A](sub: F[A]) = sub
    def prj[A](sup: F[A]) = Some(sup)
  }

  implicit def injLeft[F[_],G[_]] = new Inject[F,({type λ[α] = Coproduct[F,G,α]})#λ] {
    def inj[A](sub: F[A]) = Coproduct(Left(sub))
    def prj[A](sup: Coproduct[F,G,A]) = sup.run match {
      case Left(fa) => Some(fa)
      case Right(_) => None
    }
  }

  implicit def injRight[F[_],G[_],H[_]](implicit I: Inject[F,G]) =
    new Inject[F,({type f[x] = Coproduct[H,G,x]})#f] {
      def inj[A](sub: F[A]) = Coproduct(Right(I.inj(sub)))
      def prj[A](sup: Coproduct[H,G,A]) = sup.run match {
        case Left(_) => None
        case Right(x) => I.prj(x)
    }
  }
}

def lift[F[_],G[_],A](f: F[A])(implicit I: Inject[F,G]): Free[G,A] =
  Bind(I.inj(f), Return(_:A))

class Interacts[F[_]](implicit I: Inject[Interact,F]) {
  def tell(msg: String): Free[F,Unit] = lift(Tell(msg))
  def ask(prompt: String): Free[F,String] = lift(Ask(prompt))
}

class Auths[F[_]](implicit I: Inject[Auth,F]) {
  def login(id: UserID, pwd: Password): Free[F,Option[User]] =
    lift(Login(id, pwd))
  def hasPermission(u: User, p: Permission): Free[F,Boolean] =
    lift(HasPermission(u, p))
}

object Auths {
  implicit def instance[F[_]](implicit I: Inject[Auth,F]): Auths[F] = new Auths[F]
}

object Interacts {
  implicit def instance[F[_]](implicit I: Inject[Interact,F]): Interacts[F] = new Interacts[F]
}

val KnowSecret = "KnowSecret"

def prg[F[_]](implicit I: Interacts[F], A: Auths[F]) = {
  import I._; import A._
  for {
    uid <- ask("What's your user ID?")
    pwd <- ask("Password, please.")
    u <- login(uid, pwd)
    b <- u.map(hasPermission(_, KnowSecret)).getOrElse(Return(false))
    _ <- if (b) tell("UUDDLRLRBA") else tell("Go away!")
  } yield ()
}

type App[A] = Coproduct[Auth, Interact, A]

val app: Free[App, Unit] = prg[App]

val TestAuth: Auth ~> Id = new (Auth ~> Id) {
  def apply[A](a: Auth[A]) = a match {
    case Login(uid, pwd) =>
      if (uid == "john.snow" && pwd == "Ghost")
        Some(User("john.snow"))
      else None
    case HasPermission(u, _) =>
      u.id == "john.snow"
  }
}

def runApp = app.foldMap(TestAuth or Console)

Hey Rúnar, thanks again for your talk at Scala Days, really inspired me. Would you be willing to look at this version?

It allows you to compose languages without having to lift them manually. It could save some boilerplate for the programmers using the free monads to compose their applications.

It is probably not a real monad anymore because the flatMap method is now also transforming F to a combination of F and G: def flatMap[G[_], B](f: A => Free[G, B]):Free[combined.Out, B] My knowledge of the theory behind monads is very limited.

I would really appreciate your comments.

I have reverted the flatMap to def flatMap[B](f:A => Free[F, B):Free[F, B] and moved the combining code into a class called Program which combines flatMap and mapSuspension.

How cool!

After 19 years the first code written in Scala I see that vastly improves
my code written in Gofer (pre Haskell) of
my paper http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.11.7093&rep=rep1&type=pdf

Probably similar Haskell code exist as well but I did not follow up the Haskell community

here's a Scalaz version: https://github.com/stew/reasonably-priced (wish I had found this before hours of fruitless hacking >_<)

What's the purpose of def prj[A](sup: G[A]): Option[F[A]]?

I also have done my exploration.... petomat/reasonably-priced

I have read this only now and find it really cool and inspiring - thank you Rúnar (also estolua for the scalaz-version)

Implemented a petomat's version with scalaz 7.1.4 turtlecoder/reasonably-priced

Here's a version that abstracts over any type mechanics and reduces almost all of the boilerplate, at the cost of explicitly committing to a given instance of Free per program definition - https://github.com/mblink/composefree