Zenn
Open11

自由モナドの基礎

Haskell
りんすりんす

自由モナドに対してモナドのインスタンスを定義する。

今回前提とする自由モナドの構造。

data Free f a
  = Pure a
  | Bind (f (Free f a))
りんすりんす

最も簡単な定義はjoin :: m (m a) -> m aを定義する方法。
しかしこれでは味気ない。

instance Functor f => Functor (Free f) where
  fmap = liftM

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

instance Functor f => Monad (Free f) where
  m >>= f = joinF $ fmap f m

joinF :: Functor f => Free f (Free f a) -> Free f a
joinF (Pure m) = m
joinF (Bind f) = Bind $ fmap joinF f
りんすりんす

ひとつひとつ定義してみる。これは最も自然な定義。

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure $ f a
  fmap f (Bind a) = Bind $ (fmap . fmap) f a

instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure f <*> a = fmap f a
  Bind f <*> a = Bind $ fmap (<*> a) f

instance Functor f => Monad (Free f) where
  Pure a >>= f = f a
  Bind m >>= f = Bind $ fmap (>>= f) m
りんすりんす

Applicativeのfmap (<*> a) fとMonadのfmap (>>= f) mの形がすごく似ている。
よく見たらFunctorもfmap (f <$>) aの形にできる。

普通はFunctor, Applicative, Monadの定義がこんなに似ることはないので不思議。自由モナドの本質的が部分が垣間見える気がする。

りんすりんす

ここからは実際に使う例。

自由モナドは、自由モノイドであるリストの亜種と捉えられる。リストを畳み込むようにして、自由モナドを畳み込む方法を確認する。

わざとらしい例ではあるが、まずは自由リストに与える関手CommandFを定義する。
ここで定義する関手はputStrLn :: String -> m ()とgetLine :: m Stringという二つのコマンドを持つものを想定している。

data CommandF cont = PutStrLn String cont | GetLine (String -> cont)

instance Functor CommandF where
  fmap f (PutStrLn s cont) = PutStrLn s (f cont)
  fmap f (GetLine cont) = GetLine $ \s -> f $ cont s

contは継続である。GetLineは継続に文字列を渡すコマンドであることを表し、PutStrLnは文字列を受け取る一方で継続に何も渡さないコマンドであることを表す。PutStrLnでは() -> contを省略してcontとしている。

りんすりんす

作った関手に自由モナドをかぶせると、モナドになる。
このCommandモナドは、予め定義したコマンドに対応するメソッドを持つ。

type Command a = Free CommandF a

putStrLn' :: String -> Command ()
putStrLn' s = Bind $ PutStrLn s $ Pure ()

getLine' :: Command String
getLine' = Bind $ GetLine Pure

Commandはモナドであるから、Haskellによる強力なサポートを受けながらメソッドを使った処理を書くことができる。

helloWorld :: Command ()
helloWorld = do
  putStrLn' "Hello, Free Monad!"
  getLine' >>= putStrLn'
  replicateM_ 3 $
    putStrLn' "The free monad is a cost-free DSL for you."
りんすりんす

Commandを作った時点では、これを使って書いた処理helloWorldはいわば畳み込む前のリスト、コンパイルする前のソースコードのようなものだ。

そこでCommand a -> m aであるようなインタプリタを定義する。例えばこれはPutStrLnコマンドをputStrLnに、GetLineをgetLineに対応させるインタプリタinterpret :: Command a -> IO aを定義する。

interpret :: Command a -> IO a
interpret (Pure a) = pure a
interpret (Bind (PutStrLn s cont)) = do
  putStrLn s
  interpret cont
interpret (Bind (GetLine cont)) = do
  s <- getLine
  interpret $ cont s

これを使えばCommandモナドをIOモナド上で実行できる。

main :: IO ()
main = interpret $ helloWorld

実行結果は次のような感じだ。

Hello, Free Monad!
This is a standard input.
The free monad is a cost-free DSL for you.
The free monad is a cost-free DSL for you.
The free monad is a cost-free DSL for you.
りんすりんす

Commandの実用性はinterpret関数とCommandモナドとの間に直接的な繋がりがないことにある。
例えばCommandをWriterモナドに変換するインタプリタを書けば、実行結果をString型の値として得ることができるようになる。

interpret :: Command a -> Writer String a
interpret (Pure a) = pure a
interpret (Bind (PutStrLn s cont)) = do
  tell $ s <> "\n"
  interpret cont
interpret (Bind (GetLine cont)) = do
  s <- getLineMock
  interpret $ cont s

getLineMock :: Monoid w => Writer w String
getLineMock = pure "This is a mock input."

次のようにしてやれば、実行結果はIOの時と変わらない。

main :: IO ()
main = putStrLn $ execWriter $ interpret $ helloWorld
りんすりんす

蛇足。liftFとして知られる次のユーティリティを用意する。

liftF :: Functor f => f a -> Free f a
liftF = Bind . fmap pure

コマンドをメソッドに変換する処理が簡単に書けるようになる。

putStrLn' :: String -> Command ()
putStrLn' s = liftF $ PutStrLn s ()

getLine' :: Command String
getLine' = liftF $ GetLine id
りんすりんす

自由モナドを使ってモナドを一般化することは、Monad*のような型クラスを定義するのに似ている。

class MonadCommand m where
  putStrLnM :: String -> m ()
  getLineM  :: m String

instance MonadCommand IO where
  putStrLnM = putStrLn
  getLineM = getLine

instance MonadCommand (Writer String) where
  putStrLnM s = tell $ s <> "\n"
  getLineM = getLineMock
りんすりんす

蛇足その二。インタプリタは、CommandFに関わる部分を外に出してやることで一般化できる。
この一般化したインタプリタはランク2多相であるため、RankNTypesなどのGHC拡張が必要だ。

interpret :: (Functor f, Monad m)
          => (forall x. f x -> m x)
          -> Free f a -> m a
interpret _ (Pure a) = pure a
interpret translate (Bind a) =
  translate a >>= interpret translate

抽出したCommandFの処理は次の通り。

translate :: CommandF a -> IO a
translate (PutStrLn s cont) = do
  putStrLn s
  pure cont
translate (GetLine cont) = do
  s <- getLineMock
  pure $ cont s

これらを組み合わせれば、見慣れた形のインタプリタになる。

interpretCommand :: Command a -> IO a
interpretCommand = interpret translate

このinterpret関数は、リストと畳み込みのアナロジーでいうとfoldrに相当する。
interpretCommandはより具体的な畳み込み関数、例えばsum関数に相当する。