Freeモナドについて今更勉強してみた

5年ほど前、Freeモナドという言葉がHaskell界隈でよく見られました。
僕のフォローしている人たちが次々に解説記事をアップしていたように思います。
5年たった今になって、Freeモナドについて興味が湧いてきたので記事を書いてみることにしました。

Freeモナドの定義に行く前にFree型について説明します。

-- The kind of f is * -> * like Maybe, [].
-- The kind of a is * like Int, Char, [Char].
data Free f a = Pure a | Free (f (Free f a)) 

ここでfはカインド * -> * を持つ型コンストラクタであり、あとで述べるようにFunctorのインスタンスです。
aはカインド * のただの型です。
fが[]、aがIntの場合について調べてみましょう。

free1 :: Free [] Int
free1 = Pure 10

free2 :: Free [] Int
free2 = Free [Free [Free [Free []]]]

free3 :: Free [] Int
free3 = Free [Pure 10]

これら3つの定数関数はすべてFree [] aの型を持ちます。
直感的に言うとリストもリストのリストのリストもただの整数もすべて同じ型になっています。
これだけではFree型をどう使っていいのかわかりません。

これをモナドにしてみましょう。

-- functor is typeclass which "fmap" is defined
-- (<$>) :: Functor f => (a->b) -> f a -> f b
-- (<$>) = fmap
instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Free fa) = Free (fmap (fmap f) fa)

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

モナドになると何が良いのでしょうか?
簡単なゲームを作る例を見ながら、Freeモナドの利点を確認しましょう。

このゲームは

  1. 入力を受け取る
  2. 文字列を出力する
  3. 一秒待つ

の3つの要素の組み合わせで構成されています。
ゲームを表すデータ型がこれです。

data Game cont = GetInput (String -> cont) | Render String cont | Wait cont

instance Functor Game where
  fmap f (GetInput g) = GetInput (f . g)
  fmap f (Render str cont) = Render str (f cont)
  fmap f (Wait cont)     = Wait (f cont)

各コンストラクタは動作を行ったあとの続きの計算を持ちます。
例えば、GetInput fだったら入力を受け取ってfに渡すことで
続きの計算contを計算し、contを実行します。

ここでGameデータ型をFreeモナドと組み合わせて使う利点を説明します。

game1 :: Free Game ()
game1 = Free (Wait (Free (Render "Hello" (Pure ()))))

game1' :: Free Game ()
game1' = (Free (Wait (Pure ()))) >>  (Free (Render "Hello" (Pure ())))

一秒待って"Hello"と出力するゲームを2つの方法で記述してみました。
game1は愚直な記述、game1'は>>演算子を用いた記述です。

実はこの2つは全く同じものです。
game1'を定義にしたがって展開してみます。

(Free (Wait (Pure ()))) >>  (Free (Render "Hello" (Pure ())))
==> (Free (Wait (Pure ()))) >>= (\x -> (Free (Render "Hello" (Pure ()))))
==> Free (fmap (>>= (\x -> (Free (Render "Hello" (Pure ()))))) (Wait (Pure ())))
==> Free (Wait ((>>= (\x -> (Free (Render "Hello" (Pure ()))))) (Pure ())))
==> Free (Wait ((Pure ()) >>= (\x -> (Free (Render "Hello" (Pure ()))))))
==> Free (Wait (Free (Render "Hello" (Pure ()))))

同じになりましたね。
モナドの枠組みを使えばGameデータ型同士を簡単に合成できることがわかります。

input :: (String -> Free Game ()) -> Free Game ()
input f = Free (GetInput f)

render :: String -> Free Game ()
render str = Free (Render str (Pure ()))

wait :: Free Game ()
wait = Free (Wait (Pure ()))

miniGame = do
  render "Please input your name."
  input (\x -> render $ "Your name is " ++ x)
  wait
  render "End"

miniGame関数ではdo記法で3種類のGameコンストラクタを合成しています。
あとはFree Game ()をIO ()に変換する、つまり実際の入出力を行う部分を書けば完成です。

runGame :: Free Game () -> IO ()
runGame (Pure ()) = return ()
runGame (Free (Wait cont)) = runGame cont
runGame (Free (GetInput f)) = getLine >>= \s -> runGame (f s)
runGame (Free (Render str cont)) = putStrLn str >> runGame cont

main :: IO ()
main = runGame miniGame

コンパイルしてmain関数を実行すると名前を聞いてくれます。(ソースコードはこの記事の末尾にあります。)

結局Freeモナドを使うとどんな利点があるのでしょうか。
この記事の例ではゲームの構造と入出力が分離できています。
つまり、テストがしやすいということが言えます。
またゲームの構造だけ作っておいてあとで入出力の部分を差し替えたりするのも簡単です。
Freeモナドを使った2Dゲーム用のライブラリというのもあります。

参考

Freeモナドって何なのさっ!? - capriccioso String Creating(Object something){ return My.Expression(something); }

そろそろFreeモナドに関して一言いっとくか - モナドとわたしとコモナド

以下ソースコード

module Main where

-- The kind of f is * -> * like Maybe, [].
-- The kind of a is * like Int, Char, [Char].
data Free f a = Pure a | Free (f (Free f a)) 

-- functor is typeclass which "fmap" is defined
-- (<$>) :: Functor f => (a->b) -> f a -> f b
-- (<$>) = fmap
instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Free fa) = Free (fmap (fmap f) fa)

-- applicative is typeclass which derived from functor
-- and offer "pure" and <*>
-- (<*>) :: f (a -> b) -> f a -> f b
instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure a <*> Pure b = Pure $ a b
  Pure a <*> Free mb = Free $ fmap a <$> mb
  Free ma <*> b = Free $ (<*> b) <$> ma

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

-- free1 :: Num a => Free f a
free1 :: Free [] Int
free1 = Pure 10

free2 :: Free [] Int
free2 = Free [Free [Free [Free []]]]

free3 :: Free [] Int
free3 = Free [Pure 10]

data Game cont = GetInput (String -> cont) | Render String cont | Wait cont

instance Functor Game where
  fmap f (GetInput g) = GetInput (f . g)
  fmap f (Render str cont) = Render str (f cont)
  fmap f (Wait cont)     = Wait (f cont)

game1 :: Free Game ()
game1 = Free (Wait (Free (Render "Hello" (Pure ()))))

game1' :: Free Game ()
game1' = (Free (Wait (Pure ()))) >> (Free (Render "Hello" (Pure ())))

input :: (String -> Free Game ()) -> Free Game ()
input f = Free (GetInput f)

render :: String -> Free Game ()
render str = Free (Render str (Pure ()))

wait :: Free Game ()
wait = Free (Wait (Pure ()))

miniGame = do
  render "Please input your name."
  input (\x -> render $ "Your name is " ++ x)
  wait
  render "End"

runGame :: Free Game () -> IO ()
runGame (Pure ()) = return ()
runGame (Free (Wait cont)) = runGame cont
runGame (Free (GetInput f)) = getLine >>= \s -> runGame (f s)
runGame (Free (Render str cont)) = putStrLn str >> runGame cont

main :: IO ()
main = runGame miniGame