Freeモナドの合成

TL;DR

• Freeモナドの合成はCoproductという型とInjectという型クラスを使うとできるよ！
• 詳しくはコードを見てね！ https://github.com/goldarn-ring/how-to-compose-free-monad

すごーい！君はDSLが得意なフレンズなんだね！

突然ですが、Freeモナドって便利ですよね！
えっ、ご存知ではない？　DSLを簡単に作れる便利なモナドですよ！　詳しくはこちら：

• Freeモナドって何なのさっ！？ - capriccioso String Creating(Object something){ return My.Expression(something); }
• そろそろFreeモナドに関して一言いっとくか - fumievalの日記

DSLによるコードと、DSLの各命令の処理を切り離すことで、モック化とかDIとかが簡単にできるのです。
例えばこのようなDSLを作って：
（コードはHaskellではなくPureScriptです。importは省略しています）

data Friends a
  = Wai a
  | Sugoi a
  | Tanoshii a
  | TokuiNandane String a

wai :: Free Friends Unit
wai = liftF $ Wai unit

sugoi :: Free Friends Unit
sugoi = liftF $ Sugoi unit

tanoshii :: Free Friends Unit
tanoshii = liftF $ Tanoshii unit

tokuiNandane :: String -> Free Friends Unit
tokuiNandane skill  = liftF $ TokuiNandane skill unit

DSLでこのようなこのようなプログラムを書きます：

friends :: String -> Free Friends Unit
friends skill = do
  wai
  sugoi
  tanoshii
  tokuiNandane skill

そしてDSLの各命令の動作を定義します：

goFriendsJp :: forall a. Friends a -> Effect a
goFriendsJp (Wai next) = do
  log "わーい！"
  pure next
goFriendsJp (Sugoi next) = do
  log "すごーい！"
  pure next
goFriendsJp (Tanoshii next) = do
  log "たーのしー！"
  pure next
goFriendsJp (TokuiNandane skill next) = do
  log ("君は" <> skill <> "が得意なフレンズなんだね！")
  pure next

最後にDSLを走らせると、「わーい！　すごーい！　たーのしー！　君はクソコードが得意なフレンズなんだね！」（改行省略）と表示されます。

runFriendsJp :: forall a. Free Friends a -> Effect a
runFriendsJp f = foldFree goFriendsJp f

main :: Effect Unit
main = do
  log "◆フレンズ（日本語）◆"
  runFriendsJp $ friends "クソコード"

フレンズたちに英語をしゃべらせてみましょう。DSLの各命令の動作を以下のようにします：

goFriendsEn :: forall a. Friends a -> Effect a
goFriendsEn (Wai next) = do
  log "Wow!"
  pure next
goFriendsEn (Sugoi next) = do
  log "Great!"
  pure next
goFriendsEn (Tanoshii next) = do
  log "Wonderful!"
  pure next
goFriendsEn (TokuiNandane skill next) = do
  log ("You are friends that good at " <> skill <> "!")
  pure next

そしてこの定義を使ってDSLで書かれたプログラムを走らせると、今度は「Wow! Great! Wonderful! You are friends that good at Crappy Code!」（改行省略）と表示されます。

runFriendsEn :: forall a. Free Friends a -> Effect a
runFriendsEn f = foldFree goFriendsEn f

main :: Effect Unit
main = do
  log "\n◆Friends (English)◆"
  runFriendsEn $ friends "Crappy Code"

この例はまごうことなきクソofクソコードですが、この命令の動作差し替えの仕組みがあれば、例えば、本番では外部APIを叩いて値を取得するけどテストコードでは適当なダミーの値を返すモックだとかを作れるだろうということが分かると思います。

すごーい！君はニンジャのフレンズなんアイエエエ！ニンジャナンデ！？

DSLというのは往々にして複数の種類のものを混ぜて使いたくなることがあります。例えばQiita API用のDSLとTwitter API用のDSLがある場合、Qiitaに記事を投稿してそれをTwitterにシェアなんて機能の実装には両方のDSLを混ぜて使うことになるでしょう。

さて、まずは前節のフレンズDSLとは別のDSLを用意しましょう。

data Ninja a
  = Domo String a
  | Yeeart a
  | Aieee a
  | Sayonara String a

domo :: String -> Free Ninja Unit
domo name = liftF $ Domo name unit

yeeart :: Free Ninja Unit
yeeart = liftF $ Yeeart unit

