test2.ml

open Printf

module rec Nil : sig
  type +'a t = 'a
  val app : ('a t, 'a) Type.app
end = struct
  type 'a t = 'a
  let app = Type.Nil
end

and Arg : functor
  (T : sig type t val t : t Type.t end)
  (Rest : sig type +'a t val app : ('a t, 'a) Type.app end) ->
sig
  type +'a t = T.t -> 'a Rest.t
  val app : ('a t, 'a) Type.app
end = functor
  (T : sig type t val t : t Type.t end)
  (Rest : sig type +'a t val app : ('a t, 'a) Type.app end) ->
struct
  type 'a t = T.t -> 'a Rest.t
  let app = Type.Arg (T.t, Rest.app)
end

and Type : sig
  module type CON = sig
    type s
    module Args : sig type +'a t val app : ('a t, 'a) Type.app end
    val name : string
    val con : s Args.t
    val decon : 'a Args.t -> 'a
  end

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

  type (_, 'r) app =
    | Nil : ('r, 'r) app
    | Arg : 'a t * ('b, 'r) app -> (('a -> 'b), 'r) app
end = Type

type t =
  | Foo
  | Bar of int * bool

module IntT = struct
  type t = int
  let t = Type.Int
end

module BoolT = struct
  type t = bool
  let t = Type.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
    let rec f : type f . (f, unit) app -> f = function
      | Nil -> ()
      | Arg (arg_ty, rest) ->
        (fun arg ->
           print_char ' ';
           print arg_ty arg;
           f rest) in
    print_string C.name;
    C.decon (f C.Args.app)

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))