Scalaz（40）－ Free ：versioned up，再回顾
在上一篇讨论里我在设计示范例子时遇到了一些麻烦。由于Free Monad可能是一种主流的FP编程规范，所以在进入实质编程之前必须把所有东西都搞清楚。前面遇到的问题主要与scalaz Free的FreeC类型有关系。这个类型主要是针对一些非Functor的F[A]特别设计的。FreeC是Coyoneda[F,A]的Free Monad类型，任何F[A]都可以被转换成Coyoneda[F,A]，而Coyoneda[F,A]本身是个Functor。因为我们通常都在Functor和非Functor ADT混合应用环境下，所以倾向于通用一些的类型和结构，特别是使用联合语句Coproduct时是不容许不同Free类型的。所以在前面的示范程序里我们只能选用scalaz提供的基于Coyoneda的类型FreeC、升格函数liftFC、及运算函数runFC。最头疼的是使用Coproduct时：Inject的目标语句集G[_]是后置的，在Inject时是否Functor还不明确：
def lift[F[_],G[_],A](fa: F[A])(implicit I: Inject[F,G]): Free.FreeC[G,A] = Free.liftFC(I.inj(fa))
由于G[_]是否Functor还不明确，唯一选项也就只能是liftFC了。实际上造成FreeC类型麻烦的根本是Free[S[_],A]类型其中一个实例case class Suspend[S[_],A](s: S[Free[S,A]])，这个实例必须用monad的join来运算，因而要求S必须是个Functor，所以这个版本的Free被称为Free for Functor。另一个原因可能是scalaz借鉴了haskell的实现方式。无论如何，为了解决我们遇到的问题，必须想办法绕过S必须是Functor这个门槛。在查找相关资料时发现Cats的Free里根本没有FreeC这个类型。当然也就没有liftFC这么个升格函数了。Cats Free的Suspend形式是不同的：case class Suspend[F[_],A](s: F[A])，这正是我们所想得到的方式。正想着如何用Cats的Free来替代scalaz Free时才发现最新scalaz版本722（前面我一直使用是scalaz v7.1）里面的Free结构定义竟然已经升级了，看来许多其他的scalaz使用者都应该遇到了相同的麻烦。研究了一下前后两个版本的Free结构定义后发现实际上我们可以用另一个方式来代表Free结构：scalaz/Free.scala
sealed abstract class Free[S[_], A] {
final def map[B](f: A => B): Free[S, B] =
flatMap(a => Return(f(a)))
/** Alias for `flatMap` */
final def >>=[B](f: A => Free[S, B]): Free[S, B] = this flatMap f
/** Binds the given continuation to the result of this computation. */
final def flatMap[B](f: A => Free[S, B]): Free[S, B] = gosub(this)(f)
...
/** Return from the computation with the given value. */
private case class Return[S[_], A](a: A) extends Free[S, A]
/** Suspend the computation with the given suspension. */
private case class Suspend[S[_], A](a: S[A]) extends Free[S, A]
/** Call a subroutine and continue with the given function. */
private sealed abstract case class Gosub[S[_], B]() extends Free[S, B] {
type C
val a: Free[S, C]
val f: C => Free[S, B]
}
private def gosub[S[_], B, C0](a0: Free[S, C0])(f0: C0 => Free[S, B]): Free[S, B] =
new Gosub[S, B] {
type C = C0
val a = a0
val f = f0
}
上面这段可以用更简单的方式表达，与下面的结构定义相同：
1 trait Free[S[_],A]
2 case class Return[S[_],A](a: A) extends Free[S,A]
3 case class FlatMap[S[_],A,B](fa: Free[S,A], f: A => Free[S,B]) extends Free[S,B]
4 case class Suspend[S[_],A](s: S[A]) extends Free[S,A]
我们把Suspend(S[Free[S,A]])变成Suspend(S[A])，增加了一个实例FlatMap。现在这个Suspend状态代表了一步运算，FlatMap状态代表连续运算，FlatMap和Suspend(S[A])加在一起可以替代Suspend(S[Free[S,A]])状态。我们知道Suspend的主要意义是在于对Free结构进行Interpret时对存放在内存里的各种状态进行运算时：如果是Return返回结果、FlatMap是连续运算，那么Suspend就扮演着Free[S,A] => M[A]这么个函数角色了。分析上面的代码不难发现FlatMap就是Gusub。
好了，现在有了这个Suspend我们可以很方便的把任何F[A]升格成Free，这是v722的liftF函数：
/** Suspends a value within a functor in a single step. Monadic unit for a higher-order monad. */
def liftF[S[_], A](value: S[A]): Free[S, A] =
Suspend(value)
上面的描述不正确：a value within a functor 应该是 a value within a type constructor。
在上次的示范例子中遗留下来最需要解决的问题是如何实现多于两种ADT联合语句集的编程，这还是由于联合语句集G[_]是后置的原因。上次遇到的具体问题是无法识别多于两个隐式参数（implicit parameter）、无法编译多于两层的Coproduct、及无法运算（interpret）多于两种联合语句集。在下面我们试试用scalaz722然后设计一套新的编程规范来编写一个由三种ADT组成的Monadic程序：
1、ADTs:
1 object FreeADTs {
2 sealed trait Interact[+NextFree]
3 case class Ask[NextFree](prompt: String, onInput: String => NextFree) extends Interact[NextFree]
4 case class Tell[NextFree](msg: String, next: NextFree) extends Interact[NextFree]
5 sealed trait InteractInstances {
6 object InteractFunctor extends Functor[Interact] {
7 def map[A,B](ia: Interact[A])(f: A => B): Interact[B] = ia match {
8 case Ask(prompt,input) => Ask(prompt, input andThen f)
9 case Tell(msg,next) => Tell(msg, f(next))
10 }
11 }
12 }
13 sealed trait InteractFunctions {
14 def ask[G[_],A](p: String, f: String => A)(implicit I: Inject[Interact,G]): Free[G,A] =
15 Free.liftF(I.inj(Ask(p,f)))
16 def tell[G[_],A](m: String)(implicit I: Inject[Interact,G]): Free[G,Unit] =
17 Free.liftF(I.inj(Tell(m,Free.pure(()))))
18 }
19 object Interacts extends InteractInstances with InteractFunctions
20 }
如上所述，我们采用了一种 xxx trait, xxxInstances, xxxFunctions, xxxs 规范。
2、ASTs:
1 object FreeASTs {
2 import FreeADTs._
3 import Interacts._
4 val interactScript = for {
5 first <- ask("what's your first name?",identity)
6 last <- ask("your last name?",identity)
7 _ <- tell(s"hello, $first $last")
8 } yield ()
9 }
3、Interpreter:
1 object FreeInterps {
2 import FreeADTs._
3 object InteractConsole extends (Interact ~> Id) {
4 def apply[A](ia: Interact[A]): Id[A] = ia match {
5 case Ask(p,onInput) => println(p); onInput(readLine)
6 case Tell(m,n) => println(m); n
7 }
8 }
9 }
4、运行：
1 object FreePrgDemo extends App {
2 import FreeASTs._
3 import FreeInterps._
4 interactScript.foldMapRec(InteractConsole)
5 }
我们在这里调用了新版本scalaz Free里的foldMapRec函数：
final def foldMapRec[M[_]](f: S ~> M)(implicit M: Applicative[M], B: BindRec[M]): M[A] =
B.tailrecM[Free[S, A], A]{
_.step match {
case Return(a) => M.point(\/-(a))
case Suspend(t) => M.map(f(t))(\/.right)
case b @ Gosub() => (b.a: @unchecked) match {
case Suspend(t) => M.map(f(t))(a => -\/(b.f(a)))
}
}
}(this)
foldMapRec又调用了BindRec typeclass的tailrecM函数：
/**
* [[scalaz.Bind]] capable of using constant stack space when doing recursive
* binds.
*
* Implementations of `tailrecM` should not make recursive calls without the
* `@tailrec` annotation.
*
* Based on Phil Freeman's work on stack safety in PureScript, described in
* [[http://functorial.com/stack-safety-for-free/index.pdf Stack Safety for
* Free]].
*/
////
trait BindRec[F[_]] extends Bind[F] { self =>
////
def tailrecM[A, B](f: A => F[A \/ B])(a: A): F[B]
这个BindRec typeclass可以保证递归运算的堆栈安全。在Free.scala里可以找到BindRec的实例，它具体实现了这个tailrecM函数：
sealed abstract class FreeInstances extends FreeInstances0 with TrampolineInstances with SinkInstances with SourceInstances {
implicit def freeMonad[S[_]]: Monad[Free[S, ?]] with BindRec[Free[S, ?]] =
new Monad[Free[S, ?]] with BindRec[Free[S, ?]] {
override def map[A, B](fa: Free[S, A])(f: A => B) = fa map f
def bind[A, B](a: Free[S, A])(f: A => Free[S, B]) = a flatMap f
def point[A](a: => A) = Free.point(a)
// Free trampolines, should be alright to just perform binds.
def tailrecM[A, B](f: A => Free[S, A \/ B])(a: A): Free[S, B] =
f(a).flatMap(_.fold(tailrecM(f), point(_)))
}
...
有了foldMapRec我们可以放心运算任何规模的AST。下面是运行结果样本：
what's your first name?
tiger
your last name?
chan
hello, tiger chan
现在我们再示范两种ADT的联合语句集编程：
1、ADTs: 增加一个非Functor的ADT UserLogin
1 sealed trait UserLogin[+A] //非Functor 高阶类
2 case class CheckId(uid: String) extends UserLogin[Boolean]
3 case class Login(uid: String, pswd: String) extends UserLogin[Boolean]
4 sealed trait LoginFunctions {
5 def checkId[G[_]](uid: String)(implicit I: Inject[UserLogin,G]): Free[G,Boolean] =
6 Free.liftF(I.inj(CheckId(uid)))
7 def login[G[_]](uid: String, pswd: String)(implicit I: Inject[UserLogin, G]): Free[G,Boolean] =
8 Free.liftF(I.inj(Login(uid,pswd)))
9 }
10 object Logins extends LoginFunctions
2、ASTs：
1 import Logins._
2 type InteractLogin[A] = Coproduct[Interact,UserLogin,A]
3 val loginScript = for {
4 uid <- ask[InteractLogin,String]("what's you id?",identity)
5 idok <- checkId[InteractLogin](uid)
6 _ <- if (idok) tell[InteractLogin](s"hi, $uid") else tell[InteractLogin]("sorry, don't know you!")
7 pwd <- if (idok) ask[InteractLogin,String](s"what's your password?",identity)
8 else Free.point[InteractLogin,String]("")
9 login <- if (idok) login[InteractLogin](uid,pwd)
10 else Free.point[InteractLogin,Boolean](false)
11 _ <- if (login) tell[InteractLogin](s"congratulations，$uid")
12 else tell[InteractLogin](idok ? "sorry, no pass!" | "")
13 } yield login
UserLogin需要验证用户编号和密码，我们通过依赖注入来提供验证功能：
1 object Dependencies {
2 trait UserControl {
3 val pswdMap: Map[String,String]
4 def validateId: Boolean
5 def validatePassword: Boolean
6 }
7 }
3、Interpreter：需要用Reader来注入UserControl依赖。现在的AST是个两种ADT的联合语句集，所以需要符合类型的语法解析函数，并且两种ADT的最终运算环境（context）必须一致用Reader：
1 import Dependencies._
2 type AuthReader[A] = Reader[UserControl,A]
3 object InteractLogin extends (Interact ~> AuthReader) {
4 def apply[A](ia: Interact[A]): AuthReader[A] = ia match {
5 case Ask(p,onInput) => println(p); Reader {m => onInput(readLine)}
6 case Tell(msg,n) => println(msg); Reader {m => n}
7 }
8 }
9 object LoginConsole extends (UserLogin ~> AuthReader) {
10 def apply[A](ua: UserLogin[A]): AuthReader[A] = ua match {
11 case CheckId(uid) => Reader {m => m.validateId(uid)}
12 case Login(uid,pwd) => Reader {m => m.validatePassword(uid, pwd)}
13 }
14 }
15 def or[F[_],H[_],G[_]](f: F~>G, h: H~>G) =
16 new (({type l[x] = Coproduct[F,H,x]})#l ~> G) {
17 def apply[A](ca: Coproduct[F,H,A]):G[A] = ca.run match {
18 case -\/(fg) => f(fg)
19 case \/-(hg) => h(hg)
20 }
21 }
4、运算时把依赖注入：
1 object FreeDemo extends App {
2 import FreeASTs._
3 import FreeInterps._
4 import Dependencies._
5 object AuthControl extends UserControl {
6 val pswdMap = Map (
7 "Tiger" -> "1234",
8 "John" -> "0000"
9 )
10 override def validateId(uid: String) =
11 pswdMap.getOrElse(uid,"???") /== "???"
12 override def validatePassword(uid: String, pswd: String) =
13 pswdMap.getOrElse(uid, pswd+"!") === pswd
14 }
15
16 loginScript.foldMapRec(or(InteractLogin,LoginConsole)).run(AuthControl)
下面是一些测试运行结果：
what's you id?
Tiger
hi, Tiger
what's your password?
0123
sorry, no pass!
...
what's you id?
foo
sorry, don't know you!
...
what's you id?
Tiger
hi, Tiger
what's your password?
1234
congratulations，Tiger
下面我们在这个基础上再增加一个ADT：Permission
1、ADTs:
1 sealed trait Permission[+A]
2 case class HasPermission(uid: String, acc: Int) extends Permission[Boolean]
3 sealed trait PermissionFunctions {
4 def hasPermission[G[_]](uid: String, acc: Int)(implicit I: Inject[Permission,G]): Free[G,Boolean] =
5 Free.liftF(I.inj(HasPermission(uid,acc)))
6 }
7 object Permissions extends PermissionFunctions
2、ASTs:
1 import Permissions._
2 type InteractLoginPermission[A] = Coproduct[Permission,InteractLogin,A]
3 type T[A] = InteractLoginPermission[A]
4 val authScript = for {
5 uid <- ask[T,String]("what's you id?",identity)
6 idok <- checkId[T](uid)
7 _ <- if (idok) tell[T](s"hi, $uid")
8 else tell[T]("sorry, don't know you!")
9 pwd <- if (idok) ask[T,String](s"what's your password?",identity)
10 else Free.point[T,String]("")
11 login <- if (idok) login[T](uid,pwd)
12 else Free.point[T,Boolean](false)
13 _ <- if (login) tell[T](s"congratulations，$uid")
14 else tell[T](idok ? "sorry, no pass!" | "")
15 acc <- if (login) ask[T,Int](s"what's your access code, $uid?",_.toInt)
16 else Free.point[T,Int](0)
17 perm <- if (login) hasPermission[T](uid,acc)
18 else Free.point[T,Boolean](false)
19 _ <- if (perm) tell[T](s"you may use the system，$uid")
20 else tell[T]((idok && login) ? "sorry, you are banned!" | "")
21
22 } yield ()
这次我们还要通过依赖来验证用户权限Permission，所以需要调整Dependencies：
1 object Dependencies {
2 trait UserControl {
3 val pswdMap: Map[String,String]
4 def validateId(uid: String): Boolean
5 def validatePassword(uid: String, pswd: String): Boolean
6 }
7 trait AccessControl {
8 val accMap: Map[String, Int]
9 def grandAccess(uid: String, acc: Int): Boolean
10 }
11 trait Authenticator extends UserControl with AccessControl
12 }
增加了AccessControl，然后用Authenticator统一它们
3、Interpreters：
1 import Dependencies._
2 type AuthReader[A] = Reader[Authenticator,A]
3 object InteractLogin extends (Interact ~> AuthReader) {
4 def apply[A](ia: Interact[A]): AuthReader[A] = ia match {
5 case Ask(p,onInput) => println(p); Reader {m => onInput(readLine)}
6 case Tell(msg,n) => println(msg); Reader {m => n}
7 }
8 }
9 object LoginConsole extends (UserLogin ~> AuthReader) {
10 def apply[A](ua: UserLogin[A]): AuthReader[A] = ua match {
11 case CheckId(uid) => Reader {m => m.validateId(uid)}
12 case Login(uid,pwd) => Reader {m => m.validatePassword(uid, pwd)}
13 }
14 }
15 // type AccessReader[A] = Reader[AccessControl,A]
16 object PermConsole extends (Permission ~> AuthReader) {
17 def apply[A](pa: Permission[A]): AuthReader[A] = pa match {
18 case HasPermission(uid,acc) => Reader {m => m.grandAccess(uid, acc)}
19 }
20 }
21 def or[F[_],H[_],G[_]](f: F~>G, h: H~>G) =
22 new (({type l[x] = Coproduct[F,H,x]})#l ~> G) {
23 def apply[A](ca: Coproduct[F,H,A]):G[A] = ca.run match {
24 case -\/(fg) => f(fg)
25 case \/-(hg) => h(hg)
26 }
27 }
28 def among3[F[_],H[_],K[_],G[_]](f: F~>G, h: H~>G, k: K~>G) = {
29 type FH[A] = Coproduct[F,H,A]
30 type KFH[A] = Coproduct[K,FH,A]
31 new (({type l[x] = Coproduct[K,FH,x]})#l ~> G) {
32 def apply[A](kfh: KFH[A]): G[A] = kfh.run match {
33 case -\/(kg) => k(kg)
34 case \/-(cfh) => cfh.run match {
35 case -\/(fg) => f(fg)
36 case \/-(hg) => h(hg)
37 }
38 }
39 }
40 }
调整了依赖类型。增加三种ADT语句集解析函数among3。
4、运算：
1 object FreeDemo extends App {
2 import FreeASTs._
3 import FreeInterps._
4 import Dependencies._
5 object AuthControl extends Authenticator {
6 val pswdMap = Map (
7 "Tiger" -> "1234",
8 "John" -> "0000"
9 )
10 override def validateId(uid: String) =
11 pswdMap.getOrElse(uid,"???") /== "???"
12 override def validatePassword(uid: String, pswd: String) =
13 pswdMap.getOrElse(uid, pswd+"!") === pswd
14
15 val accMap = Map (
16 "Tiger" -> 8,
17 "John" -> 0
18 )
19 override def grandAccess(uid: String, acc: Int) =
20 accMap.getOrElse(uid, -1) > acc
21 }
22 authScript.foldMapRec(among3(InteractLogin,LoginConsole,PermConsole)).run(AuthControl)
23 // loginScript.foldMapRec(or(InteractLogin,LoginConsole)).run(AuthControl)
24 // interactScript.foldMapRec(InteractConsole)
25
26 }
运算结果：
what's you id?
Tiger
hi, Tiger
what's your password?
1234
congratulations，Tiger
what's your access code, Tiger?
3
you may use the system，Tiger
Beautiful! 下面是本文示范的完整代码：
1 package demo.app
2 import scalaz._
3 import Scalaz._
4 import scala.language.implicitConversions
5 import scala.language.higherKinds
6 import com.sun.beans.decoder.FalseElementHandler
7 import java.rmi.server.UID
8
9 object FreeADTs {
10 sealed trait Interact[NextFree]
11 case class Ask[NextFree](prompt: String, onInput: String => NextFree) extends Interact[NextFree]
12 case class Tell[NextFree](msg: String, next: NextFree) extends Interact[NextFree]
13 sealed trait InteractInstances {
14 object InteractFunctor extends Functor[Interact] {
15 def map[A,B](ia: Interact[A])(f: A => B): Interact[B] = ia match {
16 case Ask(prompt,input) => Ask(prompt, input andThen f)
17 case Tell(msg,next) => Tell(msg, f(next))
18 }
19 }
20 }
21 sealed trait InteractFunctions {
22 def ask[G[_],A](p: String, f: String => A)(implicit I: Inject[Interact,G]): Free[G,A] =
23 Free.liftF(I.inj(Ask(p,f)))
24 def tell[G[_]](m: String)(implicit I: Inject[Interact,G]): Free[G,Unit] =
25 Free.liftF(I.inj(Tell(m,Free.pure(()))))
26 }
27 object Interacts extends InteractInstances with InteractFunctions
28
29 sealed trait UserLogin[+A] //非Functor 高阶类
30 case class CheckId(uid: String) extends UserLogin[Boolean]
31 case class Login(uid: String, pswd: String) extends UserLogin[Boolean]
32 sealed trait LoginFunctions {
33 def checkId[G[_]](uid: String)(implicit I: Inject[UserLogin,G]): Free[G,Boolean] =
34 Free.liftF(I.inj(CheckId(uid)))
35 def login[G[_]](uid: String, pswd: String)(implicit I: Inject[UserLogin, G]): Free[G,Boolean] =
36 Free.liftF(I.inj(Login(uid,pswd)))
37 }
38 object Logins extends LoginFunctions
39 sealed trait Permission[+A]
40 case class HasPermission(uid: String, acc: Int) extends Permission[Boolean]
41 sealed trait PermissionFunctions {
42 def hasPermission[G[_]](uid: String, acc: Int)(implicit I: Inject[Permission,G]): Free[G,Boolean] =
43 Free.liftF(I.inj(HasPermission(uid,acc)))
44 }
45 object Permissions extends PermissionFunctions
46 }
47 object FreeASTs {
48 import FreeADTs._
49 import Interacts._
50 val interactScript = for {
51 first <- ask("what's your first name?",identity)
52 last <- ask("your last name?",identity)
53 _ <- tell(s"hello, $first $last")
54 } yield ()
55 import Logins._
56 type InteractLogin[A] = Coproduct[Interact,UserLogin,A]
57 val loginScript = for {
58 uid <- ask[InteractLogin,String]("what's you id?",identity)
59 idok <- checkId[InteractLogin](uid)
60 _ <- if (idok) tell[InteractLogin](s"hi, $uid") else tell[InteractLogin]("sorry, don't know you!")
61 pwd <- if (idok) ask[InteractLogin,String](s"what's your password?",identity)
62 else Free.point[InteractLogin,String]("")
63 login <- if (idok) login[InteractLogin](uid,pwd)
64 else Free.point[InteractLogin,Boolean](false)
65 _ <- if (login) tell[InteractLogin](s"congratulations，$uid")
66 else tell[InteractLogin](idok ? "sorry, no pass!" | "")
67 } yield login
68 import Permissions._
69 type InteractLoginPermission[A] = Coproduct[Permission,InteractLogin,A]
70 type T[A] = InteractLoginPermission[A]
71 val authScript = for {
72 uid <- ask[T,String]("what's you id?",identity)
73 idok <- checkId[T](uid)
74 _ <- if (idok) tell[T](s"hi, $uid")
75 else tell[T]("sorry, don't know you!")
76 pwd <- if (idok) ask[T,String](s"what's your password?",identity)
77 else Free.point[T,String]("")
78 login <- if (idok) login[T](uid,pwd)
79 else Free.point[T,Boolean](false)
80 _ <- if (login) tell[T](s"congratulations，$uid")
81 else tell[T](idok ? "sorry, no pass!" | "")
82 acc <- if (login) ask[T,Int](s"what's your access code, $uid?",_.toInt)
83 else Free.point[T,Int](0)
84 perm <- if (login) hasPermission[T](uid,acc)
85 else Free.point[T,Boolean](false)
86 _ <- if (perm) tell[T](s"you may use the system，$uid")
87 else tell[T]((idok && login) ? "sorry, you are banned!" | "")
88
89 } yield ()
90 }
91 object FreeInterps {
92 import FreeADTs._
93 object InteractConsole extends (Interact ~> Id) {
94 def apply[A](ia: Interact[A]): Id[A] = ia match {
95 case Ask(p,onInput) => println(p); onInput(readLine)
96 case Tell(m,n) => println(m); n
97 }
98 }
99 import Dependencies._
100 type AuthReader[A] = Reader[Authenticator,A]
101 object InteractLogin extends (Interact ~> AuthReader) {
102 def apply[A](ia: Interact[A]): AuthReader[A] = ia match {
103 case Ask(p,onInput) => println(p); Reader {m => onInput(readLine)}
104 case Tell(msg,n) => println(msg); Reader {m => n}
105 }
106 }
107 object LoginConsole extends (UserLogin ~> AuthReader) {
108 def apply[A](ua: UserLogin[A]): AuthReader[A] = ua match {
109 case CheckId(uid) => Reader {m => m.validateId(uid)}
110 case Login(uid,pwd) => Reader {m => m.validatePassword(uid, pwd)}
111 }
112 }
113 object PermConsole extends (Permission ~> AuthReader) {
114 def apply[A](pa: Permission[A]): AuthReader[A] = pa match {
115 case HasPermission(uid,acc) => Reader {m => m.grandAccess(uid, acc)}
116 }
117 }
118 def or[F[_],H[_],G[_]](f: F~>G, h: H~>G) =
119 new (({type l[x] = Coproduct[F,H,x]})#l ~> G) {
120 def apply[A](ca: Coproduct[F,H,A]):G[A] = ca.run match {
121 case -\/(fg) => f(fg)
122 case \/-(hg) => h(hg)
123 }
124 }
125 def among3[F[_],H[_],K[_],G[_]](f: F~>G, h: H~>G, k: K~>G) = {
126 type FH[A] = Coproduct[F,H,A]
127 type KFH[A] = Coproduct[K,FH,A]
128 new (({type l[x] = Coproduct[K,FH,x]})#l ~> G) {
129 def apply[A](kfh: KFH[A]): G[A] = kfh.run match {
130 case -\/(kg) => k(kg)
131 case \/-(cfh) => cfh.run match {
132 case -\/(fg) => f(fg)
133 case \/-(hg) => h(hg)
134 }
135 }
136 }
137 }
138 }
139 object Dependencies {
140 trait UserControl {
141 val pswdMap: Map[String,String]
142 def validateId(uid: String): Boolean
143 def validatePassword(uid: String, pswd: String): Boolean
144 }
145 trait AccessControl {
146 val accMap: Map[String, Int]
147 def grandAccess(uid: String, acc: Int): Boolean
148 }
149 trait Authenticator extends UserControl with AccessControl
150 }
151 object FreeDemo extends App {
152 import FreeASTs._
153 import FreeInterps._
154 import Dependencies._
155 object AuthControl extends Authenticator {
156 val pswdMap = Map (
157 "Tiger" -> "1234",
158 "John" -> "0000"
159 )
160 override def validateId(uid: String) =
161 pswdMap.getOrElse(uid,"???") /== "???"
162 override def validatePassword(uid: String, pswd: String) =
163 pswdMap.getOrElse(uid, pswd+"!") === pswd
164
165 val accMap = Map (
166 "Tiger" -> 8,
167 "John" -> 0
168 )
169 override def grandAccess(uid: String, acc: Int) =
170 accMap.getOrElse(uid, -1) > acc
171 }
172 authScript.foldMapRec(among3(InteractLogin,LoginConsole,PermConsole)).run(AuthControl)
173 // loginScript.foldMapRec(or(InteractLogin,LoginConsole)).run(AuthControl)
174 // interactScript.foldMapRec(InteractConsole)
175
176 }
