3

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

1 件の回答 1

4

クラスの継承の関数型言語での実装の方法と言っていいと思います。

eval 関数を reval -> reval という「関数を拡張する関数」として実装し、それらを関数合成で繋げた後に不動点を取るとよいです。次は名前をオブジェクト指向風にいろいろ変えましたが、そんな実装です。

このようなテクニックは OCaml コンパイラ内部の ppx 拡張用のモジュール parsing/ast_mapper.ml でも使われていますので参考にしてください。

ただ、落とし穴としては、一つでも未実装のコンストラクタケースがあると…そのコンストラクタを貰うと無限ループして死んでしまいます…

type 'a t = ..
type self = { f : 'a. 'a t -> 'a }

module NumApp = struct
  module Type = struct
    type 'a t +=
        Num : int -> int t
      | App : ('a -> 'b) t * 'a t -> 'b t
  end
  open Type

  let extend (self:self) : self = 
    let f (type a) (t:a t) : a =
      match t with
      | Num i -> i
      | App (f, x) -> self.f f (self.f x)
      | e -> self.f e
    in
    { f = f }

end

module Plus = struct
  module Type = struct
    type 'a t += 
      | Plus : (int -> int -> int) t
  end
  open Type

  let extend (self:self) : self =
    let f (type a) (t:a t) : a =
      match t with
        Plus -> (+)
      | e -> self.f e
    in
    { f = f }
end

module Neg = struct
  module Type = struct
    type 'a t += 
      | Neg : (int -> int -> int) t
  end
  open Type

  let extend (self:self) : self =
    let f (type a) (t:a t) : a =
      match t with
      | Neg -> (-)
      | e -> self.f e
    in
    { f = f }
end

include NumApp.Type
include Plus.Type
include Neg.Type

let rec fix (self : self -> self) : self =
  {f = fun x -> (self (fix self)).f x}

let fixed = fix (fun x -> NumApp.extend (Plus.extend (Neg.extend x)))

let e = App
  (App (Plus, (App (App (Neg, Num 21), Num 21))),
      App (App (Plus, Num 21), Num 21))

let v = print_int @@  fixed.f e 
1
  • selfがopen recursionとパターン不一致の継続の両方の役割を果たしています。それぞれ別だと思ってましたが、統合できるんですね。よくわかりました。ありがとうございます。 Commented 2015年1月27日 12:32

この質問に回答するには、ログインする必要があります。

求めていた回答ではありませんか? のタグが付いた他の質問を参照する。