open recursionなモジュールに型定義を持たせる（下改）

open recursionの記事に関して、より良い書き方があることに気づいたので書き留めておく。

あっちの記事ではシグニチャ二つを定義していて、GT.t = GT.s greet、NT.t = NT.s named greetと、GT.t型とNT.t型の形が違っていた：

module type NT = sig
  type s
  type t = s named greet
  type ctor

  val create : ctor -> t
  val addressee : t -> string
  val greet : t -> string
end

そのせいでNamedF内のSelfモジュール（NT型だ）を直接GreetFに渡すことができず、struct ... endで無名モジュールを作って型合わせに色々とやる必要が出てきた：

module NamedF(Self : NT)
  : NT with type s = Self.s and type t = Self.t and type ctor = Self.ctor
  = struct
    module Super = GreetF(struct
      type s = Self.s named
      type t = s greet
      include (Self : GT with type s := Self.s named and type t := s greet)
    end)
    include Self
    let greet = Super.greet
    let addressee x = x.greet_child.name
  end

しかしよく考えるとNT.t型とGT.t型を両方s greetにしてしまえばこういう問題は生じない。NTではNT.tが'a named greet型になるようにしたい、という制約があるが、それを実現するために新しく型を追加すればいい、というのが今回の気づきポイント：

module type NT = sig
  type r
  include GT with type s = r named
end

type rを導入することによってtype s = r namedとsの形に制約をつけられる。それ以外はすべてGTと同じなのでinclude GT with type s = r namedでNTが作れる。

これでGTと同じようにtype t = s greetになるのでNamedFがスッキリ書ける：

module NamedF(Self : NT)
  : NT with type r = Self.r and type s = Self.s and type t = Self.t and type ctor = Self.ctor
  = struct
    module Super = GreetF(Self) (* ここ *)
    include Self
    let addressee x = x.greet_child.name
    let greet = Super.greet
  end

Superをモジュールとして定義せずにincludeできるかも考えたのだが、Selfの中のほしいものをshadowしてしまう（あるいは逆にSelfにshadowされてしまう）のでうまくいかなそう。

コード全容：

type 'child greet = { message : string; greet_child : 'child }

module type GT = sig
  type s
  type t = s greet
  type ctor

  val create : ctor -> t
  val addressee : t -> string
  val greet : t -> string
end

module GreetF(Self : GT)
  : GT with type s = Self.s and type t = Self.t and type ctor = Self.ctor
  = struct
    include Self
    let addressee _x = "world"
    let greet x = x.message ^ " " ^ Self.addressee x
  end

module rec Greet
  : GT with type s = unit and type ctor = string (* ここもtype tが省略できることに気づいて少し簡単になっている *)
  = GreetF(struct
    include Greet
    let create id = { message=id; greet_child=() }
  end)

type 'child named = { name : string; named_child : 'child }

module type NT = sig
  type r
  include GT with type s = r named
end

module NamedF(Self : NT)
  : NT with type r = Self.r and type s = Self.s and type t = Self.t and type ctor = Self.ctor
  = struct
    module Super = GreetF(Self)
    include Self
    let addressee x = x.greet_child.name
    let greet = Super.greet
  end

module rec Named
  : NT with type r = unit and type ctor = (string * string) (* 上に同じ *)
  = NamedF(struct
    include Named
    let create (message, name) = { message=message; greet_child={ name=name; named_child=() }}
  end)