gsg

(*
 * GADT friendly hash tables.
 *)

module type GadtHashEq = sig
  type 'a key
  type 'a value
  val eq_assoc : 'a key -> 'b key -> 'b value -> 'a value option
  val hash : 'a key -> int
end

gsg

module rec Value : sig
  type t =
    | Nil
    | Bool of bool
    | Float of float
    | String of string
    | Table of table
  and table = {
    id : int;
    table : t Table.t;

gsg

type x = [ `A ]
type y = [ x | `B ]
type z = [ y | `C ]

type 'a t =
  | X_1 of x * 'a
  | X_2 of x * 'a
  | Y_a of x
  | Y_var of 'a
  constraint 'a = [< z ]

gsg

module Univ : sig
  type t
  val embed : unit -> ('a -> t) * (t -> 'a option)
end = struct
  type t = unit ref * (unit -> unit)
  let embed () =
    let id = ref () in
    let loc = ref None in
    let put x = id, (fun () -> loc := Some x) in
    let get (rid, rstore) =

gsg

module Eq = struct
  type (_,_) t = Refl : ('a,'a) t
end

module type EqAssoc = sig
  type 'a key
  type 'a value
  val equal : 'a key -> 'b key -> ('a, 'b) Eq.t option
end

gsg

type _ t = I : int -> int t | F : float -> float t

module TEq = struct
  type 'a key = 'a t
  type 'a value = 'a t
  let equal : type a b . a key -> b key -> (a, b) Eq.t option =
    fun x y -> match x, y with
      | I a, I b -> if a = b then Some Eq.Refl else None
      | F a, F b ->  if a = b then Some Eq.Refl else None
      | _ -> None

gsg

module M = struct
  type 'a key
  type 'a value
  type t = Univ : 'a key * 'a value -> t
  type polymorphic_operations = {
    conv_key : 'a . 'a key -> string;
    conv_value : 'a . 'a value -> string;
  }
  let as_strings : type a . polymorphic_operations -> t -> (string * string) =
    fun ops t -> match t with

gsg

module type Witness = sig type 'a key type 'a value end

module type Witnessed = sig
  type 'a key
  type 'a value
  type t
  type ('a, 'b) conv = {
    key : 'c . 'c key -> 'a;
    value : 'c . 'c value -> 'b;
  }

gsg

(defun comb2 (f x y)
  (funcall f (+ x y))
  (funcall f (- x y))
  (funcall f (- y x))
  (funcall f (* x y))
  (when (not (zerop y))
    (funcall f (/ x y)))
  (when (not (zerop x))
    (funcall f (/ y x))))

gsg

module Test : sig
  val f : unit -> unit
end = struct
  exception Foo
  exception Bar of exn
  let f () = raise (Bar Foo)
end