この記事は ML Advent Calendar 2020 の18日目の記事です。

前置き

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

と聞いてはいたが、それ以外はよく知らなかったので、とりあえず OCaml で Lens してみようと思ったものの、opam - lens のように単に getter と setter の組で表現すると音に聞く Prism 等に拡張できなさそうだし、 Haskell の型クラスによる実装をモジュールとファンクタで真似する¹と構文的に重くなる（例えば、OCaml lenses via modules | Notes on Computing）、 F# は型クラスを実現する手法があり、Lens (FSharpPlus) はそれを使っているようだけれど、 OCaml では真似できなさそうだ、という感じにさまよっていたときに見掛けた OCaml van Laarhoven CPS lenses. が面白かったので、自分で書き写したり書き換えたりしつつ読んだときのことをメモしておく。

定義

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

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

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

Lens の定義

Lens は has-a 関係の特徴づけと説明されている³。

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

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 で最終結果に変換する。

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

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

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

具体的な Lens の定義

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

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）になり、値制限を回避できる⁴。

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

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

optic.ml

let _2 () = lens snd (fun (x, _) b -> (x, b))

Opticsの合成

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

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

optic.ml

let app lens = (lens ()).op

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

optic.ml

let (//) f g () = { op = fun z -> app f (app g z) }

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

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) を得る。

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 が使える。

optic.ml

let set lens v s =
  over lens (Fun.const v) s

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

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

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 関係の特徴づけであると言われている³。第一級の場合分けとか言われている。

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

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 という名前にした⁵）。

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 を定義する。

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 で包んで返す。

使ってみる

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

# #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 に置いてある。

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

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

参考URL

OCaml van Laarhoven CPS lenses.
- 元ネタ
ocaml - Sneaking lenses and CPS past the value restriction - Stack Overflow
- 上記の値制限を回避する方法
My new lens idea :: lpaste — Lambda pastebin (Internet Archive)
- 元ネタの元ネタ。「setter の途中で脱出すれば get が作れるのでは？ → CPS 変換しよう！」というのが元々のアイデアだったようだ。本記事での get の実装はこのあたりの経緯を知らずに偶然同じ実装にたどりついていた。

Haskell の型クラスは、クラス定義をシグネチャ、インスタンス定義をモジュール定義、型クラス制約をファンクタにすると ML 系言語に写せる ↩
('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 によれば、これは Profunctor Optics のインスタンスのひとつで、 'a -> ('b, 'r) cont がどのくらい強い Profunctor のサブクラスの制約を満たすかによって Optics としての表現力が決まるそうだ。 ↩
haskell - What are Prisms? - Stack Overflow ↩
ただし、これでも合成時の値制限は回避できず、 _1 // _1 などの多相性は失われてしまう（let _1_1 () = (_1 // _1) () のようにη変換すればよいが）。 ↩
Haskell の optics-core ライブラリでは construct, match という名前を使っている。lens ライブラリでは b → t と s → Either t a なので bt と seta と呼んでいたりする…… ↩