Skip to content

Instantly share code, notes, and snippets.

@gsg
Created July 24, 2015 13:54
Show Gist options
  • Save gsg/de52c76657b523b49fae to your computer and use it in GitHub Desktop.
Save gsg/de52c76657b523b49fae to your computer and use it in GitHub Desktop.
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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment