Create a gist now

Instantly share code, notes, and snippets.

Embed
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

This comment has been minimized.

Show comment
Hide comment
@EECOLOR

EECOLOR 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 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

This comment has been minimized.

Show comment
Hide comment
@EECOLOR

EECOLOR 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.

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

This comment has been minimized.

Show comment
Hide comment
@LucDupAtGitHub

LucDupAtGitHub Sep 26, 2014

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

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

This comment has been minimized.

Show comment
Hide comment
@estolua

estolua Nov 26, 2014

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

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

This comment has been minimized.

Show comment
Hide comment
@petomat

petomat Aug 4, 2015

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

petomat commented Aug 4, 2015

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

@petomat

This comment has been minimized.

Show comment
Hide comment
@petomat

petomat Aug 4, 2015

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

petomat commented Aug 4, 2015

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

@Galy1

This comment has been minimized.

Show comment
Hide comment
@Galy1

Galy1 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)

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

This comment has been minimized.

Show comment
Hide comment
@turtlecoder

turtlecoder Sep 30, 2015

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

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

@beezee

This comment has been minimized.

Show comment
Hide comment
@beezee

beezee 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

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