test.ml

open Printf

module type T = sig type t end

module type ARGLIST = sig type 'a t end

module Nil = struct type 'a t = 'a end

module Arg (T : T) (Rest : ARGLIST) = struct
  type 'a t = T.t -> 'a Rest.t
end

module type CON = sig
  type s
  module Args : ARGLIST
  val name : string
  val con : s Args.t
  val decon : 'a Args.t -> 'a
end

module Type = struct
  type _ t =
    | Bool : bool t
    | Int : int t
    | Sum : string * ('s -> 's con) -> 's t
    and 's con = (module CON with type s = 's)
end

type t =
  | Foo
  | Bar of int * bool

module IntT = struct type t = int end
module BoolT = struct type t = bool end

let rec print : type a . a Type.t -> a -> unit =
  let open Type in
  fun ty value ->
    match ty with
    | Bool -> printf "%b" value
    | Int -> print_int value
    | Sum (_, op) -> print_sum op value

and print_sum : type s . (s -> s Type.con) -> s -> unit =
  let open Type in
  fun op value ->
    let module C : CON with type s = s = (val op value) in
    print_string C.name;
    (* trouble here *)
    C.decon (assert false)

let rec copy : type a . a Type.t -> a -> a =
  let open Type in
  fun ty value ->
    match ty with
    | Bool -> value
    | Int -> value
    | Sum (_, op) -> copy_sum op value

and copy_sum : type s . (s -> s Type.con) -> s -> s =
  let open Type in
  fun op value ->
    let module C : CON with type s = s = (val op value) in
    C.decon C.con

let t_op : t -> t Type.con = function
  | Foo ->
    (module struct
      type s = t
      module Args = Nil
      let name = "Foo"
      let con = Foo
      let decon x = x
    end)
  | Bar (i, b) ->
    (module struct
      type s = t
      module Args = Arg (IntT) (Arg (BoolT) (Nil))
      let name = "Bar"
      let con i b = Bar (i, b)
      let decon x = x i b
    end)

let t_type = Type.(Sum ("t", t_op))