Extensible variant typesを使ってバリアントを拡張すると、パターンマッチも拡張しなければなりません。しかも、もし二つの独立したバリアントの拡張を合成しようとすると、二つの独立した(パターンマッチを内部的に使っている)関数を合成しなければなりません。(下記の例ではPlus.open_evalとNeg.open_eval)
これを実現するために、下記の例では例外を使ってorElseという合成関数を定義しました。
しかし、例外を使っているあたりが残念です。
パターンマッチに失敗したら次の指定したパターンマッチに移るといった「パターンマッチの合成」のような事をする慣用句、定番の方法はあるのでしょうか?
exception ParticalMatchFailure
(* fのパターンマッチが失敗したら、例外で検知して次の関数へ移る *)
let orElse f g x =
try f x with ParticalMatchFailure -> g x
module Lang = struct
module Type = struct
type 'a expr = ..
type 'a expr +=
Num : int -> int expr
| App : ('a -> 'b) expr * 'a expr -> 'b expr
end
include Type
type reval = { f : 'a. 'a expr -> 'a }
let open_eval (type a) (eval:reval) (exp:a expr) : a =
match exp with
Num i -> i
| App (f, x) -> eval.f f (eval.f x)
| _ -> raise ParticalMatchFailure
end
(* Langの拡張 *)
module Plus = struct
module Type = struct
type 'a Lang.expr +=
Plus : (int -> int -> int) Lang.expr
end
include Type
let open_eval (type a) (eval:Lang.reval) (expr:a Lang.expr) : a =
match expr with
Plus -> (+)
| x -> raise ParticalMatchFailure
let show : type a. a Lang.expr -> string = function
Plus -> "plus"
| Lang.App _ -> "app"
| Lang.Num _ -> "num"
| _ -> "no match"
end
(* LangのPlusとは関係ない拡張 *)
module Neg = struct
module Type = struct
type 'a Lang.expr +=
Neg : (int -> int -> int) Lang.expr
end
include Type
let open_eval (type a) (eval:Lang.reval) (expr:a Lang.expr) : a =
match expr with
Neg -> (-)
| x -> raise ParticalMatchFailure
end
(* 二つの独立したバリアント拡張(Plus, Neg)の合成 *)
module PlusNegLang = struct
(* includeで型は用意に合成できる *)
include Lang.Type
include Plus.Type
include Neg.Type
let rec eval : 'a . 'a Lang.expr -> 'a =
fun x ->
let reval = Lang.{ f = eval } in
(* open_evalを合成するために、orElseを使う *)
(Neg.open_eval reval
|> orElse (Plus.open_eval reval)
|> orElse (Lang.open_eval reval)) x
let () =
eval
(App
(App (Plus, (App (App (Neg, Num 21), Num 21))),
App (App (Plus, Num 21), Num 21)))
|> print_int
end