Zenn
🆓

実用的なFreeモナド(purescript-free)の秘密を探る

2023/07/15に公開
PureScript
関数型言語
モナド
解説
tech

序

以前私は「フリーモナドを自分で作ってみよう」という趣旨の記事を投稿したのですが、そのときのフリーモナドの作例は簡単に作って遊べるよう非常にシンプルなものでした。

しかしそれはあくまで作って理解するためのもの。
実際にあちこちで使われている実用に耐えうるフリーモナドとは異なります。
ではそのようなフリーモナドはどのように作られているのでしょうか？

今回は、そんな実用的なフリーモナドの機能がどのように実現されているかを解説したいと思います。

解説に用いるフリーモナドのライブラリはpurescript-freeとします（というかこれ一択？他にいいライブラリはあるのでしょうか？）。

おことわり

  • purescript-freeは複雑ゆえ、解説もクソ長いです。ごめんなさい。
  • 記事中のpurescript-freeのコードは、実際のライブラリのコードを用いていますが、わかりやすさのため一部の関数に私が型アノテーションを加えていますのでご了承ください。

解説していくぞ

解説に使うサンプルコード

Freeはライブラリなので、Freeの解説にはFreeを使って動かすコードが必要でしょう。

ということでまず、解説に使うためのサンプルコードを載せます。
こちらのコードに対し解説を加えていきたいと思います。
ちなみにこのコードはpurescript-freeに含まれるサンプルコードを利用したものです（ちょっと削った）。

Teletype.purs
import Prelude

import Effect (Effect)
import Effect.Console (log)
import Control.Monad.Free (Free, foldFree, liftF)

data TeletypeF a = PutStrLn String a | GetLine (String -> a)

type Teletype a = Free TeletypeF a

putStrLn :: String -> Teletype Unit
putStrLn s = liftF (PutStrLn s unit)

getLine :: Teletype String
getLine = liftF (GetLine identity)

teletypeN :: TeletypeF ~> Effect
teletypeN (PutStrLn s a) = const a <$> log s
teletypeN (GetLine k) = pure (k "fake input")

run :: Teletype ~> Effect
run = foldFree teletypeN

echo :: Teletype Unit
echo = do
  a <- getLine
  putStrLn a

main :: Effect Unit
main = do
  run echo

Free型の定義

サンプルコードを見たところで、Freeの解説に移っていきますよ。

まずは型の定義をみましょう。すべてはそこから始まる。

ということでFreeのコードから、型の定義部分を抜粋してきました。。

Freeの定義の抜粋
data Free f a = Free (FreeView f Val Val) (CatList (ExpF f))

newtype ExpF f = ExpF (Val -> Free f Val)

data FreeView f a b = Return a | Bind (f b) (b -> Free f a)

data Val

シンプルなフリーモナドの定義と比べてみましょうか。

シンプルなフリーモナドの定義
data Free f a
  = Pure a
  | Free (f (Free f a))

・・・・・・どうです？シンプルな定義と比べてやけに複雑になっていませんか？

型の解説を行う前に、このような複雑な定義になっている理由をお伝えしたいと思います。
なぜならば、この定義の複雑さに付随してFreeのモジュールの関数も複雑になっているため、ここの説明をしておくことが、理解の助けに繋がるからです。

複雑さの理由(ワケ)

なぜこのように複雑になっているかですが、私は大まかに2つの理由があると考えています。

  1. フリーモナドの生成におけるFunctorの制約を無くす
  2. パフォーマンスを上げる

Functorの制約を無くす

まず「1」ですが、一般的に紹介されているフリーモナドは、食わせる値の型がFunctorのインスタンスになっている必要があると思います。
以前の記事で作ったフリーモナドを例にとると、モナドにするための各種インスタンスにFunctorの制約があります。
そしてそれは実装にmap関数を利用しているためでした。

簡単なフリーモナドのインスタンス群
instance functorFree :: (Functor f) => Functor (Free f) where
  map f (Pure a) = Pure (f a)
  map f (Free fa) = Free (map f <$> fa)

instance applyFree :: (Functor f) => Apply (Free f) where
  apply = ap

instance applicativeFree :: (Functor f) => Applicative (Free f) where
  pure = Pure

instance bindFree :: (Functor f) => Bind (Free f) where
  bind :: forall a b. Free f a -> (a -> Free f b) -> Free f b
  bind (Pure a) fn = fn a
  bind (Free f) fn = Free $ (\a -> a >>= fn) <$> f   

instance monadFree :: (Functor f) => Monad (Free f)

一方purescript-freeのフリーモナドであるFreeは、Functorの制約なしにフリーモナドの恩恵にあずかることができます。
Functorが要らないという意味では、Freerモナドと考えていいかもしれません。
FreerモナドはフリーモナドにCoyonedaと呼ばれる型を埋め込んだ構造になっていると説明されているのをよく見ます。
（参考：私が昔書いたFreerモナド導出の流れ、および簡単なFreerモナドのコード）
しかしpurescript-freeにはCoyonedaが存在するものの、Freeの定義では使われておらず、いまの定義で実現しているようです。

