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

Freeモナドはすごい。

Haskellを書いていて、「特殊化された処理を記述するモナドが簡単に作れたら便利だろうなー」と思ったことはないだろうか？簡単に作れるのである、そう、Haskellならね。

これが、純粋なFreeモナドの定義である。

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

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

(Functor、Applicativeのインスタンス宣言は自明なので省略)

与えられたFunctorをお互いに埋め込み合っている、という漠然とした印象で、何が嬉しいのかよくわからないかもしれない。だが、この単純さこそFreeモナドの便利さの秘訣なのだ。

一文字ずつ入出力をしたい場面を考えてみよう。標準入出力ならgetCharとputCharで事足りるが、ネットワークやGUIでも使えるものを作りたい。以下は簡単な例である:

import Data.Char
ex0 :: GenericIO ()
ex0 = do
    mapM_ putCh "Hello, Haskeller! Please input a character:"
    ch <- getCh
    mapM_ putCh "The ordinal of the character is:"
    mapM_ putCh (show (ord ch))
    mapM_ putCh ".\nThank you!\n"

このような、入出力そのものだけを表すインターフェイスを作りたい場合はどうすればいいだろうか？そこでFreeモナドの登場である。

data CharIO a = GetCh (Char -> a) | PutCh Char a

instance Functor CharIO where
    fmap f (GetCh g) = GetCh (f . g)
    fmap f (PutCh c x) = PutCh c (f x)

まず、CharIOというFunctorを定義した。型変数aには、続きの計算が入ると思ってよい。

追記:GHCのDeriveFunctor拡張を使うことで、自動的にFunctorのインスタンスを作ることができる*1

そして、インターフェイスを定義する。

getCh :: Free CharIO Char
getCh = Free $ GetCh $ \ch -> Pure ch

putCh :: Char -> Free CharIO ()
putCh ch = Free $ PutCh ch (Pure ())

Freeの定義

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

と比較すると、確かにgetCh、putChが型Free CharIO Char、Free CharIO ()を持っているのが分かる。

type GenericIO = Free CharIOとすれば、ex0はもう「使える」。そう、続きの計算を包むFunctorを定義して、Freeにはめ込めば、簡単にモナドが作れてしまうのである。

あとは、Free CharIOという抽象的なモナドを、IOなどの具体的なモナドに接地させる関数を作ればよい。

runStdIO :: Free CharIO a -> IO a
runStdIO (Pure a) = return a
runStdIO (Free (GetCh f)) = getChar >>= \ch -> runStdIO (f ch)
runStdIO (Free (PutCh ch cont)) = putChar ch >> runStdIO cont

はい、これだけ。runStdIO ex0とすれば動くはずだ。

runStdIOの動きを追ってみよう。

Free (GetCh f)を受け取ると、getCharで一文字取り出し、関数fに渡して続きの計算を取り出したのち、runStdIOに渡す。
Free (PutCh 文字続きの計算)を受け取ると、文字を出力し、続きの計算をrunStdIOに渡す。
Pure aは最終的な結果であり、受け取ったら終了する。

同様に、runHandleIO :: Handle -> Free CharIO a -> IO aなどを作れば、好きなハンドルでex0を動かせるだろう。

(追記:勘のいい読者はPythonやRubyなどの言語におけるジェネレータに似ていることに気付いたかもしれない。runList :: Free CharIO a -> [Char] -> (a, [Char])も実装できるので、試してみてほしい)

Freeモナドのメリットは、諸概念を限定された世界に閉じ込めて抽象化できることだけではない。自分でMonadを作ると、MonadWriterなどの型クラスの大量のインスタンス宣言をしなければならないが、Freeモナドならその必要はない。Freeモナドの性質を決めるのはあくまでFunctorなので、そういったインスタンス宣言をFreeそのものに集約できる。いわば、モナドがタダ(free)で手に入るのだ。

Freeモナドはコルーチン的な使い方もできる。先ほどのCharIOを拡張してみよう。

data SyncCharIO a = GetCh (Char -> a) | PutCh Char a | Tick a

instance Functor SyncCharIO where
    fmap f (GetCh g) = GetCh (f . g)
    fmap f (PutCh c x) = PutCh c (f x)
    fmap f (Tick x) = Tick (f x)

getCh :: Free SyncCharIO Char
getCh = Free $ GetCh $ \ch -> Pure ch

putCh :: Char -> Free SyncCharIO ()
putCh ch = Free $ PutCh ch (Pure ())

tick :: Free SyncCharIO ()
tick = Free $ Tick (return ())

新たにtickという操作が定義された。

runSyncStdIO :: Free SyncCharIO a -> IO (Free SyncCharIO a)
runSyncStdIO (Pure a) = return (Pure a)
runSyncStdIO (Free (GetCh f)) = getChar >>= \ch -> runSyncStdIO (f ch)
runSyncStdIO (Free (PutCh ch cont)) = putChar ch >> runSyncStdIO cont
runSyncStdIO (Free (Tick cont)) = return cont

runSyncStdIOは、Free SyncCharIO aを実行し、「tickが実行された段階での続きの計算」を返す関数である。これは、計算を外から切り取れることを意味し、ゲームなどを作る上で非常に便利だ。

最後に、もっと拡張し、任意のIO操作を埋め込めるようにしてみよう。

data SyncCharIOEx a = GetCh (Char -> a) | PutCh Char a | Tick a | EmbedIO (IO a)

instance Functor SyncCharIOEx where
    fmap f (Get g) = Get (f . g)
    fmap f (Put c x) = Put c (f x)
    fmap f (Tick x) = Tick (f x)
    fmap f (EmbedIO m) = EmbedIO (fmap f m)

getCh :: Free SyncCharIOEx Char
getCh = Free $ GetCh $ \ch -> Pure ch

putCh :: Char -> Free SyncCharIOEx ()
putCh ch = Free $ PutCh ch (Pure ())

tick :: Free SyncCharIOEx ()
tick = Free $ Tick (Pure ())

embedIO :: IO a -> Free SyncCharIOEx a
embedIO m = Free $ EmbedIO $ fmap return m

runSyncStdIOEx :: Free SyncCharIOEx a -> IO (Free SyncCharIOEx a)
runSyncStdIOEx (Pure a) = return (Pure a)
runSyncStdIOEx (Free (GetCh f)) = getChar >>= \ch -> runSyncStdIO Ex(f ch)
runSyncStdIOEx (Free (PutCh ch cont)) = putChar ch >> runSyncStdIOEx cont
runSyncStdIOEx (Free (Tick cont)) = return cont
runSyncStdIOEx (Free (EmbedIO m)) = m >>= runSyncStdIOEx