OCaml Effects Tutorialの第一演習「Exceptionの再実装」をやってみる１

前回に続いてOCaml Effects Tutorialをやっていく。

問題

github.com

Exercise 1: Implement exceptions from effects ★☆☆☆☆

As mentioned before, effects generalise exceptions. Exceptions handlers are effect handlers that ignore the continuation. Your task is to implement exceptions in terms of effects. The source file is sources/exceptions.ml.

sources/exceptions.mlは以下の通り：

let raise (e : exn) : 'a = failwith "not implemented"
(* Todo *)

let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a = failwith "not implemented"
(* Todo *)

exception Invalid_argument

(** [sqrt f] returns the square root of [f].
    @raise Invalid_argument if f < 0. *)
let sqrt f =
  if f < 0.0 then raise Invalid_argument
  else sqrt f

let _ =
  try_with (fun () ->
    let r = sqrt 42.42 in
    Printf.printf "%f\n%!" r;
    let r = sqrt (-1.0) in
    Printf.printf "%f\n" r)
  (fun Invalid_argument -> Printf.printf "Invalid_argument to sqrt\n")

(* Prints:
   6.513064
   Invalid_argument to sqrt *)

raise (e : exn) : 'aとtry_with (f : unit -> 'a) (h : exn -> 'a) : 'aを実装せよ、ということだ。

sqrtに0未満のfloatが渡されたら投げる例外を処理できるかをテスト部分で確認している。

気になる点としては「実装する部分」から外れる(fun Invalid_argument -> Printf.printf "Invalid_argument to sqrt\n")がInvalid_argument以外の例外をハンドルできていない点で、これではwarningが出てしまうと思うがここはいじらないでおいていいんだろうか。

参考にする例

まずはtutorialのここまでで出てきた唯一の例を見てみる：

open Effect
open Effect.Deep

type _ Effect.t += Conversion_failure : string -> int Effect.t

let int_of_string l =
  try int_of_string l with
  | Failure _ -> perform (Conversion_failure l)

let rec sum_up acc =
    let l = input_line stdin in
    acc := !acc + int_of_string l;
    sum_up acc

let _ =
  Printf.printf "Starting up. Please input:\n%!";
  let r = ref 0 in
  match_with sum_up r
  { effc = (fun (type c) (eff: c Effect.t) ->
      match eff with
      | Conversion_failure s -> Some (fun (k: (c,_) continuation) ->
              Printf.fprintf stderr "Conversion failure \"%s\"\n%!" s;
              continue k 0)
      | _ -> None
    );
    exnc = (function
        | End_of_file -> Printf.printf "Sum is %d\n" !r
        | e -> raise e
    );
    (* Shouldn't reach here, means sum_up returned a value *)
    retc = fun _ -> failwith "Impossible, sum_up shouldn't return"
  }

上記のコードからパクる参考にするべきは以下の四箇所だろう：

open Effect
open Effect.Deep

type _ Effect.t += Conversion_failure : string -> int Effect.t

...
  | Failure _ -> perform (Conversion_failure l)

...
  match_with sum_up r
  { ... }

解答１

というわけで演習問題をやっていく。

まずはモジュールをOpenしてEffect.tに例外処理のeffectを追加する：

open Effect
open Effect.Deep

type _ Effect.t += Raise_exception : exn -> _ Effect.t

exception Invalid_argumentという本物のOCaml Exceptionを使うのが決まっているのでRaise_exceptionはexn型を引数に取るコンストラクタとなっている。Raise_exceptionをperformした場合、その箇所に何らかの値を戻して続行することはない（限定継続は破棄される）のでexn -> _ Effect.tとしてある（_の部分に入れる明確な型がない）。

次に実装する必要のある箇所の一つであるraise関数：

let raise (e : exn) : 'a = perform (Raise_exception e)

Raise_exceptionというeffectをperformするだけ。

最後にtry_with関数：

let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a = failwith "not implemented"

try_withは「fというthunk」と「hという例外処理」の２関数を引数にとる。どちらの関数も返り値は同一な'a型で、try_with自体も返り値が'a型になる。

Effect的に考えるとfの中でRaise_exceptionなeffectが生じた場合にうまく処理するハンドラをtry_withの中に書く形になる：

let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a =
  let handler = { effc=...; exnc=...; retc=...} in
  match_with f () handler

今回はexncには「f ()の中で本当に例外が投げられたらそのまま上に投げる」、retcには「f ()が普通に処理が終わって結果を返した場合はそのままその結果を返す」という処理を入れる：

let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a =
  let handler = { effc=...; exnc=(fun e -> raise e); retc=(fun x -> x)} in
  match_with f () handler

（ただしraiseはこの場合シャドーされたやつになるが・・・　というかOCamlでのraiseって予約語じゃなくてシャドーできるものなんだ・・・）

なのでeffcの部分の実装：

effc = (fun (type c) (eff : c Effect.t) ->
  match eff with
  | Raise_exception e -> Some (fun (k : (c, _) continuation) -> h e)
  | _ -> None)

愚直にBasicsの例をなぞってみた。まず生じるeffectを表すeffとその限定継続k両方の型の一部に同一の型cが出てくる、という制約を表すために明示的に(type c)とlocally abstract typeを導入。effの型はc Effect.t、kの型は(c, _) continuationとなる。kの型の第二パラメータは限定継続がcontinueされると返ってくる型で、Exceptionの場合はcontinueすることはないので_にしておく。

effにパターンマッチしてRaise_exceptionならSome (fun (k : (c, _) continuation) -> h e)でこのハンドラで処理できることを示す（そして他のeffectはハンドルできない、ということを| _ -> Noneで表す）。

fun (k : (c, _) continuation) -> h eでは限定継続を引数にとるが使わず、その代わりRaise_exceptionに包まれていたexn型の値eをtry_withの引数として渡された「例外処理用の関数」hに適用している。

というわけで解答として実装した部分は以下の通り：

open Effect
open Effect.Deep

type _ Effect.t += Raise_exception : exn -> _ Effect.t

let raise (e : exn) : 'a = perform (Raise_exception e)

let try_with (f : unit -> 'a) (h : exn -> 'a) : 'a =
  let handler = {
    effc = (fun (type c) (eff : c Effect.t) ->
      match eff with
      | Raise_exception e -> Some (fun (k : (c,_) continuation) -> h e)
      | _ -> None);
    exnc = (fun e -> raise e);
    retc = (fun e -> e)
  } in
  match_with f () handler

テスト

実行してみる：

$ ocaml exceptions.ml
File "./exceptions.ml", line 33, characters 2-70:
33 |   (fun Invalid_argument -> Printf.printf "Invalid_argument to sqrt\n")
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8 [partial-match]: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
*extension*
Matching over values of extensible variant types (the *extension* above)
must include a wild card pattern in order to be exhaustive.
6.513064
Invalid_argument to sqrt

懸念どおりfun Invalid_argument -> ...の部分でwarningが出る、がとりあえず期待された出力にはなる。

次回

この解答にはいくつか修正したい点がある。長くなったので次回に持ち越し。