在上節我們介紹了Free Monad的基本情況。可以說Free Monad又是一個以數據結構替換程序堆棧的實例。實際上Free Monad的功能絕對不止如此，以heap換stack必須成為Free Monad的運算模式，這樣我們才可以放心的使用Free Monad所產生的Monadic編程語言了。前面我們介紹了Trampoline的運算模式可以有效解決堆棧溢出問題，而上節的Free Monad介紹里還沒有把Free Monad與Trampoline運算模式掛上鈎。我們先考慮一下如何在Free Monad數據類型里引入Trampoline運算模式。
我們先對比一下Tranpoline和Free這兩個數據類型的基本結構：
1 trait Free[F[_],A] { 2 private case class FlatMap[B](a: Free[F,A], f:A => Free[F,B]) extends Free[F,B] 3 def unit(a: A) = Return(a) 4 def flatMap[B](f: A => Free[F,B])(implicit F: Functor[F]): Free[F,B] = this match { 5 case Return(a) => f(a) 6 case Suspend(k) => Suspend(F.map(k)( _ flatMap f)) 7 case FlatMap(b,g) => FlatMap(b, x => g(x) flatMap f) //FlatMap(b, g andThen (_ flatMap f))
8 } 9 def map[B](f: A => B)(implicit F: Functor[F]): Free[F,B] = flatMap(a => Return(f(a))) 10 } 11 case class Return[F[_],A](a: A) extends Free[F,A] 12 case class Suspend[F[_],A](ffa: F[Free[F,A]]) extends Free[F,A] 13 trait Trampoline[A] { 14 private case class FlatMap[B](a: Trampoline[A], f: A => Trampoline[B]) extends Trampoline[B] 15 final def runT: A = resume match { 16 case Right(a) => a 17 case Left(k) => k().runT 18 } 19 def unit[A](a: A) = Done(a) 20 def flatMap[B](f: A => Trampoline[B]): Trampoline[B] = this match { 21 // case FlatMap(b,g) => FlatMap(b, g andThen (_ flatMap f) 22 // case FlatMap(b,g) => FlatMap(b, x => FlatMap(g(x),f))
23 case FlatMap(b,g) => FlatMap(b, x => g(x) flatMap f) 24 case x => FlatMap(x,f) 25 } 26 def map[B](f: A => B): Trampoline[B] = flatMap(a => More(() => Done(f(a)))) 27 final def resume: Either[() => Trampoline[A],A] = this match { 28 case Done(a) => Right(a) 29 case More(k) => Left(k) 30 case FlatMap(a,f) => a match { 31 case Done(v) => f(v).resume 32 case More(k) => Left(() => FlatMap(k(),f)) 33 case FlatMap(b,g) => FlatMap(b, g andThen (_ flatMap f)).resume 34 } 35 } 36 } 37 case class Done[A](a: A) extends Trampoline[A] 38 case class More[A](k: () => Trampoline[A]) extends Trampoline[A]
這兩個數據類型的設計目的都是為了能逐步運行算法：按照算法運算的狀態確定下一步該如何運行。這個F[Free[F,A]]就是一個循環遞歸結構，里面保存了運算當前狀態和下一步運算。
我們曾說如果一個數據類型能有個Functor實例，那么我們就可以用它來產生一個Free Monad。這個要求從上面Free[F,A]類型里的map,flatMap可以了解：我們用了implicit F: Functor[F]參數，因為必須有個Functor實例F才能實現map和flatMap。
為了實現Free Monad在運行中采用Trampoline運行機制，我們可以像Trampoline數據類型一樣來實現resume,這個確定每一步運算方式的函數：
1 trait Free[F[_],A] { 2 private case class FlatMap[B](a: Free[F,A], f:A => Free[F,B]) extends Free[F,B] 3 def unit(a: A) = Return(a) 4 def flatMap[B](f: A => Free[F,B])(implicit F: Functor[F]): Free[F,B] = this match { 5 case Return(a) => f(a) 6 case Suspend(k) => Suspend(F.map(k)( _ flatMap f)) 7 case FlatMap(b,g) => FlatMap(b, x => g(x) flatMap f) //FlatMap(b, g andThen (_ flatMap f))
8 } 9 def map[B](f: A => B)(implicit F: Functor[F]): Free[F,B] = flatMap(a => Return(f(a))) 10 final def resume(implicit F: Functor[F]): Either[F[Free[F,A]],A] = this match { 11 case Return(a) => Right(a) 12 case Suspend(k) => Left(k) 13 case FlatMap(a,f) => a match { 14 case Return(v) => f(v).resume 15 case Suspend(k) => Left(F.map(k)(_ flatMap f)) 16 case FlatMap(b,g) => FlatMap(b, g andThen (_ flatMap f)).resume 17 } 18 } 19 } 20 case class Return[F[_],A](a: A) extends Free[F,A] 21 case class Suspend[F[_],A](ffa: F[Free[F,A]]) extends Free[F,A]
Free類型的resume函數與Trampoline的基本一致，只有返回類型和增加了參數implicit F: Functor［F]，因為Free[F,A]的F必須是個Functor：用Functor F可以產生Free[F,A]。
我們用個實際例子來體驗一下用Functor產生Free：
我們可以用上一節的Interact類型：
1 trait Interact[A] 2 case class Ask(prompt: String) extends Interact[String] 3 case class Tell(msg: String) extends Interact[Unit]
這個類型太簡單了，太單純了。我還沒想到如何得出它的Functor實例。好像沒辦法實現那個map函數。那么如果修改一下這個Interact類型：
1 trait Interact[A] 2 case class Ask[A](prompt: String, next: A) extends Interact[A] 3 case class Tell[A](msg: String, next: A) extends Interact[A]
這個新類型的兩個狀態Ask,Tell都增加了個參數next，代表下一步操作。實際上我們是用map來運行next的。這樣我們就可以得出Interact的Functor實例。
1 trait Interact[A] 2 case class Ask[A](prompt: String, next: A) extends Interact[A] 3 case class Tell[A](msg: String, next: A) extends Interact[A] 4 implicit val interactFunctor = new Functor[Interact] { 5 def map[A,B](ia: Interact[A])(f: A => B): Interact[B] = ia match { 6 case Ask(x,n) => Ask(x,f(n)) 7 case Tell(x,n) => Tell(x,f(n)) 8 } 9 } //> interactFunctor : ch13.ex1.Functor[ch13.ex1.Interact] = ch13.ex1$$anonfun$
從上面的Functor實例中我們可以看到如何通過map的f(n)來運行下一步驟next。
接下來我們要把Interact類型升格到Free類型：
1 def liftF[F[_],A](fa: F[A])(implicit F: Functor[F]): Free[F,A] = { 2 Suspend(F.map(fa)(a => Return(a))) 3 } //> liftF: [F[_], A](fa: F[A])(implicit F: ch13.ex1.Functor[F])ch13.ex1.Free[F, 4 //| A]
5 implicit def LiftInteract[A](ia: Interact[A]): Free[Interact,A] = liftF(ia) 6 //> LiftInteract: [A](ia: ch13.ex1.Interact[A])ch13.ex1.Free[ch13.ex1.Interact, 7 //| A]
8 val prg = for { 9 first <- Ask("What's your first name?",()) 10 last <- Ask("What's your last name?",()) 11 _ <- Tell(s"Hello $first $last",()) 12 } yield () //> prg : ch13.ex1.Free[ch13.ex1.Interact,Unit] = Suspend(Ask(What's your firs 13 //| t name?,Suspend(Ask(What's your last name?,Suspend(Tell(Hello () (),Return( 14 //| ())))))))
看，把Interact升格后就可以使用for-comprehension了。
還是那句話：用一個有Functor實例的類型就可以產生一個Free Monad。然后我們可以用這個產生的Monad來在for-comprehension里面編寫一個算法。
解譯運算(Interpret)是Free Monad的Interpreter功能。我們說過要把Trampoline運行機制引入Free Monad運算：
1 def foldMap[G[_]](f: F ~> G)(implicit F: Functor[F], G: Monad[G]): G[A] = resume match { 2 case Right(a) => G.unit(a) 3 case Left(k) => G.flatMap(f(k))(_ foldMap f) 4 }
foldMap通過調用resume引入了Trampoline運行機制。
前面介紹的Free Monad相對都比較簡單。實際上Free Monad的Suspend處理可以是很復雜的，包括返回結果及接受輸入等任何組合。下面我們再看一個較復雜的例子：我們可以把State視為一種簡單的狀態轉變編程語言，包括讀取及設定狀態兩種操作指令：
1 trait StateF[S,A] 2 case class Get[S,A](f: S => A) extends StateF[S,A] 3 case class Put[S,A](s: S, a: A) extends StateF[S,A]
我們先看看嫩不能獲取StateF的Functor實例：
1 mplicit def stateFFunctor[S] = new Functor[({type l[x] = StateF[S,x]})#l] { 2 def map[A,B](sa: StateF[S,A])(f: A => B): StateF[S,B] = sa match { 3 case Get(g) => Get( s => f(g(s)) ) 4 case Put(s,a) => Put(s, f(a)) 5 } 6 } //> stateFFunctor: [S]=> ch13.ex1.Functor[[x]ch13.ex1.StateF[S,x]]
既然有了Functor實例，那么我們可以用來產生Free Monad:
1 type FreeState[S,A] = Free[({type l[x] = StateF[S,x]})#l, A]
Free[F,A]里的Functor F只接受一個類型參數。StateF[S,A]有兩個類型參數，我們必須用type lambda來解決類型參數匹配問題。
現在我們已經得到了一個FreeState Monad。下面接着實現FreeState的基礎組件函數：
1 def unit[S,A](a: A): FreeState[S,A] = Return[({type l[x] = StateF[S,x]})#l, A](a) 2 //> unit: [S, A](a: A)ch13.ex1.FreeState[S,A]
3 def getState[S]: FreeState[S,S] = Suspend[({type l[x] = StateF[S,x]})#l, S]( 4 Get(s => Return[({type l[x] = StateF[S,x]})#l, S](s))) 5 //> getState: [S]=> ch13.ex1.FreeState[S,S]
6 def setState[S](s: S): FreeState[S,Unit] = Suspend[({type l[x] = StateF[S,x]})#l, Unit]( 7 Put(s, Return[({type l[x] = StateF[S,x]})#l, Unit](()))) 8 //> setState: [S](s: S)ch13.ex1.FreeState[S,Unit]
注意類型匹配。我們可以寫個函數來運算這個FreeState：
1 def evalS[S,A](s: S, t: FreeState[S,A]): A = t.resume match { 2 case Right(a) => a 3 case Left(Get(f)) => evalS(s, f(s)) 4 case Left(Put(n,a)) => evalS(n,a) 5 } //> evalS: [S, A](s: S, t: ch13.ex1.FreeState[S,A])A
這個運算方式還是調用了resume函數。注意：Get(f) 返回 StateF[S,A]，StateF是個Functor, F[Free[F,A]]那么A就是Free[F,A]
還是試試運算那個zipIndex函數：
1 def zipIndex[A](as: List[A]): List[(Int, A)] = { 2 evalS(1, as.foldLeft(unit[Int,List[(Int,A)]](List()))( 3 (acc,a) => for { 4 xs <- acc 5 n <- getState 6 _ <- setState(n+1) 7 } yield (n, a) :: xs)).reverse 8 } //> zipIndex: [A](as: List[A])List[(Int, A)]
9
10 zipIndex((0 to 10000).toList) //> res0: List[(Int, Int)] = List((1,0), (2,1), (3,2), (4,3), (5,4), (6,5), (7, 11 //| 6), (8,7), (9,8), (10,9), (11,10), (12,11), (13,12), (14,13), (15,14), (16, 12 //| 15), (17,16), (18,17), (19,18), (20,19), (21,20), (22,21), (23,22), (24,23)
沒錯，這段程序不但維護了一個狀態而且使用了Trampoline運算模式，可以避免StackOverflow問題。
下面我們再用一個例子來示范Free Monad的Monadic Program和Interpreter各自的用途：
我們用一個Stack操作的例子。對Stack中元素的操作包括：Push,Add,Sub,Mul,End。這幾項操作也可被視作一種Stack編程語言中的各項操作指令：
1 trait StackOps[A] 2 case class Push[A](value: Int, ops:A) extends StackOps[A] 3 case class Add[A](ops: A) extends StackOps[A] 4 case class Mul[A](ops: A) extends StackOps[A] 5 case class Dup[A](ops: A) extends StackOps[A] 6 case class End[A](ops: A) extends StackOps[A]
我們先推導它的Functor實例：
1 implicit val stackOpsFunctor: Functor[StackOps] = new Functor[StackOps] { 2 def map[A,B](oa: StackOps[A])(f: A => B): StackOps[B] = oa match { 3 case Push(v,a) => Push(v,f(a)) 4 case Add(a) => Add(f(a)) 5 case Mul(a) => Mul(f(a)) 6 case Dup(a) => Dup(f(a)) 7 case End(a) => End(f(a)) 8 } 9 }
這里的next看起來是多余的，但它代表的是下一步運算。有了它才可能得到Functor實例，即使目前每一個操作都是完整獨立步驟。
有了Functor實例我們就可以實現StackOps的Monadic programming:
1 def liftF[F[_],A](fa: F[A])(implicit F: Functor[F]): Free[F,A] = { 2 Suspend(F.map(fa)(a => Return(a))) 3 } //> liftF: [F[_], A](fa: F[A])(implicit F: ch13.ex1.Functor[F])ch13.ex1.Free[F, 4 //| A]
5 implicit def liftStackOps[A](sa: StackOps[A]): Free[StackOps,A] = liftF(sa) 6 //> liftStackOps: [A](sa: ch13.ex1.StackOps[A])ch13.ex1.Free[ch13.ex1.StackOps, 7 //| A]
8 val stkprg = for { 9 _ <- Push(1,()) 10 _ <- Push(2,()) 11 _ <- Add(()) 12 } yield x //> stkprg : ch13.ex1.Free[ch13.ex1.StackOps,Unit] = Suspend(Push(1,Suspend(Pu 13 //| sh(2,Suspend(Add(Suspend(Pop(Return(())))))))))
我們用lisftStackOps函數把StackOps升格到Free[StackOps,A]后就可以用for-comprehension進行Monadic programming了。如果不習慣Add(())這樣的表達式可以這樣：
1 def push(value: Int) = Push(value,()) //> push: (value: Int)ch13.ex1.Push[Unit]
2 def add = Add(()) //> add: => ch13.ex1.Add[Unit]
3 def sub = Sub(()) //> sub: => ch13.ex1.Sub[Unit]
4 def mul = Mul(()) //> mul: => ch13.ex1.Mul[Unit]
5 def end = End(()) //> end: => ch13.ex1.End[Unit]
6 val stkprg = for { 7 _ <- push(1) 8 _ <- push(2) 9 _ <- add 10 _ <- push(4) 11 _ <- mul 12 } yield () //> stkprg : ch13.ex1.Free[ch13.ex1.StackOps,Unit] = Suspend(Push(1,Suspend(Pu 13 //| sh(2,Suspend(Add(Suspend(Push(4,Suspend(Mul(Return(())))))))))))
這樣從文字意思上描述就清楚多了。但是，這個stkprg到底是干什么的？如果不從文字意義上解釋我們根本不知道這段程序干了些什么，怎么干的。換句直白的話就是：沒有意義。這正是Free Monad功能精妙之處：我們用Monad for-comprehension來編寫一段Monadic program，然后在Interpreter中賦予它具體意義：用Interpreter來確定程序具體的意義。
那我們就進入Interpreter來運算這段程序吧。
先申明Stack類型： type Stack = List[Int]
在上面我們有個Interpreter, foldMap:
1 def foldMap[G[_]](f: F ~> G)(implicit F: Functor[F], G: Monad[G]): G[A] = resume match { 2 case Right(a) => G.unit(a) 3 case Left(k) => G.flatMap(f(k))(_ foldMap f) 4 }
但是運行stkprg必須傳入Stack起始值，foldMap無法滿足。那么我們再寫另一個runner吧：
1 final def foldRun[B](b: B)(f: (B, F[Free[F,A]]) => (B, Free[F,A]))(implicit F: Functor[F]): (B, A) = { 2 @annotation.tailrec 3 def run(t: Free[F,A], z: B): (B, A) = t.resume match { 4 case Right(a) => (z, a) 5 case Left(k) => { 6 val (b1, f1) = f(z, k) 7 run(f1,b1) 8 } 9 } 10 run(this,b) 11 }
foldRun也是個折疊算法：給予一個起始值及一個對數據結構內部元素的處理函數然后可以開始運行。這個函數剛好符合我們的需要。下一步就是給予stkprg意義：確定Push,Add...這些指令具體到底干什么：
1 type Stack = List[Int] 2 def stackFn(stack: Stack, prg: StackOps[Free[StackOps,Unit]]): (Stack, Free[StackOps,Unit]) = prg match { 3 case Push(v, n) => { 4 (v :: stack, n) 5 } 6 case Add(n) => { 7 val hf :: hs :: t = stack 8 ((hf + hs) :: stack, n) 9 } 10 case Sub(n) => { 11 val hf :: hs :: t = stack 12 ((hs - hf) :: stack, n) 13 } 14 case Mul(n) => { 15 val hf :: hs :: t = stack 16 ((hf * hs) :: stack, n) 17 } 18 } //> stackFn: (stack: ch13.ex1.Stack, prg: ch13.ex1.StackOps[ch13.ex1.Free[ch13. 19 //| ex1.StackOps,Unit]])(ch13.ex1.Stack, ch13.ex1.Free[ch13.ex1.StackOps,Unit])
啊。。。在這里我們才能具體了解每一句StackOps指令的意義。這就是Free Monad Interpreter的作用了。我們試着運算這個stkprg：
1 val stkprg = for { 2 _ <- push(1) 3 _ <- push(2) 4 _ <- add 5 _ <- push(4) 6 _ <- mul 7 } yield () //> stkprg : ch13.ex1.Free[ch13.ex1.StackOps,Unit] = Suspend(Push(1,Suspend(Pu 8 //| sh(2,Suspend(Add(Suspend(Push(4,Suspend(Mul(Return(())))))))))))
9 stkprg.foldRun(List[Int]())(stackFn) //> res0: (List[Int], Unit) = (List(12, 4, 3, 2, 1),())
跟蹤一下操作步驟，最終結果是正確的。
我們再試一下用Natural Transformation原理的foldMap函數。我們可以用State的runS來傳入Stack初始值：
1 type StackState[A] = State[Stack,A] 2 implicit val stackStateMonad = new Monad[StackState] { 3 def unit[A](a: A) = State(s => (a,s)) 4 def flatMap[A,B](sa: StackState[A])(f: A => StackState[B]): StackState[B] = sa flatMap f 5 } //> stackStateMonad : ch13.ex1.Monad[ch13.ex1.StackState] = ch13.ex1$$anonfun$ 6 //| main$1$$anon$5@26f67b76
這個StackState類型就是一個State類型。我們能夠推導它的Monad實例，那我們就可以調用foldMap了。我們先編寫Interpreter功能：
1 object StackOperator extends (StackOps ~> StackState) { 2 def apply[A](sa: StackOps[A]): StackState[A] = sa match { 3 case Push(v,n) => State((s: Stack) => (n, v :: s)) 4 case Add(n) => State((s: Stack) => { 5 val hf :: hs :: t = s 6 (n, (hf + hs) :: s) 7 }) 8 case Sub(n) => State((s: Stack) => { 9 val hf :: hs :: t = s 10 (n, (hs - hf) :: s) 11 }) 12 case Mul(n) => State((s: Stack) => { 13 val hf :: hs :: t = s 14 (n, (hf * hs) :: s) 15 }) 16 } 17 }
通過Natural Transformation把StackOps轉成StackState狀態維護。StackOps具體意義也在這里才能得到體驗。我們用foldMap運算stkprg：
1 stkprg.foldMap(StackOperator).runS(List[Int]()) //> res1: (Unit, ch13.ex1.Stack) = ((),List(12, 4, 3, 2, 1))
我們得到了同樣的運算結果。
希望通過這些例子能把Free Monad的用途、用法、原理解釋清楚了。