fun with extensible variants, including extensible GADTs

extensible_variants.ml

(* extensible variant types, including GADTs
 * not to be confused with polymorphic variants
 *)

type extend_me = ..

type extend_me += This
type extend_me += That of int
type extend_me += TheOther of string

let print_extend_me = function
  | This -> "this"
  | That x -> "that " ^ string_of_int x
  | TheOther s -> "the other \"" ^ s ^ "\""
  | _ -> "something we don't know about yet"

type 'a polymorph_me = ..

type 'a polymorph_me += Untagged of 'a
type 'a polymorph_me += Tagged of string * 'a

let print_polymorph_me = function
  | Untagged x -> "an untagged thing"
  | Tagged (lbl, x) -> "a thing tagged \"" ^ lbl ^ "\""
  | _ -> "something we don't know about yet"

type 'a gadt_me = ..

type _ gadt_me += Literal: 'a -> 'a gadt_me
type _ gadt_me += Add: int gadt_me * int gadt_me -> int gadt_me
type _ gadt_me += IsZero: int gadt_me -> bool gadt_me
type _ gadt_me +=
  IfThenElse: bool gadt_me * 'a gadt_me * 'a gadt_me -> 'a gadt_me

let rec eval_gadt_me: type a. a gadt_me -> a = function
  | Literal x -> x
  | Add (x, y) -> eval_gadt_me x + eval_gadt_me y
  | IsZero x -> eval_gadt_me x = 0
  | IfThenElse (c, e_if, e_else) ->
      if eval_gadt_me c
        then eval_gadt_me e_if
        else eval_gadt_me e_else
  | _ -> raise (Invalid_argument "we can't magic an 'a into existence")