January 2, 2020

Monad: Free Monad

本文沿用 minimum usable 原则,以可运行的最小例子为核心,梳理 Free Monad 的动机、定义与常见用法。文中的代码块都可以直接点击 Run 运行(输出为本地 GHC 预计算结果)。

Readings

• haskell for all: You could have invented free monads
• fp complete: Free Monads are Simple
• hackage: Control.Monad.Free

为什么要 Free Monad

先回忆前面三兄弟的上下文语义:

它们的共同点是:上下文语义写死在 Monad 实例里。这带来一个问题:如果我想”换个方式执行”同一个程序呢?比如:

• 同一个交互程序,生产环境走 IO(真的打印、真的读键盘),测试环境不碰 IO(输入来自列表、输出被吞掉);
• 同一个”读/写状态”的程序,既想在 State 里跑,又想用纯函数 s -> (a,s) 跑,甚至想在数据库上跑。

传统的解决方案各有代价:

• MonadIO 之类的类型类:把语义拆成接口,但类型签名会越来越复杂;
• ReaderT design pattern 里注入函数:本质是把”解释”塞进环境里,语义仍然和 IO 纠缠。

Free Monad 走的是另一条路:把程序写成”数据”,把执行写成”遍历数据的函数”。

一个类比:程序是菜谱(数据),解释器是厨师(函数)。同一份菜谱,交给川菜厨师和粤菜厨师,能做出完全不同的菜。菜谱本身可以被检查、被抄写、被翻译,而不会”烧糊任何东西”——因为它压根不执行。

在 Haskell 里,这个思路的落地方式就是 Free Monad:

1. 你先定义指令集(一个 Functor),比如”读一行输入""打印一行字”;
2. 用 do 语法把这些指令组合成程序——此时程序只是一个嵌套的数据结构(语法树),什么都不会发生;
3. 编写解释器(一个函数),把语法树翻译成真正的计算(IO、State、纯函数……随便);
4. 同一个程序,换解释器 = 换语义。

flowchart LR
    SRC["程序(语法树, 数据)"] --> INT["解释器 foldFree / iterM"]
    INT --> A["IO 解释器(生产)"]
    INT --> B["State 解释器(测试)"]

“Free” 的含义:对任意 Functor f,Free f 免费得到一个合法的 Monad 实例。你不需要为每个 DSL 手写 Monad(还要自己证明 monad laws 成立),只需要定义指令集、推导 Functor,组合能力(>>=、do)是白送的。

定义

简单定义(控制结构):

data Free f a = Pure a              -- 叶子:一个计算结果 a
              | Free (f (Free f a)) -- 节点:一条指令,子树是"剩下的程序"

一棵”程序树”只有两种形态:

• Pure a :计算完成,结果为 a;
• Free (f (Free f a)) :一步指令 f,它的”续延”(continuation)里装着剩下的程序。

flowchart TB
    subgraph shape["Free f a 的结构"]
        P["Pure a —— 叶子:计算结果"]
        F["Free (f (Free f a)) —— 节点:一条指令 + 剩余程序"]
    end

完整定义 (from Control.Monad.Free, package: free):

instance (Functor f) => Functor (Free f) where
  fmap f (Pure a)  = Pure (f a)
  fmap f (Free as) = Free (fmap (fmap f) as)

instance (Functor f) => Applicative (Free f) where
  pure = Pure
  Pure f <*> x = fmap f x
  Free fs <*> x = Free (fmap (<*> x) fs)

instance (Functor f) => Monad (Free f) where
  return = Pure
  Pure a >>= f = f a
  Free m >>= f = Free (fmap (>>= f) m)

看 >>= 的定义,这是理解 Free Monad 的关键:

• Pure a >>= f :结果已经算出,直接交给续延 f;
• Free m >>= f :指令还没被解释,不执行任何东西,只是用 fmap 把续延 (>>= f) 递归地”挂”到 m 里的每一个续延上。