パフォーマンスを上げる

次に「2」の「パフォーマンスを上げる」です。

purescript-freeのgithubのREADME.mdには

フリーモナドの実装は、シーケンシャルなデータ構造を使って表現されます。詳細は以下を参照してください

と書かれています。
そしてそのすぐあとに、左結合のbindと右結合のbindにおけるパフォーマンスを2バージョンで比較したベンチマークの画像が貼られています。

上記の論文では次のようなことが書かれています（概要や内容から抜粋）。

  • モナドは左結合にするとアルゴリズム的にパフォーマンスが低下する。
  • その問題に対する解決方法としてCPS(Continuation Passing Style) 継続渡しスタイル がよく知られている。
  • ただしCPSが解決できるのは特定の使用パターンのみである。連結の中間の値をobserveしたり、他の連結の部分を用いて連結を構築する必要がある場合、性能はすぐに低下する。
  • モナドの結合のような形式は抽象的なシーケンスであり、シーケンスは明示すべきである（一般的なbindの実装や、CPSを用いた方法などは暗黙的なシーケンスとなっていると主張されている）。
  • シーケンスの表現を明示的にすることで、より適切なシーケンスデータ構造を選択することができ、どのような使用パターンに対しても性能問題を解決することができる。
  • 左引数の型が右引数の型に依存する演算子を含む式(bindはそうですね)を明示的に表現するためにType aligned sequences（型整列されたシーケンス）が必要。
  • フリーモナドの性能問題も同じアプローチで解決できる。

purescript-freeのFreeでは、Type aligned sequencesを構築するデータ構造としてCatenable Listを使っています。
定義を見てみると CatList というのがいますね。これがCatenable Listです。

data Free f a = Free (FreeView f Val Val) (CatList (ExpF f))

ここまででなぜ定義が複雑化しているかの説明が終わりました。

では予定していた通り、定義の解説に戻りましょう。

Free型の定義（再）

ここまでの前提を踏まえて再度、Freeの定義を見てみましょう。

Freeの定義
data Free f a = Free (FreeView f Val Val) (CatList (ExpF f))

newtype ExpF f = ExpF (Val -> Free f Val)

data FreeView f a b = Return a | Bind (f b) (b -> Free f a)

data Val

まず型構築子Free f aの部分ですが、型引数aはデータ構築子の部分に一切登場しません。
つまりPhantom Typeになっています。

FreeView

続いて型構築子FreeView f a bを見てみましょう。
Bind (f b) (b -> Free f a)とReturn aという2つのデータ構築子が存在します。
このBindは名前から想像がつくかもしれませんが、関数bindをデータとして表したものといえます。
両者を比較してみると分かりやすいです。

比較
Bind               (f b)   (b -> Free f a)

-- こちらは関数のbind
bind :: forall a b. m a -> (a -> m b) -> m b

Returnの方は関数pureをデータとして表したものといえます。

Val

次にFreeのデータ構築子としてFreeViewが使われている部分を見てみましょう。

データ構築子で使われるFreeView
--                    ~~~~~~~~~~~~~~~~~~
data Free f a = Free (FreeView f Val Val) (CatList (ExpF f))

何か変ではありませんか？
FreeViewはFreeView f a bという型構築子なのに、なぜか型引数にaやbが登場せず、Valなどというよくわからんものが使われていますね？
これはPureScriptでは次のように存在量化ができないからです(右辺にforallが書けない)。
型構築子にbを登場させずにデータ構築子にbを登場させることはできないということです(Haskellは言語拡張でできる)。

存在量化(コンパイルエラーになる)
data Free f a = forall b. Free (FreeView f Val b) (CatList (ExpF f))

こういう場合のアプローチとして私が見かけたことがあるのがpurescript-existsというライブラリを使う方法です。
次のようにExistsという型を使うことでbの存在を隠蔽できます（使うときはbが「ある」とすて扱うための関数がある）。

Existsを使ったFreerの定義
data FreerBindF f a b = FreerBindF (f b) (b -> (Freer f a)) 
data Freer f a
  = Pure a
  | Bind (Exists (FreerBindF f a))

Freeの場合は、Existsではなく、Valという空のデータ型を使うことで同じことを実現しています。
データ構築子でValを使わず、(FreeView f a b)のようにすると、上記のように存在量化できないゆえに型構築子の方にもbを登場させざるを得なくなってしまいます。
が、これであればFreeViewのaもbもValで隠蔽できます。
ちなみにこのValの部分が実際の処理でどう扱われているかは後々説明します。

ExpF

ExpFはBindの(b -> Free f a)と同じ型の関数を持っている型です。
ここでもValが使われています。

--                    ~~~~           ~~~~
newtype ExpF f = ExpF (Val -> Free f Val)

後述しますが、bindで繋いでいった関数を保持するのがこの型です。

CatList

前述したCatenable Listです。
bindに渡した関数は、上記のExpFに包まれて、このデータ構造に追加されます。

