Type equality register with hashtbl

hashed_eq_register.ml

type _ data_cstr = ..

type 'a data_format = { id: extension_constructor; cstr: 'a data_cstr}


type (_, _) eq = Eq : ('a, 'a) eq

type data_key = { is_eq: 'a 'b. 'a data_cstr -> 'b data_cstr -> ('a,'b) eq option }

let data_format_register : (extension_constructor, data_key) Hashtbl.t   = Hashtbl.create 17

let mk_data_format : type a. unit -> a data_format = fun () ->
  let module M = struct type _ data_cstr += Fmt : a data_cstr end in
  let is_eq : type a b. a data_cstr -> b data_cstr -> (a, b) eq option =
    fun fmt1 fmt2 ->
      match fmt1, fmt2 with
      | M.Fmt, M.Fmt -> Some (Eq : (a, b) eq)
      | _, _ -> None
  in
  let id = [%extension_constructor M.Fmt] in
  Hashtbl.replace  data_format_register id { is_eq };
  { id; cstr= M.Fmt }

exception Cast_failure

let data_format_iseq : type a b. a data_format -> b data_format -> (a, b) eq option =
  fun fmt1 fmt2 ->
  match Hashtbl.find data_format_register fmt1.id with
  | {is_eq} -> is_eq fmt1.cstr fmt2.cstr
  | exception Not_found -> None