問題

今回はStateを更新する機能としてPutの追加をやっていく。HIstoryも追加しようと思うと内部表現を多少変える必要があるので、まずは変更の少ないPutだけやって「ハンドラが複数Effectを処理できるようにする」という点に集中する。

具体的にはまずSTATEシグニチャを以下のように変えていく：

module type STATE = sig
  type t
  val get : unit -> t
  val put : t -> unit
  val run : (unit -> unit) -> init:t -> unit
end

putは新しい状態を受けとり、コンテキストの状態を更新してunitを返す。

あとはStateファンクタでこのシグニチャを実装するだけ。

実装

まずはPutも追加したStateファンクタの全容：

module State (S : sig type t end) : STATE with type t = S.t = struct
  type t = S.t

  type _ Effect.t += Get : t Effect.t
  type _ Effect.t += Put : t -> unit Effect.t

  let get () = Effect.perform Get
  let put x = Effect.perform (Put x)

  let run f ~init =
    let module Es = Effect.Shallow in
    let rec loop : type a r. t -> (a, r) Es.continuation -> a -> r =
      fun state k x ->
        let handler = {
          Es.retc = (fun result -> result);
          Es.exnc = (fun e -> raise e);
          Es.effc = (fun (type b) (eff : b Effect.t) ->
            match eff with
            | Get -> Some (fun (k: (b, r) Es.continuation) ->
                       loop state k state)
            | Put x -> Some (fun (k: (b, r) Es.continuation) ->
                       loop x k ())
            | _ -> None)
        } in
        Es.continue_with k x handler
    in
    loop init (Es.fiber f) ()
end

変更点を見ていく。

  type _ Effect.t += Put : t -> unit Effect.t

PutというコンストラクタをEffect.tに追加。これはt型（つまり新しい状態）を引数にとるコンストラクタで、t型を包んだ値の型はunit Effect.t、つまりPut xをperformした場合返ってくる値はunit型だ。

put関数ではそのPutを包んでEffect.performしている：

  let put x = Effect.perform (Put x)

xはt型、Put xはunit Effect.t型なのでputはシグニチャ通りt -> unitな関数となる。

これでシグニチャに追加した関数は実装できたわけだが、新しく追加したPutエフェクトを正しく処理できるようにハンドラを変更する必要がある。

run関数のなかのハンドラ：

  let run f ~init =
      ...
        let handler = { ...
          Es.effc = (fun (type b) (eff : b Effect.t) ->
            match eff with
            | Get -> Some (fun (k: (b, r) Es.continuation) ->
                       loop state k state)
            | Put x -> Some (fun (k: (b, r) Es.continuation) ->
                       loop x k ())
            | _ -> None)
        } ...

生じたエフェクトeffに対してのパターンマッチで、GetケースだけだったところにPut xケースも追加している。このケースでは限定継続kをとってloop x k ()している。

loopの型はtype a r. t -> (a, r) Es.continuation -> a -> rで定義はfun state k x -> ...だ。第一引数は新しい状態、第二引数は限定継続、そして第三引数は限定継続に渡す値である。

このPutケースの処理を追っていくと、パターンPut xの引数部分xが「新しい状態」となる値、(k: (b, r) Es.continuation)の部分がPutエフェクトが生じた箇所の限定継続。loop関数の再帰的呼び出しloop x k ()ではstate引数はx、限定継続はk、そしてその限定継続に渡すための引数部分に当たる第三引数は()となる。loop関数の中では、新しいstateを使ってhandlerが再定義され、そのハンドラを使ってEffect.Shallow.continue_withで限定継続kに()を渡して実行している。

面白い点としては

(fun (type b) (eff : b Effect.t) ->
    match eff with
    | Get -> Some (fun (k: (b, r) Es.continuation) ->
               loop state k state)
    | Put x -> Some (fun (k: (b, r) Es.continuation) ->
               loop x k ())

のb型がGetとPutで違う型だということ。Getはt Effect.t、Putはunit Effect.tで、限定継続に渡す値の型はtとunitだと決まっている。locally abstract typeを使得ことで、ハンドラを多相にした上でeffの型と限定継続の型の制約を表現している。

これはエフェクトごとに限定継続が期待している「返ってくる値」の型が違うというケースで、Stateのように複数のEffect.tの相互作用で実装するエフェクトでは頻出するパターンだろう。

使ってみる

前回の使用例に少し手を加えてputを追加してみる：

module IS = State (struct type t = int end)
module SS = State (struct type t = string end)

let foo () : unit =
  let open Printf in
  printf "%d\n" (IS.get ());
  printf "%d\n" (IS.get ());
  IS.put 0;
  printf "%d\n" (IS.get ());
  printf "%s\n" (SS.get ());
  SS.put "hello";
  printf "%s\n" (SS.get ())

let _ = IS.run (fun () -> SS.run foo ~init:"forty two") ~init:42

実行してみる：

$ ocaml state2.ml
42
42
0
forty two
hello

期待通りにIS.getやSS.getの結果がそれ以前に行われるIS.put, SS.putによって変わっていく。

次回

次はStateのHistoryを実装する。

Arantium Maestum

プログラミング、囲碁、読書の話題

OCaml Effects Tutorialの演習「StateのPut実装」をやってみる

問題

実装

使ってみる

次回