aieee :: Free Ninja Unit
aieee = liftF $ Aieee unit

sayonara :: String -> Free Ninja Unit
sayonara name = liftF $ Sayonara name unit

runNinjaJp :: forall a. Free Ninja a -> Effect a
runNinjaJp f = foldFree goNinjaJp f

goNinjaJp :: forall a. Ninja a ->  Effect a
goNinjaJp (Domo name next) = do
  log ("ドーモ、" <> name <> "＝サン") 
  pure next
goNinjaJp (Yeeart next) = do
  log "イヤーッ！"
  pure next
goNinjaJp (Aieee next) = do
  log "アイエエエ！？"
  pure next
goNinjaJp (Sayonara name next) = do
  log ("サヨナラ！ " <> name <> "＝サンは爆発四散！")
  pure next

さて、このニンジャDSLと先ほどのフレンズDSLを混ぜて使うにはどうすればいいでしょう？
具体的にはDSLで書かれた以下のようなプログラムが動くようになってほしいということです。

ninjaFriends :: String -> String -> String -> Free NinjaFriends Unit
ninjaFriends skill ninja1 ninja2 = do
  wai
  domo ninja1
  sugoi
  yeeart
  tanoshii
  aieee
  sayonara ninja2
  tokuiNandane skill

「Free モナド 合成」でググると一番上にこんなブログ記事がヒットします。

• CoproductとInjectを使ったFree Monadの合成とExtensible Effects - xuwei-k's blog

Coproduct・・・？　Inject・・・？　よくわからないですが、この二つを使えば、二つのDSLを合成してニンジャフレンズDSLを爆誕させることができそうです。コードはScalaで書かれていますね。型クラスを使ったScalaのコードを読むのは慣れませんが、PureScriptで書くとどうなるのでしょう・・・。

ドーモ、Coproduct＝サン

まずはFriendsとNinjaを合成して、NinjaFriendsと言う型を作ります。ここで早くもCoproductが登場します。Coproductは、kindがType -> Typeの型を二つ受け取って、それらの直和型を作る型のようです。NinjaもFriendsも型引数を一つ取る（つまりkindがType -> Type）のでCoproductで合成できます。

type NinjaFriends = Coproduct Ninja Friends

Coproductがどんな型なのか、より詳しくは以下のドキュメントを参照してください

• https://pursuit.purescript.org/packages/purescript-functors/3.1.0/docs/Data.Functor.Coproduct#t:Coproduct

ドーモ、Inject＝サン

次に、DSLの各命令（waiとかdomoとか）をNinjaFriendsのFreeモナドでも使えるようにします。ここでInjectの出番です。
もともと以下のような定義だった各命令を：

wai :: Free Friends Unit
wai = liftF $ Wai unit

domo :: String -> Free Ninja Unit
domo name = liftF $ Domo name unit

Injectを使って以下のように書き換えます。するとwaiやdommoがNinjaFriendsのFreeモナドでも使えるようになります。

liftF' :: forall f g a. Inject f g => f a -> Free g a
liftF' f = liftF $ inj f

wai :: forall f. Inject Friends f => Free f Unit
wai = liftF' $ Wai unit

domo :: forall f. Inject Ninja f => String -> Free f Unit
domo name = liftF' $ Domo name unit

なぜこれだけで使えるようになるのでしょう？ それはCoproductがInjectのインスタンスになっているからです。ソースコードを見てみましょう。

（https://github.com/purescript/purescript-functors/blob/v3.1.0/src/Data/Functor/Coproduct/Inject.purs より一部抜粋)

class Inject f g where
  inj :: forall a. f a -> g a

instance injectLeft :: Inject f (Coproduct f g) where
  inj = Coproduct <<< Left

else instance injectReflexive :: Inject f f where
  inj = identity

Injectの型引数が両方ともNinjaやFriendsの場合、injはidentityになります。つまり、liftF'はliftFと同じ動作になります。型引数の左側がNinjaやFirendsで右側がそれと何かのCoproductの場合、injは引数のNinjaやFriendsの値からCoproductの値を作るようになります。これにより、waiやdomoは、もとのNinjaやFriendsでもそれらのCoproductであるNinjaFriendsでも使えるようになります。

命令実行関数合成すべし。慈悲は無い

次に、DSLの各命令の動作を定義する関数を合成しましょう。つまり以下のようなコードで、goNinjaJpとgoFriendsJpを合成できるようなor関数を作ります。

