Haskell语言学习笔记（72）Free Monad

安装 free 包

$ cabal install free
Installed free-5.0.2

Free Monad

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f = go where
    go (Pure a)  = Pure (f a)
    go (Free fa) = Free (go <$> fa)

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

• data Free f a = Pure a | Free (f (Free f a))
  Free f a 是一种递归数据结构。它带有两个类型参数：Functor类型参数 f 以及作为递归终点的数据类型 a。
  Free 数据类型内可包含一个或多个 f，但只能包含一个 a。
• instance Functor f => Functor (Free f) where
  如果 f 是 Functor，那么 Free f 就是 Functor
• instance Functor f => Monad (Free f) where
  如果 f 是 Functor，那么 Free f 就是 Monad

证明 Free f’ 符合Funtor法则：  
1. fmap id ≡ id
即 fmap id m ≡ id m
1.1 m = Pure a 时
fmap id (Pure a) ≡ Pure (id a) ≡ Pure a ≡ id (Pure a)
1.2 m = Free (f' x) 时
fmap id (Free (f' x)) ≡ Free (fmap id (f' x)) ≡ Free (f' (id x)) ≡ Free (f' x) ≡ id (Free (f' x))
2. fmap (f . g) ≡ fmap f . fmap g
即 fmap (f . g) m ≡ (fmap f . fmap g) m
2.1 m = Pure a 时
fmap (f . g) (Pure a) ≡ Pure ((f . g) a) ≡ Pure (f (g a))
(fmap f . fmap g) (Pure a) ≡ fmap f (fmap g (Pure a)) ≡ fmap f (Pure (g a)) ≡ Pure (f (g a))
2.2 m = Free (f' x) 时
fmap (f . g) (Free (f' x)) ≡ Free (fmap (f . g) (f' x)) ≡ Free (f' ((f . g) x) ≡ Free (f' (f (g x)))
(fmap f . fmap g) (Free (f' x)) ≡ fmap f (fmap g (Free (f' x)))
≡ fmap f (Free (fmap g (f' x))) ≡ fmap f (Free (f' (g x)))
≡ Free (fmap f (f' (g x))) ≡ Free (f' (f (g x)))

证明 Free f’ 符合Monad法则：  
1. return a >>= f ≡ f a
return a >>= f ≡ Pure a >>= f ≡ f a   
2. m >>= return ≡ m
2.1 m = Pure a 时
Pure a >>= return ≡ Pure a >>= Pure ≡ Pure a
2.2 m = Free (f' x) 时
Free (f' x) >>= return
≡ Free (f' x) >>= Pure
≡ Free (fmap (>>= Pure) (f' x))
≡ Free (f' (x >>= Pure))
≡ Free (f' (Free (f' ... (Free (f' (Pure a >>= Pure))) ... )))
≡ Free (f' (Free (f' ... (Free (f' (Pure a))) ... )))
≡ Free (f' x)
3. (m >>= f) >>= g ≡ m >>= (x -> f x >>= g)
(m >>= f) >>= g
≡ (Free (f' (Free (f' ... (Free (f' (Pure a))) ... ))) >>= f) >>= g
≡ Free (f' (Free (f' ... (Free (f' (Pure a >>= f))) ... ))) >>= g
≡ Free (f' (Free (f' ... (Free (f' (f a))) ... ))) >>= g
≡ Free (f' (Free (f' ... (Free (f' (f a >>= g))) ... )))
m >>= (x -> f x >>= g)  
≡ Free (f' (Free (f' ... (Free (f' (Pure a))) ... ))) >>= (x -> f x >>= g)
≡ Free (f' (Free (f' ... (Free (f' (Pure a >>= (x -> f x >>= g)))) ... )))
≡ Free (f' (Free (f' ... (Free (f' ((x -> f x >>= g) a))) ... )))
≡ Free (f' (Free (f' ... (Free (f' (f a >>= g))) ... )))

Prelude Control.Monad.Free> :t Pure 3
Pure 3 :: Num a => Free f a
Prelude Control.Monad.Free> :t Free (Just (Pure 3))
Free (Just (Pure 3)) :: Num a => Free Maybe a
Prelude Control.Monad.Free> :t Free (Just (Free (Just (Pure 3))))
Free (Just (Free (Just (Pure 3)))) :: Num a => Free Maybe a
Prelude Control.Monad.Free> Free (Just (Free (Just (Pure 3)))) >> Free (Just (Free (Just (Pure 3))))
Free (Just (Free (Just (Free (Just (Free (Just (Pure 3))))))))
Prelude Control.Monad.Free> :t Free [Pure 3]
Free [Pure 3] :: Num a => Free [] a
Prelude Control.Monad.Free> :t Free [Free [Pure 3]]
Free [Free [Pure 3]] :: Num a => Free [] a
Prelude Control.Monad.Free> Free [Free [Pure 3]] >> Free [Free [Pure 3]]
Free [Free [Free [Free [Pure 3]]]]

应用实践

Why free monads matter

Free Monad 可以用来实现语言解释器。

假设有一种Toy语言，它包含以下三种命令。

output b -- prints a "b" to the console
bell     -- rings the computer's bell
done     -- end of execution

• output 命令输出数据 b 到控制台，带参数 b。
• bell 命令响铃，不带参数。
• done 命令用于结束程序。

下面通过使用 Free Monad 来实现该语言的解释器。

import Control.Monad.Free

首先定义 Toy 数据类型，它是由三条命令组成的和类型：

data Toy b next =
    Output b next
  | Bell next
  | Done

• 类型参数 b 是通过 output 命令输出到控制台的数据的类型
• 类型参数 next 是下一条命令的类型

要使用 Free Monad，Toy 数据类型必须是 Functor 类型类的实例：

instance Functor (Toy b) where
    fmap f (Output x next) = Output x (f next)
    fmap f (Bell     next) = Bell     (f next)
    fmap f  Done           = Done

要避免手动实现 Functor 类型类可以使用语言扩展 DeriveFunctor

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data Toy b next =
    Output b next
  | Bell next
  | Done
  deriving (Functor)

Toy b 是 Functor，根据定义可得 Free (Toy b) 是 Free Monad。

要使用 Free Monad，所有命令都必须是 Free (Toy b) r 类 型。此时需要使用 liftF 函数。

output :: a -> Free (Toy a) ()
output x = liftF (Output x ())

bell :: Free (Toy a) ()
bell     = liftF (Bell     ())

done :: Free (Toy a) r
done     = liftF  Done

要避免这些重复定义可以使用 makeFree

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}

import Control.Monad.Free
import Control.Monad.Free.TH

data Toy b next =
    Output b next
  | Bell next
  | Done
  deriving (Functor)

makeFree ''Toy

以下定义子例程 subroutine 和程序 program ：

subroutine :: Free (Toy Char) ()
subroutine = output 'A'

program :: Free (Toy Char) r
program = do
    subroutine
    bell
    done

以下定义第一个解释器：打印程序的函数 showProgram

showProgram :: (Show a, Show r) => Free (Toy a) r -> String
showProgram (Free (Output a x)) =
    "output " ++ show a ++ "
" ++ showProgram x
showProgram (Free (Bell x)) =
    "bell
" ++ showProgram x
showProgram (Free Done) =
    "done
"
showProgram (Pure r) =
    "return " ++ show r ++ "
"

pretty :: (Show a, Show r) => Free (Toy a) r -> IO ()
pretty = putStr . showProgram

以下定义第二个解释器：解释运行程序的函数 interpret

interpret :: (Show b) => Free (Toy b) r -> IO ()
interpret (Free (Output b x)) = print b  >> interpret x
interpret (Free (Bell     x)) = print "bell" >> interpret x
interpret (Free  Done       ) = return ()
interpret (Pure r) = return ()

载入程序，确认运行结果：

*Main> putStr (showProgram program)
output 'A'
bell
done

*Main> pretty (output 'A')
output 'A'
return ()

*Main> pretty (return 'A' >>= output)
output 'A'
return ()

*Main> pretty (output 'A' >>= return)
output 'A'
return ()

*Main> pretty ((output 'A' >> done) >> output 'C')
output 'A'
done

*Main> pretty (output 'A' >> (done >> output 'C'))
output 'A'
done

*Main> interpret program
'A'
"bell"

参考链接

https://github.com/lotz84/haskell/blob/master/docs/free-monad.md
Free monads in 7 easy steps