|
|
@@ -0,0 +1,199 @@ |
|
|
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[_]] { |
|
|
def apply[A](f: F[A]): G[A] |
|
|
|
|
|
def or[H[_]](f: F ~> H, g: G ~> H): ({ type f[x] = Coproduct[F, G, x]})#f ~> H = |
|
|
new (({ type f[x] = Coproduct[F, G, x]})#f ~> H) { |
|
|
def apply[A](c: Coproduct[F,G,A]): H[A] = c.run match { |
|
|
case Left(fa) => f(fa) |
|
|
case Right(ga) => g(ga) |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
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 TestConsole) |
runarorama revised this gist