goNinjaFriendsJp :: forall a. NinjaFriends a -> Effect a
goNinjaFriendsJp x = (goNinjaJp `or` goFriendsJp) x

そして、以下がそのor関数の定義です。f aを受け取る関数とg aを受け取る関数から、両方のCoproductを受け取る関数を作ります。その関数の中では、渡されたCoproductの値が左右どちらの値なのかを確認し、適切な方の関数に渡しています。

or :: forall f g h a. (f a -> h a) -> (g a -> h a) -> (Coproduct f g a -> h a)
or fh gh = case _ of
  (Coproduct (Left left)) -> fh left
  (Coproduct (Right right)) -> gh right

ここまでやってようやく、ニンジャフレンズDSLを以下のように走らせることができるようになります。

runNinjaFriendsEn :: forall a. Free NinjaFriends a -> Effect a
runNinjaFriendsEn f = foldFree goNinjaFriendsEn f

main :: Effect Unit
main =  do
  log "◆ニンジャフレンズ（日本語）◆"
  runNinjaFriendsJp $ ninjaFriends "クソコード" "サーバル" "カバン"

コンソールには以下のような出力がされることでしょう。ナムアミダブツ！

◆ニンジャフレンズ（日本語）◆
わーい！
ドーモ、サーバル＝サン
すごーい！
イヤーッ！
たーのしー！
アイエエエ！？
サヨナラ！ カバン＝サンは爆発四散！
君はクソコードが得意なフレンズなんだね！

番外編1：君って本当にFreeモナドのフレンズなの・・・？

Freeモナドとは、Functorさえあればそこからモナドを作れるモナドです。HaskellにもPureScriptにも、Functorを導出する仕組みがあります。

例えばHaskellではこんな感じ：

{-# LANGUAGE DeriveFunctor #-}

data Foo a = Hoge a | Fuga a deriving (Functor)

PureScriptだとこんな感じ：

data Foo a = Hoge | Fuga a

derive instance functorFoo :: Functor Foo

あれ・・・？　本編でderive instanceなんて書いてないぞ・・・。
この記事でさんざん使ってきたliftFとfoldFreeの型をHaskellとPureScriptで比較してみましょう。

ドキュメントは以下から
- Haskell: http://hackage.haskell.org/package/free-5.1/docs/Control-Monad-Free.html
- PureScript: https://pursuit.purescript.org/packages/purescript-free/5.1.0/docs/Control.Monad.Free

HaskellではliftFとfoldFreeはそれぞれ以下のような定義になっています。
はい。liftFがFunctorを要求していますね。

liftF :: (Functor f, MonadFree f m) => f a -> m a
foldFree :: Monad m => (forall x. f x -> m x) -> Free f a -> m a

一方、PureScriptでは以下のような定義になっています。~> という見慣れない矢印がありますが、これは自然変換を表します。簡単に言えば、f ~> gはf a -> g aの略記だと思えばいいでしょう。それはそれとして、やはりliftFがFunctorを要求しませんね・・・。

liftF :: forall f. f ~> (Free f)
foldFree :: forall f m. MonadRec m => (f ~> m) -> (Free f) ~> m

どういうことなの・・・？ もしかしてOperationalモナドなの？　CoyonedaというFunctorを使えばただのデータ型からFunctorを作れるので、それとFreeモナドを組み合わせることで、ただのデータ型からモナドを作れるというのがOperationalモナドですが・・・。

ソースコードを見るとCoyonedaも使っていないんですよねー・・・。
https://github.com/purescript/purescript-free/blob/v5.1.0/src/Control/Monad/Free.purs

番外編2: Haskellでも書いてみたよ！

• Haskellの場合、CoproductじゃなくてSumを使うよ！ 機能は実質一緒だよ
  • https://hackage.haskell.org/package/transformers-0.4.2.0/docs/Data-Functor-Sum.html
• Injectは無いっぽいから、自分で実装しよう！
  • Haskellにはinstance chainなんて構文は無いから、代わりに{-# OVERLAPS #-}と{-# OVERLAPPABLE #-}プラグマを使うよ！
• 詳しくはGitHubのコードを見てね！
  • https://github.com/goldarn-ring/how-to-compose-free-monad/tree/master/haskell/how-to-compose-free-monad

コード

冒頭にも貼りましたが、最後に書いたコードへのリンクを張っておきます。コードはご自由にお使いください。