OCamlでFree Applicative Functors

Monad に対して Free Monad があるように、 Applicative に対しても Free Applicative Functor がある^{1 2}。

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 ライブラリを使って 'a f を ('a, f) app と読み替えている。こうすれば、 f の部分を型変数にできるので OCaml でも扱える。また、 Apply の方の 'a は結果型に表れない存在型になっているので GADTs が必要になる。ここでは Apply の関数の型を t、引数の型を app にしたが、これを逆にしたものもこれと同型であることが証明されている（らしい。元論文を参照）。

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

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 の関数側に何もしない関数を入れておく。

let id x = x

let lift v =
  Apply (pure id, v)

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

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 で楽をしている。

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

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 の条件に合致しているのでこのような書き方ができる。

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

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

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 の定義と、おまけで Freer Monad の定義は gist に置いてある。

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

1. Paolo Capriotti and Ambrus Kaposi: "Free Applicative Functors", 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 ↩