--                                                ~~~~~~~~~~~~~~~~~
data Free f a = forall b. Free (FreeView f Val b) (CatList (ExpF f))

ついでにFreeで使われているCatListの関数をこの場で紹介しておきましょう。

  • empty :: forall a. CatList a
    空のCatListを作る
  • cons :: forall a. a -> CatList a -> CatList a
    要素をリストの先頭に追加
  • snoc :: forall a. CatList a -> a -> CatList a
    要素をリストの末尾に追加(consを逆に読んだのか)
  • uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
    リストを、最初の要素と残りのリストからなるタプルに分解する。
  • append :: forall a. CatList a -> CatList a -> CatList a
    2つのCatListを結合する(CatListは型クラスSemigroupのインスタンスになっており、Semigroupの関数appendの実装はこのappendになっているので、関数<>を使ったときはこのappendが呼ばれる)

さあ、これにてようやくFree型の定義部分の説明が終わりました。

まだまだ続きますよ。

次は、Freeのモナド関連の部分です！
Freeはモナドなのでそこを見ないわけにはいかないでしょうし、後々の説明を考えてもここは外せません。

Bind(bind)

超重要関数bind です。
定義を見てみましょう。

bind
instance freeBind :: Bind (Free f) where
  bind :: forall a b. Free f a -> (a -> Free f b) -> Free f b
  bind (Free v s) k = Free v (snoc s (ExpF (unsafeCoerceBind k)))
    where
    unsafeCoerceBind :: forall a b. (a -> Free f b) -> Val -> Free f Val
    unsafeCoerceBind = unsafeCoerce

まずv(FreeView)の部分に着目してください。新たなFreeが作られていますが、vは何の操作もされずそのまま引き継がれていっています。
（FreeViewにはBindがあるのにそっちが使われないのは意外かもしれませんが、こっちはまた別に使われます）
次にs(CatList)を見てください。これはnewtype ExpF f = ExpF (Val -> Free f Val)という定義のExp fのリストでした。このリストに対し、bindに渡された関数kをsnoc関数でもって末尾に追加しています。その際unsafeCoerceを使って型を合わせています。
（unsafeCoerceは無理やり型を合わせる関数。それゆえ慎重に使う必要がある。）
存在量化できなかったためこのようなことをやっているのです。
ちなみに先に説明したExistsも結局は隠蔽した値を使う際は内部でunsafeCoerceを使っています。

とにかく渡された関数kはCatListに追加されるんだなということを覚えておいてください。

Applicative(pure)

bindときたら次はpureでしょう！
定義を見てみましょう。

pure
instance freeApplicative :: Applicative (Free f) where
  pure :: forall a. a -> Free f a
  pure = fromView <<< Return

ReturnとfromViewの合成関数に渡された値を適用させています。
Returnの定義は頗るシンプルなので特に疑問はわかないでしょう。
data FreeView f a b = Return a | Bind (f b) (b -> Free f a)
となると問題はfromViewです。

なんかFreeViewからFreeに変換するやつ (fromView)

『ちいかわ』みたいな見出しにしてみましたが、fromViewは小さいし、かわいいと言っても差し支えない関数なのではないでしょうか。
これが定義です。

fromView
fromView :: forall f a. FreeView f a Val -> Free f a
fromView f = Free (unsafeCoerceFreeView f) empty
  where
  unsafeCoerceFreeView :: FreeView f a Val -> FreeView f Val Val
  unsafeCoerceFreeView = unsafeCoerce

bindのときと同じく、unsafeCoerceを使って型をValにしてやって、Freeの型にマッチさせています。つまりfに対しては何の操作も行われていません。
次にFreeのCatListの部分を見るとempty関数の結果が渡されています。
つまり、渡されたFreeViewと、空のCatListからFreeを作って返すのがこの関数です。

fromViewの動きがわかったので、pureの動きもわかるでしょう。
つまり、pureはこんな感じの値を返します。
Free (Return 値) 空のCatList

Functor(map)

これがmapの定義です。

instance freeFunctor :: Functor (Free f) where
  map :: forall a b. (a -> b) -> Free f a -> Free f b
  map k f = pure <<< k =<< f

pure <<< k =<< fの部分ですが、括弧で括ってわかりやすくすると、(pure <<< k) =<< fとなります（演算子の優先順位的は逆束縛より関数合成の方が高いため）。
ここで逆束縛によりbindが使われています。
つまりbind f (pure <<< k)です。
bindとpureの定義をまとめて見てみましょう。

bindとpureの定義(型アノテーションのみ)
bind :: forall a b. Free f a -> (a -> Free f b) -> Free f b
pure :: forall a. a -> Free f a

kである(a -> b)とpureの合成関数はa -> Free f bとなるでしょう。
これはつまりbindの(a -> Free f b)と一致します。
更にmapの引数のFree f aはbindの引数と一致します。
それゆえ、pure <<< k =<< fでmapの実装ができているのです。

bindとpureとmapがわかったので、次はFreeを作るところにいきましょう。

