Cats（4）－ 叠加Free程序运算结果，Stacking monadic result types

在前面的几篇关于Free编程的讨论示范中我们均使用了基础类型的运算结果。但在实际应用中因为需要考虑运算中出现异常的情况，常常会需要到更高阶复杂的运算结果类型如Option、Xor等。因为Monad无法实现组合（monad do not compose），我们如何在for-comprehension中组合这些运算呢？假如在我们上一篇讨论里的示范DSL是这样的：

 trait Login[+A]
  case class Authenticate(uid: String, pwd: String) extends Login[Option[Boolean]]

  trait Auth[+A]
  case class Authorize(uid: String) extends Auth[Xor[String,Boolean]]

这两个ADT在for-comprehension里如果我们勉强将Option和Xor叠加在一起就会产生所谓下台阶式运算（stair-stepping），因为monad do not compose! 我们可以看看下面的示范：

  type Result[A] = Xor[String,Option[A]]
  def getResult: Result[Int] = .some.right       //> getResult: => demo.ws.catsMTX.Result[Int]
  for {
    optValue <- getResult
  } yield {
    for {
      valueA <- optValue
    } yield valueA +                             //> res0: cats.data.Xor[String,Option[Int]] = Right(Some(80))
  }

我们必须用两层for-comprehension来组合最终结果。这就是所谓的下台阶运算了。如果遇到三层叠加类型，那么整个程序会变得更加复杂了。其实不单是程序结构复杂问题，更重要的是运算效果（effect）无法正确体现：出现None和Left值时并不能立即终止for-comprehension、再就是如果第一层是有副作用（side-effect）运算时，由于我们必须先得出第一层的运算结果才能进行下一层运算，所以这个for-comprehension产生了不纯代码（impure-code），如下：

 for {
   optionData <- IO {readDB()}
 } yield {
   for {
     data <- optionData
   } yield Process(data)
 }

我们必须先运算IO才能开始运算Process。这就使这段程序变成了不纯代码。我在一篇scalaz-monadtransform的博客中介绍了如何用MonadTransformer来解决这种类型堆叠的问题，大家可以参考。cats同样实现了几个类型的MonadTransformer如：OptionT、EitherT、StateT、WriterT、Kleisli等等，命名方式都是以类型名称尾缀加T的规范方式，如：

final case class OptionT[F[_], A](value: F[Option[A]]) {...}
inal case class EitherT[F[_], A, B](value: F[Either[A, B]]) {...}
final class StateT[F[_], S, A](val runF: F[S => F[(S, A)]]) extends Serializable {...}
final case class WriterT[F[_], L, V](run: F[(L, V)]) {...}

我们可以从MonadTransformer的value或run,runF获取其代表的数据类型，如：

OptionT[Xor,A](value: Xor[?,Option[A]]) >>> 代表的类型:Xor[?,Option[A]]

XorT[OptionT,A](value: Option[Xor[?,A]]) >>>代表的类型:Option[Xor[?,A]]

我们可以用Applicative.pure来把一个值升格成堆叠类型：

 import cats._,cats.instances.all._
 import cats.data.{Xor,XorT}
 import cats.syntax.xor._
 import cats.data.OptionT
 import cats.syntax.option._
 import cats.syntax.applicative._

  type Error[A] = Xor[String,A]
  type XResult[A] = OptionT[Error,A]
  type OResult[A] = XorT[Option,String,A]
  Applicative[XResult].pure()             //> res0: demo.ws.catsMTX.XResult[Int] = OptionT(Right(Some(62)))
  .pure[XResult]                          //> res1: demo.ws.catsMTX.XResult[Int] = OptionT(Right(Some(62)))
  Applicative[OResult].pure()             //> res2: demo.ws.catsMTX.OResult[Int] = XorT(Some(Right(62)))
  .pure[OResult]                          //> res3: demo.ws.catsMTX.OResult[Int] = XorT(Some(Right(62)))

