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
    
```
CC BY-SA 3.0
2015-01-27T11:29:19.937
5427
2015-01-27T12:02:44.073
2015-01-27T11:39:19.133
7611
7611
question
ocaml
パターンマッチを合成するには？
クラスの継承の関数型言語での実装の方法と言っていいと思います。

各 `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 
    
```
CC BY-SA 3.0
2015-01-27T12:02:44.073
5430
2015-01-27T12:02:44.073
898
5427
answer