OCamlでFree Applicative Functors

[Monad](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Monad.html#t:Monad) に対して Free Monad があるように、 [Applicative](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative) に対しても Free Applicative Functor がある[^1] [^2]。

[^1]: Paolo Capriotti and Ambrus Kaposi: "[Free Applicative Functors](http://arxiv.org/abs/1403.0749)", Proceedings 5th Workshop on Mathematically Structured Functional Programming, (MSFP 2014), Grenoble, France, 12 April 2014. EPTCS 153, 2014, pp. 2–30
[^2]: Scala で紹介した記事もある。[Free Applicative Functors in Scala](http://halcat.org/free_ap.html)

OCaml で定義すると下のようになる。

```ocaml
open Higher

type (_, _) t =
  | Pure : 'a -> ('a, 'f) t
  | Apply : ('a -> 'b, 'f) t * ('a, 'f) app -> ('b, 'f) t
```

`Pure` はちょうど `Applicative` の `pure` をそのままバリアントとして表したものになっていて、 `Apply` は `<*>` を表現したものになっている。OCaml では `'a f` の `f` の部分（型構成子）をパラメータ化することができないので、[higher](https://github.com/ocamllabs/higher/) ライブラリを使って `'a f` を `('a, f) app` と読み替えている。こうすれば、 `f` の部分を型変数にできるので OCaml でも扱える。また、 `Apply` の方の `'a` は結果型に表れない存在型になっているので GADTs が必要になる。ここでは `Apply` の関数の型を `t`、引数の型を `app` にしたが、これを逆にしたものもこれと同型であることが証明されている（らしい。元論文を参照）。

あとは `Applicative` のメソッドを定義する。

```ocaml
let pure v = Pure v

let rec (<$>) : 'a 'b. ('a -> 'b) -> ('a, 'f) t -> ('b, 'f) t =
  fun f -> function
    | Pure v -> Pure (f v)
    | Apply (ga, v) -> Apply ((fun g x -> f (g x)) <$> ga, v)

let map f a = f <$> a

let rec (<*>) : 'a 'b. ('a -> 'b, 'f) t -> ('a, 'f) t -> ('b, 'f) t =
  fun fa xa ->
    match fa with
    | Pure f -> f <$> xa
    | Apply (ga, v) ->
        Apply ((fun g x y -> g y x) <$> ga <*> xa, v)

let app f a = f <*> a
```

`pure` は単に `Pure` で包むだけでよい。 `<$>` （`map`）は `Pure` の場合は内側の値に `f` を適用して再度包み直し、 `Apply` の場合は関数の側に `f` を合成する。 `<*>` （`app`）は関数が `Pure` であれば得られた関数を `map` し、 `Apply` のときは `v` は `('c, 'f) app`、 `ga` が `('c -> 'a -> 'b, 'f) t` で、 `xa` が `('a, 'f) t` のような感じなので、 `'a` の部分を部分適用すると全体が `('b, 'f) t` になって型が合う。型を追うと理解しやすいと思う。ここで、 `<$>` と `<*>` は呼び出されたときの型と、その中で再帰呼び出しされるときの型が異なる多相再帰になっているので、自分で多相型アノテーションを書かなければならない。

さらに、実際に副作用を表す型をこの型に持ち上げる。型としては `('a, 'f) app` を `('a, 'f) t` に変換したい。 `t` の定義を見ると、 `('a, 'f) app` が入る場所は `Apply` しかないので、 `Apply` の関数側に何もしない関数を入れておく。

```ocaml
let id x = x

let lift v =
  Apply (pure id, v)
```

たぶん大丈夫なので、実際のインスタンスを定義していく。まずは `list`。

```ocaml
module L = Newtype1(struct type 'a t = 'a list end)

let llift v = v |> L.inj |> lift

let flat_map f xs = List.flatten (List.map f xs)

let rec run_list : 'a. ('a, L.t) t -> 'a list = function
  | Pure v -> [v]
  | Apply (fs, vs) ->
      let fs = run_list fs in
      let vs = L.prj vs in
      fs |> flat_map (fun f -> vs |> List.map f)

let pl x =
  x |> [%derive.show: (int * int) list] |> print_endline

let la =
  (fun x y -> (x, y)) <$> llift [1; 2; 3] <*> llift [5; 6; 7]

let () = run_list la |> pl
```

`higher` ライブラリの `Newtype1` ファンクタで `'a list` と `('a, L.t) app` を相互変換するモジュールを作成する。 `llift` は `'a list -> ('a, L.t) t` で `'a list` を Applicative な値にする。

`run_list` は `('a, L.t) t` に解釈を与えるもので、 Haskell の `Applicative []` と同じく、取り得る値すべての組み合わせを計算するような解釈をしている。

OCaml で複雑な構造の値を表示しようとすると何かと面倒なのだけれど、今回は [ppx_deriving](https://github.com/whitequark/ppx_deriving) で楽をしている。

同様に Haskell の `ZipList` のような解釈を書くこともできる。

```ocaml
let rec map2 f xs ys =
  match xs, ys with
  | [], _ | _, [] -> []
  | x::xs, y::ys -> f x y :: map2 f xs ys

let rec run_zip_list : 'a. ('a, L.t) t -> 'a list = function
  | Pure v -> let rec vs = v::vs in vs
  | Apply (fs, vs) ->
      map2 (@@)
        (run_zip_list fs)
        (L.prj vs)

let () = run_zip_list la |> pl
```

こちらは `zipWithN` のように値を組み合わせる。 OCaml の `List.map2` は引数のリストが同じ長さでないといけないので新たに `map2` を自前で定義している。 `Pure` の方の解釈は [Recursive definitions of values](http://caml.inria.fr/pub/docs/manual-ocaml/extn.html#sec213) の条件に合致しているのでこのような書き方ができる。

というように、リストに対する `Applicative` のインスタンスが複数ある場合でも `ZipList` のような型の別名を定義しなくても、解釈関数を別に用意することで対応できる。

もちろん、リスト以外にも `option` のような別の型にも対応できる。

```ocaml
module O = Newtype1(struct type 'a t = 'a option end)

let olift v = v |> O.inj |> lift

let rec run_option : 'a. ('a, O.t) t -> 'a option = function
  | Pure v -> Some v
  | Apply (f, v) ->
      match run_option f, O.prj v with
      | None, _
      | _, None -> None
      | Some f, Some v -> Some (f v)

let po v =
  v |> [%derive.show: string option] |> print_endline

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift (Some 42) <*> olift (Some 3.14)
end |> po

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift (Some 42) <*> olift None
end |> po

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift None <*> olift (Some 3.14)
end |> po
```

ここでも ppx_deriving が活躍している。

今回の OCaml での [Free Applicative の定義](https://gist.github.com/leque/9cf9110637f07b465684)と、おまけで [Freer Monad の定義](https://gist.github.com/leque/147095bd992df351305a)は gist に置いてある。

OCaml で Haskell 風の Monad や Applicative スタイルのプログラムを真似しようとすると、型クラスの辞書をひとつひとつ自分で渡すことになったり、 [ppx_implicits](https://bitbucket.org/camlspotter/ppx_implicits) のような外部ライブラリに頼ったり、 [modular implicits](https://github.com/ocamllabs/ocaml-modular-implicits) のようなコンパイラ拡張が公式に採用されることを夢見たり、と、どうも大掛かりな感じになってしまう。今回の Free Applicative Functor や、 Freer Monad のようなものだと少し気軽に使えないだろうか。