liftFでデータ型をFreeに持ち上げる

Freeを使う際は、なんらかのデータ型をliftFで持ち上げてFreeを作ります。
サンプルではこのようにliftFを使っていました。

liftFの例
data TeletypeF a = PutStrLn String a | GetLine (String -> a)
type Teletype a = Free TeletypeF a

putStrLn :: String -> Teletype Unit
putStrLn s = liftF (PutStrLn s unit)

getLine :: Teletype String
getLine = liftF (GetLine identity)

実装はどうなっているでしょうか。

liftFの実装
liftF :: forall f. f ~> Free f
liftF f = fromView (Bind (unsafeCoerceF f) (pure <<< unsafeCoerceVal))
  where
  unsafeCoerceF :: forall a. f a -> f Val
  unsafeCoerceF = unsafeCoerce

  unsafeCoerceVal :: forall a. Val -> a
  unsafeCoerceVal = unsafeCoerce

出てきた要素を見てください。
fromView, Bind, Val, unsafeXXX, pure
すべて既出です。
つまりliftF (GetLine identity)とした場合、このような値が返ることになります。
(CatListのところで書いた通り空のCatListは説明のため配列のように[]と置いています)
Free (Bind (GetLine identity) pure) []

bind呼び出すとどーなるの？

では前項でFree型の値の形がわかったところで、次はそれらを使って次のようにbindを呼び出したときどうなるかを見ていきます。

example :: Teletype Unit
example = do
  a <- getLine
  putStrLn a

bindの定義と、liftFで作られるFree型の値を使って考えると次のようなイメージになるでしょう。

図:値が使われる様子
最終的には、次のようにCatListに関数が追加された新たなFreeが返されます。

