try-with-finally

camp4が使えるようになりたいと思っていたので
向井さんの訳された http://www.jmuk.org/~mukai/camlp4tut.html
を読ませてもらう。はじめはよくわからないけど、読み進めていくうちになんとかわかってきた。

そこで、p4ckで配布されているpa_tryfinally.mlを改造して Javaとかにあるのと同じような、　try .. with .. finally と書ける構文拡張を作ってみた。
これを使うと

  try 
    print_endline "hoge1";
    ignore (1 / 0);
    print_endline "moe1";
  with
      _ -> print_endline "error1"
  finally
    print_endline "finally1";
    print_endline "finally1-2"

とか

  try 
    print_endline "hoge2";
    print_endline "moe2";
  finally
    print_endline "finally2"

とか書ける。

以下ソースコード。pa_tryfinallyのコードを一部に使っているのでライセンスはpa_tryfinallyと同じ。

コンパイルはソースコードをpa_trywithfinally.mlに保存して、

ocamlc -c -I +camlp4 -pp "camlp4o pa_extend.cmo q_MLast.cmo" pa_trywithfinally.ml -o pa_trywithfinally.cmo

とするか、OCamlMakefileを使って適当にコンパイル。

(*pp camlp4o pa_extend.cmo q_MLast.cmo *)
open Pcaml

let unique = 
  let counter = ref 0 in
  fun () -> incr counter; "__pa_trywithfinally" ^ string_of_int !counter


let expand_trywithfinally _loc e1 wl e2 =
  let result = unique () in
  <:expr<
  let $lid:result$ =
    try
      `Result (try $e1$
               with [ $list:wl$])
    with [ exn -> `Exn exn  ] in
  let () = $e2$ in
  match $lid:result$ with
      [ `Result x -> x
      | `Exn exn -> raise exn ]
  >>

let expand_tryfinally _loc e1 e2 =
  let result = unique () in
  <:expr<
  let $lid:result$ =
    try `Result $e1$
    with [ exn -> `Exn exn ] in
  let () = $e2$ in
  match $lid:result$ with
      [ `Result x -> x
      | `Exn exn -> raise exn ]
  >>



EXTEND
  GLOBAL: expr;

  expr: LEVEL "expr1"
    [ [ "try"; e1 = expr; 
        "with"; OPT "|"; wl = LIST1 match_case SEP "|";
        "finally"; e2 = expr LEVEL "top" 
          -> expand_trywithfinally _loc e1 wl e2 

      | "try"; e1 = expr;
        "with"; OPT "|"; wl = LIST1 match_case SEP "|"
          -> <:expr<try $e1$ with [$list:wl$]>>

      | "try"; e1 = expr;
        "finally"; e2 = expr LEVEL "top" 
          -> expand_tryfinally _loc e1  e2 
      ]
    ];

  match_case:
    [ [ p = patt;  w = when_expr_opt; "->"; e = expr ->
          (p, w, e) ] ]
  ;

  when_expr_opt:
    [ [ "when"; e = expr -> Some e
      | ->  None ] ]
  ;

END