Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Compositional application architecture with reasonably priced monads
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)
@EECOLOR
EECOLOR commented Jun 29, 2014

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.

@EECOLOR
EECOLOR commented Jun 30, 2014

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.

@LucDupAtGitHub

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

@estolua
estolua commented Nov 26, 2014

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

@petomat
petomat commented Aug 4, 2015

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

@petomat
petomat commented Aug 4, 2015

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

@Galy1
Galy1 commented Sep 28, 2015

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

@turtlecoder

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

@beezee
beezee commented Jul 29, 2016

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

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