注意，用Applicative.pure来升格None或者Left会产生错误结果：

  Applicative[XResult].pure(none[Int])
 //> res4: demo.ws.catsMTX.XResult[Option[Int]] = OptionT(Right(Some(None)))
  (None: Option[Int]).pure[XResult]
 //> res5: demo.ws.catsMTX.XResult[Option[Int]] = OptionT(Right(Some(None)))
  Applicative[XResult].pure("oh no".left[Int])
  //> res6: demo.ws.catsMTX.XResult[cats.data.Xor[String,Int]] = OptionT(Right(Some(Left(oh no))))
  (Left[String,Int]("oh no")).pure[XResult]
 //> res7: demo.ws.catsMTX.XResult[scala.util.Left[String,Int]] = OptionT(Right(Some(Left(oh no))))
  Applicative[OResult].pure(Left[String,Int]("oh no"))
 //> res8: demo.ws.catsMTX.OResult[scala.util.Left[String,Int]] = XorT(Some(Right(Left(oh no))))
  "oh no".left[Int].pure[OResult]
 //> res9: demo.ws.catsMTX.OResult[cats.data.Xor[String,Int]] = XorT(Some(Right(Left(oh no))))
  Applicative[OResult].pure(none[Int])
 //> res10: demo.ws.catsMTX.OResult[Option[Int]] = XorT(Some(Right(None)))
  (None: Option[Int]).pure[OResult]
 //> res11: demo.ws.catsMTX.OResult[Option[Int]] = XorT(Some(Right(None)))
  Applicative[OResult].pure("oh no".left[Int])
 //> res12: demo.ws.catsMTX.OResult[cats.data.Xor[String,Int]] = XorT(Some(Right(Left(oh no))))
  (Left[String,Int]("oh no")).pure[OResult]
 //> res13: demo.ws.catsMTX.OResult[scala.util.Left[String,Int]] = XorT(Some(Right(Left(oh no))))

Some(None)，Right(Left("oh no)))是什么意思呢？明显是错误。我们必须用MonadTransformer的构建器（constructor）才能正确的对这些边际值进行升格：

  OptionT(none[Int].pure[Error])
 //> res14: cats.data.OptionT[demo.ws.catsMTX.Error,Int] = OptionT(Right(None))
  OptionT("oh no".left: Error[Option[Int]])
 //> res15: cats.data.OptionT[demo.ws.catsMTX.Error,Int] = OptionT(Left(oh no))
  XorT(none[Error[Int]])
 //> res16: cats.data.XorT[Option,String,Int] = XorT(None)
  XorT("oh no".left[Int].pure[Option])
 //> res17: cats.data.XorT[Option,String,Int] = XorT(Some(Left(oh no)))

下面我们示范一下在for-comprehension中运算Xor[?Option[A]]这种堆叠类型：

  type Error[A] = Xor[String,A]
  type XResult[A] = OptionT[Error,A]
  type OResult[A] = XorT[Option,String,A]
  def getXor(s: String): Error[String] = s.right   //> getXor: (s: String)demo.ws.catsMTX.Error[String]
  def getOption(s: String): Option[String] = s.some
                                                   //> getOption: (s: String)Option[String]
   val composed: XResult[String] =
    for {
       s1 <- OptionT.liftF(getXor("Hello "))
       s2 <- OptionT.liftF(getXor("World!"))
       s3 <- OptionT(getOption("come to papa!").pure[Error])
    } yield s1 + s2 + s3     //> composed  : demo.ws.catsMTX.XResult[String] = OptionT(Right(Some(Hello World!come to papa!)))
    composed.value           //> res18: demo.ws.catsMTX.Error[Option[String]] = Right(Some(Hello World!come to papa!))

测试一下Xor，Option的left和none效果：

  val composed: XResult[String] =
    for {
       s1 <- OptionT.liftF(getXor("Hello "))
       s0 <- OptionT(none[String].pure[Error])
       s2 <- OptionT.liftF(getXor("World!"))
       s3 <- OptionT(getOption("come to papa!").pure[Error])
    } yield s1 + s2 + s3      //> composed  : demo.ws.catsMTX.XResult[String] = OptionT(Right(None))
    composed.value            //> res18: demo.ws.catsMTX.Error[Option[String]] = Right(None)

   val composed: XResult[String] =
    for {
       s1 <- OptionT.liftF(getXor("Hello "))
       s0 <- OptionT("oh no".left: Error[Option[Int]])
       s2 <- OptionT.liftF(getXor("World!"))
       s3 <- OptionT(getOption("come to papa!").pure[Error])
    } yield s1 + s2 + s3       //> composed  : demo.ws.catsMTX.XResult[String] = OptionT(Left(oh no))
    composed.value             //> res18: demo.ws.catsMTX.Error[Option[String]] = Left(oh no)

从运算结果我们看到在for-comprehension中这个堆叠类型的组成类型Xor和Option的效果可以得到体现。

在现实中三层以上的运算结果类型堆叠还是很普遍的，如：Future[Xor[?,Option[A]]]。要注意MonadTransformer类型堆叠的顺序是重要的，而且是由内向外的，决定着最终运算结果的类型。如果增加一层Future类型，我们就需要把它放到堆叠结构的最内部：

    type FError[A] = XorT[Future,String,A]
    type FResult[A] = OptionT[FError,A]

现在我们需要考虑如何进行MonadTransformer类型的升格了。请相信我，这项工作绝对是一场噩梦。具体示范可以在我这篇博客scalaz-monadtransformer中找到。我的意思是如果没有更好的办法，这项工作基本是一项不可能的任务（mission impossible）。

对于上面提出的问题，freeK提供了很好的解决方法。freeK的Onion数据类型就是为简化Monad堆叠操作而设计的。Onion表达形式如下：

 type Stack[A] = F[G[H[I[A]]]]
 type O = F :&: G :&: H :&: I :&: Bulb
 type Stack[A] = O#Layers[A]

O就是Onion类型，代表了一个Monad堆叠。我们可以用O#Layers[A]返还原始的多层Monad，如下面的示例：

   import freek._
    type O = Xor[String,?] :&: Option :&: Bulb
    type MStack[A] = O#Layers[A]

我们用一个具体的Free程序来示范堆叠Monad运算结果的操作。假如例子的ADT是这样的：

    sealed trait Foo[A]
    final case class Foo1(s: String) extends Foo[Option[Int]]
    final case class Foo2(i: Int) extends Foo[Xor[String, Int]]
    final case object Foo3 extends Foo[Unit]
    final case class Foo4(i: Int) extends Foo[Xor[String, Option[Int]]]

    sealed trait Bar[A]
    final case class Bar1(s: String) extends Bar[Option[String]]
    final case class Bar2(i: Int) extends Bar[Xor[String, String]]

    sealed trait Laa[A]
    final case class Push(s: String) extends Laa[List[String]]

从模拟运算结果类型来看，我们将面对相当复杂的三层Monad堆叠。我们先用Foo,Bar来示范两层堆叠的DSL。首先，我们希望使用DSL的语法如下：

 for {
   i   <- Foo1("").freek[PRG] // 运算结果是： Option[String]
   s   <- Bar2(i).freek[PRG]   // 运算结果是： Xor[String, String]
   ...
 } yield (())

我们希望对运算结果进行一种升格：把它们升格成一致堆叠类型，如下：

 Free[PRG.Cop, Option[A]]
 // 和这个类型
 Free[PRG.Cop, Xor[String, A]]

 // 一致升格成
 Free[PRG.Cop, Xor[String, Option[A]]]

 // 也就是这个
 type O = Xor[String, ?] :&: Option :&: Bulb
 Free[PRG.Cop, O#Layers]

像cats的MonadTransformer，freeK也提供了个OnionT，OnionT代表Monad堆叠类型容器。我们希望实现以下升格（lifting）操作：

 //把
 Free[PRG.Cop, Option[A]
 //或
 Xor[String, A]]
 //统统转成
 OnionT[Free, PRG.Cop, O, A]

我们可以用.onionT[O]来升格：

   type PRG = Foo :|: Bar :|: NilDSL
   val PRG = DSL.Make[PRG]
   type O = Xor[String,?] :&: Option :&: Bulb
   val prg: OnionT[Free,PRG.Cop,O,Int]= for {
     i  <- Foo1("").freek[PRG].onionT[O]
     i2 <- Foo2(i).freek[PRG].onionT[O]
     _  <- Foo3.freek[PRG].onionT[O]
     s  <- Bar1(i2.toString).freek[PRG].onionT[O]
     i3 <- Foo4(i2).freek[PRG].onionT[O]
   } yield (i3)

我们可以用比较简单点的表达形式freeko来示范同样效果：

   val prg2: OnionT[Free,PRG.Cop,O,Int]= for {
     i  <- Foo1("").freeko[PRG,O]
     i2 <- Foo2(i).freeko[PRG,O]
     _  <- Foo3.freeko[PRG,O]
     s  <- Bar1(i2.toString).freeko[PRG,O]
     i3 <- Foo4(i2).freeko[PRG,O]
   } yield (i3)

注意，现在程序prg的返回结果类型是OnionT。但我们的运算interpret函数是在Free上面的。OnionT.value可以返回Free类型：

 pre.value
 //res12: cats.free.Free[PRG.Cop,O#Layers[Int]] = Free(...)

所以运算程序方式要调整成：prg.value.interpret(interpreters)

如果我们再增加一层Monad堆叠呢？

   type PRG3 = Laa :|: Foo :|: Bar :|: NilDSL
   val PRG3 = DSL.Make[PRG3]
   type O3 = List :&: Xor[String,?] :&: Option :&: Bulb
   val prg3: OnionT[Free,PRG3.Cop,O3,Int]= for {
     i  <- Foo1("").freeko[PRG3,O3]
     i2 <- Foo2(i).freeko[PRG3,O3]
     _  <- Foo3.freeko[PRG3,O3]
     s  <- Bar1(i2.toString).freeko[PRG3,O3]
     i3 <- Foo4(i2).freeko[PRG3,O3]
     _ <- Push(s).freeko[PRG3,O3]
   } yield (i3)

就是这么简单。

下面我们把上篇讨论的用户验证示范例子的运算结果类型调整成复杂类型，然后用freeK.Onion来完善程序。先调整ADT：

   object ADTs {
     sealed trait Interact[+A]
     object Interact {
       case class Ask(prompt: String) extends Interact[Xor[String,String]]
       case class Tell(msg: String) extends Interact[Unit]
     }
     sealed trait Login[+A]
     object Login {
       case class Authenticate(uid: String, pwd: String) extends Login[Option[Boolean]]
     }
     sealed trait Auth[+A]
     object Auth {
       case class Authorize(uid: String) extends Auth[Option[Boolean]]
     }
   }

我们把运算结果改成了Xor,Option。再看看DSL调整：

   object DSLs {
     import ADTs._
     import Interact._
     import Login._
     type PRG = Interact :|: Login :|: NilDSL
     val PRG = DSL.Make[PRG]
     type O =  Xor[String,?] :&: Option :&: Bulb
     val authenticDSL: OnionT[Free,PRG.Cop, O, Boolean] =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O]
         pwd <- Ask("Enter password:").freeko[PRG,O]
         auth <- Authenticate(uid,pwd).freeko[PRG,O]
       } yield auth
     type O2 =  Option :&: Xor[String,?] :&: Bulb
     val authenticDSLX =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O2].peelRight
         pwd <- Ask("Enter password:").freeko[PRG,O2].peelRight
         auth <- (uid,pwd) match {
           case (Xor.Right(u),Xor.Right(p)) => Authenticate(u,p).freeko[PRG,O2].peelRight
           case _ => Authenticate("","").freeko[PRG,O2].peelRight
         }
       } yield auth
     val interactLoginDSL: OnionT[Free,PRG.Cop, O, Unit] =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O]
         pwd <- Ask("Enter password:").freeko[PRG,O]
         auth <- Authenticate(uid,pwd).freeko[PRG,O]
         _ <- if (auth) Tell(s"Hello $uid, welcome to the zoo!").freeko[PRG,O]
         else Tell(s"Sorry, Who is $uid?").freeko[PRG,O]
       } yield ()

     import Auth._
     type PRG3 = Auth :|: PRG   //Interact :|: Login :|: NilDSL
     val PRG3 = DSL.Make[PRG3]
     val authorizeDSL: OnionT[Free,PRG3.Cop, O , Unit] =
       for {
         uid <- Ask("Enter your User ID:").freeko[PRG3,O]
         pwd <- Ask("Enter your Password:").freeko[PRG3,O]
         auth <- Authenticate(uid,pwd).freeko[PRG3,O]
         perm <-  if (auth) Authorize(uid).freeko[PRG3,O]
                  else OnionT.pure[Free,PRG3.Cop,O,Boolean](false)
         _ <- if (perm)  Tell(s"Hello $uid, access granted!").freeko[PRG3,O]
              else Tell(s"Sorry $uid, access denied!").freeko[PRG3,O]
       } yield()
   }

注意上面代码中这个authenticDSLX：当我们需要对Option:&:Xor:&:Bulb中的整个Xor值而不是运算值A来操作时可以用peelRight来获取这个Xor。如果有需要的话我们还可以用peelRight2,peelRight3来越过二、三层类型。具体实现interpreter部分也需要按照ADT的运算结果类型来调整：

 object IMPLs {
     import ADTs._
     import Interact._
     import Login._
     import Auth._
     val idInteract = new (Interact ~> Id) {
       def apply[A](ia: Interact[A]): Id[A] = ia match {
         case Ask(p) => {println(p); (scala.io.StdIn.readLine).right}
         case Tell(m) => println(m)
       }
     }
     val idLogin = new (Login ~> Id) {
       def apply[A](la: Login[A]): Id[A] = la match {
         case Authenticate(u,p) => (u,p) match {
           case ("Tiger","") => true.some
           case _ => false.some
         }
       }
     }
     val interactLogin = idInteract :&: idLogin
     import Dependencies._
     type ReaderContext[A] = Reader[Authenticator,A]
     object readerInteract extends (Interact ~> ReaderContext) {
       def apply[A](ia: Interact[A]): ReaderContext[A] = ia match {
         case Ask(p) => Reader {pc => {println(p); (scala.io.StdIn.readLine).right}}
         case Tell(m) => Reader {_ => println(m)}
       }
     }
     object readerLogin extends (Login ~> ReaderContext) {
       def apply[A](la: Login[A]): ReaderContext[A] = la match {
         case Authenticate(u,p) => Reader {pc => pc.matchUserPassword(u,p).some}
       }
     }
     val userInteractLogin = readerLogin :&: readerInteract

     val readerAuth = new (Auth ~> ReaderContext) {
       def apply[A](aa: Auth[A]): ReaderContext[A] = aa match {
         case Authorize(u) => Reader {ac => ac.grandAccess(u).some}
       }
     }
     val userAuth = readerAuth :&: userInteractLogin
   }

具体运行方式需要调整成：

   authorizeDSL.value.interpret(userAuth).run(AuthControl)

测试运行与我们上篇示范相同。

完整的示范源代码如下：

 import cats.instances.all._
 import cats.free.Free
 import cats.{Id, ~>}
 import cats.data.Reader
 import freek._
 import cats.data.Xor
 import cats.syntax.xor._
 import cats.syntax.option._
 object FreeKModules {
   object ADTs {
     sealed trait Interact[+A]
     object Interact {
       case class Ask(prompt: String) extends Interact[Xor[String,String]]
       case class Tell(msg: String) extends Interact[Unit]
     }
     sealed trait Login[+A]
     object Login {
       case class Authenticate(uid: String, pwd: String) extends Login[Option[Boolean]]
     }
     sealed trait Auth[+A]
     object Auth {
       case class Authorize(uid: String) extends Auth[Option[Boolean]]
     }
   }
   object DSLs {
     import ADTs._
     import Interact._
     import Login._
     type PRG = Interact :|: Login :|: NilDSL
     val PRG = DSL.Make[PRG]
     type O =  Xor[String,?] :&: Option :&: Bulb
     val authenticDSL: OnionT[Free,PRG.Cop, O, Boolean] =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O]
         pwd <- Ask("Enter password:").freeko[PRG,O]
         auth <- Authenticate(uid,pwd).freeko[PRG,O]
       } yield auth
     type O2 =  Option :&: Xor[String,?] :&: Bulb
     val authenticDSLX =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O2].peelRight
         pwd <- Ask("Enter password:").freeko[PRG,O2].peelRight
         auth <- (uid,pwd) match {
           case (Xor.Right(u),Xor.Right(p)) => Authenticate(u,p).freeko[PRG,O2].peelRight
           case _ => Authenticate("","").freeko[PRG,O2].peelRight
         }
       } yield auth
     val interactLoginDSL: OnionT[Free,PRG.Cop, O, Unit] =
       for {
         uid <- Ask("Enter your user id:").freeko[PRG,O]
         pwd <- Ask("Enter password:").freeko[PRG,O]
         auth <- Authenticate(uid,pwd).freeko[PRG,O]
         _ <- if (auth) Tell(s"Hello $uid, welcome to the zoo!").freeko[PRG,O]
         else Tell(s"Sorry, Who is $uid?").freeko[PRG,O]
       } yield ()

     import Auth._
     type PRG3 = Auth :|: PRG   //Interact :|: Login :|: NilDSL
     val PRG3 = DSL.Make[PRG3]
     val authorizeDSL: OnionT[Free,PRG3.Cop, O , Unit] =
       for {
         uid <- Ask("Enter your User ID:").freeko[PRG3,O]
         pwd <- Ask("Enter your Password:").freeko[PRG3,O]
         auth <- Authenticate(uid,pwd).freeko[PRG3,O]
         perm <-  if (auth) Authorize(uid).freeko[PRG3,O]
                  else OnionT.pure[Free,PRG3.Cop,O,Boolean](false)
         _ <- if (perm)  Tell(s"Hello $uid, access granted!").freeko[PRG3,O]
              else Tell(s"Sorry $uid, access denied!").freeko[PRG3,O]
       } yield()

   }
   object IMPLs {
     import ADTs._
     import Interact._
     import Login._
     import Auth._
     val idInteract = new (Interact ~> Id) {
       def apply[A](ia: Interact[A]): Id[A] = ia match {
         case Ask(p) => {println(p); (scala.io.StdIn.readLine).right}
         case Tell(m) => println(m)
       }
     }
     val idLogin = new (Login ~> Id) {
       def apply[A](la: Login[A]): Id[A] = la match {
         case Authenticate(u,p) => (u,p) match {
           case ("Tiger","") => true.some
           case _ => false.some
         }
       }
     }
     val interactLogin = idInteract :&: idLogin
     import Dependencies._
     type ReaderContext[A] = Reader[Authenticator,A]
     object readerInteract extends (Interact ~> ReaderContext) {
       def apply[A](ia: Interact[A]): ReaderContext[A] = ia match {
         case Ask(p) => Reader {pc => {println(p); (scala.io.StdIn.readLine).right}}
         case Tell(m) => Reader {_ => println(m)}
       }
     }
     object readerLogin extends (Login ~> ReaderContext) {
       def apply[A](la: Login[A]): ReaderContext[A] = la match {
         case Authenticate(u,p) => Reader {pc => pc.matchUserPassword(u,p).some}
       }
     }
     val userInteractLogin = readerLogin :&: readerInteract

     val readerAuth = new (Auth ~> ReaderContext) {
       def apply[A](aa: Auth[A]): ReaderContext[A] = aa match {
         case Authorize(u) => Reader {ac => ac.grandAccess(u).some}
       }
     }
     val userAuth = readerAuth :&: userInteractLogin
   }

 }
 object Dependencies {
   trait PasswordControl {
     val mapPasswords: Map[String,String]
     def matchUserPassword(uid: String, pswd: String): Boolean
   }
   trait AccessControl {
     val mapAccesses: Map[String, Boolean]
     def grandAccess(uid: String): Boolean
   }
   trait Authenticator extends PasswordControl with AccessControl
 }

 object freeKDemo extends App {
   import FreeKModules._
   import DSLs._
   import IMPLs._
   // val r0 = authenticDSL.foldMap(interactLogin.nat)
   // val r = authenticDSL.interpret(interactLogin)
   import Dependencies._
   object AuthControl extends Authenticator {
     override val mapPasswords = Map(
       "Tiger" -> "",
       "John" -> ""
     )
     override def matchUserPassword(uid: String, pswd: String) =
       mapPasswords.getOrElse(uid, pswd+"!") == pswd

     override val mapAccesses = Map (
       "Tiger" -> true,
       "John" -> false
     )
     override def grandAccess(uid: String) =
       mapAccesses.getOrElse(uid, false)
   }

   //  interactLoginDSL.value.interpret(userInteractLogin).run(AuthControl)
   authorizeDSL.value.interpret(userAuth).run(AuthControl)
 }