也就是说,绑定操作只负责”盖楼”,不负责”入住”。整个程序被组合成一个越来越大的嵌套结构,语义完全留到解释阶段。正因为这份实现是最”直白”的(把续延显式存在树里),monad laws 天然成立——这就是”自由”一词的来源。

liftF

liftF :: (Functor f) => f r -> Free f r
liftF command = Free (fmap Pure command)

liftF 把一条指令 command :: f r 包装成一棵最小的树:节点是 command,叶子是 Pure。

实践中通常再包一层 smart constructor,把类型写得更友好。例如后文 Example two 里:

get :: Free (StateCmd s) s
get = liftF (Get id)

解释器

foldFree —— 把每个指令翻译成目标 monad m 里的动作:

foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
foldFree _ (Pure a)  = return a
foldFree f (Free as) = f as >>= foldFree f

• 解释器 f 收到节点,此时节点里的续延仍然是 Free f(未解释的程序);
• f 把它翻译成 m (Free f a),剩下的程序由 >>= 交给 foldFree 继续递归解释;
• 签名里的 forall x . f x -> m x 是 rank-2 类型,要求翻译对任意剩余程序都成立。

iterM —— 续延已经被递归解释成 m 里的动作,你只负责”缝合”:

iterM :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a
iterM _ (Pure a)  = return a
iterM f (Free as) = f (fmap (iterM f) as)

• 与 foldFree 的区别:fmap (iterM f) 先递归解释了子树,所以 f 收到的节点里,续延已经是 m a;
• 写起来更省心:不需要处理 Free 结构,也没有 rank-2 类型。

retract —— 当 f 本身已经是 Monad 时,把树”塌缩”回 f:

retract :: Monad f => Free f a -> f a
retract (Pure a) = return a
retract (Free as) = as >>= retract

import Control.Monad.Free

main :: IO ()
main = do
  print (retract (liftF Nothing) :: Maybe Int)
  print (retract (liftF (Just 3) >>= return . (+1)) :: Maybe Int)

retract 说明了一件事:Free f 是”最通用”的基于 f 的 monad——任何具体的解释,都是把这份通用结构折叠进某个目标 monad。

Monadic Semantics

• Target type : a
• Context type : Free f
  • Explicitly : transformation among target types(a -> b -> c,与三兄弟一致)。
  • Implicitly : 计算不被执行,而是被记录成一棵由指令 f 构成的树;语义由解释器在最后一刻赋予。

常见用法

1. 定义指令集 f(一个 Functor;每个构造子都必须携带续延,见下文) (compulsory)
2. 用 liftF / smart constructor 把指令变成 Free f 计算 (compulsory)
3. 用 do / >>= 组合成程序——此刻它只是数据,不会执行 (compulsory)
4. 编写解释器:foldFree / iterM / retract (compulsory)
5. 用不同的解释器运行同一个程序(测试替身 vs 真实执行) (optional, 但这就是全部意义所在)

直觉

• 程序 = 数据(语法树)。可以检查、转换、测试,而不会有副作用;
• 指令集是语法,解释器是语义;
• 你只需要关心”有哪些指令”,>>= / do 的组合能力是 Free 免费送的。

Example one: 一个程序,两个解释器

1. 指令集

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free
import Control.Monad.Trans.State    -- 测试解释器会用到 runState

-- | 一个交互程序的指令集:三种指令
data Prompt a
  = Todo a                  -- 提醒自己还有 TODO,带着续延
  | Prompt String (String -> a)  -- 打印提示语,读取一行输入
  | Print String a          -- 打印一行字
  deriving (Functor)

注意:每个构造子都必须带着”续延”。原因是节点自己并不知道”剩下的程序”是什么,只能靠构造子里存着。以 Todo 为例,若定义成没有续延的 Todo,那么

Free Todo >>= f = Free (fmap (>>= f) Todo) = Free Todo

续延 f 被静默丢弃,程序语义就错了。所以正确的写法是 Todo a,把”接下来干什么”显式存进指令里。

2. smart constructors

todo :: Free Prompt ()
todo = liftF (Todo ())

