Skip to content

Instantly share code, notes, and snippets.

@stliang
Forked from runarorama/gist:a8fab38e473fafa0921d
Created December 12, 2015 02:11
Show Gist options
  • Save stliang/7a0b2129252608b32cb7 to your computer and use it in GitHub Desktop.
Save stliang/7a0b2129252608b32cb7 to your computer and use it in GitHub Desktop.
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment