OCamlでもLensしたい2020

この記事は [ML Advent Calendar 2020](https://qiita.com/advent-calendar/2020/ml) の18日目の記事です。

# 前置き

Lens は合成可能な getter/setter みたいなものらしい。

と聞いてはいたが、それ以外はよく知らなかったので、とりあえず OCaml で Lens してみようと思ったものの、[opam - lens](http://opam.ocaml.org/packages/lens/) のように単に getter と setter の組で表現すると音に聞く Prism 等に拡張できなさそうだし、 Haskell の型クラスによる実装をモジュールとファンクタで真似する[^ml-mod-typeclass]と構文的に重くなる（例えば、[OCaml lenses via modules | Notes on Computing](https://jobjo.github.io/2017/12/20/lenses-as-modules.html)）、 F# は型クラスを実現する手法があり、[Lens (FSharpPlus)](https://fsprojects.github.io/FSharpPlus/reference/fsharpplus-lens.html) はそれを使っているようだけれど、 OCaml では真似できなさそうだ、という感じにさまよっていたときに見掛けた [OCaml van Laarhoven CPS lenses.](https://gist.github.com/tel/08d2a94de21f483cbb20) が面白かったので、自分で書き写したり書き換えたりしつつ読んだときのことをメモしておく。

[^ml-mod-typeclass]: Haskell の型クラスは、クラス定義をシグネチャ、インスタンス定義をモジュール定義、型クラス制約をファンクタにすると ML 系言語に写せる


# 定義

まず、 `Optic.t` 型の定義は以下の通り。 Optics は Lens や Prism 等の総称。

```ocaml:optic.ml
type (-'s, +'t, +'a, -'b) _t =
  { op : 'r. ('a -> ('b -> 'r) -> 'r) -> ('s -> ('t -> 'r) -> 'r) }

type (-'s, +'t, +'a, -'b) t = unit -> ('s, 't, 'a, 'b) _t
```

最初から型がすごいことになっているが、 `(-'s, +'t, +'a, -'b) _t` は継続渡しっぽい型になっているようだ[^how-to-read-t]。この型をそのまま `t` として使いたいのだけれど、あとで説明するように、値制限（value restriction）でうまくいかないので、これに `unit ->` を追加した型を `(-'s, +'t, +'a, -'b) t` とする（型の変性指定は推論されるので、定義時には必要ないのだけど、 `_t` を抽象型にするときにシグネチャで必要になるのでここで書いておく）。

[^how-to-read-t]: `('a -> 'b) -> ('s -> 't)` をCPS変換した型で、 `('a, 'r) cont = ('a -> 'r) -> 'r` とすると、 `'r. ('a -> ('b, 'r) cont) -> ('s -> ('t, 'r) cont)` のような型になっている。 [My lens idea (asking for approval/suggestions/corrections/etc.) : haskell](https://www.reddit.com/r/haskell/comments/2zsmg5/my_lens_idea_asking_for/) によれば、これは Profunctor Optics のインスタンスのひとつで、 `'a -> ('b, 'r) cont` がどのくらい強い Profunctor のサブクラスの制約を満たすかによって Optics としての表現力が決まるそうだ。

直観としては `('s, 't, 'a, 'b) t` は、「`'s` の中に `'a` があるとき、それを `'b` に書き換えて新たに `'t` を得る」処理だ。例えば、 2-タプル `'a * 'b` の最初の要素を `'x` に書き換える処理は、 `('a * 'b, 'x * 'b, 'a, 'x) t` で表現される。

# Lens の定義

Lens は has-a 関係の特徴づけと説明されている[^what-are-prisms]。

getter と setter から Lens を作る `lens` 関数の定義は以下の通り。

```ocaml:optic.ml
(*
val lens   : ('s -> 'a) -> ('s -> 'b -> 't) -> ('s, 't, 'a, 'b) _t
 *)
let lens get set =
  let op acont s tcont =
    acont (get s) (fun b -> tcont (set s b))
  in { op }
```

`_t` の定義でいうと、 `acont` の型は `('a -> ('b -> 'r) -> 'r)`、 `s` の型が `'s`、 `tcont` は `'t -> 'r` で、 `op` の結果型は `'r` だ（`('a -> ('b -> 'r) -> 'r) -> ('s -> ('t -> 'r) -> 'r)` は対称性のために括弧をつけたが、 `->` は右結合なので、 `('a -> ('b -> 'r) -> 'r) -> 's -> ('t -> 'r) -> 'r` と同じ）。

`acont` は `get` で取得した値 `a` と、 それ値を加工した値を待ち受ける継続 `(fun b -> ...)` を受け取る。後者の継続は、受け取った値をもとの `s` に再設定し、 `tcont` で最終結果に変換する。

流れを書き出してみると以下のような感じだ。

1. `get` で `s` から `a` を取得する
2. 3. 以降の処理を継続 `bcont` として受け取る。必要に応じて `a` を加工して `b` にしたり、それを `bcont` に引き渡したりする
3. `set` で `b` を `s` に設定して `t` を得る
4. `tcont` に `t` を渡して最終結果を得る

`acont` を受け取った値を継続にそのまま引き渡す関数 `fun a bcont -> bcont a`、 `tcont` を恒等関数 `Fun.id` にすると、値をそのままコピーする関数が得られる。

## 具体的な Lens の定義

先程の `lens` 関数を使ってタプルの第1要素に対する Lens を定義する。

```ocaml:optic.ml
let _1 () = lens fst (fun (_, x) b -> (b, x))
```

`lens` は getter と setter を受け取るものだったので、 `fst` と `(fun (_, x) b -> (b, x))` を渡す。

これだけだと値制限により `lens fst (fun (_, x) b -> (b, x))` の型は `('_a * '_b, '_x * _'b, '_a, '_x) _t` のようになってしまうため、 `_1` に `()` 引数を追加して関数にする。これで `_1` の型は `unit -> ('a * 'b, 'x * 'b, 'a, 'x) _t` （= `('a * 'b, 'x * 'b, 'a, 'x) t`）になり、値制限を回避できる[^value-restriction-on-compose]。

[^value-restriction-on-compose]: ただし、これでも合成時の値制限は回避できず、 `_1 // _1` などの多相性は失われてしまう（`let _1_1 () = (_1 // _1) ()` のようにη変換すればよいが）。

これが、 `t` の定義に `unit ->` を追加した理由だ。

第2要素に対する Lens もほぼ同じで以下の通り。

```ocaml:optic.ml
let _2 () = lens snd (fun (x, _) b -> (x, b))
```

# Opticsの合成

今回の Optics の定義は単純な関数にはなっていないので、合成関数も別途定義する。

`Optic.t` は thunk になっているうえ、レコードにも包まれていて適用するのがちょっと面倒なので、まず補助関数をつくっておく。

```ocaml:optic.ml
let app lens = (lens ()).op
```

次に Optics の合成を定義する（もとのコードでは `(>>)` という名前にしているが、関数合成の気持ちでは `(<<)` のような気がする（F#脳）。実際、 PureScript では関数合成の `<<<` で Lens を合成する。ここでは階層構造をたどるときのイメージで `(//)` としてみる）。 `app` のおかげで普通の関数合成との類似が見て取りやすい。

```ocaml:optic.ml
let (//) f g () = { op = fun z -> app f (app g z) }
```

恒等Opticsも定義しておく。これは単に `op` を恒等関数にしておく。

```ocaml:optic.ml
let id () = { op = Fun.id }
```

# Optics を使う関数

定義した Lens を使う関数を定義してみよう。

まずは取り出した値に関数を適用してもとの場所にsetしなおす `over` を定義する。 `over lens f s` は `s` 内の `lens` が指し示す値に `f` を適用して書き戻す。例えば `over _1 abs (-42, 3.14)` であれば、タプルの第1要素に `abs` を適用して `(42, 3.14)` を得る。

```ocaml:optic.ml
let over lens f s =
  app lens (fun a bcont -> bcont (f a)) s Fun.id
```

`app lens` の第1引数には getter で取り出された `a` と、 `b` を使う継続 `bcont` が渡ってくるので、 `bcont` に渡す前に `f` を適用しておく。 setter を適用したあとにさらに値を加工する必要はないので、 `tcont` には `Fun.id` を渡しておく。

次は、 `lens` が指し示す値を、単純に指定された値で置き換える `set` を定義する。これには `over` が使える。

```ocaml:optic.ml
let set lens v s =
  over lens (Fun.const v) s
```

`over` に渡す関数で、もとの値を無視して `v` を返せばよい。

次は `lens` が注目している値を取り出す `get` だ。これはちょっとややこしい。

```ocaml:optic.ml
let get lens s =
  app lens Fun.const s (fun _ -> assert false)
```

前述の手順で言うと、興味があるのは getter で `a` を取り出す部分までなので、 setter がかかわる処理の部分は飛ばしたい。これは継続 `bcont` を起動しなければよい。 `Fun.const` の部分をベタ書きにして `fun a _bcont -> a` のようにした方がわかりやすいかもしれない。 `tcont` の方は呼び出されないので何でもいいような気がするが、 getter と型を合わせないといけないので `assert false` でつじつまを合わせておく。

# Prism の定義

Lens が has-a 関係であるのに対して、 Prism は is-a 関係の特徴づけであると言われている[^what-are-prisms]。第一級の場合分けとか言われている。

Lens が、例えば `'a * 'b * ...` の `'a` を操作するのに対して、 Prism は `'a + 'b + ...` の `'a` を操作するとか云々。

[^what-are-prisms]: [haskell - What are Prisms? - Stack Overflow](https://stackoverflow.com/questions/50915526/what-are-prisms/50916648#50916648)

Lens が getter, setter で考えるのに対して、 Prism は upcast, downcast で考える。例えば、 `'a option` 型に対しては、 `Some` のときの `'a` を `'a option` にする upcast と、 `'a option` を `Some` のときの `'a` にする downcast が考えられる（`None` のときは `unit` に対する upcast / downcast にする）。

upcast, downcast の組から Prism をつくる `prism` 関数の定義は以下の通り（ここでは、 `b` から `t` を構成するための関数、 `s` から `a` を取り出せるかどうかの場合分け、という意味で引数を `construct`, `destruct` という名前にした[^haskell-prism-naming]）。

[^haskell-prism-naming]: Haskell の [optics-core ライブラリ](https://hackage.haskell.org/package/optics-core-0.3.0.1/docs/Optics-Prism.html#v:prism)では `construct`, `match` という名前を使っている。[lens ライブラリ](https://hackage.haskell.org/package/lens-4.19.2/docs/Control-Lens-Prism.html#v:prism)では `b → t` と `s → Either t a` なので `bt` と `seta` と呼んでいたりする……

```ocaml:optic.ml
(*
val prism  : ('b -> 't) -> ('s -> ('a, 't) Result.t) -> ('s, 't, 'a, 'b) _t
 *)
let prism construct destruct =
  let op acont s tcont =
    Result.fold (destruct s)
      ~error:tcont
      ~ok:(fun x -> acont x (fun b -> tcont (construct b)))
  in { op }
```

`s` から `a` への downcast は失敗することがあるので、 `destruct` の結果は `Result.t` にする（圏論的には Prism は Lens の双対で余積がどうこうなので `Either.t` のような気もするが、同型だし、成功/失敗という観点から `Result.t` にする）。

基本は `lens` と同じで、 `destruct` で場合分けをして、望む値が得られたら `acont` に引き渡して加工し、 `construct` で結果型の値を構築し、 `tcont` でさらに加工する。 `Result.Error` の場合は `'t` 型の値が返ってくることになっているので、型にしたがって `tcont` に引き渡す。

## 具体的な Prism の定義

上記の `prism` 関数を使って `option` の `Some` に対する Prism を定義する。

```ocaml:optic.ml
let _Some () =
  prism Option.some
    (function
      | Some x -> Result.ok x
      | None as x -> Result.error x)
```

`construct` は単に `Option.some` を渡す。 `destruct` の方は、場合分けをして `Some` のときは中の値を `Ok` に、 `None` のときはもとの値を `Error` で包んで返す。

# 使ってみる

これで最低限の道具はできたので使ってみよう。

```ocaml
# #use "optic.ml";;
...

# over _1 abs (-42, 3.14);;
- : int * float = (42, 3.14)

# over _1 Int.to_string (-42, 3.14);;
- : string * float = ("-42", 3.14)

# get (_2 // _1) (42, (3.14, "foo"));;
- : float = 3.14

# set (_2 // _2) "bar" (42, (3.14, "foo"));;
- : int * (float * string) = (42, (3.14, "bar"))

# set (_2 // _2 // _Some) "bar" (42, (3.14, Some "foo"));;
- : int * (float * string option) = (42, (3.14, Some "bar"))

# set (_2 // _2 // _Some) "bar" (42, (3.14, None));;
- : int * (float * string option) = (42, (3.14, None))
```

どうやら動いているようだ。

# いろいろ

この他いくつかの Lens, Prism の定義と、見た目のために indexing operator を追加したものを https://gist.github.com/leque/6dd5996b52111d7f8c12b8496b7f1688 に置いてある。

最終的なシグネチャは下記の通り。

```ocaml:optic.mli
type (-'s, +'t, +'a, -'b) _t
type (-'s, +'t, +'a, -'b) t = unit -> ('s, 't, 'a, 'b) _t

val lens   : ('s -> 'a) -> ('s -> 'b -> 't) -> ('s, 't, 'a, 'b) _t

val prism  : ('b -> 't) -> ('s -> ('a, 't) Result.t) -> ('s, 't, 'a, 'b) _t
val prism' : ('b -> 's) -> ('s ->       'a Option.t) -> ('s, 's, 'a, 'b) _t

val (//) : ('a, 'b, 'c, 'd) t -> ('c, 'd, 'e, 'f) t -> ('a, 'b, 'e, 'f) t

val id : ('s, 'a, 's, 'a) t

val _1 : ('a * 'x, 'b * 'x, 'a, 'b) t
val _2 : ('x * 'a, 'x * 'b, 'a, 'b) t

val _Ok    : (('a, 'x) Result.t, ('b, 'x) Result.t, 'a, 'b) t
val _Error : (('x, 'a) Result.t, ('x, 'b) Result.t, 'a, 'b) t

val _Some : ('a Option.t, 'b Option.t, 'a, 'b) t

val over : ('s, 't, 'a, 'b) t -> ('a -> 'b) -> ('s -> 't)
val set : ('s, 't, 'a, 'b) t -> 'b -> 's -> 't
val get : ('s, 't, 'a, 'b) t -> 's -> 'a
val (.%[]<-) : 's -> ('s, 't, 'a, 'b) t -> 'b -> 't
val (.%[]) : 's -> ('s, 't, 'a, 'b) t -> 'a
```

## 2020-12-24 追記

上記のコードは `get _Some None` などとすると `Assert_failure` 例外が上がってしまう。「`tcont` の方は呼び出されないので何でもいいような気がする」というのは Prism では成り立たないからだ。

Optics の部分型関係を考えると、 Prism は Getter の部分型ではないので `get` はできるべきでない。幽霊型（phantom type）などをつかってこれを表現すべきなのだろう。

→ 続編: [続・OCamlでもLensしたい2020 - Qiita](https://qiita.com/dico_leque/items/cc0a0162f17cea8f8ae0)

# 参考URL

* [OCaml van Laarhoven CPS lenses.](https://gist.github.com/tel/08d2a94de21f483cbb20)
    * 元ネタ
* [ocaml - Sneaking lenses and CPS past the value restriction - Stack Overflow](https://stackoverflow.com/questions/29187287/sneaking-lenses-and-cps-past-the-value-restriction)
    * 上記の値制限を回避する方法
* [My new lens idea :: lpaste — Lambda pastebin (Internet Archive)](http://web.archive.org/web/20160923005504/http://www.lpaste.net/128137)
    * 元ネタの元ネタ。「setter の途中で脱出すれば `get` が作れるのでは？ → CPS 変換しよう！」というのが元々のアイデアだったようだ。本記事での `get` の実装はこのあたりの経緯を知らずに偶然同じ実装にたどりついていた。