prompt :: String -> Free Prompt String
prompt msg = liftF (Prompt msg id)

printOut :: String -> Free Prompt ()
printOut s = liftF (Print s ())

3. 程序(只是数据!)

program :: Free Prompt ()
program = do
  todo
  name <- prompt "what's your name?"
  printOut ("hello, " ++ name)

到这一步为止,program 只是一个嵌套的 Free 结构,do 语法不过是在”盖楼”。什么都还没有执行。

4. 解释器一:IO(生产环境)

runIO :: Free Prompt a -> IO a
runIO = foldFree f
  where
    f :: Prompt x -> IO x
    f (Todo rest)     = putStrLn "[TODO]" >> return rest
    f (Prompt msg k)  = putStrLn msg >> fmap k getLine
    f (Print s rest)  = putStrLn s >> return rest

5. 解释器二:纯函数 + State(测试环境)

测试时不碰 IO:输入来自一个字符串列表,状态用 State [String] 管理:

runTest :: Free Prompt a -> [String] -> (a, [String])
runTest = runState . iterM f
  where
    f :: Prompt (State [String] a) -> State [String] a
    f (Todo rest)     = rest
    f (Prompt msg k)  = do
      xs <- get
      case xs of
        (x:rest) -> put rest >> k x
        []       -> error "no more input"
    f (Print s rest)  = rest

两个解释器跑的是同一个 program。生产与测试的差异只体现在解释器里,程序本身一行都不用改——这就是”描述与解释分离”的价值。点 Run 试试:

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free
import Control.Monad.Trans.State (State, runState, get, put)

data Prompt a
  = Todo a
  | Prompt String (String -> a)
  | Print String a
  deriving (Functor)

todo :: Free Prompt ()
todo = liftF (Todo ())

prompt :: String -> Free Prompt String
prompt msg = liftF (Prompt msg id)

printOut :: String -> Free Prompt ()
printOut s = liftF (Print s ())

program :: Free Prompt ()
program = do
  todo
  name <- prompt "what's your name?"
  printOut ("hello, " ++ name)

runIO :: Free Prompt a -> IO a
runIO = foldFree f
  where
    f :: Prompt x -> IO x
    f (Todo rest)    = putStrLn "[TODO]" >> return rest
    f (Prompt msg k) = putStrLn msg >> fmap k getLine
    f (Print s rest) = putStrLn s >> return rest

runTest :: Free Prompt a -> [String] -> (a, [String])
runTest = runState . iterM f
  where
    f :: Prompt (State [String] a) -> State [String] a
    f (Todo rest)    = rest
    f (Prompt msg k) = do
      xs <- get
      case xs of
        (x:rest) -> put rest >> k x
        []       -> error "no more input"
    f (Print s rest) = rest

main :: IO ()
main = do
  putStrLn "== runIO (生产解释器) =="
  runIO program
  putStrLn "== runTest (测试解释器) =="
  print (runTest program ["emmettng"])
  print (runTest program ["emmettng","unused"])

Example two: 用 Free 亲手造一个 State(呼应 03-state)

既然语义由解释器决定,那么三兄弟的语义当然也可以用 Free 复刻。以 03-state 为例,State 的本质是”隐式传递并更新状态 s”,对应两条指令:读状态、写状态。

1. 指令集

import Control.Monad.Free
import qualified Control.Monad.Trans.State as S

-- | 状态指令:Get 读状态,Put 写状态
data StateCmd s a
  = Get (s -> a)    -- 读取当前状态 s,交给续延
  | Put s a         -- 丢弃当前状态,换成 s 后继续
  deriving (Functor)

get :: Free (StateCmd s) s
get = liftF (Get id)

put :: s -> Free (StateCmd s) ()
put s = liftF (Put s ())

modify :: (s -> s) -> Free (StateCmd s) ()
modify f = do
  s <- get
  put (f s)

2. 程序

counter :: Free (StateCmd Int) Int
counter = do
  modify (+1)
  modify (+10)
  get

3. 解释器一:交给真正的 State Monad