Free (Bind (GetLine identity) pure) [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

この例では一つだけbindで処理を繋ぎましたが、これ以上増やした場合も同じで、CatListの末尾に関数が追加されていくことになります。

Freeの実行 〜その裏で起きているコト〜

ここまでで、実行に使うFreeを作るまでの説明が終わりました。
いよいよ作ったFreeがどう実行（解釈）されるのかを説明していきたいと思います。

今一度冒頭で例示したサンプルコードを見てみます。

サンプルコード
teletypeN :: TeletypeF ~> Effect
teletypeN (PutStrLn s a) = const a <$> log s
teletypeN (GetLine k) = pure (k "fake input")

run :: Teletype ~> Effect
run = foldFree teletypeN

echo :: Teletype Unit
echo = do
  a <- getLine
  putStrLn a

main :: Effect Unit
main = do
  run echo

echpで返されるTeletype Unit(Free TeletypeF Unit)が実行対象のFreeです

teletypeNはフリーモナドでおなじみのハンドラ部分ですね。

このハンドラはfoldFreeでどう呼び出されるのか？
その呼び出しの裏で何が起きているのか？
そこを解説していきます。
先に書いておきます。

・・・・・・長い！複雑！

でも解説します。

foldFree

まずfoldFreeはこんな定義になっています。

foldFree
foldFree :: forall f m. MonadRec m => (f ~> m) -> Free f ~> m
foldFree k = tailRecM go
  where
  go :: forall a. Free f a -> m (Step (Free f a) a)
  go f = case toView f of
    Return a -> Done <$> pure a
    Bind g i -> (Loop <<< i) <$> k g

この関数を理解するには、関数冒頭のtailRecMの部分と、toViewの部分の理解が必要となります。
なので、先にそれぞれを説明します。

tailRecM

tailRecMはMonadRecという末尾再帰の際にスタックを大量消費しないことを表す型クラスの関数です。
foldFreeの定義を見ると、MonadRec mの制約があり、そして返される型がmになっています。
これは(f ~> m)が返す型と一致しています。

定義
foldFree :: forall f m. MonadRec m => (f ~> m) -> Free f ~> m
foldFree k = tailRecM go
　where ...

動作的には単純で、tailRecMに渡したaに対し、関数(a -> m (Step a b))を実行し、Stepの値がLoop aであればaの値を使ってループし、Done bであればm bを返すという動きをします(当然インスタンスによってやり方は異なる)。

MonadRec
data Step a b = Loop a | Done b

class Monad m <= MonadRec m where
  tailRecM :: forall a b. (a -> m (Step a b)) -> a -> m b

ところで、上記の例でfoldFreeに渡している関数はteletypeN :: TeletypeF ~> Effectという型の関数でした。つまりこの場合mはEffectとなります。
EffectはMonadRecのインスタンスになっているため使うことができるのです。

ちなみに今回の例の場合は関係ない話(なので飛ばしても結構です)なのですが、FreeもまたMonadRec型クラスのインスタンスになっています。
これがどういうことを意味するかというと、foldFreeに渡す引数をteletypeN :: TeletypeF ~> 別のFreeというようにできるということです。

tailRecM
instance freeMonadRec :: MonadRec (Free f) where
  tailRecM :: forall a b. (a -> Free f (Step a b)) -> a -> Free f b
  tailRecM k a = k a >>= case _ of
    Loop b -> tailRecM k b
    Done r -> pure r
-- bindの定義
bind :: forall a b. Free f a -> (a -> Free f b) -> Free f b

まず最初にk aとした結果はFree f (Step a b)となります。
その次にbindが呼び出されます。
bindの(a -> Free f b)の部分は、上記のコードのcaseの部分を見ると、Step a b -> Free f bなので、型にマッチしています。
処理的にはStepの値がLoopである限りはtailRecMを再帰的に呼び出し、値がDoneになったらpure rでFree f b型の値を返すようになっています。

なんかFreeからFreeViewに変換するやつ (toView)

また『ちいかわ』みたいな見出しですが、『ちいかわ』とは違って、この関数は小さくもかわいくもないです。

toView
toView :: forall f a. Free f a -> FreeView f a Val
toView (Free v s) =
  case v of
    Return a ->
      case uncons s of
        Nothing ->
          Return (unsafeCoerceVal a)
        Just (Tuple h t) ->
          toView (unsafeCoerceFree (concatF ((runExpF h) a) t))
    Bind f k ->
      Bind f (\a -> unsafeCoerceFree (concatF (k a) s))
  where
  concatF :: Free f Val -> CatList (ExpF f) -> Free f Val
  concatF (Free v' l) r = Free v' (l <> r)

  runExpF :: ExpF f -> (Val -> Free f Val)
  runExpF (ExpF k) = k

  unsafeCoerceFree :: Free f Val -> Free f a
  unsafeCoerceFree = unsafeCoerce

  unsafeCoerceVal :: Val -> a
  unsafeCoerceVal = unsafeCoerce

まずcase v ofでv(FreeView)をパターンマッチにかけます。
それぞれのパターンを説明します。

Bindだった場合
Bindだった場合は、新しいBindを返しています。
その際fはそのまま引き継いで使われます。

次に(\a -> unsafeCoerceFree (concatF (k a) s))の説明をしましょう。
Bindの定義は、Bind (f b) (b -> Free f a)ですが、Freeのデータ構築子で使われる際は(FreeView f Val Val)という定義になっていました。
すなわちBind (f Val) (Val -> Free f Val)です。
なのでBind f kのkは(Val -> Free f Val)です。
そして(\a -> unsafeCoerceFree (concatF (k a) s))のaはValです。
なのでk aはFree f Valを返してきます。
concatFでは、一つ目の引数のFree f ValのValの部分すなわちCatListと、二つ目の引数のCatListを<>で結合させて返します。その際、Free f Valのfはまたそのまま引き継ぎます。
ちなみにconcatFの二つ目の引数に渡していたsとは、toViewを呼び出したときのFreeが持っていたCatListです。
そしてこのCatListにはbind関数が呼ばれたとき継続の処理が追加されていたのでした。
その値がFree (FreeView f Val Val) (CatList (ExpF f))のCatListから、FreeViewの方に移されて返っているということなのです。

bindを使ったときの説明の例で出てきた次のような値

Free
  (Bind (GetLine identity) pure)
  [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

に対して、toViewを呼び出した場合は次のようになるでしょう。

Bind
  (GetLine identity)
  (\a -> concatF (pure a) [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]))

ということで、FreeViewに変換してもCatListの内容は残っているということなのです。

Returnだった場合
Returnだった場合、Freeの持っているs(CatList)をunconsでh(head)とt(tail)のTupleに分解しています。
hとはnewtype ExpF f = ExpF (Val -> Free f Val)のことで、tはそのリストです。
concatF ((runExpF h) a) tの部分では、(runExpF h) aの結果、すなわち(Val -> Free f Val) aの結果であるFree f Valとtを引数にconcatFを呼び出しています。
CatListが保持している関数が呼び出されるのは、説明においてここが初ですね。
BindのときのconcatFとは異なり、こちらの場合はunconsによって一つ関数が消費された状態のリストが結合されることになります。
そうしてできた値をtoViewに渡して再帰します。
この再帰呼び出しはsが空になるまで続けられ、sが空になったらようやくReturnが返って処理が終わります。
これがReturnの場合の処理です。

以上が、toViewの説明になります。
ざっくり要約して書くとこんな感じでしょうか。

  • FreeをFreeViewにして返す。
  • Freeが持つFreeViewがBindだったら新しいBindを返す。その際、Freeが持っていたCatListの内容は、新しいBindの方に(関数の中で使われるという形で)移動する。
  • Freeが持つFreeViewがReturnだったら、Freeが持つCatListをunconsでhead要素の関数とtailのリストに分解し、head要素の関数を適用した結果(とtailのリストを結合したもの)で再帰呼び出しをする
  • Freeが持つFreeViewがReturnでかつCatListが空の場合は、Returnを返す。
    なのでtoViewに渡したFreeのFreeViewがReturnだったとしても、Bindが返ってくる可能性があります(CatListが持っている関数の結果がBindかもしれない)。

続・実行の解説

tailRecMとtoViewの説明が終わったので、foldFreeの動きも理解できるでしょう。

ということで、解説に必要なコードを再掲した上で、本格的に実行時の処理の流れの解説をしましょう。

以下が解説に必要なコードです。

サンプルコード
data TeletypeF a = PutStrLn String a | GetLine (String -> a)

type Teletype a = Free TeletypeF a

putStrLn :: String -> Teletype Unit
putStrLn s = liftF (PutStrLn s unit)

getLine :: Teletype String
getLine = liftF (GetLine identity)

teletypeN :: TeletypeF ~> Effect
teletypeN (PutStrLn s a) = const a <$> log s
teletypeN (GetLine k) = pure (k "fake input")

run :: Teletype ~> Effect
run = foldFree teletypeN

echo :: Teletype Unit
echo = do
  a <- getLine
  putStrLn a

main :: Effect Unit
main = do
  run echo
foldFree
foldFree :: forall f m. MonadRec m => (f ~> m) -> Free f ~> m
foldFree k = tailRecM go
  where
  go :: forall a. Free f a -> m (Step (Free f a) a)
  go f = case toView f of
    Return a -> Done <$> pure a
    Bind g i -> (Loop <<< i) <$> k g
toView
toView :: forall f a. Free f a -> FreeView f a Val
toView (Free v s) =
  case v of
    Return a ->
      case uncons s of
        Nothing ->
          Return (unsafeCoerceVal a)
        Just (Tuple h t) ->
          toView (unsafeCoerceFree (concatF ((runExpF h) a) t))
    Bind f k ->
      Bind f (\a -> unsafeCoerceFree (concatF (k a) s))
-- unsafe系の関数やrunExpFの定義は省略

この例ではechoが返すFreeの値をfoldFree teletypeNに渡しています。
echoが返す値はこのようになっています。

Free
  (Bind (GetLine identity) pure)
  [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

foldFreeのgo関数はDoneを返すまで、すなわちtoView fがReturnを返してくるまで再帰的に呼び出され続けます。

この再帰的な処理をステップごとに順々に追っていきたいと思います。

1. toView(1回目)
上記の値(echoが返す値)をfとしてtoView fが呼ばれます。

toView(Bindのパターンのみ抜粋)
toView (Free v s) =
  case v of
    Bind f k ->
      Bind f (\a -> unsafeCoerceFree (concatF (k a) s))

vの値はBindだったのでBind f kにマッチします。
なので次のような値が返ってきます。

Bind
  (GetLine identity)
  (\a -> concatF (pure a) [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])])

2. case toView f ofのパターンマッチ(1回目)

go(Bindのパターンのみ抜粋)
  go f = case toView f of
    Bind g i -> (Loop <<< i) <$> k g

上記toViewの結果はBindなので、Bind g iのパターンにマッチします。
そしてgは(GetLine identity)、 iは(\a -> concatF (pure a) ...)となります。
処理としてはまずk gが呼び出されます。

3. k gの処理(1回目)
kは処理を遡ってみればteletypeNだとわかります。

teletypeN :: TeletypeF ~> Effect
teletypeN (PutStrLn s a) = const a <$> log s
teletypeN (GetLine k) = pure (k "fake input")

なのでk gはteletypeN gとなりますね。
gはteletypeN (GetLine k)にマッチしkはidentity(getLineを参照)なので、pure (identity "fake input")が返るでしょう。

更に書くとidentityはそのまま値を返すのでこれはpure "fake input"です。
pureはEffectのpureなのでEffect String型の値が返ります。

4. (Loop <<< i) <$> k gの処理(1回目)
k gの結果はEffect String型の値pure "fake input"だったので、Effectのmapが呼ばれます。
mapに渡される合成関数の最初の関数iとは

(\a -> concatF (pure a) [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]))

でした。
今回のaは"fake input"なので

concatF (pure "fake input") [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

となるでしょう。
そしてpure "fake input"は、Return "fake input" []です。
これに対しconcatFが呼ばれてCatListの内容が結合され

Free (Return "fake input") [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

という値になり、更にiはLoopと合成されていたので

Loop (Free (Return "fake input") [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])])

となります。
map関数はEffectのものであったので正確には上記の値はEffectに包まれていますね。
（これはtailRecMが戻り値の型として期待していたm (Step a b)とマッチしています）
この値がループにより再帰に使われます。

5. toView(2回目)
ループして再度toView fにやってきました。今度のfは

Free (Return "fake input") [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

という値になっています。
これに対してtoViewを呼び出すとどうなるか。

toView(Returnのパターンのみ抜粋)
toView (Free v s) =
  case v of
    Return a ->
      case uncons s of
        Nothing ->
          Return (unsafeCoerceVal a)
        Just (Tuple h t) ->
          toView (unsafeCoerceFree (concatF ((runExpF h) a) t))

まずCatListであるsは今回は空でないのでuncons sで分解すると次の値を持つJust (Tuple h t)になります。

h = ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])
t = []

aは今回の場合"fake input"で、runExpFはExpFが持つ関数を取り出す関数なので

(runExpF h) a
↓
(\s -> Free (Bind (PutStrLn s unit) pure) []) "fake input"
↓
Free (Bind (PutStrLn "fake input" unit) pure) []

となります。
この値でもってtoViewが再帰的に呼び出されます。

6. toView(3回目)
ループして再度toView fにやってきました。今度のfは

Free (Bind (PutStrLn "fake input" unit) pure) []

という値になっています。
この値でtoViewを呼び出すとどうなるか？

toView(Bindのパターンのみ抜粋)
toView (Free v s) =
  case v of
    Bind f k ->
      Bind f (\a -> unsafeCoerceFree (concatF (k a) s))

はい。今回の戻り値は次のようになるでしょう。

Bind (PutStrLn "fake input" unit) (\a -> unsafeCoerceFree (concatF (pure a) []))

7.case toView f ofのパターンマッチ(2回目)

foldFree(Bindのパターンマッチのみ抜粋)
  go f = case toView f of
    Bind g i -> (Loop <<< i) <$> k g

上記toViewの結果はまたBindなので、Bind g iのパターンにマッチします。
そしてgは(PutStrLn "fake input" unit)、 iは(\a -> unsafeCoerceFree (concatF (pure a) []))となります。
処理としてはまずk gが呼び出されます。

8. k gの処理(2回目)
kとはteletypeNでしたね。

teletypeN :: TeletypeF ~> Effect
teletypeN (PutStrLn s a) = const a <$> log s
teletypeN (GetLine k) = pure (k "fake input")

となると、今回のgはteletypeN (PutStrLn s a)にマッチするので、const unit <$> log "fake input"が呼び出されます。
log "fake input"でログ出力がされるとEffect Unit型の値が返され、それに対してmap関数が呼ばれます。
つまり(\b -> const unit) <$> log "fake input"ということなので、constによりunitがそのま返されEffect Unit型の値が返ります。

9. (Loop <<< i) <$> k gの処理(2回目)
k gの結果はEffect Unit型の値unitだったので、Effectのmapが呼ばれます。
mapに渡される合成関数の最初の関数iは(\a -> unsafeCoerceFree (concatF (pure a) []))でした。
今回のaはunitなので
concatF (pure unit) []
となるでしょう。そしてpure unitは、Return unit []です。
これに対しconcatFが呼ばれCatListが結合された次のFreeとなります（空同士の結合なので結果は空）。

Free (Return unit) []

更にiはLoopと合成されていたので

Loop (Free (Return unit) [])

となります(これは本当はEffectに包まれています)。
この値がループによりまた再帰に使われます。

10. toView f(3回目)
今回はLoop (Free (Return unit) [])に対してtoViewが呼ばれます。

toView(Returnのパターンのみ抜粋)
toView (Free v s) =
  case v of
    Return a ->
      case uncons s of
        Nothing ->
          Return (unsafeCoerceVal a)
        Just (Tuple h t) ->
          toView (unsafeCoerceFree (concatF ((runExpF h) a) t))

CatListは空なので、uncons sでこれ以上分解できません。
それゆえ今度はNothingのパターンにマッチします。
ということはReturn unitが返されるということです。

11. case toView f ofのパターンマッチ(3回目)
今度はようやくReturn aにマッチするようになりました。

go(Returnのパターンのみ抜粋)
  go f = case toView f of
    Return a -> Done <$> pure a

aはunitなのでEffectに包まれたDone unitが返ります。
Doneを返しているので遂にここでループは終了します。
最終的にはEffect Unit型の値unitが返ります。

以上の処理の流れで、echoの値に着目し、値がどのように変化していったかを書いてみます。

Free
  (Bind (GetLine identity) pure)
  [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]
  
-- ↓ toView

Bind
  (GetLine identity)
  (\a -> concatF (pure a) [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])])
  
-- ↓ ハンドラ(teletypeN)の呼び出し。ここで入力が与えられ、処理の結果以下が返る。

