Zenn
Open12

Operationalモナドの基礎 （Haskell）

Haskell
りんすりんす

Yonedaの定義。見ての通りExistentialQuantification拡張が必要。

data Yoneda f a = forall x. Yoneda (x -> a) (f x)

あるいはGADTs拡張を使って次のように定義しても同じ。

data Yoneda f a where
  Yoneda :: (x -> a) -> f x -> Yoneda f a

これら二つの定義は全く同じように使うことができる。

りんすりんす

Yonedaは任意のfを取ってFunctorを実装する。

instance Functor (Yoneda f) where
  fmap f (Yoneda g h) = Yoneda (f . g) h

しばしばこれ自体が魔法のように語られるが、これ自体はYonedaの特殊な力というよりはYonedaの一つ目のフィールドforall x. x -> aの力だと思う。

data A a = forall x. A (x -> a)

instance Functor A where
  fmap f (A g) = A (f . g)

これが関手を実装するのだから、Yonedaに与えるfは関手の実装には一切影響を与えず、したがってYonedaが任意のfを取ってFunctorを実装するのは自明に思える。

りんすりんす

米田の補題によりYonedaとf aとは同型なので、次のように米田写像とその逆射を定義することができる。

liftY :: f a -> Yoneda f a
liftY = Yoneda id

unliftY :: Functor f => Yoneda f a -> f a
unliftY (Yoneda f a) = fmap f a
りんすりんす

ここからは実際に使う例。
しばしば語られるストーリーとして「Yonedaで関手を作って自由モナドでそれをモナドにしよう」というものがある。それを追ってみよう。

まずは上のストーリーをそのままコードに落とし込む。これを慣例に倣ってOperationalと名付ける。

type Operational f = Free (Yoneda f)
りんすりんす

次に自由モナドでやったような命令セットを用意する。
GADTsを利用して定義されたこのデータ型はFunctorを実装しないが、Operationalに渡してやるとモナドになる。

data CommandF a where
  PutStrLnF :: String -> CommandF ()
  GetLineF  :: CommandF String

type Command = Operational CommandF
りんすりんす

このCommandモナドは、予め定義したコマンドに対応するメソッドを持つ。あとは自由モナドの時とほとんど同じだ。

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

getLine' :: Command String
getLine' = liftF $ liftY GetLineF

自由モナドの時と全く同じ処理を書いてみよう。

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

例によってCommand aを実行するためのインタプリタが必要だ。素朴な実装は次の通りだ。

interpret :: Command a -> IO a
interpret (Pure a) = pure a
interpret (Bind (Yoneda f (PutStrLnF s))) =
  putStrLn s >>= interpret . f
interpret (Bind (Yoneda f GetLineF)) =
  getLine >>= interpret . f

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

main :: IO ()
main = interpret $ helloWorld

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

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

次にいかにも一般化できそうなinterpretを解体していく。

translateCommandF :: CommandF a -> IO a
translateCommandF (PutStrLnF s) = putStrLn s
translateCommandF GetLineF = getLineMock

interpret :: Command a -> IO a
interpret (Pure a) = pure a
interpret (Bind (Yoneda f commandF)) =
  translateCommandF commandF >>= interpret . f

interpretからtranslateCommandFを外に出す。

interpretOperational :: Monad m => (forall x. f x -> m x) -> Operational f a -> m a
interpretOperational _ (Pure a) = pure a
interpretOperational translate (Bind (Yoneda f a)) =
  translate a >>= interpretOperational translate . f

interpretOperationalからYonedaを処理している部分を切り出す。

translateYoneda :: Monad m => (forall x. f x -> m x) -> Yoneda f a -> m a
translateYoneda translate (Yoneda f a) = fmap f $ translate a

interpretOperational :: Monad m => (forall x. f x -> m x) -> Operational f a -> m a
interpretOperational translate (Pure a) = pure a
interpretOperational translate (Bind a) =
  translateYoneda translate a >>= interpretOperational translate

ここまでくれば、自由モナド用のインタプリタを使って書けるようになる。

interpretOperational :: Monad m => (forall x. f x -> m x) -> Operational f a -> m a
interpretOperational translate = interpretFree $ translateYoneda translate

自由モナド用のインタプリタの定義。

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

最終的にユーザーが書く必要のある部分は次の通りになった。自由モナドを直接扱うよりは直感的な部分が多いと思う。

よくあるモナドのコードのように、run*の命名でCommandを受け取るようにしてあげると、非常に見慣れたコードになる。

data CommandF a where
  PutStrLnF :: String -> CommandF ()
  GetLineF  :: CommandF String

type Command = Operational CommandF

putStrLn' :: String -> Command ()
putStrLn' = liftF . liftY . PutStrLnF

getLine' :: Command String
getLine' = liftF $ liftY GetLineF

translateCommandF :: CommandF a -> IO a
translateCommandF (PutStrLnF s) = putStrLn s
translateCommandF GetLineF = getLine

runCommand :: Command a -> IO a
runCommand = interpretOperational translateCommandF

main :: IO ()
main = runCommand $ do
  putStrLn' "Hello, Operational Monad!"
  getLine' >>= putStrLn'
  replicateM_ 3 $
    putStrLn' "The free monad is a cost-free DSL for you."