runWithState :: Free (StateCmd s) a -> S.State s a
runWithState = iterM f
  where
    f :: StateCmd s (S.State s a) -> S.State s a
    f (Get k)    = S.get >>= k
    f (Put s' m) = S.put s' >> m

4. 解释器二:纯函数 s -> (a,s)

回忆 03-state 里 State 的本体:newtype State s a = State { runState :: s -> (a,s) }。我们可以完全不依赖 State 类型,手写一个递归遍历语法树的纯函数解释器:

runPure :: Free (StateCmd s) a -> s -> (a, s)
runPure (Pure a)           s  = (a, s)
runPure (Free (Get k))     s  = runPure (k s) s          -- 读:把当前状态交给续延,原样传下去
runPure (Free (Put s' next)) _ = runPure next s'         -- 写:忽略当前状态,带着新状态继续

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free
import qualified Control.Monad.Trans.State as S

data StateCmd s a
  = Get (s -> a)
  | Put s a
  deriving (Functor)

get :: Free (StateCmd s) s
get = liftF (Get id)

put :: s -> Free (StateCmd s) ()
put s = liftF (Put s ())

modify :: (s -> s) -> Free (StateCmd s) ()
modify f = do
  s <- get
  put (f s)

counter :: Free (StateCmd Int) Int
counter = do
  modify (+1)
  modify (+10)
  get

runWithState :: Free (StateCmd s) a -> S.State s a
runWithState = iterM f
  where
    f :: StateCmd s (S.State s a) -> S.State s a
    f (Get k)    = S.get >>= k
    f (Put s' m) = S.put s' >> m

runPure :: Free (StateCmd s) a -> s -> (a, s)
runPure (Pure a)          s = (a, s)
runPure (Free (Get k))    s = runPure (k s) s
runPure (Free (Put s' next)) _ = runPure next s'

main :: IO ()
main = do
  print (runPure counter 0)
  print (S.runState (runWithState counter) 0)

两个解释器结果完全一致。更有意思的是:把 runPure 对 Get/Put 的处理和 03-state 里 >>= 的定义放在一起看——

m >>= k  = StateT $ \ s -> do
    ~(a, s') <- runStateT m s
    runStateT (k a) s'

Get k 是”把当前状态交给续延、原样传下去”(runPure (k s) s,对应 s' = s),Put s' next 是”用新状态继续”(runPure next s')——你的解释器手写的正是 State Monad 的语义。换句话说,State 不过是”由 Get/Put 组成的 Free Monad”的一种固定解释。理解了这一层,三兄弟就不再神秘:它们各自的语义,都可以在 Free Monad 的框架里重新造一遍(练习:试试用 Ask/Local 复刻 Reader,用 Tell 复刻 Writer)。

5. 动画:counter 的构建与解释

下面的播放器展示了 counter 从”程序”到”语法树”再到”被解释”的全过程。点 ▶ 播放,或用 ← → 手动步进:

counter :: Free (StateCmd Int) Int
counter = do
modify (+1)      ← 现在处理这一行
modify (+10)
get

Free (Put 1 (续延))

对比一下 03-state 里 >>= 的定义,Get/Put 的这两条规则正是 State 语义本身——你的解释器”手写”了 State Monad。

Intuition recap

• Writer w 隐式聚合 w,Reader r 隐式传递 r,State s 隐式更新 s——语义固定;
• Free f 隐式记录”执行过哪些指令”,语义开放,由解释器赋予;
• 程序是数据,所以可以被测试、被检查、被转换,而不会产生副作用;
• 同一程序 + 不同解释器 = 测试环境与生产环境的差异,只发生在解释器一层;
• 你只需定义指令集(Functor),Monad 的组合能力与 monad laws 由 Free 免费提供。

TODO

• 效率问题:普通 Free 的左结合 >>= 会造成嵌套过深,实践中常用 FreeT/Codensity 优化;
• 与 tagless final 的对比(见 design-patterns);
• 练习:用 Free 复刻 Reader(指令 Ask/Local)与 Writer(指令 Tell),并写出两套解释器。