Free
  (Return "fake input")
  [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

-- ↓ toView (CatListの要素が残っているので以下のFreeでtoViewを再帰呼出し)

Free
  (Bind (PutStrLn "fake input" unit) pure) 
  []

-- ↓ toView

Bind
  (PutStrLn "fake input" unit)
  (\a -> unsafeCoerceFree (concatF (pure a) []))

-- ↓ ハンドラ(teletypeN)の呼び出し。ここで値がログ出力され、処理の結果以下が返る。

Free
  (Return unit)
  []

-- ↓ CatListが空なので値が返って処理終了

Return unit

まとめると次のような流れになっていますね。

  • toViewするとFreeViewが返る。
  • FreeViewがBind f bなら、fを使ってハンドラを呼び出す。
  • ハンドラを実行結果はBindが持っている関数(b -> Free f a)`の引数として使われ関数が呼び出される。
  • 上記の結果また新しいFreeが返ってきて、それがまたtoViewに渡って再帰する。
  • FreeViewがReturn aなら
    • CatListの先頭の関数をaを引数として呼び出す。結果はFreeなのでtoViewを再帰
    • CatListが空ならReturn aを返す

わかりやすいかわかりませんが、頑張って流れを図解してみます。

まとめ

まずFreeを作るliftFがこのような値を返してきます。

Free (Bind (GetLine identity) pure) []

pure aはFree (Return a) []のような値を返す関数で、これはBind (f b) (b -> Free f a)の(b -> Free f a)の部分になっています。
つまりliftFが作るFreeのBindは常にReturnを返す関数を持っているということです。
これがミソです。
実行していったときこのReturnが持つ値が、CatListが持つ先頭の関数の引数になっているからです。
後続の処理に繋ぐための橋渡しをするというかくっつける糊的存在というか、そんな感じです。
例えば、bindで処理を繋げて次のような値になった場合、pureが返すReturnの値がExpFの関数の引数になっているわけですね。

Free
  (Bind (GetLine identity) pure)
  [ExpF (\s -> Free (Bind (PutStrLn s unit) pure) [])]

つまりFreeのFreeViewはCatListの先頭の関数に処理を繋ぐことができ、その関数はまた同じような構造のFreeを返してきて（かつCatListの先頭の関数は除去される）、そのFreeのFreeViewからCatListの先頭の関数に処理が繋がって、、、、
というように（bindで繋いだ関数がすべてなくなるまで）繰り返されるというわけです。

それにしても、bindで繋いでいく後続の処理を「(整列された)関数のシーケンス」と考え、パフォーマンスの良いデータ構造に持っておき、実行のとき取り出して使うというアイデアが実現されているのを見てきたわけですが、よくこんなやり方を思いついたものだと思います。

さぁ以上で、ようやく、ようやく、実行の解説が終わり、この記事の目的を果たすことができました。

＿人人人人人人人人人人人人人＿
＞　長かった戦いよさらば！！　＜
￣Y^Y^Y^Y^Y^YY^Y^Y^Y^Y^Y^￣

終

私はPureScriptの学び始めの頃、いきなりこれを理解しようとしてエラい苦労した記憶があります。
前提知識もなかったし、勘所もなかったからです。
写経もしましたが、それでもよくわからなかった。
最初にシンプルなフリーモナドの実装で、おおまかに構造を理解していればまた違ったのでしょう。
（そういう意味で前の記事を書いた）

このような経験があったため、ある程度まとまった記事があれば、同じ道を辿らなくて済む人が増えると思い、今回の記事を書きました。

どの程度PureScriptのフリーモナドに関心がある（しかも実装まで）人がいるかわかりませんが、少しでも理解の助けになっていれば幸いです。

おまけ: FreeでReaderモナドを作ってみるよ

foldFreeは、ハンドラを使って結合されていたすべてのFreeを一気にまとめて処理しましたが、Freeのレイヤーを一枚一枚剥がしながら実行するための関数resumeというものがあります。

resume:resume
  :: forall f a
   . Functor f
  => Free f a
  -> Either (f (Free f a)) a
resume = resume' (\g i -> Left (i <$> g)) Right

resume'
  :: forall f a r
   . (forall b. f b -> (b -> Free f a) -> r)
  -> (a -> r)
  -> Free f a
  -> r
resume' k j f = case toView f of
  Return a -> j a
  Bind g i -> k g i

これを使って、FreeのReaderモナドを作ってみます！

newtype ReaderF r e = ReaderF (r -> e)
derive newtype instance functorReaderF :: Functor (ReaderF r)
type FreeReader r a = Free (ReaderF r) a

ask :: forall e. FreeReader e e
ask = liftF (ReaderF identity)

local :: forall r a. (r -> r) -> FreeReader r a -> FreeReader r a
local f r = map f ask >>= pure <<< runReader r

asks :: forall e a. (e -> a) -> FreeReader e a
asks f = f <$> ask

-- ここでresumeを使っているよ
runReader :: forall r a. FreeReader r a -> r -> a
runReader f e = case resume f of
  Left (ReaderF r) -> runReader (r e) e
  Right a -> a

こちらがテストになります！

test
type Config = { debug :: Boolean }

spec :: Spec Unit
spec = do
  describe "Reader(Free版)のテスト" do
    describe "ask" do
      it "環境を取得できる" do
        "value" `shouldEqual` runReader ask "value"
    
    describe "asks" do
      it "環境を取得する際に渡した関数で環境の値を変更することができる" do
        "value added" `shouldEqual` runReader (asks (_ <> " added")) "value"

    describe "local" do     
      it "環境の変更を、渡した関数内のスコープに閉じることができる" do
        let 
          getFlag :: FreeReader Config Boolean
          getFlag = do
            _ <- local (\c -> c { debug = true }) do
              -- ここでaskするとdebugはtrueになってる。
              pure false -- 説明のためだけの処理なので適当な値を返す
            c <- ask
            pure c.debug
        runReader getFlag { debug: false } `shouldEqual` false

Discussion