Coyonedaの基礎（Haskell）

自由モナドの基礎の続き。圏論での位置づけは別でまとめる。

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

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

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

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

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

りんす

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

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

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

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

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

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

りんす

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

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

unliftY :: Functor f => Coyoneda f a -> f a
unliftY (Coyoneda f a) = fmap f a

りんす

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

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

type Operational f = Free (Coyoneda 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 (Coyoneda f (PutStrLnF s))) =
  putStrLn s >>= interpret . f
interpret (Bind (Coyoneda 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 (Coyoneda 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 (Coyoneda f a)) =
  translate a >>= interpretOperational translate . f

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

translateCoyoneda :: Monad m => (forall x. f x -> m x) -> Coyoneda f a -> m a
translateCoyoneda translate (Coyoneda 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) =
  translateCoyoneda translate a >>= interpretOperational translate

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

interpretOperational :: Monad m => (forall x. f x -> m x) -> Operational f a -> m a
interpretOperational translate = interpretFree $ translateCoyoneda 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."

りんす

https://play.haskell.org/saved/sCPTIKk0