deriving-0.1.1/0000755000175000017500000000000010761620003012663 5ustar jeremyjeremyderiving-0.1.1/tests/0000755000175000017500000000000010636601775014045 5ustar jeremyjeremyderiving-0.1.1/tests/rejected/0000755000175000017500000000000010636601775015632 5ustar jeremyjeremyderiving-0.1.1/tests/rejected/eqparams.ml0000644000175000017500000000017710636601556017777 0ustar jeremyjeremy(* All types in a group must have the same parameters *) type 'a t1 = int and ('a,'b) t2 = int and t3 = int deriving (Eq) deriving-0.1.1/tests/rejected/polyrec.ml0000644000175000017500000000013410636601556017634 0ustar jeremyjeremy(* non-regular datatype *) type 'a seq = Nil | Cons of 'a * ('a * 'a) seq deriving (Eq) deriving-0.1.1/tests/rejected/a.ml0000644000175000017500000000016210636601556016400 0ustar jeremyjeremy(* Reject types called 'a' to avoid confusion with the overloaded type parameter *) type a = A deriving (Eq) deriving-0.1.1/tests/rejected/polyrecord.ml0000644000175000017500000000036210636601556020344 0ustar jeremyjeremy(* Polymorphic variant definitions within polymorphic record field types *) type r = { (* I think this could be supported without too much difficulty, but it doesn't have much benefit *) x : 'a. [`Foo of 'a] } deriving (Eq) deriving-0.1.1/tests/rejected/enum1.ml0000644000175000017500000000007410636601556017207 0ustar jeremyjeremy(* enum for records *) type r = { x : int } deriving (Enum) deriving-0.1.1/tests/rejected/functorf.ml0000644000175000017500000000016210636601556020006 0ustar jeremyjeremy(* Reject types called 'f' to avoid confusion with the overloaded type parameter *) type f = F deriving (Functor) deriving-0.1.1/tests/rejected/eq1.ml0000644000175000017500000000007110636601557016646 0ustar jeremyjeremy(* Eq for functions *) type t = int -> int deriving (Eq) deriving-0.1.1/tests/rejected/enum2.ml0000644000175000017500000000012210636601557017203 0ustar jeremyjeremy(* Enum for sum types with arguments *) type t = X of int | Y deriving (Enum) deriving-0.1.1/tests/rejected/dump1.ml0000644000175000017500000000021310636601557017204 0ustar jeremyjeremy(* private datatypes cannot be instances of dump (because Dump.from_string constructs values *) type p = private F deriving (Dump) deriving-0.1.1/tests/rejected/README0000644000175000017500000000042510636601557016511 0ustar jeremyjeremyThis directory contains programs that are syntactically correct but that are rejected by deriving because the types invovled don't meet the requirements for the classses in the deriving list. They're here so that it's easy to check the quality of the error messages produced. deriving-0.1.1/tests/rejected/eq2.ml0000644000175000017500000000013510636601557016650 0ustar jeremyjeremy(* Eq for records with polymorphic fields *) type r4 = { l1 : 'a . 'a list } deriving (Eq) deriving-0.1.1/tests/rejected/enum3.ml0000644000175000017500000000014310636601557017207 0ustar jeremyjeremy(* Enum for polymorphic variant types with arguments *) type t = [`A of int | `B] deriving (Enum) deriving-0.1.1/tests/rejected/dump2.ml0000644000175000017500000000025310636601557017211 0ustar jeremyjeremy(* records with mutable fields cannot be instances of Dump (because it doesn't preserve sharing *) type t = { x : int; mutable y : int ; z : int } deriving (Dump) deriving-0.1.1/tests/rejected/eq3.ml0000644000175000017500000000007010636601557016647 0ustar jeremyjeremy(* Eq for classes *) class c = object end deriving (Eq) deriving-0.1.1/tests/rejected/enum4.ml0000644000175000017500000000016510636601557017214 0ustar jeremyjeremy(* Enum for extending polymorphic variant types *) type t1 = [`A] deriving (Enum) type t2 = [`B|t1] deriving (Enum) deriving-0.1.1/tests/rejected/alias.ml0000644000175000017500000000015410636601557017253 0ustar jeremyjeremy(* Alias variable names must be distinct from parameter names *) type 'a x = [`Foo] as 'a deriving (Eq) deriving-0.1.1/tests/rejected/labels.ml0000644000175000017500000000005210636601557017421 0ustar jeremyjeremytype label = x:int -> int deriving (Eq) deriving-0.1.1/tests/rejected/infsup.ml0000644000175000017500000000010310636601557017460 0ustar jeremyjeremy(* < > variant types *) type poly6 = [< `A > `B] deriving (Eq) deriving-0.1.1/tests/rejected/privaterows1.ml0000644000175000017500000000011310636601557020623 0ustar jeremyjeremy(* Private rows are currently not supported *) type poly4 = private [< `A] deriving-0.1.1/tests/rejected/privaterows2.ml0000644000175000017500000000013510636601557020630 0ustar jeremyjeremy(* Private rows are currently not supported *) type poly4 = private [> `A] deriving (Eq) deriving-0.1.1/tests/bimap.ml0000644000175000017500000000103710636601557015466 0ustar jeremyjeremy(* Bidirectional map {t -> t} *) module type S = sig type item type t val empty : t val add : item -> item -> t -> t val find : item -> t -> item val mem : item -> t -> bool val rmem : item -> t -> bool end module type OrderedType = sig type t val compare : t -> t -> int end module Make (Ord : OrderedType) = struct type item = Ord.t type t = (item * item) list let empty = [] let add l r list = (l,r)::list let find = List.assoc let mem = List.mem_assoc let rmem item = List.exists (fun (_,i) -> i = item) end deriving-0.1.1/tests/pickle_tests.ml0000644000175000017500000001742210636601557017074 0ustar jeremyjeremy(*pp deriving *) open Defs module Test (S : Pickle.Pickle) = struct let test v = S.E.eq (S.from_string (S.to_string v)) v end let sum = begin let test = let module T = Test(Pickle_sum) in T.test in assert (test S0); assert (test (S1 3)); assert (test (S2 (10,2.0))); assert (test (Sunit ())); assert (test (Stup (10,2.0))); assert (test (Stup1 3)); end let nullsum = begin let test = let module T = Test(Pickle_nullsum) in T.test in assert (test N0); assert (test N1); assert (test N2); assert (test N3); end let r1 = begin let test = let module T = Test(Pickle_r1) in T.test in assert (test {r1_l1 = 10; r1_l2 = 20}); assert (test {r1_l1 = min_int; r1_l2 = max_int}); assert (test {r1_l1 = max_int; r1_l2 = min_int}); end let r2 = begin let v = { r2_l1 = 10; r2_l2 = 14 } in assert (not (Eq_r2.eq (Pickle_r2.from_string (Pickle_r2.to_string v)) v)); assert (Pickle_r2.from_string (Pickle_r2.to_string v) = v); end let r3 = begin let v = { r3_l1 = 10; r3_l2 = 14 } in assert (not (Eq_r3.eq (Pickle_r3.from_string (Pickle_r3.to_string v)) v)); assert (Pickle_r3.from_string (Pickle_r3.to_string v) = v); end let intseq = begin let test = let module T = Test(Pickle_intseq) in T.test in assert (test INil); assert (test (ICons (10, ICons (20, ICons (30, ICons (40, INil)))))); assert (test (ICons (max_int, ICons (min_int, INil)))); end let seq = begin let test = let module T = Test(Pickle_seq(Pickle.Pickle_bool)) in T.test in let test' = let module T = Test(Pickle_seq(Pickle_seq(Pickle.Pickle_bool))) in T.test in assert (test Nil); assert (test (Cons (false, Cons (true, Cons (false, Nil))))); assert (test' Nil); assert (test' (Cons (Cons (false, Cons (true, Nil)), Cons (Cons (true, Cons (false, Nil)), Nil)))); end let uses_seqs = begin let test = let module T = Test(Pickle_uses_seqs) in T.test in assert (test (INil, Nil)); assert (test (INil, Cons (0.0, Cons(10.0, Nil)))); assert (test (ICons (10, ICons(20, INil)), Nil)); assert (test (ICons (10, ICons(20, INil)), Cons (0.0, Cons(10.0, Nil)))); end type permute0 = [`T3 | `T1 | `T2 | `T0] deriving (Typeable, Eq, Pickle) let poly0 = begin let test v = Eq_permute0.eq (Pickle_permute0.from_string (Pickle_poly0.to_string v)) v in assert (test `T0); assert (test `T1); assert (test `T2); assert (test `T3); end type permute3 = [`Nil | `Cons of int * permute3] deriving (Typeable, Eq, Pickle) let _ = begin let test v = Eq_permute3.eq (Pickle_permute3.from_string (Pickle_poly3.to_string v)) v in assert (test `Nil); assert (test (`Cons (0, `Cons (1, `Cons (2, `Nil))))); end let poly3b = begin let test = let module T = Test(Pickle_poly3b) in T.test in assert (test (10, `Nil, `F)); assert (test (10, `Cons (10, `Cons (-20, `Nil)), `F)); end let _ = begin let test = let module T = Test(Pickle_poly7(Pickle.Pickle_bool)) in T.test and test' = let module T = Test(Pickle_poly8(Pickle.Pickle_int)) in T.test in assert (test (Foo (`F true))); assert (test (Foo (`F false))); assert (test' {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); assert (test' {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); end let _ = begin let test = let module T = Test(Pickle_poly10) in T.test in assert (test `F); assert (test `Nil); assert (test (`Cons (12, `Cons (14, `Nil)))); end let mutrec = begin let module A = Test(Pickle_mutrec_a) in let module B = Test(Pickle_mutrec_b) in let module C = Test(Pickle_mutrec_c) in let module D = Test(Pickle_mutrec_d) in let a = N in let b = { l1 = S (3, a); l2 = a } in let c = S (3, S (4, S (5, N))) in let d = `T b in assert (A.test a); assert (B.test b); assert (C.test c); assert (D.test d); end let pmutrec = begin (* type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] *) end let ff1 = begin let test = let module T = Test(Pickle_ff1(Pickle.Pickle_bool)) in T.test in assert (test (F (true,false))); assert (test (G 435)); end let ff2 = begin let test = let module T = Test(Pickle_ff2(Pickle.Pickle_bool)(Pickle.Pickle_int)) in T.test in assert (test (F1 (F2 (Nil, 10, None)))); assert (test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); end let unit = begin let test = let module T = Test(Pickle_unit) in T.test in assert (test ()); end let tup2 = begin let test = let module T = Test(Pickle_tup2) in T.test in assert (test (-10,12e4)); assert (test (max_int,12e4)); end let tup3 = begin let test = let module T = Test(Pickle_tup3) in T.test in assert (test (0,12.3,true)); assert (test (min_int,-12.3,false)); end let tup4 = begin let test = let module T = Test(Pickle_tup4) in T.test in assert (test (0,0,true,())); assert (test (min_int,max_int,false,())); end let withref = begin let v = WR (10, ref 20) in assert (not (Eq_withref.eq (Pickle_withref.from_string (Pickle_withref.to_string v)) v)); assert (Pickle_withref.from_string (Pickle_withref.to_string v) = v); end let t = begin let test v = Eq_int.eq (Pickle_int.from_string (Pickle_t.to_string v)) v in assert (test min_int); assert (test max_int); assert (test 10); end type refobj = A | B of refobj ref deriving (Eq, Typeable, Pickle) let circular = let s = ref A in let r = B s in s := r; r let _ = let v = Pickle_refobj.from_string (Pickle_refobj.to_string circular) in let (B {contents = B {contents = B {contents = B {contents = B {contents = B {contents = B {contents = _ }}}}}}}) = v in () type mut = { mutable x : mut option; mutable y : mut option; z : int; } deriving (Eq, Typeable, Pickle) let circularm = let i = {z = 1; x = None; y = None} in let j = {z = 2; x = None; y = Some i} in i.x <- Some j; i.y <- Some i; j.x <- Some j; i let _ = let v = Pickle_mut.from_string (Pickle_mut.to_string circularm) in let {z = 1; x = Some {z = 2; x = Some {z = 2; x = Some _; y = Some _}; y = Some _}; y = Some {z = 1; x = Some {z = 2; x = Some {z = 2; x = Some {z = 2; x = Some _; y = Some _}; y = Some _}; y = Some _}; y = Some _}} = v in () type t1 = { mutable x : t2 option } and t2 = { y : t1 option } deriving (Eq, Typeable, Pickle) let circular_a = let a = { x = None } in let b = { y = Some a } in a.x <- Some b; a let _ = let {x = Some {y = Some {x = Some {y = Some {x = Some {y = Some {x = Some {y = Some _}}}}}}}} = Pickle_t1.from_string (Pickle_t1.to_string circular_a) in () deriving-0.1.1/tests/exp.ml0000644000175000017500000000557410636601557015204 0ustar jeremyjeremy(*pp deriving *) module Env = Bimap.Make(String) type name = string deriving (Show, Dump, Typeable) module Eq_string : Eq.Eq with type a = name = struct type a = name let eq = (=) end module Pickle_name = Pickle.Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string) module rec Exp : sig type exp = Var of name | App of exp * exp | Abs of name * exp deriving (Eq,Show,Pickle,Typeable,Dump) end = struct module Eq_exp = struct open Exp type a = exp let eq : exp -> exp -> bool = let rec alpha_eq env l r = match l, r with | Var l, Var r when Env.mem l env -> Env.find l env = r | Var l, Var r -> not (Env.rmem r env) && l = r | App (fl,pl), App (fr,pr) -> alpha_eq env fl fr && alpha_eq env pl pr | Abs (vl,bl), Abs (vr,br) -> alpha_eq (Env.add vl vr env) bl br | _ -> false in alpha_eq Env.empty end type exp = Var of name | App of exp * exp | Abs of name * exp deriving (Show, Typeable, Pickle,Dump) end open Exp (* let args = ref [] *) let discover_sharing : exp -> 'a = let find (next,dynmap) obj = let repr = Obj.repr obj in try List.assq repr dynmap, next, dynmap with Not_found -> next,next+1,(repr,next)::dynmap in let rec discover (next,dynmap) = function | Var s as v -> let (id,next,dynmap) = find (next,dynmap) v in Printf.printf "Var %d\n" id; let (id,next,dynmap) = find (next,dynmap) s in Printf.printf "string: %s %d\n" s id; (next, dynmap) | App (e1,e2) as a -> let (id,next,dynmap) = find (next,dynmap) a in Printf.printf "App %d\n" id; let (next,dynmap) = discover (next,dynmap) e1 in let (next,dynmap) = discover (next,dynmap) e2 in (next,dynmap) | Abs (s,e) as l -> let (id,next,dynmap) = find (next,dynmap) l in Printf.printf "Abs %d\n" id; let (id,next,dynmap) = find (next,dynmap) s in Printf.printf "string: %s %d\n" s id; let (next,dynmap) = discover (next,dynmap) e in (next,dynmap) in fun e -> (discover (1,[]) e) let y = Abs ("a", App (Abs ("b", App (Var "a", Abs ("c", App (App (Var "b", Var "b"), Var "c")))), Abs ("d", App (Var "a", Abs ("e", App (App (Var "d", Var "d"), Var "e")))))) let app e1 e2 = App (e1, e2) let abs (v,e) = Abs (v,e) let freevar x = Var x let rec term_size = function | Var _ -> 1 | App (e1,e2) -> term_size e1 + term_size e2 | Abs (_, body) -> 1 + term_size body deriving-0.1.1/tests/inline.ml0000644000175000017500000000121010636601557015645 0ustar jeremyjeremy(*pp deriving *) let _ = Eq.eq true false let _ = Show.show<(bool * string) list option> (Some ([true, "yes"; false, "no"])) let _ = [Typeable.mk 3; Typeable.mk 3.0; Typeable.mk [1;2;3]] type 'a seq = [`Nil | `Cons of 'a * 'a seq] deriving (Typeable) type nil = [`Nil] deriving (Typeable) type intlist = ([nil| `Cons of int * 'a ] as 'a) deriving (Typeable) let _ = Typeable.throwing_cast (Typeable.mk (`Cons (1, `Cons (2, `Cons (3, `Nil))))) let _ = Eq.eq true (Eq.eq 3 4) let _ = print_endline "Tests succeeded!" deriving-0.1.1/tests/defs.ml0000644000175000017500000001100110636601557015307 0ustar jeremyjeremy(*pp deriving *) (* sums (nullary, unary, and n-ary) *) type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum = N0 | N1 | N2 | N3 deriving (Enum, Bounded, Eq, Typeable, Pickle) (* records with mutable and immutable fields (and various combinations) *) type r1 = { r1_l1 : int; r1_l2 : int; } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r3 = { r3_l1 : int; mutable r3_l2 : int; } deriving (Eq, Show, Typeable, Pickle) (* polymorphic records *) type r4 = { r4_l1 : 'a . 'a list } (* deriving (Dump, Eq, Show, Typeable, Pickle) *) (* label types *) type label = x:int -> int (* deriving (Dump, Eq, Show) *) (* function types *) type funct = int -> int (* deriving (Dump, Eq, Show) *) (* recursive types *) type intseq = INil | ICons of int * intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq = Nil | Cons of 'a * 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* applied type constructors (nullary, n-ary) *) type uses_seqs = (intseq * float seq) deriving (Dump, Eq, Show, Typeable, Pickle) (* object and class types *) type obj = < x : int > (* class types *) class c = object end (* polymorphic variants (nullary, unary tags, extending complex type expressions, defined inline) *) type poly0 = [`T0 | `T1 | `T2 | `T3] deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 = [`T0 | `T1 of int] deriving (Dump, Eq, Show) type poly2 = P of int * [`T0 | `T1 of int] * float deriving (Dump, Eq, Show) (* `as'-recursion *) type poly3 = [`Nil | `Cons of int * 'c] as 'c deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] deriving (Dump, Eq, Show, Typeable, Pickle) (* <, >, =, > < polymorphic variants *) type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* type poly9 = [`F | [`G]] deriving (Dump, Eq, Show, Typeable, Pickle) currently broken. *) type poly10 = [`F | poly3] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* mutually recursive types (monomorphic, polymorphic) *) type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* polymorphic types *) type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option deriving (Dump, Eq, Show, Functor, Typeable, Pickle) (* tuples *) type tup0 = unit deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 = int * float deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 = int * float * bool deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 = int * int * bool * unit deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) (* type equations (replication) *) (* TODO *) (* references *) type withref = WR of int * (int ref) deriving (Eq, Show, Typeable, Pickle) (* through module boundaries *) module rec M : sig type t deriving (Show, Eq, Dump) end = struct type t = [`N|`C of M.t] deriving (Show, Eq, Dump) end (* parameterized types through module boundaries *) module rec P : sig type 'a t (* deriving (Show) *) end = struct type 'a t = [`N|`C of 'a P.t] (*Doesn't work: results in an unsafe module definition *)(* deriving (Show)*) end (* with constraints *) type 'a constrained = [`F of 'a] constraint 'a = int deriving (Functor) (* Show, etc. don't work here *) (* private datatypes *) type p1 = private P1 deriving (Show, Eq) (* check that `private' in the interface is allowed for classes that disallow `private' (e.g. Dump) as long as we don't have `private' in the implementation *) module Private : sig type p2 = private Q deriving (Show, Eq, Dump) end = struct type p2 = Q deriving (Show, Eq, Dump) end (* Reusing existing instances *) type t = int deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) deriving-0.1.1/tests/bounded_tests.ml0000644000175000017500000000100510636601557017233 0ustar jeremyjeremyopen Defs let nullsum = begin assert (Bounded_nullsum.min_bound = N0); assert (Bounded_nullsum.max_bound = N3); end let poly0 = begin assert (Bounded_poly0.min_bound = `T0); assert (Bounded_poly0.max_bound = `T3); end let tup4 = begin assert (Bounded_tup4.min_bound = (min_int, min_int, false, ())); assert (Bounded_tup4.max_bound = (max_int, max_int, true, ())); end let t = begin assert (Bounded_t.min_bound = min_int); assert (Bounded_t.max_bound = max_int); end deriving-0.1.1/tests/functor_tests.ml0000644000175000017500000000565710636601557017314 0ustar jeremyjeremyopen Defs let r1 = begin let map : r1 -> r1 = Functor_r1.map in let x = {r1_l1 = 2; r1_l2 = 12} in assert (map x = x); end let intseq = begin let map : intseq -> intseq = Functor_intseq.map in let i = ICons (0, ICons (1, ICons (2, INil))) in assert (map i = i); end let seq = begin let map = let module M : sig val map : ('a -> 'b) -> 'a seq -> 'b seq end = struct let map = Functor_seq.map end in M.map in assert (map ((+)1) (Cons (1, Cons (2, Cons (3, Cons (4, Nil))))) = Cons (2, Cons (3, Cons (4, Cons (5, Nil))))); end let poly7 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a poly7 -> 'b poly7 end = struct let map = Functor_poly7.map end in M.map in assert (map ((+)1) (Foo (`F 0)) = Foo (`F 1)); end let poly8 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a poly8 -> 'b poly8 end = struct let map = Functor_poly8.map end in M.map in assert (map ((+)1) { x = `G (`H (`I (Foo (`F 0))))} = { x = `G (`H (`I (Foo (`F 1))))}); end let poly10 = begin let map : poly10 -> poly10 = Functor_poly10.map in assert (map `F = `F); assert (map (`Cons (1,`Cons (2, `Nil))) = (`Cons (1,`Cons (2, `Nil)))); end let pmutrec = begin let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_a -> ('b,'d) pmutrec_a end = struct let map = Functor_pmutrec_a.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_b -> ('b,'d) pmutrec_b end = struct let map = Functor_pmutrec_b.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_c -> ('b,'d) pmutrec_c end = struct let map = Functor_pmutrec_c.map end in M.map in let _ = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) pmutrec_d -> ('b,'d) pmutrec_d end = struct let map = Functor_pmutrec_d.map end in M.map in () end let ff1 = begin let map = let module M : sig val map : ('a -> 'b) -> 'a ff1 -> 'b ff1 end = struct let map = Functor_ff1.map end in M.map in assert (map ((+)1) (F (1,2)) = F (2,3)); assert (map ((+)1) (G 3) = G 3); end let ff2 = begin let map f = let module M : sig val map : ('a -> 'b) -> ('c -> 'd) -> ('a,'c) ff2 -> ('b,'d) ff2 end = struct let map = Functor_ff2.map end in M.map f in assert (map ((+)1) not (F1 (F2 (Cons (1,Cons (2, Nil)), 3, Some true))) = (F1 (F2 (Cons (2,Cons (3, Nil)), 3, Some false)))); assert (map not ((+)1) (F1 (F2 (Cons (true,Nil), 3, Some 0))) = (F1 (F2 (Cons (false,Nil), 3, Some 1)))); end (* type 'a constrained = [`F of 'a] constraint 'a = int *) let t = begin let map : int -> int = Functor_t.map in assert (map 12 = 12); end deriving-0.1.1/tests/show_tests.ml0000644000175000017500000000000010636601557016565 0ustar jeremyjeremyderiving-0.1.1/tests/sigs.ml0000644000175000017500000001633610636601557015353 0ustar jeremyjeremy(*pp deriving *) (* Deriving a signature with types exposed *) module T : sig type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum = N0 | N1 | N2 | N3 deriving (Enum, Bounded, Eq, Typeable, Pickle) type r1 = { r1_l1 : int; r1_l2 : int; } deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r3 = { r3_l1 : int; mutable r3_l2 : int; } deriving (Eq, Show, Typeable, Pickle) type r4 = { r4_l1 : 'a . 'a list } type label = x:int -> int type funct = int -> int type intseq = INil | ICons of int * intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq = Nil | Cons of 'a * 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type uses_seqs = (intseq * float seq) deriving (Dump, Eq, Show, Typeable, Pickle) type obj = < x : int > type poly0 = [`T0 | `T1 | `T2 | `T3] deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 = [`T0 | `T1 of int] deriving (Dump, Eq, Show) type poly2 = P of int * [`T0 | `T1 of int] * float deriving (Dump, Eq, Show) type poly3 = [`Nil | `Cons of int * 'c] as 'c deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] deriving (Dump, Eq, Show, Typeable, Pickle) type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type poly10 = [`F | poly3] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type 'a ff1 = F of 'a * 'a | G of int deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type tup0 = unit deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 = int * float deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 = int * float * bool deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 = int * int * bool * unit deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) type withref = WR of int * (int ref) deriving (Eq, Show, Typeable, Pickle) module M : sig type t deriving (Show, Eq, Dump) end module P : sig type 'a t (* deriving (Show) *) end type 'a constrained = [`F of 'a] constraint 'a = int deriving (Functor) type p1 = private P1 deriving (Show, Eq) module Private : sig type p2 = private Q deriving (Show, Eq, Dump) end type t = int deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) end = Defs (* Deriving a signature with types made abstract *) module T_opaque : sig type sum deriving (Dump, Eq, Show, Typeable, Pickle) type nullsum deriving (Enum, Bounded, Eq, Typeable, Pickle) type r1 deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type r2 deriving (Eq, Show, Typeable, Pickle) type r3 deriving (Eq, Show, Typeable, Pickle) type r4 type label type funct type intseq deriving (Dump, Eq, Show, Typeable, Pickle, Functor) type 'a seq deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type uses_seqs deriving (Dump, Eq, Show, Typeable, Pickle) type obj type poly0 deriving (Enum, Bounded, Show, Eq, Typeable, Pickle) type poly1 deriving (Dump, Eq, Show) type poly2 deriving (Dump, Eq, Show) type poly3 deriving (Dump, Eq, Show, Typeable, Pickle) type poly3b deriving (Dump, Eq, Show, Typeable, Pickle) type 'a poly7 and 'a poly8 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type poly10 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type mutrec_a and mutrec_b and mutrec_c and mutrec_d deriving (Dump, Eq, Show, Typeable, Pickle) type ('a,'b) pmutrec_a and ('a,'b) pmutrec_b and ('a,'b) pmutrec_c and ('a,'b) pmutrec_d deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type 'a ff1 deriving (Show, Eq, Dump, Functor, Typeable, Pickle) type ('a,'b) ff2 deriving (Dump, Eq, Show, Functor, Typeable, Pickle) type tup0 deriving (Dump, Eq, Show, Typeable, Pickle) type tup2 deriving (Dump, Eq, Show, Typeable, Pickle) type tup3 deriving (Dump, Eq, Show, Typeable, Pickle) type tup4 deriving (Dump, Eq, Show, Typeable, Pickle, Bounded) type withref deriving (Eq, Show, Typeable, Pickle) module M : sig type t deriving (Show, Eq, Dump) end module P : sig type 'a t end type 'a constrained constraint 'a = int deriving (Functor) type p1 deriving (Show, Eq) module Private : sig type p2 end type t deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor) end = Defs (* A signature with no deriving (to make sure that the types are still compatible) *) module T_no_deriving : sig type sum = S0 | S1 of int | S2 of int * float | S3 of int * float * bool | Sunit of unit | Stup of (int * float) | Stup1 of (int) type nullsum = N0 | N1 | N2 | N3 type r1 = { r1_l1 : int; r1_l2 : int; } type r2 = { mutable r2_l1 : int; mutable r2_l2 : int; } type r3 = { r3_l1 : int; mutable r3_l2 : int; } type r4 = { r4_l1 : 'a . 'a list } type label = x:int -> int type funct = int -> int type intseq = INil | ICons of int * intseq type 'a seq = Nil | Cons of 'a * 'a seq type uses_seqs = (intseq * float seq) type obj = < x : int > type poly0 = [`T0 | `T1 | `T2 | `T3] type poly1 = [`T0 | `T1 of int] type poly2 = P of int * [`T0 | `T1 of int] * float type poly3 = [`Nil | `Cons of int * 'c] as 'c type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F] type 'a poly7 = Foo of [`F of 'a] and 'a poly8 = { x : [`G of [`H of [`I of 'a poly7]]] } type poly10 = [`F | poly3] type mutrec_a = mutrec_c and mutrec_b = { l1 : mutrec_c ; l2 : mutrec_a } and mutrec_c = S of int * mutrec_a | N and mutrec_d = [`T of mutrec_b] type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] type 'a ff1 = F of 'a * 'a | G of int type ('a,'b) ff2 = F1 of ('a,'b) ff2 | F2 of 'a seq * int * 'b option type tup0 = unit type tup2 = int * float type tup3 = int * float * bool type tup4 = int * int * bool * unit type withref = WR of int * (int ref) module M : sig type t end module P : sig type 'a t end type 'a constrained = [`F of 'a] constraint 'a = int type p1 = private P1 module Private : sig type p2 = private Q end type t = int end = Defs deriving-0.1.1/tests/Makefile0000644000175000017500000000131010636601557015476 0ustar jeremyjeremyOCAMLMAKEFILE = ../OCamlMakefile AUXLIB_DIRS = ../lib/ OCAMLOPT = ocamlopt.opt OCAMLC = ocamlc.opt OCAMLDEP = ocamldep PATH := $(PATH):../syntax OCAMLFLAGS = -w Aef SOURCES = defs.ml \ bimap.ml bimap.mli \ sigs.ml \ pickle_tests.ml \ typeable_tests.ml \ bounded_tests.ml \ eq_tests.ml \ dump_tests.ml \ enum_tests.ml \ functor_tests.ml \ show_tests.ml \ exp.ml \ inline.ml \ LIBS = nums deriving RESULT = tests CLIBS = INCDIRS = $(AUXLIB_DIRS) LIBDIRS = $(AUXLIB_DIRS) include $(OCAMLMAKEFILE) deriving-0.1.1/tests/enum_tests.ml0000644000175000017500000000510210636601557016561 0ustar jeremyjeremyopen Defs let nullsum = begin let module E = Enum_nullsum in assert (E.succ N0 = N1); assert (E.succ N1 = N2); assert (E.succ N2 = N3); assert (try ignore (E.succ N3); false with Invalid_argument "succ" -> true); assert (try ignore (E.pred N0); false with Invalid_argument "pred" -> true); assert (E.pred N1 = N0); assert (E.pred N2 = N1); assert (E.pred N3 = N2); assert (E.from_enum N0 = 0); assert (E.from_enum N1 = 1); assert (E.from_enum N2 = 2); assert (E.from_enum N3 = 3); assert (E.to_enum 0 = N0); assert (E.to_enum 1 = N1); assert (E.to_enum 2 = N2); assert (E.to_enum 3 = N3); assert (try ignore (E.to_enum 4); false with Invalid_argument "to_enum" -> true); assert (E.enum_from N0 = [N0;N1;N2;N3]); assert (E.enum_from N1 = [N1;N2;N3]); assert (E.enum_from N2 = [N2;N3]); assert (E.enum_from N3 = [N3]); assert (E.enum_from_then N0 N1 = [N0;N1;N2;N3]); assert (E.enum_from_then N0 N2 = [N0;N2]); assert (E.enum_from_then N1 N2 = [N1;N2;N3]); assert (E.enum_from_then N1 N3 = [N1;N3]); assert (try ignore (E.enum_from_then N3 N3); false with Invalid_argument _ -> true); assert (try ignore (E.enum_from_then N3 N1); false with Invalid_argument _ -> true); assert (E.enum_from_to N0 N1 = [N0;N1]); assert (E.enum_from_to N1 N3 = [N1;N2;N3]); assert (E.enum_from_to N1 N1 = [N1]); assert (E.enum_from_to N1 N0 = []); assert (E.enum_from_then_to N0 N1 N3 = [N0;N1;N2;N3]); assert (E.enum_from_then_to N0 N2 N3 = [N0;N2]); assert (E.enum_from_then_to N0 N3 N3 = [N0;N3]); assert (try ignore (E.enum_from_then_to N0 N0 N0); false with Invalid_argument _ -> true); end let poly0 = begin let module E = Enum_poly0 in assert (E.succ `T0 = `T1); assert (E.succ `T1 = `T2); assert (E.succ `T2 = `T3); assert (try ignore (E.succ `T3); false with Invalid_argument "succ" -> true); assert (try ignore (E.pred `T0); false with Invalid_argument "pred" -> true); assert (E.pred `T1 = `T0); assert (E.pred `T2 = `T1); assert (E.pred `T3 = `T2); end let t = begin ListLabels.iter (Enum.Enum_int.enum_from_to (-1000) 1000) ~f:(fun i -> assert (Enum_t.succ i = i+1); assert (Enum_t.pred i = i-1); assert (Enum_t.to_enum i = i); assert (Enum_t.from_enum i = i)); end deriving-0.1.1/tests/dump_tests.ml0000644000175000017500000000752510636601557016575 0ustar jeremyjeremy(*pp deriving *) open Defs module Test (D : Dump.Dump) = struct let test v = D.from_string (D.to_string v) = v end let sum = begin let module T = Test (Dump_sum) in assert (T.test S0); assert (T.test (S1 max_int)); assert (T.test (S2 (min_int, 1243.2))); assert (T.test (S2 (min_int, 1243.2))); assert (T.test (S3 (12, 0.0, true))); assert (T.test (Sunit ())); assert (T.test (Stup (1001, 10.01))); end let r1 = begin let module T = Test (Dump_r1) in assert (T.test {r1_l1 = max_int - 10; r1_l2 = min_int + 10}); end let intseq = begin let module T = Test (Dump_intseq) in assert (T.test INil); assert (T.test (ICons (10, ICons (20, ICons (30, INil))))); end let seq = begin let module T = Test (Dump_seq (Dump.Dump_bool)) in assert (T.test Nil); assert (T.test (Cons (true, Cons (false, Cons (true, Nil))))); end let uses_seqs = begin let module T = Test (Dump_uses_seqs) in assert (T.test (INil, Nil)); assert (T.test (INil, Cons (0.0, Cons(10.0, Nil)))); assert (T.test (ICons (10, ICons(20, INil)), Nil)); assert (T.test (ICons (10, ICons(20, INil)), Cons (0.0, Cons(10.0, Nil)))); end let poly1 = begin let module T = Test (Dump_poly1) in assert (T.test `T0); assert (T.test (`T1 (-1231))); end let poly2 = begin let module T = Test (Dump_poly2) in assert (T.test (P (10, `T1 11, 12.0))); end let poly3 = begin let module T = Test (Dump_poly3) in assert (T.test `Nil); assert (T.test (`Cons (1, `Cons (2, `Cons (3, `Nil))))); end let poly3b = begin let module T = Test (Dump_poly3b) in assert (T.test (10, `Nil, `F)); assert (T.test (0, `Cons (10, `Cons (11, `Cons (12, `Nil))), `F)); end let poly7 = begin let module T = Test(Dump_poly7(Dump.Dump_bool)) in let module T' = Test(Dump_poly8(Dump.Dump_int)) in assert (T.test (Foo (`F true))); assert (T.test (Foo (`F false))); assert (T'.test {x = `G (`H (`I (Foo (`F (max_int - 1)))))}); assert (T'.test {x = `G (`H (`I (Foo (`F (min_int + 1)))))}); end let poly10 = begin let module T = Test (Dump_poly10) in assert (T.test `F); assert (T.test `Nil); assert (T.test (`Cons (12, `Cons (14, `Nil)))); end let mutrec = begin let module A = Test (Dump_mutrec_a) in let module B = Test (Dump_mutrec_b) in let module C = Test (Dump_mutrec_c) in let module D = Test (Dump_mutrec_d) in let a = N in let b = { l1 = S (3, a); l2 = a } in let c = S (3, S (4, S (5, N))) in let d = `T b in assert (A.test a); assert (B.test b); assert (C.test c); assert (D.test d); end let pmutrec = begin (* type ('a,'b) pmutrec_a = ('a,'b) pmutrec_c and ('a,'b) pmutrec_b = { pl1 : ('a,'b) pmutrec_c ; pl2 : ('a,'b) pmutrec_a } and ('a,'b) pmutrec_c = SS of 'a * ('a,'b) pmutrec_a * 'b and ('a,'b) pmutrec_d = [`T of ('a,'b) pmutrec_b] *) end let ff1 = begin let module T = Test(Dump_ff1(Dump.Dump_bool)) in assert (T.test (F (true,false))); assert (T.test (G 435)); end let ff2 = begin let module T = Test(Dump_ff2(Dump.Dump_bool)(Dump.Dump_int)) in assert (T.test (F1 (F2 (Nil, 10, None)))); assert (T.test (F1 (F2 (Cons (true, Cons (false, Nil)), 10, Some 14)))); end let tup0 = begin let module T = Test (Dump_tup0) in assert (T.test ()); end let tup2 = begin let module T = Test (Dump_tup2) in assert (T.test (10, 10.0)); assert (T.test (max_int, -10.0)); end let tup3 = begin let module T = Test (Dump_tup3) in assert (T.test (0,12.3,true)); assert (T.test (min_int,-12.3,false)); end let tup4 = begin let module T = Test (Dump_tup4) in assert (T.test (0,0,true,())); assert (T.test (min_int,max_int,false,())); end let t = begin let module T = Test (Dump_t) in assert (T.test min_int); assert (T.test max_int); assert (T.test 10); end deriving-0.1.1/tests/eq_tests.ml0000644000175000017500000001443110636601560016221 0ustar jeremyjeremyopen Defs let sum = begin assert (Eq_sum.eq S0 S0); assert (not (Eq_sum.eq S0 (S1 0))); assert (Eq_sum.eq (S1 0) (S1 0)); assert (Eq_sum.eq (Stup (3,0.0)) (Stup (3,0.0))); assert (not (Eq_sum.eq (Stup (0,0.0)) (Stup (1,0.0)))); end let nullsum = begin assert (Eq_nullsum.eq N2 N2) end let r1 = begin assert (Eq_r1.eq { r1_l1 = 10; r1_l2 = 20 } { r1_l1 = 10; r1_l2 = 20 }); assert (not (Eq_r1.eq { r1_l1 = 20; r1_l2 = 10 } { r1_l1 = 10; r1_l2 = 20 })); end let r2 = begin let l, r = ({ r2_l1 = 10; r2_l2 = 20}, { r2_l1 = 10; r2_l2 = 20}) in assert (Eq_r2.eq l l); assert (not (Eq_r2.eq l r)); assert (not (Eq_r2.eq r l)); end let r3 = begin let l, r = ({ r3_l1 = 10; r3_l2 = 20}, { r3_l1 = 10; r3_l2 = 20}) in assert (Eq_r3.eq l l); assert (not (Eq_r3.eq l r)); assert (not (Eq_r3.eq r l)); end let intseq = begin assert (Eq_intseq.eq INil INil); assert (Eq_intseq.eq (ICons (1,INil)) (ICons (1,INil))); assert (not (Eq_intseq.eq (ICons (1,INil)) INil)); assert (not (Eq_intseq.eq INil (ICons (1,INil)))); assert (not (Eq_intseq.eq INil (let rec i = ICons(1,i) in i))); end let uses_seqs = begin let eq = Eq_uses_seqs.eq in assert (eq (INil,Cons(1.0,Nil)) (INil,Cons(1.0,Nil))); assert (not (eq (INil,Cons(1.0,Nil)) (INil,Cons(2.0,Nil)))); assert (not (eq (ICons (1,INil),Nil) (INil,Nil))); end let poly0 = begin let eq = Eq_poly0.eq in assert (eq `T0 `T0); assert (not (eq `T1 `T3)); end let poly1 = begin let eq = Eq_poly1.eq in assert (eq `T0 `T0); assert (eq (`T1 10) (`T1 10)); assert (not (eq (`T1 20) (`T1 10))); assert (not (eq (`T1 20) `T0)); end let poly2 = begin let eq = Eq_poly2.eq in assert (eq (P (3, `T0, 0.0)) (P (3, `T0, 0.0))); assert (eq (P (4, `T1 10, 2.0)) (P (4, `T1 10, 2.0))); assert (not (eq (P (5, `T1 10, 2.0)) (P (5, `T0, 2.0)))); assert (not (eq (P (6, `T0, 2.0)) (P (6, `T0, 10.0)))); assert (not (eq (P (0, `T0, 2.0)) (P (7, `T0, 2.0)))); end let poly3 = begin let eq = Eq_poly3.eq in assert (eq `Nil `Nil); assert (eq (`Cons (3,`Nil)) (`Cons (3,`Nil))); assert (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Cons (4,`Nil)))); assert (not (eq (`Cons (3,`Cons (4,`Nil))) (`Cons (3,`Nil)))); end let poly3b = begin let eq = Eq_poly3b.eq in assert (eq (0,`Nil,`F) (0,`Nil,`F)); assert (not (eq (0,`Cons (1,`Nil),`F) (0,`Nil,`F))); assert (not (eq (1,`Nil,`F) (0,`Nil,`F))); end let poly7_8 = begin let module M7 = Eq_poly7(Eq.Eq_int) in let module M8 = Eq_poly8(Eq.Eq_int) in assert (M7.eq (Foo (`F 0)) (Foo (`F 0))); assert (not (M7.eq (Foo (`F 0)) (Foo (`F 1)))); assert (M8.eq {x = `G (`H (`I (Foo (`F 0))))} {x = `G (`H (`I (Foo (`F 0))))}); assert (not (M8.eq {x = `G (`H (`I (Foo (`F 0))))} {x = `G (`H (`I (Foo (`F 1))))})); end let poly10 = begin let eq = Eq_poly10.eq in assert (eq `F `F); assert (eq `Nil `Nil); assert (not (eq `Nil `F)); end let mutrec = begin let rec cyclic_1 = S (0, cyclic_2) and cyclic_2 = S (1, cyclic_1) in assert (not (Eq_mutrec_a.eq cyclic_1 cyclic_2)); assert (not (Eq_mutrec_d.eq (`T {l1 = cyclic_1; l2 = cyclic_2}) (`T {l1 = cyclic_2; l2 = cyclic_1}))); end let pmutrec = begin let module M_a = Eq_pmutrec_a(Eq.Eq_int)(Eq.Eq_bool) in let module M_b = Eq_pmutrec_b(Eq.Eq_int)(Eq.Eq_bool) in let module M_c = Eq_pmutrec_c(Eq.Eq_int)(Eq.Eq_bool) in let module M_d = Eq_pmutrec_d(Eq.Eq_int)(Eq.Eq_bool) in let rec cyclic_1 = SS (0, cyclic_2, true) and cyclic_2 = SS (1, cyclic_1, true) in assert (not (M_a.eq cyclic_1 cyclic_2)); assert (not (M_d.eq (`T {pl1 = cyclic_1; pl2 = cyclic_2}) (`T {pl1 = cyclic_2; pl2 = cyclic_1}))); end let ff1 = begin let module M = Eq_ff1(Eq.Eq_bool) in assert (M.eq (F (true,false)) (F (true,false))); assert (M.eq (G (-1)) (G (-1))); assert (not (M.eq (F (false,true)) (F (true,false)))); assert (not (M.eq (G (-1)) (G 0))); assert (not (M.eq (G (-1)) (F (true, true)))); end let ff2 = begin let module M = Eq_ff2(Eq.Eq_bool)(Eq.Eq_bool) in assert (M.eq (F1 (F2 (Cons (true,Nil), 0, None))) (F1 (F2 (Cons (true,Nil), 0, None)))); assert (not (M.eq (F2 (Nil, 0, None)) (F2 (Cons (true,Nil), 0, None)))); assert (not (M.eq (F2 (Cons (true,Nil), 0, Some true)) (F2 (Cons (true,Nil), 0, Some false)))); assert (not (M.eq (F2 (Cons (true,Nil), 0, None)) (F2 (Cons (true,Nil), 0, Some false)))); end let tup0 = begin assert (Eq_tup0.eq () ()); end let tup2 = begin assert (Eq_tup2.eq (10,5.0) (10,5.0)); assert (not (Eq_tup2.eq (10,5.0) (11,5.0))); assert (not (Eq_tup2.eq (10,5.0) (10,4.0))); end let tup3 = begin assert (Eq_tup3.eq (10,2.5,true) (10,2.5,true)); assert (not (Eq_tup3.eq (10,2.5,true) (11,2.5,true))); assert (not (Eq_tup3.eq (10,2.5,true) (10,2.4,true))); assert (not (Eq_tup3.eq (10,2.5,true) (10,2.5,false))); end let tup4 = begin assert (Eq_tup4.eq (1,2,true,()) (1,2,true,())); assert (not (Eq_tup4.eq (1,2,true,()) (0,2,true,()))); assert (not (Eq_tup4.eq (1,2,true,()) (1,3,true,()))); assert (not (Eq_tup4.eq (1,2,true,()) (1,2,false,()))); end let withref = begin let x = ref 0 in assert (Eq_withref.eq (WR (0,x)) (WR (0,x))); assert (not (Eq_withref.eq (WR (0,x)) (WR (0,ref 0)))); end let t = begin assert (Eq_t.eq 0 0); assert (Eq_t.eq (-10) (-10)); assert (Eq_t.eq 14 14); assert (not (Eq_t.eq 14 0)); assert (not (Eq_t.eq 0 14)); assert (not (Eq_t.eq (-1) 0)); end deriving-0.1.1/tests/typeable_tests.ml0000644000175000017500000000420310636601560017415 0ustar jeremyjeremy(*pp deriving *) type t1 = F deriving (Typeable) type t2 = F deriving (Typeable) let eq_types = Typeable.TypeRep.eq let _ = begin assert (eq_types (Typeable_t1.type_rep ()) (Typeable_t1.type_rep ())); assert (eq_types (Typeable_t2.type_rep ()) (Typeable_t2.type_rep ())); assert (not (eq_types (Typeable_t1.type_rep ()) (Typeable_t2.type_rep ()))); assert (not (eq_types (Typeable_t2.type_rep ()) (Typeable_t1.type_rep ()))); end type t3 = int deriving (Typeable) let _ = begin assert (eq_types (Typeable.Typeable_int.type_rep ()) (Typeable_t3.type_rep ())); end type t4 = [`T of int] deriving (Typeable) type t5 = [`T of t3] deriving (Typeable) let _ = begin assert (eq_types (Typeable_t4.type_rep ()) (Typeable_t5.type_rep ())); end type t6 = [`T of t5] deriving (Typeable) let _ = begin assert (not (eq_types (Typeable_t5.type_rep ()) (Typeable_t6.type_rep ()))); end type t7 = [`T of t6] deriving (Typeable) let _ = begin assert (not (eq_types (Typeable_t6.type_rep ()) (Typeable_t7.type_rep ()))); end type t8 = [`A | `B] deriving (Typeable) type t9 = [`B | `A] deriving (Typeable) let _ = begin assert (eq_types (Typeable_t8.type_rep ()) (Typeable_t9.type_rep ())); end type ('a,'r) openr = [`Nil | `Cons of 'a * 'r] deriving (Typeable) type 'a closedr = [`Nil | `Cons of 'a * 'a closedr] deriving (Typeable) type l1 = (int, l1) openr and l2 = int closedr deriving (Typeable) let _ = begin assert (eq_types (Typeable_l1.type_rep ()) (Typeable_l1.type_rep ())); end type nil = [`Nil] deriving (Typeable) type t10 = ([nil| `Cons of int * 'a ] as 'a) list deriving (Typeable) type t11 = l2 list deriving (Typeable) let _ = begin assert (eq_types (Typeable_t10.type_rep ()) (Typeable_t11.type_rep ())); end deriving-0.1.1/lib/0000755000175000017500000000000010761620733013443 5ustar jeremyjeremyderiving-0.1.1/lib/interned.ml0000644000175000017500000000122410761620575015610 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Interned strings *) module StringMap = Map.Make(String) (* global state *) let map = ref StringMap.empty let counter = ref 0 type t = int * string deriving (Show) let intern s = try StringMap.find s !map with Not_found -> let fresh = (!counter, String.copy s) in begin map := StringMap.add s fresh !map; incr counter; fresh end let to_string (_,s) = String.copy s let name = snd let compare (l,_) (r,_) = compare l r let eq (l,_) (r,_) = l = r deriving-0.1.1/lib/enum.mli0000644000175000017500000000134010636601560015106 0ustar jeremyjeremymodule type Enum = sig type a val succ : a -> a val pred : a -> a val to_enum : int -> a val from_enum : a -> int val enum_from : a -> a list val enum_from_then : a -> a -> a list val enum_from_to : a -> a -> a list val enum_from_then_to : a -> a -> a -> a list end module Defaults (E : sig type a val numbering : (a * int) list end) : Enum with type a = E.a module Defaults' (E : sig type a val from_enum : a -> int val to_enum : int -> a end) (B : Bounded.Bounded with type a = E.a) : Enum with type a = B.a module Enum_bool : Enum with type a = bool module Enum_char : Enum with type a = char module Enum_int : Enum with type a = int module Enum_unit : Enum with type a = unit deriving-0.1.1/lib/eq.mli0000644000175000017500000000176410636601560014561 0ustar jeremyjeremy(* A module for SML-style equality, i.e. where equality of mutables is physical equality and equality of immutables is structural equality. *) module type Eq = sig type a val eq : a -> a -> bool end module Defaults (E : Eq) : Eq with type a = E.a module Eq_immutable (S : sig type a end) : Eq with type a = S.a module Eq_mutable (S : sig type a end) : Eq with type a = S.a module Eq_int : Eq with type a = int module Eq_num : Eq with type a = Num.num module Eq_bool : Eq with type a = bool module Eq_float : Eq with type a = float module Eq_unit : Eq with type a = unit module Eq_char : Eq with type a = char module Eq_string : Eq with type a = string module Eq_ref (E : Eq) : Eq with type a = E.a ref module Eq_array (E : Eq) : Eq with type a = E.a array module Eq_list (E : Eq) : Eq with type a = E.a list module Eq_option (E : Eq): Eq with type a = E.a option module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t deriving-0.1.1/lib/dump.mli0000644000175000017500000000234410636601560015114 0ustar jeremyjeremymodule type Dump = sig type a val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (P : sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end) : Dump with type a = P.a exception Dump_error of string module Dump_int32 : Dump with type a = Int32.t module Dump_int64 : Dump with type a = Int64.t module Dump_nativeint : Dump with type a = Nativeint.t module Dump_int : Dump with type a = int module Dump_char : Dump with type a = char module Dump_string : Dump with type a = string module Dump_float : Dump with type a = float module Dump_num : Dump with type a = Num.num module Dump_bool : Dump with type a = bool module Dump_unit : Dump with type a = unit module Dump_list (P : Dump) : Dump with type a = P.a list module Dump_option (P : Dump) : Dump with type a = P.a option module Dump_undumpable (P : sig type a val tname : string end) : Dump with type a = P.a module Dump_via_marshal (P : sig type a end) : Dump with type a = P.a deriving-0.1.1/lib/typeable.mli0000644000175000017500000000264710636601560015762 0ustar jeremyjeremymodule TypeRep : sig type t type delayed = unit -> t val compare : t -> t -> int val eq : t -> t -> bool val mkFresh : string -> delayed list -> delayed val mkTuple : delayed list -> delayed val mkPolyv : (string * delayed option) list -> delayed list -> delayed end exception CastFailure of string type dynamic val tagOf : dynamic -> TypeRep.t module type Typeable = sig type a val type_rep : unit -> TypeRep.t val has_type : dynamic -> bool val cast : dynamic -> a option val throwing_cast : dynamic -> a val make_dynamic : a -> dynamic val mk : a -> dynamic end module Defaults (T : (sig type a val type_rep : unit -> TypeRep.t end)) : Typeable with type a = T.a module Typeable_list (A : Typeable) : Typeable with type a = A.a list module Typeable_option (A : Typeable) : Typeable with type a = A.a option module Typeable_ref (A : Typeable) : Typeable with type a = A.a ref (*module Primitive_typeable (T : sig type t end): Typeable with type a = T.t *) module Typeable_unit : Typeable with type a = unit module Typeable_int : Typeable with type a = int module Typeable_num : Typeable with type a = Num.num module Typeable_float : Typeable with type a = float module Typeable_bool : Typeable with type a = bool module Typeable_string : Typeable with type a = string module Typeable_char : Typeable with type a = char deriving-0.1.1/lib/functor.ml0000644000175000017500000000231710761620567015465 0ustar jeremyjeremyopen Monad (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Functor = sig type 'a f val map : ('a -> 'b) -> 'a f -> 'b f end module MonadFunctor (M : Monad) : Functor with type 'a f = 'a M.m = struct open M type 'a f = 'a M.m let map f x = x >>= (fun x -> return (f x)) end module Functor_option = MonadFunctor(Monad.Monad_option) module Functor_list = MonadFunctor(Monad.Monad_list) module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t = struct include Map.Make(O) type 'a f = 'a t end (* NB: Instances for mutable types (including ref queue stack array stream buffer) are deliberately omitted. Since sharing is detectable for values of these types we have two distinct design choices: 1. Always create a new copy that shares no structure with the original. 2. Always mutate the original copy Neither of these seems like the right thing to do, so instead we simply don't handle mustable types at all. (Lazy.t is another example: we'd like map to be total and side-effect free, which is impossible to guarantee if we handle lazy. *) deriving-0.1.1/lib/bounded.ml0000644000175000017500000000333010761620542015412 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (** Primitive instanecs for bounded **) module Bounded = struct module type Bounded = sig type a val min_bound : a val max_bound : a end module Bounded_integer(B : sig type t val max_int : t val min_int : t end) : Bounded with type a = B.t = struct type a = B.t let min_bound = B.min_int let max_bound = B.max_int end module Bounded_int32 = Bounded_integer(Int32) module Bounded_int64 = Bounded_integer(Int64) module Bounded_nativeint = Bounded_integer(Nativeint) module Bounded_int = struct type a = int let min_bound = Pervasives.min_int let max_bound = Pervasives.max_int end module Bounded_bool = struct type a = bool let min_bound = false let max_bound = true end module Bounded_char = struct type a = char let min_bound = Char.chr 0 let max_bound = Char.chr 0xff (* Is this guaranteed? *) end module Bounded_unit = struct type a = unit let min_bound = () let max_bound = () end end include Bounded type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Bounded) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Bounded) deriving-0.1.1/lib/pickle.mli0000644000175000017500000000422310636601561015415 0ustar jeremyjeremytype id (* representation of values of user-defined types *) module Repr : sig type t val make : ?constructor:int -> id list -> t end (* Utilities for serialization *) module Write : sig type s include Monad.Monad_state_type with type state = s module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) : sig val allocate : T.a -> (id -> unit m) -> id m val store_repr : id -> Repr.t -> unit m end end (* Utilities for deserialization *) module Read : sig type s include Monad.Monad_state_type with type state = s module Utils (T : Typeable.Typeable) : sig val sum : (int * id list -> T.a m) -> (id -> T.a m) val tuple : (id list -> T.a m) -> (id -> T.a m) val record : (T.a -> id list -> T.a m) -> int -> (id -> T.a m) end end exception UnpicklingError of string exception UnknownTag of int * string module type Pickle = sig type a module T : Typeable.Typeable with type a = a module E : Eq.Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (S : sig type a module T : Typeable.Typeable with type a = a module E : Eq.Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m end) : Pickle with type a = S.a module Pickle_unit : Pickle with type a = unit module Pickle_bool : Pickle with type a = bool module Pickle_int : Pickle with type a = int module Pickle_char : Pickle with type a = char module Pickle_float : Pickle with type a = float module Pickle_num : Pickle with type a = Num.num module Pickle_string : Pickle with type a = string module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list module Pickle_ref (S : Pickle) : Pickle with type a = S.a ref module Pickle_from_dump (P : Dump.Dump) (E : Eq.Eq with type a = P.a) (T : Typeable.Typeable with type a = P.a) : Pickle with type a = P.a deriving-0.1.1/lib/show.ml0000644000175000017500000001451310761620613014756 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module Show = struct (** Show **) module type Show = sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit val show : a -> string val show_list : a list -> string end module type SimpleFormatter = sig type a val format : Format.formatter -> a -> unit end module ShowFormatterDefault (S : SimpleFormatter) = struct include S let format_list formatter items = let rec writeItems formatter = function | [] -> () | [x] -> S.format formatter x; | x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs in Format.fprintf formatter "@[[%a]@]" writeItems items end module ShowDefaults' (S : (sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit end)) : Show with type a = S.a = struct include S let showFormatted f item = let b = Buffer.create 16 in let formatter = Format.formatter_of_buffer b in Format.fprintf formatter "@[%a@]@?" f item; Buffer.sub b 0 (Buffer.length b) (* Warning: do not eta-reduce either of the following *) let show item = showFormatted S.format item let show_list items = showFormatted S.format_list items end module Defaults (S : SimpleFormatter) : Show with type a = S.a = ShowDefaults' (ShowFormatterDefault (S)) module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) = Defaults (struct type a = S.a let format formatter _ = Format.pp_print_string formatter "..." end) (* instance Show a => Show [a] *) module Show_list (S : Show) : Show with type a = S.a list = Defaults (struct type a = S.a list let format = S.format_list end) (* instance Show a => Show (a option) *) module Show_option (S : Show) : Show with type a = S.a option = Defaults (struct type a = S.a option let format formatter = function | None -> Format.fprintf formatter "@[None@]" | Some s -> Format.fprintf formatter "@[Some@;<1 2>%a@]" S.format s end) (* instance Show a => Show (a array) *) module Show_array (S : Show) : Show with type a = S.a array = Defaults (struct type a = S.a array let format formatter obj = let writeItems formatter items = let length = Array.length items in for i = 0 to length - 2 do Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i) done; if length <> 0 then S.format formatter (Array.get items (length -1)); in Format.fprintf formatter "@[[|%a|]@]" writeItems obj end) module Show_map (O : Map.OrderedType) (K : Show with type a = O.t) (V : Show) : Show with type a = V.a Map.Make(O).t = Defaults( struct module M = Map.Make(O) type a = V.a M.t let format formatter map = Format.pp_open_box formatter 0; Format.pp_print_string formatter "{"; M.iter (fun key value -> Format.pp_open_box formatter 0; K.format formatter key; Format.pp_print_string formatter " => "; V.format formatter value; Format.pp_close_box formatter (); ) map; Format.pp_print_string formatter "}"; Format.pp_close_box formatter (); end) module Show_set (O : Set.OrderedType) (K : Show with type a = O.t) : Show with type a = Set.Make(O).t = Defaults( struct module S = Set.Make(O) type a = S.t let format formatter set = Format.pp_open_box formatter 0; Format.pp_print_string formatter "{"; S.iter (fun elt -> Format.pp_open_box formatter 0; K.format formatter elt; Format.pp_close_box formatter (); ) set; Format.pp_print_string formatter "}"; Format.pp_close_box formatter (); end) module Show_bool = Defaults (struct type a = bool let format formatter item = match item with | true -> Format.pp_print_string formatter "true" | false -> Format.pp_print_string formatter "false" end) module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct type a = S.t let format formatter item = Format.pp_print_string formatter (S.to_string item) end) module Show_int32 = Show_integer(Int32) module Show_int64 = Show_integer(Int64) module Show_nativeint = Show_integer(Nativeint) module Show_char = Defaults (struct type a = char let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'") end) module Show_int = Defaults (struct type a = int let format formatter item = Format.pp_print_string formatter (string_of_int item) end) module Show_num = Defaults (struct type a = Num.num let format formatter item = Format.pp_print_string formatter (Num.string_of_num item) end) module Show_float = Defaults(struct type a = float let format formatter item = Format.pp_print_string formatter (string_of_float item) end) module Show_string = Defaults (struct type a = string let format formatter item = Format.pp_print_char formatter '"'; Format.pp_print_string formatter (String.escaped item); Format.pp_print_char formatter '"' end) module Show_unit = Defaults(struct type a = unit let format formatter () = Format.pp_print_string formatter "()" end) end include Show type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Show) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Show) type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; } deriving (Show) deriving-0.1.1/lib/interned.mli0000644000175000017500000000023710636601561015757 0ustar jeremyjeremy(* Interned strings *) type t val compare : t -> t -> int val eq : t -> t -> bool val intern : string -> t val to_string : t -> string val name : t -> string deriving-0.1.1/lib/util.mli0000644000175000017500000000010110636601561015112 0ustar jeremyjeremyval last : 'a list -> 'a val rassoc : 'a -> ('b * 'a) list -> 'b deriving-0.1.1/lib/dynmap.ml0000644000175000017500000000324710761620561015272 0ustar jeremyjeremy(* Finite maps : t -> dynamic *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Typeable module Comp (T : Typeable) (E : Eq.Eq with type a = T.a) = struct type a = T.a let adjust_comparator : (T.a -> T.a -> bool) -> dynamic -> dynamic -> bool = fun comparator d1 d2 -> match T.cast d1, T.cast d2 with | Some l, Some r -> comparator l r | _ -> assert false let eq = adjust_comparator E.eq end module DynMap = struct module TypeMap = Map.Make(TypeRep) type comparator = dynamic -> dynamic -> bool type 'value t = (((dynamic * 'value) list * comparator) TypeMap.t) let empty = TypeMap.empty let add dynamic value comparator map = let typeRep = tagOf dynamic in let monomap = try (List.filter (fun (k,_) -> not (comparator k dynamic)) (fst (TypeMap.find typeRep map))) with Not_found -> [] in TypeMap.add typeRep (((dynamic,value)::monomap), comparator) map let mem dynamic map = try let monomap, comparator = TypeMap.find (tagOf dynamic) map in (List.exists (fun (k,_) -> (comparator dynamic k)) monomap) with Not_found -> false let find dynamic map = try let monomap, comparator = TypeMap.find (tagOf dynamic) map in Some (snd (List.find (fun (k,_) -> comparator dynamic k) monomap)) with Not_found -> None let iter : (dynamic -> 'a -> unit) -> 'a t -> unit = fun f -> TypeMap.iter (fun _ (monomap,_) -> List.iter (fun (k, v) -> f k v) monomap) end deriving-0.1.1/lib/functor.mli0000644000175000017500000000054210636601561015626 0ustar jeremyjeremymodule type Functor = sig type 'a f val map : ('a -> 'b) -> 'a f -> 'b f end module MonadFunctor (M : Monad.Monad) : Functor with type 'a f = 'a M.m module Functor_option : Functor with type 'a f = 'a option module Functor_list : Functor with type 'a f = 'a list module Functor_map (O : Map.OrderedType) : Functor with type 'a f = 'a Map.Make(O).t deriving-0.1.1/lib/bounded.mli0000644000175000017500000000113510636601561015565 0ustar jeremyjeremymodule type Bounded = sig type a val min_bound : a val max_bound : a end module Bounded_bool : Bounded with type a = bool module Bounded_char : Bounded with type a = char module Bounded_int : Bounded with type a = int module Bounded_int32 : Bounded with type a = int32 module Bounded_int64 : Bounded with type a = int64 module Bounded_nativeint : Bounded with type a = nativeint module Bounded_unit : Bounded with type a = unit module Bounded_open_flag : Bounded with type a = Pervasives.open_flag module Bounded_fpclass : Bounded with type a = Pervasives.fpclass deriving-0.1.1/lib/show.mli0000644000175000017500000000253610636601561015133 0ustar jeremyjeremymodule type Show = sig type a val format : Format.formatter -> a -> unit val format_list : Format.formatter -> a list -> unit val show : a -> string val show_list : a list -> string end module Defaults (S : sig type a val format : Format.formatter -> a -> unit end) : Show with type a = S.a module Show_unprintable (S : sig type a end) : Show with type a = S.a module Show_char : Show with type a = char module Show_bool : Show with type a = bool module Show_unit : Show with type a = unit module Show_int : Show with type a = int module Show_int32 : Show with type a = int32 module Show_int64 : Show with type a = int64 module Show_nativeint : Show with type a = nativeint module Show_num : Show with type a = Num.num module Show_float : Show with type a = float module Show_string : Show with type a = string module Show_list (S : Show) : Show with type a = S.a list module Show_ref (S : Show) : Show with type a = S.a ref module Show_option (S : Show) : Show with type a = S.a option module Show_array (S : Show) : Show with type a = S.a array module Show_map (O : Map.OrderedType) (K : Show with type a = O.t) (V : Show) : Show with type a = V.a Map.Make(O).t module Show_set (O : Set.OrderedType) (K : Show with type a = O.t) : Show with type a = Set.Make(O).t deriving-0.1.1/lib/monad.ml0000644000175000017500000001717710761620603015104 0ustar jeremyjeremy(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Monad = sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val (>>=) : 'a m -> ('a -> 'b m) -> 'b m val (>>) : 'a m -> 'b m -> 'b m end module type MonadPlus = sig include Monad val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m end module MonadDefault (M : sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val (>>=) : 'a m -> ('a -> 'b m) -> 'b m end) : Monad with type 'a m = 'a M.m = struct include M let (>>) x y = x >>= (fun _ -> y) end module Monad_option : MonadPlus with type 'a m = 'a option = struct include MonadDefault( struct type 'a m = 'a option let fail _ = None let return x = Some x let (>>=) x f = match x with | None -> None | Some x -> f x end) let mzero = None let mplus l r = match l, r with | None, r -> r | l, _ -> l end module Monad_list : MonadPlus with type 'a m = 'a list = struct include MonadDefault( struct type 'a m = 'a list let return x = [x] let fail _ = [] let (>>=) m f = List.concat (List.map f m) end) let mzero = [] let mplus = (@) end module IO = (struct type 'a m = unit -> 'a let return a = fun () -> a let (>>=) m k = fun () -> let v = m () in k v () let (>>) x y = x >>= (fun _ -> y) let fail = failwith let putStr s = fun () -> print_string s let runIO f = f () let mkIO (f : unit -> 'b) = return (f ()) end) module type MonadUtilsSig = sig include Monad val liftM : ('a -> 'b) -> 'a m -> 'b m val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m val liftM4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m val liftM5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m val ap : ('a -> 'b) m -> 'a m -> 'b m val sequence : 'a m list -> 'a list m val sequence_ : 'a m list -> unit m val mapM : ('a -> 'b m) -> 'a list -> 'b list m val mapM_ : ('a -> 'b m) -> 'a list -> unit m val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m val join : 'a m m -> 'a m val filterM : ('a -> bool m) -> 'a list -> 'a list m val mapAndUnzipM : ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m val replicateM : int -> 'a m -> 'a list m val replicateM_ : int -> 'a m -> unit m val quand : bool -> unit m -> unit m val unless : bool -> unit m -> unit m end (* Control.Monad *) module MonadUtils (M : Monad) = struct include M let liftM : ('a1 -> 'r) -> 'a1 m -> 'r m = fun f m1 -> m1 >>= (fun x1 -> return (f x1)) let liftM2 : ('a1 -> 'a2 -> 'r) -> 'a1 m -> 'a2 m -> 'r m = fun f m1 m2 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> return (f x1 x2))) let liftM3 : ('a1 -> 'a2 -> 'a3 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'r m = fun f m1 m2 m3 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> return (f x1 x2 x3)))) let liftM4 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'r m = fun f m1 m2 m3 m4 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> m4 >>= (fun x4 -> return (f x1 x2 x3 x4))))) let liftM5 : ('a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'r) -> 'a1 m -> 'a2 m -> 'a3 m -> 'a4 m -> 'a5 m -> 'r m = fun f m1 m2 m3 m4 m5 -> m1 >>= (fun x1 -> m2 >>= (fun x2 -> m3 >>= (fun x3 -> m4 >>= (fun x4 -> m5 >>= (fun x5 -> return (f x1 x2 x3 x4 x5)))))) let ap : ('a -> 'b) m -> 'a m -> 'b m = fun f -> liftM2 (fun x -> x) f let sequence : ('a m) list -> ('a list) m = let mcons p q = p >>= (fun x -> q >>= (fun y -> return (x::y))) in fun l -> List.fold_right mcons l (return []) let sequence_ : ('a m) list -> unit m = fun l -> List.fold_right (>>) l (return ()) let mapM : ('a -> 'b m) -> 'a list -> ('b list) m = fun f xs -> sequence (List.map f xs) let mapM_ : ('a -> 'b m) -> 'a list -> unit m = fun f xs -> sequence_ (List.map f xs) let (=<<) : ('a -> 'b m) -> 'a m -> 'b m = fun f x -> x >>= f let join : ('a m) m -> 'a m = fun x -> x >>= (fun x -> x) let rec filterM : ('a -> bool m) -> 'a list -> ('a list) m = fun p -> function | [] -> return [] | x::xs -> p x >>= (fun flg -> filterM p xs >>= (fun ys -> return (if flg then (x::ys) else ys))) let mapAndUnzipM : ('a -> ('b *'c) m) -> 'a list -> ('b list * 'c list) m = fun f xs -> sequence (List.map f xs) >>= fun x -> return (List.split x) let zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> ('c list) m = fun f xs ys -> sequence (List.map2 f xs ys) let zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m = fun f xs ys -> sequence_ (List.map2 f xs ys) let rec foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m = fun f a -> function | [] -> return a | x::xs -> f a x >>= (fun fax -> foldM f fax xs) let foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m = fun f a xs -> foldM f a xs >> return () let ((replicateM : int -> 'a m -> ('a list) m), (replicateM_ : int -> 'a m -> unit m)) = let replicate n i = let rec aux accum = function | 0 -> accum | n -> aux (i::accum) (n-1) in aux [] n in ((fun n x -> sequence (replicate n x)), (fun n x -> sequence_ (replicate n x))) let quand (* when *) : bool -> unit m -> unit m = fun p s -> if p then s else return () let unless : bool -> unit m -> unit m = fun p s -> if p then return () else s end module type MonadPlusUtilsSig = sig include MonadUtilsSig val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m val guard : bool -> unit m val msum : 'a m list -> 'a m end module MonadPlusUtils (M : MonadPlus) = struct include MonadUtils(M) let mzero = M.mzero let mplus = M.mplus let guard : bool -> unit M.m = function | true -> M.return () | false -> M.mzero let msum : ('a M.m) list -> 'a M.m = fun l -> List.fold_right M.mplus l M.mzero end module MonadPlusUtils_option = MonadPlusUtils(Monad_option) module MonadPlusUtils_list = MonadPlusUtils(Monad_list) module Monad_IO = MonadUtils(MonadDefault (IO)) module type Monad_state_type = sig include MonadUtilsSig type state val get : state m val put : state -> unit m val runState : 'a m -> state -> 'a * state end module Monad_state_impl (A : sig type state end) = struct type state = A.state type 'a m = State of (A.state -> ('a * A.state)) let get = State (fun s -> s,s) let put s = State (fun _ -> (), s) let runState (State s) = s let return a = State (fun state -> (a, state)) let fail s = failwith ("state monad error " ^ s) let (>>=) (State x) f = State (fun s -> (let v, s' = x s in runState (f v) s')) let (>>) s f = s >>= fun _ -> f end module Monad_state(S : sig type state end) : Monad_state_type with type state = S.state = struct module M = Monad_state_impl(S) include MonadUtils(M) type state = M.state let get = M.get let put = M.put let runState = M.runState end deriving-0.1.1/lib/dynmap.mli0000644000175000017500000000072210636601561015436 0ustar jeremyjeremy(* Finite map : dynamic |-> t *) open Typeable module Comp (T : Typeable) (E : Eq.Eq with type a = T.a) : sig type a = T.a val eq : dynamic -> dynamic -> bool end module DynMap : sig type comparator = dynamic -> dynamic -> bool type 'a t val empty : 'a t val add : dynamic -> 'a -> comparator -> 'a t -> 'a t val mem : dynamic -> 'a t -> bool val find : dynamic -> 'a t -> 'a option val iter : (dynamic -> 'a -> unit) -> 'a t -> unit end deriving-0.1.1/lib/enum.ml0000644000175000017500000001051310761620563014742 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Bounded let rec rassoc (rkey : 'b) : ('a * 'b) list -> 'a = function | [] -> raise Not_found | (a,b)::_ when b = rkey -> a | _::xs -> rassoc rkey xs let rec last : 'a list -> 'a = function | [] -> raise (Invalid_argument "last") | [x] -> x | _::xs -> last xs module Enum = struct (** Enum **) module type Enum = sig type a val succ : a -> a val pred : a -> a val to_enum : int -> a val from_enum : a -> int val enum_from : a -> a list val enum_from_then : a -> a -> a list val enum_from_to : a -> a -> a list val enum_from_then_to : a -> a -> a -> a list end let startThenTo (start : int) (next : int) (until : int) : int list = let step = next - start in if step <= 0 then invalid_arg "startThenTo" else let rec upFrom current = if current > until then [] else current :: upFrom (current+step) in upFrom start let range : int -> int -> int list = fun f t -> startThenTo f (f+1) t module Defaults (E : (sig type a val numbering : (a * int) list end)) : Enum with type a = E.a = struct let firstCon = fst (List.hd E.numbering) let lastCon = fst (last E.numbering) type a = E.a let from_enum a = List.assoc a E.numbering let to_enum i = try rassoc i E.numbering with Not_found -> raise (Invalid_argument "to_enum") let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) let enum_from_then x y = (enum_from_then_to x y (if from_enum y >= from_enum x then lastCon else firstCon)) let enum_from x = enum_from_to x lastCon end module Defaults' (E : (sig type a val from_enum : a -> int val to_enum : int -> a end)) (B : Bounded with type a = E.a) : Enum with type a = E.a and type a = B.a = struct include E let firstCon = B.min_bound let lastCon = B.max_bound let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ") let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred") let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y)) let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z)) let enum_from_then x y = (enum_from_then_to x y (if from_enum y >= from_enum x then lastCon else firstCon)) let enum_from x = enum_from_to x lastCon end module Enum_bool = Defaults(struct type a = bool let numbering = [false, 0; true, 1] end) module Enum_char = Defaults'(struct type a = char let from_enum = Char.code let to_enum = Char.chr end) (Bounded_char) module Enum_int = Defaults' (struct type a = int let from_enum i = i let to_enum i = i end)(Bounded_int) (* Can `instance Enum Float' be justified? For some floats `f' we have `succ f == f'. Furthermore, float is wider than int, so from_enum will necessarily give nonsense on many inputs. *) module Enum_unit = Defaults' (struct type a = unit let from_enum () = 0 let to_enum = function | 0 -> () | _ -> raise (Invalid_argument "to_enum") end) (Bounded_unit) end include Enum type open_flag = Pervasives.open_flag = | Open_rdonly | Open_wronly | Open_append | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock deriving (Enum) type fpclass = Pervasives.fpclass = | FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan deriving (Enum) deriving-0.1.1/lib/eq.ml0000644000175000017500000000307610761620566014414 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module type Eq = sig type a val eq : a -> a -> bool end module Defaults (E : Eq) = E module Eq_immutable(S : sig type a end) : Eq with type a = S.a = struct type a = S.a let eq = (=) end module Eq_mutable(S : sig type a end) : Eq with type a = S.a = struct type a = S.a let eq = (==) end module Eq_int = Eq_immutable(struct type a = int end) module Eq_bool = Eq_immutable(struct type a = bool end) module Eq_float = Eq_immutable(struct type a = float end) module Eq_unit = Eq_immutable(struct type a = unit end) module Eq_char = Eq_immutable(struct type a = char end) module Eq_string = Eq_mutable(struct type a = string end) module Eq_ref (E : Eq) = Eq_mutable(struct type a = E.a ref end) module Eq_array (E : Eq) = Eq_mutable(struct type a = E.a array end) module Eq_option (E : Eq) : Eq with type a = E.a option = struct type a = E.a option let eq l r = match l, r with | None, None -> true | Some l, Some r -> E.eq l r | _ -> false end module Eq_map_s_t (E : Eq) (M : Map.S) : Eq with type a = E.a M.t = struct type a = E.a M.t let eq = M.equal (E.eq) end module Eq_list (E : Eq) : Eq with type a = E.a list = struct type a = E.a list let rec eq l r = match l, r with | [], [] -> true | (lfst::lrst), (rfst::rrst) when E.eq lfst rfst -> eq lrst rrst | _ -> false end module Eq_num : Eq with type a = Num.num = struct type a = Num.num let eq = Num.eq_num end deriving-0.1.1/lib/dump.ml0000644000175000017500000001744010761620553014750 0ustar jeremyjeremy(** Dump **) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* TODO: we could have an additional debugging deserialisation method. *) module type Dump = sig type a val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module type SimpleDump = sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end exception Dump_error of string let bad_tag tag stream typename = raise (Dump_error (Printf.sprintf "Dump: failure during %s deserialisation at character %d; unexpected tag %d" typename (Stream.count stream) tag)) module Defaults (P : sig type a val to_buffer : Buffer.t -> a -> unit val from_stream : char Stream.t -> a end) : Dump with type a = P.a = struct include P (* is there a reasonable value to use here? *) let buffer_size = 128 let to_string obj = let buffer = Buffer.create buffer_size in P.to_buffer buffer obj; Buffer.contents buffer (* should we explicitly deallocate the buffer? *) and from_string string = P.from_stream (Stream.of_string string) and from_channel in_channel = from_stream (Stream.of_channel in_channel) and to_channel out_channel obj = let buffer = Buffer.create buffer_size in P.to_buffer buffer obj; Buffer.output_buffer out_channel buffer end (* Generic int dumper. This should work for any (fixed-size) integer type with suitable operations. *) module Dump_intN (P : sig type t val zero : t val logand : t -> t -> t val logor : t -> t -> t val lognot : t -> t val shift_right_logical : t -> int -> t val shift_left : t -> int -> t val of_int : int -> t val to_int : t -> int end) = Defaults ( struct type a = P.t (* Format an integer using the following scheme: The lower 7 bits of each byte are used to store successive 7-bit chunks of the integer. The highest bit of each byte is used as a flag to indicate whether the next byte is present. *) open Buffer open Char open P let to_buffer buffer = let rec aux int = (* are there more than 7 bits? *) if logand int (lognot (of_int 0x7f)) <> zero (* if there are, write the lowest 7 bite plus a high bit (to indicate that there's more). Then recurse, shifting the value 7 bits right *) then begin add_char buffer (chr (to_int (logor (of_int 0x80) (logand int (of_int 0x7f))))); aux (shift_right_logical int 7) end (* otherwise, write the bottom 7 bits only *) else add_char buffer (chr (to_int int)) in aux and from_stream stream = let rec aux (int : t) shift = let c = of_int (code (Stream.next stream)) in let int = logor int (shift_left (logand c (of_int 0x7f)) shift) in if logand c (of_int 0x80) <> zero then aux int (shift + 7) else int in aux zero 0 end ) module Dump_int32 = Dump_intN (Int32) module Dump_int64 = Dump_intN (Int64) module Dump_nativeint = Dump_intN (Nativeint) module Dump_int = Defaults ( struct type a = int let to_buffer buffer int = Dump_nativeint.to_buffer buffer (Nativeint.of_int int) and from_stream stream = Nativeint.to_int (Dump_nativeint.from_stream stream) end ) module Dump_char = Defaults ( struct type a = char let to_buffer = Buffer.add_char and from_stream = Stream.next end ) (* This is questionable; it doesn't preserve sharing *) module Dump_string = Defaults ( struct type a = string let to_buffer buffer string = begin Dump_int.to_buffer buffer (String.length string); Buffer.add_string buffer string end and from_stream stream = let len = Dump_int.from_stream stream in let s = String.create len in for i = 0 to len - 1 do String.set s i (Stream.next stream) (* could use String.unsafe_set here *) done; s end ) module Dump_float = Defaults ( struct type a = float let to_buffer buffer f = Dump_int64.to_buffer buffer (Int64.bits_of_float f) and from_stream stream = Int64.float_of_bits (Dump_int64.from_stream stream) end ) (* This should end up a bit more compact than the derived version *) module Dump_list (P : SimpleDump) = Defaults ( (* This could perhaps be more efficient by serialising the list in reverse: this would result in only one traversal being needed during serialisation, and no "reverse" being needed during deserialisation. (However, dumping would no longer be tail-recursive) *) struct type a = P.a list let to_buffer buffer items = begin Dump_int.to_buffer buffer (List.length items); List.iter (P.to_buffer buffer) items end and from_stream stream = let rec aux items = function | 0 -> items | n -> aux (P.from_stream stream :: items) (n-1) in List.rev (aux [] (Dump_int.from_stream stream)) end ) (* Dump_ref and Dump_array cannot preserve sharing, so we don't provide implementations *) module Dump_option (P : SimpleDump) = Defaults ( struct type a = P.a option let to_buffer buffer = function | None -> Dump_int.to_buffer buffer 0 | Some s -> begin Dump_int.to_buffer buffer 1; P.to_buffer buffer s end and from_stream stream = match Dump_int.from_stream stream with | 0 -> None | 1 -> Some (P.from_stream stream) | i -> bad_tag i stream "option" end ) module Dump_bool = Defaults ( struct type a = bool let to_buffer buffer = function | false -> Buffer.add_char buffer '\000' | true -> Buffer.add_char buffer '\001' and from_stream stream = match Stream.next stream with | '\000' -> false | '\001' -> true | c -> bad_tag (Char.code c) stream "bool" end ) module Dump_unit = Defaults ( struct type a = unit let to_buffer _ () = () and from_stream _ = () end ) module Dump_num = Defaults ( struct (* TODO: a less wasteful dumper for nums. A good start would be using half a byte per decimal-coded digit, instead of a whole byte. *) type a = Num.num let to_buffer buffer n = Dump_string.to_buffer buffer (Num.string_of_num n) and from_stream stream = Num.num_of_string (Dump_string.from_stream stream) end ) module Dump_undumpable (P : sig type a val tname : string end) = Defaults ( struct type a = P.a let to_buffer _ _ = failwith ("Dump: attempt to serialise a value of unserialisable type : " ^ P.tname) let from_stream _ = failwith ("Dump: attempt to deserialise a value of unserialisable type : " ^ P.tname) end ) (* Uses Marshal to serialise the values that the parse-the-declarations technique can't reach. *) module Dump_via_marshal (P : sig type a end) = Defaults ( (* Rather inefficient. *) struct include P let to_buffer buffer obj = Buffer.add_string buffer (Marshal.to_string obj [Marshal.Closures]) let from_stream stream = let readn n = let s = String.create n in for i = 0 to n - 1 do String.set s i (Stream.next stream) done; s in let header = readn Marshal.header_size in let datasize = Marshal.data_size header 0 in let datapart = readn datasize in Marshal.from_string (header ^ datapart) 0 end) deriving-0.1.1/lib/typeable.ml0000644000175000017500000002002310761620616015577 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (** A type is viewed as the application of type constructors to zero or more type arguments. We provide equality and ordering operations on types. The ordering is unspecified, but consistent within a process, i.e. sufficient for use in Map etc. This might be considered to break abstraction, since it exposes the fact that two types are the same, even if that fact has been hidden by type abstraction (modules etc.). This is considered a good thing, since it assists with the intended use, which is to maximise value sharing. *) module TypeRep : sig type t type delayed = unit -> t val compare : t -> t -> int val eq : t -> t -> bool val mkFresh : string -> delayed list -> delayed val mkTuple : delayed list -> delayed val mkPolyv : (string * delayed option) list -> delayed list -> delayed end = struct module StringMap = Map.Make(Interned) module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) module StringSet = Set.Make(Interned) let counter = ref 0 let fresh () = let c = !counter in incr counter; c type t = [`Variant of (delayed option StringMap.t) |`Gen of Interned.t * delayed list ] * int and delayed = unit -> t let make_fresh row : t = (* Just allocate a pointer for now. Dereference the row later *) `Variant row, fresh () module EqualMap = struct type map = int list IntMap.t let equalp : map -> int -> int -> bool = fun map l r -> try List.mem r (IntMap.find l map) with Not_found -> false let record_equality : map -> int -> int -> map = fun map l r -> let add map l r = try let vals = IntMap.find l map in IntMap.add l (r::vals) map with Not_found -> IntMap.add l [r] map in add (add map l r) r l end let keys : 'a StringMap.t -> StringSet.t = fun m -> StringMap.fold (fun k _ set -> StringSet.add k set) m StringSet.empty let rec equal : EqualMap.map -> t -> t -> bool = fun equalmap (l,lid) (r,rid) -> if lid = rid then true else if EqualMap.equalp equalmap lid rid then true else match l, r with | `Variant lrow, `Variant rrow -> (* distinct types. assume they're equal for now; record that fact in the map, then look inside the types for evidence to the contrary *) equal_rows (EqualMap.record_equality equalmap lid rid) lrow rrow | `Gen (lname, ls), `Gen (rname, rs) when Interned.eq lname rname -> List.for_all2 (fun l r -> equal equalmap (l ()) (r ())) ls rs | _ -> false and equal_rows equalmap lfields rfields = equal_names lfields rfields && StringMap.fold (fun name t eq -> let t' = StringMap.find name rfields in match t, t' with | None, None -> eq | Some t, Some t' -> equal equalmap (t ()) (t' ()) && eq | _ -> false) lfields true and equal_names lmap rmap = StringSet.equal (keys lmap) (keys rmap) let mkFresh name args = let t : t = `Gen (Interned.intern name, args), fresh () in fun () -> t let mkTuple args = mkFresh (string_of_int (List.length args)) args let mkPolyv (args : (string * delayed option) list) (extends : delayed list) : delayed = (* assume all extensions have to be completely known types at this point *) let initial = List.fold_left (fun map extension -> match fst (extension ()) with | `Variant map' -> StringMap.fold StringMap.add map map' | `Gen _ -> assert false) StringMap.empty extends in let row = List.fold_left (fun map (name, t) -> StringMap.add (Interned.intern name) t map) initial args in let fresh = make_fresh row in fun () -> fresh let eq = equal IntMap.empty let rec compare recargs (lrep,lid as l) (rrep,rid as r) = if eq l r then 0 else if EqualMap.equalp recargs lid rid then 0 else match lrep, rrep with | `Gen (lname, ls), `Gen (rname, rs) -> begin match Pervasives.compare lname rname with | 0 -> begin match Pervasives.compare (List.length ls) (List.length rs) with | 0 -> List.fold_left2 (fun cmp l r -> if cmp <> 0 then cmp else compare recargs (l ()) (r ())) 0 ls rs | n -> n end | n -> n end | `Variant lrow, `Variant rrow -> compare_rows (EqualMap.record_equality recargs lid rid) lrow rrow | `Variant _, `Gen _ -> -1 | `Gen _, `Variant _ -> 1 and compare_rows recargs lrow rrow = match StringSet.compare (keys lrow) (keys rrow) with | 0 -> StringMap.compare (fun l r -> match l, r with | None, None -> 0 | Some l, Some r -> compare recargs (l ()) (r ()) | None, Some _ -> -1 | Some _, None -> 1) lrow rrow | n -> n let compare = compare IntMap.empty end (* Dynamic types *) type dynamic = Obj.t * TypeRep.t let tagOf (_, tag) = tag let untag (obj, tag) target = if TypeRep.eq tag target then Some obj else None (* Signature for type representations *) module type Typeable = sig type a val type_rep : unit -> TypeRep.t val has_type : dynamic -> bool val cast : dynamic -> a option val throwing_cast : dynamic -> a val make_dynamic : a -> dynamic val mk : a -> dynamic end exception CastFailure of string module Defaults (T : (sig type a val type_rep : unit -> TypeRep.t end)) : Typeable with type a = T.a = struct include T let has_type o = tagOf o = type_rep () let cast d = match untag d (type_rep ()) with | Some c -> Some (Obj.obj c) | None -> None let make_dynamic o = (Obj.repr o, type_rep ()) let mk = make_dynamic let throwing_cast d = match cast d with | None -> (*raise (CastFailure ("cast from type "^ TypeRep.Show_t.show (tagOf d) ^" to type "^ TypeRep.Show_t.show (T.type_rep ()) ^" failed"))*) raise (CastFailure "cast failed") | Some s -> s end module Typeable_list (A:Typeable) : Typeable with type a = A.a list = Defaults(struct type a = A.a list let type_rep = TypeRep.mkFresh "Primitive.list" [A.type_rep] end) module Typeable_option (A:Typeable) : Typeable with type a = A.a option = Defaults(struct type a = A.a option let type_rep = TypeRep.mkFresh "Primitive.option" [A.type_rep] end) module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t = Defaults(struct type a = T.t let type_rep = TypeRep.mkFresh T.magic [] end) module Typeable_unit = Primitive_typeable(struct type t = unit let magic = "Primitive.unit" end) module Typeable_int = Primitive_typeable(struct type t = int let magic = "Primitive.int" end) module Typeable_num = Primitive_typeable(struct type t = Num.num let magic = "Primitive.Num.num" end) module Typeable_float = Primitive_typeable(struct type t = float let magic = "Primitive.float" end) module Typeable_bool = Primitive_typeable(struct type t = bool let magic = "Primitive.bool" end) module Typeable_string = Primitive_typeable(struct type t = string let magic = "Primitive.string" end) module Typeable_char = Primitive_typeable(struct type t = char let magic = "Primitive.char" end) module Typeable_ref(A : Typeable) : Typeable with type a = A.a ref = Defaults(struct type a = A.a ref let type_rep = TypeRep.mkFresh "Primitive.ref" [A.type_rep] end) deriving-0.1.1/lib/Makefile0000644000175000017500000000126210636601561015103 0ustar jeremyjeremyOCAMLMAKEFILE = ../OCamlMakefile PATH := $(PATH):../syntax OCAMLOPT = ocamlopt.opt OCAMLC = ocamlc.opt OCAMLDEP = ocamldep.opt OCAMLFLAGS =-w ae LIBS = nums str unix SOURCES = show.ml show.mli \ interned.mli interned.ml \ eq.ml eq.mli \ bounded.ml bounded.mli \ enum.ml enum.mli \ monad.ml monad.mli \ dump.ml dump.mli \ typeable.ml typeable.mli \ dynmap.ml dynmap.mli \ pickle.ml pickle.mli \ functor.ml functor.mli \ RESULT = deriving include $(OCAMLMAKEFILE) deriving-0.1.1/lib/monad.mli0000644000175000017500000000544410636601561015252 0ustar jeremyjeremymodule type Monad = sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m val ( >> ) : 'a m -> 'b m -> 'b m end module type MonadPlus = sig include Monad val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m end module MonadDefault (M : sig type +'a m val return : 'a -> 'a m val fail : string -> 'a m val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m end) : Monad with type +'a m = 'a M.m module Monad_option : MonadPlus with type 'a m = 'a option module Monad_list : MonadPlus with type 'a m = 'a list module IO : sig include Monad val putStr : string -> unit m val runIO : 'a m -> 'a val mkIO : (unit -> 'b) -> 'b m end module type MonadUtilsSig = sig include Monad val liftM : ('a -> 'b) -> 'a m -> 'b m val liftM2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m val liftM3 : ('a -> 'b -> 'c -> 'd) -> 'a m -> 'b m -> 'c m -> 'd m val liftM4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m val liftM5 : ('a -> 'b -> 'c -> 'd -> 'e -> 'f) -> 'a m -> 'b m -> 'c m -> 'd m -> 'e m -> 'f m val ap : ('a -> 'b) m -> 'a m -> 'b m val sequence : 'a m list -> 'a list m val sequence_ : 'a m list -> unit m val mapM : ('a -> 'b m) -> 'a list -> 'b list m val mapM_ : ('a -> 'b m) -> 'a list -> unit m val ( =<< ) : ('a -> 'b m) -> 'a m -> 'b m val join : 'a m m -> 'a m val filterM : ('a -> bool m) -> 'a list -> 'a list m val mapAndUnzipM : ('a -> ('b * 'c) m) -> 'a list -> ('b list * 'c list) m val zipWithM : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> 'c list m val zipWithM_ : ('a -> 'b -> 'c m) -> 'a list -> 'b list -> unit m val foldM : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m val foldM_ : ('a -> 'b -> 'a m) -> 'a -> 'b list -> unit m val replicateM : int -> 'a m -> 'a list m val replicateM_ : int -> 'a m -> unit m val quand : bool -> unit m -> unit m val unless : bool -> unit m -> unit m end module MonadUtils (M : Monad) : MonadUtilsSig with type 'a m = 'a M.m module type MonadPlusUtilsSig = sig include MonadUtilsSig val mzero : 'a m val mplus : 'a m -> 'a m -> 'a m val guard : bool -> unit m val msum : 'a m list -> 'a m end module MonadPlusUtils (M : MonadPlus) : MonadPlusUtilsSig with type 'a m = 'a M.m module MonadPlusUtils_option : MonadPlusUtilsSig with type 'a m = 'a Monad_option.m module MonadPlusUtils_list : MonadPlusUtilsSig with type 'a m = 'a Monad_list.m module Monad_IO : MonadUtilsSig with type 'a m = 'a IO.m module type Monad_state_type = sig include MonadUtilsSig type state val get : state m val put : state -> unit m val runState : 'a m -> state -> 'a * state end module Monad_state (S : sig type state end) : Monad_state_type with type state = S.state deriving-0.1.1/lib/pickle.ml0000644000175000017500000003774410761620611015256 0ustar jeremyjeremy(*pp deriving *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Idea: 1. every object receives a serializable id. 2. an object is serialized using the ids of its subobjects *) module Pickle = struct exception UnknownTag of int * string exception UnpicklingError of string module Id : sig type t deriving (Show, Dump, Eq) val initial : t val compare : t -> t -> int val next : t -> t end = struct type t = int deriving (Show, Dump, Eq) let initial = 0 let compare = compare let next = succ end module IdMap = Map.Make (Id) type id = Id.t deriving (Show, Dump) module Repr : sig (* Break abstraction for the sake of efficiency for now *) type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) val of_string : string -> t val to_string : t -> string val make : ?constructor:int -> id list -> t val unpack_ctor : t -> int option * id list end = struct type t = Bytes of string | CApp of (int option * Id.t list) deriving (Dump, Show) let of_string s = Bytes s let to_string = function | Bytes s -> s | _ -> invalid_arg "string_of_repr" let make ?constructor ids = match constructor with | Some n -> CApp (Some n, ids) | None -> CApp (None, ids) let unpack_ctor = function | CApp arg -> arg | _ -> raise (UnpicklingError "Error unpickling constructor") end type repr = Repr.t module Write : sig type s = { nextid : Id.t; obj2id : Id.t Dynmap.DynMap.t; id2rep : repr IdMap.t; } val initial_output_state : s include Monad.Monad_state_type with type state = s module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) : sig val allocate : T.a -> (id -> unit m) -> id m val store_repr : id -> Repr.t -> unit m end end = struct type s = { nextid : Id.t; (* the next id to be allocated *) obj2id : Id.t Dynmap.DynMap.t; (* map from typerep to id cache for the corresponding type *) id2rep : repr IdMap.t; } let initial_output_state = { nextid = Id.initial; obj2id = Dynmap.DynMap.empty; id2rep = IdMap.empty; } include Monad.Monad_state (struct type state = s end) module Utils (T : Typeable.Typeable) (E : Eq.Eq with type a = T.a) = struct module C = Dynmap.Comp(T)(E) let comparator = C.eq let allocate o f = let obj = T.make_dynamic o in get >>= fun ({nextid=nextid;obj2id=obj2id} as t) -> match Dynmap.DynMap.find obj obj2id with | Some id -> return id | None -> let id, nextid = nextid, Id.next nextid in put {t with obj2id=Dynmap.DynMap.add obj id comparator obj2id; nextid=nextid} >> f id >> return id let store_repr id repr = get >>= fun state -> put {state with id2rep = IdMap.add id repr state.id2rep} end end module Read : sig type s = (repr * (Typeable.dynamic option)) IdMap.t include Monad.Monad_state_type with type state = s val find_by_id : id -> (Repr.t * Typeable.dynamic option) m module Utils (T : Typeable.Typeable) : sig val sum : (int * id list -> T.a m) -> id -> T.a m val tuple : (id list -> T.a m) -> id -> T.a m val record : (T.a -> id list -> T.a m) -> int -> id -> T.a m val update_map : id -> (T.a -> unit m) end end = struct type s = (repr * (Typeable.dynamic option)) IdMap.t include Monad.Monad_state (struct type state = s end) let find_by_id id = get >>= fun state -> return (IdMap.find id state) module Utils (T : Typeable.Typeable) = struct let decode_repr_ctor c = match Repr.unpack_ctor c with | (Some c, ids) -> (c, ids) | _ -> invalid_arg "decode_repr_ctor" let decode_repr_noctor c = match Repr.unpack_ctor c with | (None, ids) -> ids | _ -> invalid_arg "decode_repr_ctor" let update_map id obj = let dynamic = T.make_dynamic obj in get >>= fun state -> match IdMap.find id state with | (repr, None) -> put (IdMap.add id (repr, Some dynamic) state) | (_, Some _) -> return () (* Checking for id already present causes unpickling to fail when there is circularity involving immutable values (even if the recursion wholly depends on mutability). For example, consider the code type t = A | B of t ref deriving (Typeable, Eq, Pickle) let s = ref A in let r = B s in s := r; let pickled = Pickle_t.pickleS r in Pickle_t.unpickleS r which results in the value B {contents = B {contents = B { ... }}} During deserialization the following steps occur: 1. lookup "B {...}" in the dictionary (not there) 2. unpickle the contents of B: 3. lookup the contents in the dictionary (not there) 4. create a blank reference, insert it into the dictionary 5. unpickle the contents of the reference: 6. lookup ("B {...}") in the dictionary (not there) 7. unpickle the contents of B: 8. lookup the contents in the dictionary (there) 9. insert "B{...}" into the dictionary. 10. insert "B{...}" into the dictionary. *) let whizzy f id decode = find_by_id id >>= fun (repr, dynopt) -> match dynopt with | None -> f (decode repr) >>= fun obj -> update_map id obj >> return obj | Some obj -> return (T.throwing_cast obj) let sum f id = whizzy f id decode_repr_ctor let tuple f id = whizzy f id decode_repr_noctor let record_tag = 0 let record f size id = find_by_id id >>= fun (repr, obj) -> match obj with | None -> let this = Obj.magic (Obj.new_block record_tag size) in update_map id this >> f this (decode_repr_noctor repr) >> return this | Some obj -> return (T.throwing_cast obj) end end module type Pickle = sig type a module T : Typeable.Typeable with type a = a module E : Eq.Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m val to_buffer : Buffer.t -> a -> unit val to_string : a -> string val to_channel : out_channel -> a -> unit val from_stream : char Stream.t -> a val from_string : string -> a val from_channel : in_channel -> a end module Defaults (S : sig type a module T : Typeable.Typeable with type a = a module E : Eq.Eq with type a = a val pickle : a -> id Write.m val unpickle : id -> a Read.m end) : Pickle with type a = S.a = struct include S type ids = (Id.t * Repr.t) list deriving (Dump, Show) type dumpable = id * ids deriving (Show, Dump) type ('a,'b) pair = 'a * 'b deriving (Dump) type capp = int option * Id.t list deriving (Dump) (* We don't serialize ids of each object at all: we just use the ordering in the output file to implicitly record the ids of objects. Also, we don't serialize the repr constructors. All values with a particular constructor are grouped in a single list. This can (and should) all be written much more efficiently. *) type discriminated = (Id.t * string) list * (Id.t * (int * Id.t list)) list * (Id.t * (Id.t list)) list deriving (Dump, Show) type discriminated_ordered = string list * (int * Id.t list) list * (Id.t list) list deriving (Dump, Show) let reorder : Id.t * discriminated -> Id.t * discriminated_ordered = fun (root,(a,b,c)) -> let collect_ids items (map,counter) = List.fold_left (fun (map,counter) (id,_) -> IdMap.add id counter map, Id.next counter) (map,counter) items in let map, _ = collect_ids c (collect_ids b (collect_ids a (IdMap.empty, Id.initial))) in let lookup id = IdMap.find id map in (lookup root, (List.map snd a, List.map (fun (_,(c,l)) -> c, List.map lookup l) b, List.map (fun (_,l) -> List.map lookup l) c)) let unorder : Id.t * discriminated_ordered -> Id.t * discriminated = fun (root,(a,b,c)) -> let number_sequentially id items = List.fold_left (fun (id,items) item -> (Id.next id, (id,item)::items)) (id,[]) items in let id = Id.initial in let id, a = number_sequentially id a in let id, b = number_sequentially id b in let _, c = number_sequentially id c in (root, (a,b,c)) type ('a,'b) either = Left of 'a | Right of 'b let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) : 'b list * 'c list = let rec aux (lefts, rights) = function | [] -> (List.rev lefts, List.rev rights) | x::xs -> match f x with | Left l -> aux (l :: lefts, rights) xs | Right r -> aux (lefts, r :: rights) xs in aux ([], []) l type discriminated_dumpable = Id.t * discriminated deriving (Dump) let discriminate : (Id.t * Repr.t) list -> discriminated = fun input -> let bytes, others = either_partition (function | id, (Repr.Bytes s) -> Left (id,s) | id, (Repr.CApp c) -> Right (id,c)) input in let ctors, no_ctors = either_partition (function | id, (Some c, ps) -> Left (id, (c,ps)) | id, (None, ps) -> Right (id,ps)) others in (bytes, ctors, no_ctors) let undiscriminate : discriminated -> (Id.t * Repr.t) list = fun (a,b,c) -> List.map (fun (id,s) -> (id,Repr.Bytes s)) a @ List.map (fun (id,(c,ps)) -> (id,Repr.CApp (Some c,ps))) b @ List.map (fun (id,(ps)) -> (id,Repr.CApp (None,ps))) c type do_pair = Id.t * discriminated_ordered deriving (Show, Dump) let write_discriminated f = fun (root,map) -> let dmap = discriminate map in let rmap = reorder (root,dmap) in f rmap let read_discriminated (f : 'b -> 'a) : 'b -> Id.t * (Id.t * Repr.t) list = fun s -> let rmap = f s in let (root,dmap) = unorder rmap in (root, undiscriminate dmap) open Write let decode_pickled_string (f : 'a -> Id.t * discriminated_ordered) : 'b -> Id.t * Read.s = fun s -> let (id, state : dumpable) = read_discriminated f s in id, (List.fold_right (fun (id,repr) map -> IdMap.add id (repr,None) map) state IdMap.empty) let encode_pickled_string f = fun (id,state) -> let input_state = id, IdMap.fold (fun id repr output -> (id,repr)::output) state.id2rep [] in write_discriminated f input_state let doPickle f v : 'a = let id, state = runState (S.pickle v) initial_output_state in encode_pickled_string f (id, state) let doUnpickle f input = let id, initial_input_state = decode_pickled_string f input in let value, _ = Read.runState (S.unpickle id) initial_input_state in value let from_channel = doUnpickle Dump.from_channel let from_string = doUnpickle Dump.from_string let from_stream = doUnpickle Dump.from_stream let to_channel channel = doPickle (Dump.to_channel channel) let to_buffer buffer = doPickle (Dump.to_buffer buffer) let to_string = doPickle Dump.to_string end module Pickle_from_dump (P : Dump.Dump) (E : Eq.Eq with type a = P.a) (T : Typeable.Typeable with type a = P.a) : Pickle with type a = P.a and type a = T.a = Defaults (struct type a = T.a module T = T module E = E module Comp = Dynmap.Comp(T)(E) open Write module W = Utils(T)(E) let pickle obj = W.allocate obj (fun id -> W.store_repr id (Repr.of_string (P.to_string obj))) open Read module U = Utils(T) let unpickle id = find_by_id id >>= fun (repr, dynopt) -> match dynopt with | None -> let obj : a = P.from_string (Repr.to_string repr) in U.update_map id obj >> return obj | Some obj -> return (T.throwing_cast obj) end) module Pickle_unit : Pickle with type a = unit = Pickle_from_dump(Dump.Dump_unit)(Eq.Eq_unit)(Typeable.Typeable_unit) module Pickle_bool = Pickle_from_dump(Dump.Dump_bool)(Eq.Eq_bool)(Typeable.Typeable_bool) module Pickle_int = Pickle_from_dump(Dump.Dump_int)(Eq.Eq_int)(Typeable.Typeable_int) module Pickle_char = Pickle_from_dump(Dump.Dump_char)(Eq.Eq_char)(Typeable.Typeable_char) module Pickle_float = Pickle_from_dump(Dump.Dump_float)(Eq.Eq_float)(Typeable.Typeable_float) module Pickle_num = Pickle_from_dump(Dump.Dump_num)(Eq.Eq_num)(Typeable.Typeable_num) module Pickle_string = Pickle_from_dump(Dump.Dump_string)(Eq.Eq_string)(Typeable.Typeable_string) module Pickle_option (V0 : Pickle) : Pickle with type a = V0.a option = Defaults( struct module T = Typeable.Typeable_option (V0.T) module E = Eq.Eq_option (V0.E) module Comp = Dynmap.Comp (T) (E) open Write type a = V0.a option let rec pickle = let module W = Utils(T)(E) in function None as obj -> W.allocate obj (fun id -> W.store_repr id (Repr.make ~constructor:0 [])) | Some v0 as obj -> W.allocate obj (fun thisid -> V0.pickle v0 >>= fun id0 -> W.store_repr thisid (Repr.make ~constructor:1 [id0])) open Read let unpickle = let module W = Utils(T) in let f = function | 0, [] -> return None | 1, [id] -> V0.unpickle id >>= fun obj -> return (Some obj) | n, _ -> raise (UnpicklingError ("Unexpected tag encountered unpickling " ^"option : " ^ string_of_int n)) in W.sum f end) module Pickle_list (V0 : Pickle) : Pickle with type a = V0.a list = Defaults ( struct module T = Typeable.Typeable_list (V0.T) module E = Eq.Eq_list (V0.E) module Comp = Dynmap.Comp (T) (E) type a = V0.a list open Write module U = Utils(T)(E) let rec pickle = function [] as obj -> U.allocate obj (fun this -> U.store_repr this (Repr.make ~constructor:0 [])) | (v0::v1) as obj -> U.allocate obj (fun this -> V0.pickle v0 >>= fun id0 -> pickle v1 >>= fun id1 -> U.store_repr this (Repr.make ~constructor:1 [id0; id1])) open Read module W = Utils (T) let rec unpickle id = let f = function | 0, [] -> return [] | 1, [car;cdr] -> V0.unpickle car >>= fun car -> unpickle cdr >>= fun cdr -> return (car :: cdr) | n, _ -> raise (UnpicklingError ("Unexpected tag encountered unpickling " ^"option : " ^ string_of_int n)) in W.sum f id end) end include Pickle type 'a ref = 'a Pervasives.ref = { mutable contents : 'a } deriving (Pickle) (* Idea: keep pointers to values that we've serialized in a global weak hash table so that we can share structure with them if we deserialize any equal values in the same process *) (* Idea: serialize small objects (bools, chars) in place rather than using the extra level of indirection (and space) introduced by ids *) (* Idea: bitwise output instead of bytewise. Probably a bit much to implement now, but should have a significant impact (e.g. one using bit instead of one byte for two-constructor sums) *) (* Should we use a different representation for lists? i.e. write out the length followed by the elements? we could no longer claim sharing maximization, but it would actually be more efficient in most cases. *) deriving-0.1.1/syntax/0000755000175000017500000000000010761620733014223 5ustar jeremyjeremyderiving-0.1.1/syntax/enum_class.ml0000644000175000017500000000465610761620644016722 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) let classname = "Enum" let instance = object(self) inherit make_module_expr ~classname ~allow_private:false method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = let numbering = List.fold_right2 (fun n ctor rest -> match ctor with | (name, []) -> <:expr< ($uid:name$, $`int:n$) :: $rest$ >> | (name,_) -> raise (Underivable ("Enum cannot be derived for the type "^ tname ^" because the constructor "^ name^" is not nullary"))) (List.range 0 (List.length summands)) summands <:expr< [] >> in <:module_expr< Enum.Defaults(struct type a = $atype ctxt decl$ let numbering = $numbering$ end) >> method variant ctxt decl (_, tags) = let numbering = List.fold_right2 (fun n tagspec rest -> match tagspec with | Tag (name, None) -> <:expr< (`$name$, $`int:n$) :: $rest$ >> | Tag (name, _) -> raise (Underivable ("Enum cannot be derived because the tag "^ name^" is not nullary")) | _ -> raise (Underivable ("Enum cannot be derived for this " ^"polymorphic variant type"))) (List.range 0 (List.length tags)) tags <:expr< [] >> in <:module_expr< Enum.Defaults(struct type a = $atype ctxt decl$ let numbering = $numbering$ end) >> method tuple context _ = raise (Underivable "Enum cannot be derived for tuple types") method record ?eq _ (tname,_,_,_,_) = raise (Underivable ("Enum cannot be derived for record types (i.e. "^ tname^")")) end end let _ = Base.register "Enum" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/base.ml0000644000175000017500000003514510761620636015501 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Utils open Type open Camlp4.PreCast type context = { loc : Loc.t; (* mapping from type parameters to functor arguments *) argmap : name NameMap.t; (* ordered list of type parameters *) params : param list; (* type names *) tnames : NameSet.t; } exception Underivable of string exception NoSuchClass of string (* display a fatal error and exit *) let error loc (msg : string) = Syntax.print_warning loc msg; exit 1 module type Loc = sig val loc : Loc.t end let contains_tvars, contains_tvars_decl = let o = object inherit [bool] fold as default method crush = List.exists F.id method expr = function | `Param _ -> true | e -> default#expr e end in (o#expr, o#decl) module InContext(L : Loc) = struct include L module Untranslate = Untranslate(L) let instantiate, instantiate_repr = let o lookup = object inherit transform as super method expr = function | `Param (name, _) -> lookup name | e -> super # expr e end in (fun (lookup : name -> expr) -> (o lookup)#expr), (fun (lookup : name -> expr) -> (o lookup)#repr) let instantiate_modargs, instantiate_modargs_repr = let lookup ctxt var = try `Constr ([NameMap.find var ctxt.argmap; "a"], []) with Not_found -> failwith ("Unbound type parameter '" ^ var) in (fun ctxt -> instantiate (lookup ctxt)), (fun ctxt -> instantiate_repr (lookup ctxt)) let substitute env = (object inherit transform as default method expr = function | `Param (p,v) when NameMap.mem p env -> `Param (NameMap.find p env,v) | e -> default# expr e end) # expr let cast_pattern ctxt ?(param="x") t = let t = Untranslate.expr (instantiate_modargs ctxt t) in (<:patt< $lid:param$ >>, <:expr< let module M = struct type t = $t$ let test = function #t -> true | _ -> false end in M.test $lid:param$ >>, <:expr< (let module M = struct type t = $t$ let cast = function #t as t -> t | _ -> assert false end in M.cast $lid:param$ )>>) let seq l r = <:expr< $l$ ; $r$ >> let record_pattern ?(prefix="") (fields : Type.field list) : Ast.patt = <:patt<{$list: (List.map (fun (label,_,_) -> <:patt< $lid:label$ = $lid:prefix ^ label$ >>) fields) $}>> let record_expr : (string * Ast.expr) list -> Ast.expr = fun fields -> let fs = List.fold_left1 (fun l r -> <:rec_binding< $l$ ; $r$ >>) (List.map (fun (label, exp) -> <:rec_binding< $lid:label$ = $exp$ >>) fields) in Ast.ExRec (loc, fs, Ast.ExNil loc) let record_expression ?(prefix="") : Type.field list -> Ast.expr = fun fields -> let es = List.fold_left1 (fun l r -> <:rec_binding< $l$ ; $r$ >>) (List.map (fun (label,_,_) -> <:rec_binding< $lid:label$ = $lid:prefix ^ label$ >>) fields) in Ast.ExRec (loc, es, Ast.ExNil loc) let mproject mexpr name = match mexpr with | <:module_expr< $id:m$ >> -> <:expr< $id:m$.$lid:name$ >> | _ -> <:expr< let module M = $mexpr$ in M.$lid:name$ >> let expr_list : Ast.expr list -> Ast.expr = (fun exprs -> List.fold_right (fun car cdr -> <:expr< $car$ :: $cdr$ >>) exprs <:expr< [] >>) let patt_list : Ast.patt list -> Ast.patt = (fun patts -> List.fold_right (fun car cdr -> <:patt< $car$ :: $cdr$ >>) patts <:patt< [] >>) let tuple_expr : Ast.expr list -> Ast.expr = function | [] -> <:expr< () >> | [x] -> x | x::xs -> Ast.ExTup (loc, List.fold_left (fun e t -> Ast.ExCom (loc, e,t)) x xs) let tuple ?(param="v") n : Ast.patt * Ast.expr = let v n = Printf.sprintf "%s%d" param n in match n with | 0 -> <:patt< () >>, <:expr< () >> | 1 -> <:patt< $lid:v 0$ >>, <:expr< $lid:v 0$ >> | n -> let patts, exprs = (* At time of writing I haven't managed to write anything using quotations that generates an n-tuple *) List.fold_left (fun (p, e) (patt, expr) -> Ast.PaCom (loc, p, patt), Ast.ExCom (loc, e, expr)) (<:patt< >>, <:expr< >>) (List.map (fun n -> <:patt< $lid:v n$ >>, <:expr< $lid:v n $ >>) (List.range 0 n)) in Ast.PaTup (loc, patts), Ast.ExTup (loc, exprs) let rec modname_from_qname ~qname ~classname = match qname with | [] -> invalid_arg "modname_from_qname" | [t] -> <:ident< $uid:classname ^ "_"^ t$ >> | t::ts -> <:ident< $uid:t$.$modname_from_qname ~qname:ts ~classname$ >> let apply_functor (f : Ast.module_expr) (args : Ast.module_expr list) : Ast.module_expr = List.fold_left (fun f p -> <:module_expr< $f$ ($p$) >>) f args class virtual make_module_expr ~classname ~allow_private = object (self) method mapply ctxt (funct : Ast.module_expr) args = apply_functor funct (List.map (self#expr ctxt) args) method virtual variant : context -> decl -> variant -> Ast.module_expr method virtual sum : ?eq:expr -> context -> decl -> summand list -> Ast.module_expr method virtual record : ?eq:expr -> context -> decl -> field list -> Ast.module_expr method virtual tuple : context -> expr list -> Ast.module_expr method param ctxt (name, variance) = <:module_expr< $uid:NameMap.find name ctxt.argmap$ >> method object_ _ o = raise (Underivable (classname ^ " cannot be derived for object types")) method class_ _ c = raise (Underivable (classname ^ " cannot be derived for class types")) method label _ l = raise (Underivable (classname ^ " cannot be derived for label types")) method function_ _ f = raise (Underivable (classname ^ " cannot be derived for function types")) method constr ctxt (qname, args) = match qname with | [name] when NameSet.mem name ctxt.tnames -> <:module_expr< $uid:Printf.sprintf "%s_%s" classname name$ >> | _ -> let f = (modname_from_qname ~qname ~classname) in self#mapply ctxt (Ast.MeId (loc, f)) args method expr (ctxt : context) : expr -> Ast.module_expr = function | `Param p -> self#param ctxt p | `Object o -> self#object_ ctxt o | `Class c -> self#class_ ctxt c | `Label l -> self#label ctxt l | `Function f -> self#function_ ctxt f | `Constr c -> self#constr ctxt c | `Tuple t -> self#tuple ctxt t method rhs ctxt (tname, params, rhs, constraints, _ as decl : Type.decl) : Ast.module_expr = match rhs with | `Fresh (_, _, (`Private : [`Private|`Public])) when not allow_private -> raise (Underivable ("The class "^ classname ^" cannot be derived for private types")) | `Fresh (eq, Sum summands, _) -> self#sum ?eq ctxt decl summands | `Fresh (eq, Record fields, _) -> self#record ?eq ctxt decl fields | `Expr e -> self#expr ctxt e | `Variant v -> self# variant ctxt decl v | `Nothing -> <:module_expr< >> end let atype_expr ctxt expr = Untranslate.expr (instantiate_modargs ctxt expr) let atype ctxt (name, params, rhs, _, _) = match rhs with | `Fresh _ | `Variant _ | `Nothing -> Untranslate.expr (`Constr ([name], List.map (fun (p,_) -> `Constr ([NameMap.find p ctxt.argmap; "a"],[])) params)) | `Expr e -> atype_expr ctxt e let make_safe (decls : (decl * Ast.module_binding) list) : Ast.module_binding list = (* re-order a set of mutually recursive modules in an attempt to make initialization problems less likely *) List.map snd (List.sort (fun ((_,_,lrhs,_,_), _) ((_,_,rrhs,_,_), _) -> match (lrhs : rhs), rrhs with (* aliases to types in the group score higher than everything else. In general, things that must come first receive a positive score when they occur on the left and a negative score when they occur on the right. *) | (`Fresh _|`Variant _), (`Fresh _|`Variant _) -> 0 | (`Fresh _|`Variant _), _ -> -1 | _, (`Fresh _|`Variant _) -> 1 | (`Nothing, `Nothing) -> 0 | (`Nothing, _) -> 1 | (_, `Nothing) -> -1 | `Expr l, `Expr r -> let module M = struct type low = [`Param of param |`Tuple of expr list] end in match l, r with | #M.low, _ -> 1 | _, #M.low -> -1 | _ -> 0) decls) let generate ~context ~decls ~make_module_expr ~classname ?default_module () = (* plan: set up an enclosing recursive module generate functors for all types in the clique project out the inner modules afterwards. later: generate simpler code for simpler cases: - where there are no type parameters - where there's only one type - where there's no recursion - etc. *) (* let _ = ensure_no_polymorphic_recursion in *) let wrapper_name = Printf.sprintf "%s_%s" classname (random_id 32) in let make_functor = List.fold_right (fun (p,_) rhs -> let arg = NameMap.find p context.argmap in <:module_expr< functor ($arg$ : $uid:classname$.$uid:classname$) -> $rhs$ >>) context.params in let apply_defaults mexpr = match default_module with | None -> mexpr | Some default -> <:module_expr< $uid:classname$.$uid:default$ ($mexpr$) >> in let mbinds = List.map (fun (name,_,_,_,_ as decl) -> if name = "a" then raise (Underivable ("deriving: types called `a' are not allowed.\n" ^"Please change the name of your type and try again.")) else (decl, <:module_binding< $uid:classname ^ "_"^ name$ : $uid:classname$.$uid:classname$ with type a = $atype context decl$ = $apply_defaults (make_module_expr context decl)$ >>)) decls in let sorted_mbinds = make_safe mbinds in let mrec = <:str_item< open $uid:classname$ module rec $list:sorted_mbinds$ >> in match context.params with | [] -> mrec | _ -> let fixed = make_functor <:module_expr< struct $mrec$ end >> in let applied = apply_functor <:module_expr< $uid:wrapper_name$ >> (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p context.argmap$>>) context.params) in let projected = List.map (fun (name,params,rhs,_,_) -> let modname = classname ^ "_"^ name in let rhs = <:module_expr< struct module P = $applied$ include P.$uid:modname$ end >> in <:str_item< module $uid:modname$ = $make_functor rhs$>>) decls in let m = <:str_item< module $uid:wrapper_name$ = $fixed$ >> in <:str_item< $m$ $list:projected$ >> let gen_sig ~classname ~context (tname,params,_,_,generated as decl) = if tname = "a" then raise (Underivable ("deriving: types called `a' are not allowed.\n" ^"Please change the name of your type and try again.")) else if generated then <:sig_item< >> else let t = List.fold_right (fun (p,_) m -> <:module_type< functor ($NameMap.find p context.argmap$ : $uid:classname$.$uid:classname$) -> $m$ >>) params <:module_type< $uid:classname$.$uid:classname$ with type a = $atype context decl$ >> in <:sig_item< module $uid:Printf.sprintf "%s_%s" classname tname$ : $t$ >> let gen_sigs ~classname ~context ~decls = <:sig_item< $list:List.map (gen_sig ~classname ~context) decls$ >> end let find_non_regular params tnames decls : name list = List.concat_map (object inherit [name list] fold as default method crush = List.concat method expr = function | `Constr ([t], args) when NameSet.mem t tnames -> (List.concat_map2 (fun (p,_) a -> match a with | `Param (q,_) when p = q -> [] | _ -> [t]) params args) | e -> default#expr e end)#decl decls let extract_params = let has_params params (_, ps, _, _, _) = ps = params in function | [] -> invalid_arg "extract_params" | (_,params,_,_,_)::rest when List.for_all (has_params params) rest -> params | (_,_,rhs,_,_)::_ -> (* all types in a clique must have the same parameters *) raise (Underivable ("Instances can only be derived for " ^"recursive groups where all types\n" ^"in the group have the same parameters.")) let setup_context loc (tdecls : decl list) : context = let params = extract_params tdecls and tnames = NameSet.fromList (List.map (fun (name,_,_,_,_) -> name) tdecls) in match find_non_regular params tnames tdecls with | _::_ as names -> failwith ("The following types contain non-regular recursion:\n " ^String.concat ", " names ^"\nderiving does not support non-regular types") | [] -> let argmap = List.fold_right (fun (p,_) m -> NameMap.add p (Printf.sprintf "V_%s" p) m) params NameMap.empty in { loc = loc; argmap = argmap; params = params; tnames = tnames } type deriver = Loc.t * context * Type.decl list -> Ast.str_item and sigderiver = Loc.t * context * Type.decl list -> Ast.sig_item let derivers : (name, (deriver * sigderiver)) Hashtbl.t = Hashtbl.create 15 let register = Hashtbl.add derivers let find classname = try Hashtbl.find derivers classname with Not_found -> raise (NoSuchClass classname) let is_registered : name -> bool = fun classname -> try ignore (find classname); true with NoSuchClass _ -> false deriving-0.1.1/syntax/dump_class.ml0000644000175000017500000001312510761620642016710 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) let classname = "Dump" let wrap ~atype ~dumpers ~undump = <:module_expr< struct type a = $atype$ let to_buffer buffer = function $list:dumpers$ let from_stream stream = $undump$ end >> let instance = object (self) inherit make_module_expr ~classname ~allow_private:false method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr * Ast.expr = List.fold_right (fun (id,t) (p,u) -> <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:id$; $p$ >>, <:expr< let $lid:id$ = $mproject (self#expr ctxt t) "from_stream"$ stream in $u$ >>) exprs (<:expr<>>, <:expr< $tuple_expr (List.map (fun (id,_) -> <:expr< $lid:id$ >>) exprs)$>>) method tuple ctxt ts = let atype = atype_expr ctxt (`Tuple ts) and dumpers, undump = let n = List.length ts in let pinner, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) ts) in let patt, expr = tuple n in [ <:match_case< $patt$ -> $pinner$ >> ], undump in <:module_expr< Defaults( $wrap ~atype ~dumpers ~undump$) >> method polycase ctxt tagspec n : Ast.match_case * Ast.match_case = let dumpn = <:expr< Dump_int.to_buffer buffer $`int:n$ >> in match tagspec with | Tag (name, args) -> (match args with | None -> <:match_case< `$name$ -> $dumpn$ >>, <:match_case< $`int:n$ -> `$name$ >> | Some e -> <:match_case< `$name$ x -> $dumpn$; $mproject (self#expr ctxt e) "to_buffer"$ buffer x >>, <:match_case< $`int:n$ -> `$name$ ($mproject (self#expr ctxt e) "from_stream"$ stream) >>) | Extends t -> let patt, guard, cast = cast_pattern ctxt t in <:match_case< $patt$ when $guard$ -> $dumpn$; $mproject (self#expr ctxt t) "to_buffer"$ buffer $cast$ >>, <:match_case< $`int:n$ -> ($mproject (self#expr ctxt t) "from_stream"$ stream :> a) >> method case ctxt (ctor,args) n = match args with | [] -> (<:match_case< $uid:ctor$ -> Dump_int.to_buffer buffer $`int:n$ >>, <:match_case< $`int:n$ -> $uid:ctor$ >>) | _ -> let nargs = List.length args in let patt, exp = tuple nargs in let dump, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) args) in <:match_case< $uid:ctor$ $patt$ -> Dump_int.to_buffer buffer $`int:n$; $dump$ >>, <:match_case< $`int:n$ -> let $patt$ = $undump$ in $uid:ctor$ $exp$ >> method field ctxt : Type.field -> Ast.expr * Ast.expr = function | (name, _, `Mutable) -> raise (Underivable ("Dump cannot be derived for record types with mutable fields ("^name^")")) | (name, ([], t), _) -> <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:name$ >>, <:expr< $mproject (self#expr ctxt t) "from_stream"$ stream >> | f -> raise (Underivable ("Dump cannot be derived for record types with polymorphic fields")) method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = let msg = "Dump: unexpected tag %d at character %d when deserialising " ^ tname in let dumpers, undumpers = List.split (List.mapn (self#case ctxt) summands) in wrap ~atype:(atype ctxt decl) ~dumpers ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ | n -> raise (Dump_error (Printf.sprintf $str:msg$ n (Stream.count stream))) >> method record ?eq ctxt decl fields = let dumpers, undumpers = List.split (List.map (self#field ctxt) fields) in let undump = List.fold_right2 (fun (field,_,_) undumper e -> <:expr< let $lid:field$ = $undumper$ in $e$ >>) fields undumpers (record_expression fields) in wrap ~atype:(atype ctxt decl) ~undump ~dumpers:[ <:match_case< $record_pattern fields$ -> $List.fold_left1 seq dumpers$ >>] method variant ctxt decl (_, tags) = let msg = "Dump: unexpected tag %d at character %d when deserialising polymorphic variant" in let dumpers, undumpers = List.split (List.mapn (self#polycase ctxt) tags) in wrap ~atype:(atype ctxt decl) ~dumpers:(dumpers @ [ <:match_case< _ -> assert false >>]) ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ | n -> raise (Dump_error (Printf.sprintf $str:msg$ n (Stream.count stream))) >> end end let _ = Base.register "Dump" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ~default_module:"Defaults" ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/eq_class.ml0000644000175000017500000001110310761620645016345 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) let classname = "Eq" let lprefix = "l" and rprefix = "r" let wildcard_failure = <:match_case< _ -> false >> let tup ctxt ts mexpr exp = match ts with | [t] -> <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$ let eq l r = let module M = $exp ctxt t$ in $mexpr$ l r end >> | ts -> let _, (lpatt, rpatt), expr = List.fold_right (fun t (n, (lpatt, rpatt), expr) -> let lid = Printf.sprintf "l%d" n and rid = Printf.sprintf "r%d" n in (n+1, (Ast.PaCom (loc,<:patt< $lid:lid$ >>, lpatt), Ast.PaCom (loc,<:patt< $lid:rid$ >>, rpatt)), <:expr< let module M = $exp ctxt t$ in $mexpr$ $lid:lid$ $lid:rid$ && $expr$ >>)) ts (0, (<:patt< >>, <:patt< >>), <:expr< true >>) in <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$ let eq $Ast.PaTup (loc, lpatt)$ $Ast.PaTup (loc, rpatt)$ = $expr$ end >> let instance = object (self) inherit make_module_expr ~classname ~allow_private:true method tuple ctxt ts = tup ctxt ts <:expr< M.eq >> (self#expr) method polycase ctxt : Type.tagspec -> Ast.match_case = function | Tag (name, None) -> <:match_case< `$name$, `$name$ -> true >> | Tag (name, Some e) -> <:match_case< `$name$ l, `$name$ r -> $mproject (self#expr ctxt e) "eq"$ l r >> | Extends t -> let lpatt, lguard, lcast = cast_pattern ctxt ~param:"l" t in let rpatt, rguard, rcast = cast_pattern ctxt ~param:"r" t in <:match_case< ($lpatt$, $rpatt$) when $lguard$ && $rguard$ -> $mproject (self#expr ctxt t) "eq"$ $lcast$ $rcast$ >> method case ctxt : Type.summand -> Ast.match_case = fun (name,args) -> match args with | [] -> <:match_case< ($uid:name$, $uid:name$) -> true >> | _ -> let nargs = List.length args in let lpatt, lexpr = tuple ~param:"l" nargs and rpatt, rexpr = tuple ~param:"r" nargs in <:match_case< ($uid:name$ $lpatt$, $uid:name$ $rpatt$) -> $mproject (self#expr ctxt (`Tuple args)) "eq"$ $lexpr$ $rexpr$ >> method field ctxt : Type.field -> Ast.expr = function | (name, ([], t), `Immutable) -> <:expr< $mproject (self#expr ctxt t) "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >> | (_, _, `Mutable) -> assert false | f -> raise (Underivable ("Eq cannot be derived for record types with polymorphic fields")) method sum ?eq ctxt decl summands = let wildcard = match summands with [_] -> [] | _ -> [ <:match_case< _ -> false >>] in <:module_expr< struct type a = $atype ctxt decl$ let eq l r = match l, r with $list:List.map (self#case ctxt) summands @ wildcard$ end >> method record ?eq ctxt decl fields = if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then <:module_expr< struct type a = $atype ctxt decl$ let eq = (==) end >> else let lpatt = record_pattern ~prefix:"l" fields and rpatt = record_pattern ~prefix:"r" fields and expr = List.fold_right (fun f e -> <:expr< $self#field ctxt f$ && $e$ >>) fields <:expr< true >> in <:module_expr< struct type a = $atype ctxt decl$ let eq $lpatt$ $rpatt$ = $expr$ end >> method variant ctxt decl (spec, tags) = <:module_expr< struct type a = $atype ctxt decl$ let eq l r = match l, r with $list:List.map (self#polycase ctxt) tags$ | _ -> false end >> end end let _ = Base.register "Eq" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ~default_module:"Defaults" ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/typeable_class.ml0000644000175000017500000000477310761620667017570 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Type open Base open Camlp4.PreCast include Base.InContext(L) let classname = "Typeable" let mkName : name -> string = let file_name, sl, _, _, _, _, _, _ = Loc.to_tuple loc in Printf.sprintf "%s_%d_%f_%s" file_name sl (Unix.gettimeofday ()) let gen ?eq ctxt ((tname,_,_,_,_) as decl : Type.decl) _ = let paramList = List.fold_right (fun (p,_) cdr -> <:expr< $uid:NameMap.find p ctxt.argmap$.type_rep::$cdr$ >>) ctxt.params <:expr< [] >> in <:module_expr< struct type a = $atype ctxt decl$ let type_rep = TypeRep.mkFresh $str:mkName tname$ $paramList$ end >> let tup ctxt ts mexpr expr = let params = expr_list (List.map (fun t -> <:expr< let module M = $expr ctxt t$ in $mexpr$ >>) ts) in <:module_expr< Defaults(struct type a = $atype_expr ctxt (`Tuple ts)$ let type_rep = Typeable.TypeRep.mkTuple $params$ end) >> let instance = object(self) inherit make_module_expr ~classname ~allow_private:true method tuple ctxt ts = tup ctxt ts <:expr< M.type_rep >> (self#expr) method sum = gen method record = gen method variant ctxt decl (_,tags) = let tags, extends = List.fold_left (fun (tags, extends) -> function | Tag (l, None) -> <:expr< ($str:l$, None) :: $tags$ >>, extends | Tag (l,Some t) -> <:expr< ($str:l$, Some $mproject (self#expr ctxt t) "type_rep"$) ::$tags$ >>, extends | Extends t -> tags, <:expr< $mproject (self#expr ctxt t) "type_rep"$::$extends$ >>) (<:expr< [] >>, <:expr< [] >>) tags in <:module_expr< Defaults( struct type a = $atype ctxt decl$ let type_rep = Typeable.TypeRep.mkPolyv $tags$ $extends$ end) >> end end let _ = Base.register "Typeable" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ~default_module:"Defaults" ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/id.ml0000644000175000017500000000005210636601562015146 0ustar jeremyjeremylet name = "deriving" let version = "0.1" deriving-0.1.1/syntax/pickle_class.ml0000644000175000017500000002470610761620660017221 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) module UT = Type.Untranslate(L) let typeable_defaults t = <:module_expr< Typeable.Defaults($t$) >> module Typeable = Typeable_class.InContext(L) module Eq = Eq_class.InContext(L) let classname = "Pickle" let bind, seq = let bindop = ">>=" and seqop = ">>" in <:expr< $lid:bindop$ >>, <:expr< $lid:seqop$ >> let unpickle_record_bindings ctxt (tname,params,rhs,cs,_) (fields : field list) e = <:expr< let module Mutable = struct type t = $UT.repr (instantiate_modargs_repr ctxt (Record (List.map (fun (n,p,_) -> (n,p,`Mutable)) fields)))$ end in $e$ >> let unpickle_record ctxt (tname,_,_,_,_ as decl) fields expr = let msg = "unexpected object encountered unpickling "^tname in let assignments = List.fold_right (fun (id,_,_) exp -> <:expr< this.Mutable.$lid:id$ <- $lid:id$; $exp$ >>) fields <:expr< return self >> in let inner = List.fold_right (fun (id,([],t),_) exp -> <:expr< $bind$ ($mproject (expr ctxt t) "unpickle"$ $lid:id$) (fun $lid:id$ -> $exp$) >>) fields assignments in let idpat = patt_list (List.map (fun (id,_,_) -> <:patt< $lid:id$ >>) fields) in unpickle_record_bindings ctxt decl fields (<:expr< W.record (fun self -> function | $idpat$ -> let this = (Obj.magic self : Mutable.t) in $inner$ | _ -> raise (UnpicklingError $str:msg$)) $`int:List.length fields$ >>) let pickle_record ctxt decl fields expr = let inner = List.fold_right (fun (id,([],t),_) e -> <:expr< $bind$ ($mproject (expr ctxt t) "pickle"$ $lid:id$) (fun $lid:id$ -> $e$) >>) fields <:expr< (W.store_repr this (Repr.make $expr_list (List.map (fun (id,_,_) -> <:expr< $lid:id$ >>) fields)$)) >> in [ <:match_case< ($record_pattern fields$ as obj) -> W.allocate obj (fun this -> $inner$) >> ] let typeable_instance ctxt tname = <:module_expr< Typeable.Defaults( $apply_functor <:module_expr< $uid:"Typeable_" ^ tname$ >> (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p ctxt.argmap$.T >>) ctxt.params)$) >> let eq_instance ctxt tname = apply_functor <:module_expr< $uid:"Eq_" ^ tname$ >> (List.map (fun (p,_) -> <:module_expr< $uid:NameMap.find p ctxt.argmap$.E >>) ctxt.params) let rebind_params ctxt name : Ast.str_item = NameMap.fold (fun _ param s -> <:str_item< $s$ module $uid:param$ = $uid:param$.$uid:name$ >>) ctxt.argmap <:str_item< >> let wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler = <:module_expr< struct open Eq open Typeable module T = $tymod$ module E = $eqmod$ type a = $atype$ open Write let pickle = let module W = Utils(T)(E) in function $list:picklers$ open Read let unpickle = let module W = Utils(T) in $unpickler$ end >> let instance = object (self) inherit make_module_expr ~classname ~allow_private:false method tuple ctxt ts = let nts = List.length ts in let ids = (List.mapn (fun t n -> (Printf.sprintf "id%d" n, t)) ts) in let eidlist = expr_list (List.map (fun (id,_) -> <:expr< $lid:id$ >>) ids) in let pidlist = patt_list (List.map (fun (id,_) -> <:patt< $lid:id$ >>) ids) in let tpatt,texpr = tuple ~param:"id" nts in let tymod = Typeable.tup ctxt ts <:expr< M.T.type_rep >> (self#expr) and eqmod = Eq.tup ctxt ts <:expr< M.E.eq >> (self#expr) and picklers = let inner = List.fold_right (fun (id,t) expr -> <:expr< $bind$ ($mproject (self#expr ctxt t) "pickle"$ $lid:id$) (fun $lid:id$ -> $expr$) >>) ids <:expr< W.store_repr this (Repr.make $eidlist$) >> in [ <:match_case< ($tpatt$ as obj) -> W.allocate obj (fun this -> $inner$) >>] and unpickler = let msg = "unexpected object encountered unpickling "^string_of_int nts^"-tuple" in let inner = List.fold_right (fun (id,t) expr -> <:expr< $bind$ ($mproject (self#expr ctxt t) "unpickle"$ $lid:id$) (fun $lid:id$ -> $expr$) >>) ids <:expr< return $texpr$ >> in <:expr< W.tuple (function | $pidlist$ -> $inner$ | _ -> raise (UnpicklingError $str:msg$)) >> and atype = atype_expr ctxt (`Tuple ts) in <:module_expr< Pickle.Defaults($wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler$) >> method polycase ctxt tagspec : Ast.match_case = match tagspec with | Tag (name, None) -> <:match_case< (`$name$ as obj) -> W.allocate obj (fun thisid -> W.store_repr thisid (Repr.make ~constructor:$`int:(tag_hash name)$ [])) >> | Tag (name, Some t) -> <:match_case< (`$name$ v1 as obj) -> W.allocate obj (fun thisid -> $bind$ ($mproject (self#expr ctxt t) "pickle"$ v1) (fun mid -> (W.store_repr thisid (Repr.make ~constructor:$`int:(tag_hash name)$ [mid])))) >> | Extends t -> let patt, guard, cast = cast_pattern ctxt t in <:match_case< ($patt$ as obj) when $guard$ -> ($mproject (self#expr ctxt t) "pickle"$ $cast$) >> method polycase_un ctxt tagspec : Ast.match_case = match tagspec with | (name, None) -> <:match_case< $`int:(tag_hash name)$, [] -> return `$name$ >> | (name, Some t) -> <:match_case< $`int:(tag_hash name)$, [x] -> $bind$ ($mproject (self#expr ctxt t) "unpickle"$ x) (fun o -> return (`$name$ o)) >> method extension ctxt tname ts : Ast.match_case = (* Try each extension in turn. If we get an UnknownTag failure, try the next one. This is * safe because any two extensions that define the same tag must be compatible at that point * fast because we can tell on the first integer comparison whether we've picked the right path or not. *) let inner = List.fold_right (fun t exp -> <:expr< let module M = $(self#expr ctxt t)$ in try $exp$ with UnknownTag (n,_) -> (M.unpickle id :> a Read.m) >>) ts <:expr< raise (UnknownTag (n, ($str:"Unexpected tag encountered during unpickling of " ^tname$))) >> in <:match_case< n,_ -> $inner$ >> method variant ctxt (tname,_,_,_,_ as decl) (_, tags) = let unpickler = let tags, extensions = either_partition (function Tag (name,t) -> Left (name,t) | Extends t -> Right t) tags in let tag_cases = List.map (self#polycase_un ctxt) tags in let extension_case = self#extension ctxt tname extensions in <:expr< fun id -> W.sum (function $list:tag_cases @ [extension_case]$) id >> in wrap ~ctxt ~atype:(atype ctxt decl) ~tymod:(typeable_instance ctxt tname) ~eqmod:(eq_instance ctxt tname) ~picklers:(List.map (self#polycase ctxt) tags) ~unpickler method case ctors ctxt (name, params') n : Ast.match_case * Ast.match_case = let nparams = List.length params' in let ids = List.map (fun n -> <:expr< $lid:Printf.sprintf "id%d" n$ >>) (List.range 0 nparams) in let exp = List.fold_right2 (fun p n tail -> <:expr< $bind$ ($mproject (self#expr ctxt p) "pickle"$ $lid:Printf.sprintf "v%d" n$) (fun $lid:Printf.sprintf "id%d" n$ -> $tail$)>>) params' (List.range 0 nparams) <:expr< W.store_repr thisid (Repr.make ~constructor:$`int:n$ $expr_list ids$) >> in match params' with | [] -> <:match_case< $uid:name$ as obj -> W.allocate obj (fun thisid -> $exp$) >>, <:match_case< $`int:n$, [] -> return $uid:name$ >> | _ -> <:match_case< $uid:name$ $fst (tuple ~param:"v" nparams)$ as obj -> W.allocate obj (fun thisid -> $exp$) >>, let _, tuple = tuple ~param:"id" nparams in let patt, exp = List.fold_right2 (fun n t (pat, exp) -> let m = Printf.sprintf "M%d" n and id = Printf.sprintf "id%d" n in <:patt< $lid:id$ :: $pat$ >>, <:expr< let module $uid:m$ = $self#expr ctxt t$ in $bind$ ($uid:m$.unpickle $lid:id$) (fun $lid:id$ -> $exp$) >>) (List.range 0 nparams) params' (<:patt< [] >>, <:expr< return ($uid:name$ $tuple$) >>) in <:match_case< $`int:n$, $patt$ -> $exp$ >> method sum ?eq ctxt (tname,_,_,_,_ as decl) summands = let nctors = List.length summands in let picklers, unpicklers = List.split (List.mapn (self#case nctors ctxt) summands) in wrap ~ctxt ~atype:(atype ctxt decl) ~tymod:(typeable_instance ctxt tname) ~eqmod:(eq_instance ctxt tname) ~picklers ~unpickler:<:expr< fun id -> let f = function $list:unpicklers$ | n,_ -> raise (UnpicklingError ($str:"Unexpected tag when unpickling " ^tname^": "$^ string_of_int n)) in W.sum f id >> method record ?eq ctxt (tname,_,_,_,_ as decl) (fields : Type.field list) = wrap ~ctxt ~atype:(atype ctxt decl) ~picklers:(pickle_record ctxt decl fields (self#expr)) ~unpickler:(unpickle_record ctxt decl fields (self#expr)) ~tymod:(typeable_instance ctxt tname) ~eqmod:(eq_instance ctxt tname) end end let _ = Base.register "Pickle" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ~default_module:"Defaults" ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/utils.ml0000644000175000017500000001401210761620671015714 0ustar jeremyjeremy(* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) type ('a,'b) either = Left of 'a | Right of 'b let either_partition (f : 'a -> ('b, 'c) either) (l : 'a list) : 'b list * 'c list = let rec aux (lefts, rights) = function | [] -> (List.rev lefts, List.rev rights) | x::xs -> match f x with | Left l -> aux (l :: lefts, rights) xs | Right r -> aux (lefts, r :: rights) xs in aux ([], []) l module List = struct include List let fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a = fun f l -> match l with | x::xs -> List.fold_left f x xs | [] -> invalid_arg "fold_left1" let rec fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a = fun f l -> match l with | [x] -> x | x::xs -> f x (fold_right1 f xs) | [] -> invalid_arg "fold_right1" let rec range from upto = let rec aux f t result = if f = t then result else aux (f+1) t (f::result) in if upto < from then raise (Invalid_argument "range") else List.rev (aux from upto []) let rec last : 'a list -> 'a = function | [] -> invalid_arg "last" | [x] -> x | _::xs -> last xs let concat_map f l = let rec aux = function | _, [] -> [] | f, x :: xs -> f x @ aux (f, xs) in aux (f,l) let concat_map2 (f : 'a -> 'b -> 'c list) (l1 : 'a list) (l2 : 'b list) : 'c list = let rec aux = function | [], [] -> [] | x::xs, y :: ys -> f x y @ aux (xs, ys) | _ -> invalid_arg "concat_map2" in aux (l1, l2) let mapn ?(init=0) f = let rec aux n = function | [] -> [] | x::xs -> f x n :: aux (n+1) xs in aux init end module F = struct let id x = x let curry f x y = f (x,y) let uncurry f (x,y) = f x y end module Option = struct let map f = function | None -> None | Some x -> Some (f x) end module DumpAst = struct open Camlp4.PreCast.Ast let rec ident = function | IdAcc (_, i1, i2) -> "IdAcc ("^ident i1^","^ident i2^")" | IdApp (_, i1, i2) -> "IdApp ("^ident i1^","^ident i2^")" | IdLid (_, s) -> "IdLid("^s^")" | IdUid (_, s) -> "IdUid("^s^")" | IdAnt (_, s) -> "IdAnt("^s^")" let rec ctyp = function | TyLab (_, s, c) -> "TyLab ("^s ^ "," ^ ctyp c ^")" | TyDcl (_, s, cs, c2, ccs) -> "TyDcl ("^s ^", [" ^ String.concat ";" (List.map ctyp cs) ^"], "^ctyp c2 ^ ", ["^ String.concat "," (List.map (fun (c1,c2) -> "(" ^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")") ccs) ^ "])" | TyObj (_, c, _) -> "TyObj ("^ ctyp c ^ ", ?)" | TyOlb (_, s, c) -> "TyOlb ("^s ^ "," ^ ctyp c ^")" | TyOf (_, c1, c2) -> "TyOf ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" | TyOr (_, c1, c2) -> "TyOr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^ ")" | TyRec (_, c) -> "TyRec("^ctyp c^")" | TySum (_, c) -> "TySum("^ctyp c^")" | TyPrv (_, c) -> "TyPrv("^ctyp c^")" | TyMut (_, c) -> "TyMut("^ctyp c^")" | TyTup (_, c) -> "TyTup("^ctyp c^")" | TyVrnEq (_, c) -> "TyVrnEq("^ctyp c^")" | TyVrnSup (_, c) -> "TyVrnSup("^ctyp c^")" | TyVrnInf (_, c) -> "TyVrnInf("^ctyp c^")" | TyCls (_, i) -> "TyCls("^ident i^")" | TyId (_, i) -> "TyId("^ident i^")" | TyNil (_) -> "TyNil" | TyAli (_, c1, c2) -> "TyAli ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAny (_) -> "TyAny" | TyApp (_, c1, c2) -> "TyApp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyArr (_, c1, c2) -> "TyArr ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyMan (_, c1, c2) -> "TyMan ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyPol (_, c1, c2) -> "TyPol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyQuo (_, s) -> "TyQuo("^s^")" | TyQuP (_, s) -> "TyQuP("^s^")" | TyQuM (_, s) -> "TyQuM("^s^")" | TyVrn (_, s) -> "TyVrn("^s^")" | TyCol (_, c1, c2) -> "TyCol ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TySem (_, c1, c2) -> "TySem ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyCom (_, c1, c2) -> "TyCom ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAnd (_, c1, c2) -> "TyAnd ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TySta (_, c1, c2) -> "TySta ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyVrnInfSup (_, c1, c2) -> "TyVrnInfSup ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")" | TyAnt (_, s) -> "TyAnt("^s^")" end module StringMap = struct include Map.Make(String) exception NotFound of string let find s m = try find s m with Not_found -> raise (NotFound s) let fromList : (key * 'a) list -> 'a t = fun elems -> List.fold_right (F.uncurry add) elems empty let union_disjoint2 l r = fold (fun k v r -> if mem k r then invalid_arg "union_disjoint" else add k v r) l r let union_disjoint maps = List.fold_right union_disjoint2 maps empty end module Set = struct module type OrderedType = Set.OrderedType module type S = sig include Set.S val fromList : elt list -> t end module Make (Ord : OrderedType) = struct include Set.Make(Ord) let fromList elems = List.fold_right add elems empty end end let random_id length = let idchars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_'" in let nidchars = String.length idchars in let s = String.create length in for i = 0 to length - 1 do s.[i] <- idchars.[Random.int nidchars] done; s (* The function used in OCaml to convert variant labels to their integer representations. The formula is given in Jacques Garrigue's 1998 ML workshop paper. *) let tag_hash s = let wrap = 0x40000000 in let acc = ref 0 in let mul = ref 1 in let len = String.length s in for i = 0 to len - 1 do let c = String.unsafe_get s (len - i - 1) in let n = Char.code c in acc := (!acc + n * !mul) mod wrap; mul := (!mul * 223) mod wrap; done; !acc let _ = (* Sanity check to make sure the function doesn't change underneath us *) assert (tag_hash "premiums" = tag_hash "squigglier"); assert (tag_hash "deriving" = 398308260) deriving-0.1.1/syntax/type.ml0000644000175000017500000004121110761620665015541 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* More convenient representation for types, and translation from the Camlp4 representation *) open Utils (* auxiliary definitions *) type name = string type qname = name list module NameMap = StringMap module NameSet = Set.Make(String) type param = name * [`Plus | `Minus] option (* no support for private types yet *) type decl = name * param list * rhs * constraint_ list (* whether the type was inserted by deriving *) * bool and rhs = [`Fresh of expr option * repr * [`Private|`Public] |`Expr of expr |`Variant of variant |`Nothing] and repr = Sum of summand list | Record of field list and field = name * poly_expr * [`Mutable | `Immutable] and summand = name * expr list and constraint_ = expr * expr and expr = (* elements that can be nested *) [ `Param of param | `Label of ([`Optional|`NonOptional] * name * expr * expr) | `Function of (expr * expr) | `Constr of (qname * expr list) | `Tuple of expr list | `Object of [`NYI] | `Class of [`NYI] ] and poly_expr = param list * expr (* no support for < > variants yet. no support for '&' yet. *) and variant = [`Gt | `Lt | `Eq] * tagspec list and tagspec = Tag of name * expr option | Extends of expr class virtual ['result] fold = object (self : 'self) method virtual crush : 'result list -> 'result method decl (d:decl) = self#crush (match d with | (_, _, rhs, cs,_) -> self#rhs rhs :: List.map self#constraint_ cs) method rhs (r:rhs) = self#crush (match r with | `Fresh (Some e, r, _) -> [self#expr e; self#repr r] | `Fresh (None, r, _) -> [self#repr r] | `Expr e -> [self#expr e] | `Variant v -> [self#variant v] | `Nothing -> []) method repr r = self#crush (match r with | Sum summands -> List.map self#summand summands | Record fields -> List.map self#field fields) method field (name, pexpr, flag) = self#crush [self#poly_expr pexpr] method summand (_,es) = self#crush (List.map self#expr es) method constraint_ (e1,e2) = self#crush [self#expr e1; self#expr e2] method expr e = self#crush (match e with `Param _ | `Object _ | `Class _ -> [] | `Label (_, _, e1, e2) | `Function (e1, e2) -> [self#expr e1; self#expr e2] | `Constr (_, exprs) | `Tuple exprs -> List.map self#expr exprs) method poly_expr (params,e) = self#crush [self#expr e] method variant (_,tagspecs) = self#crush (List.map self#tagspec tagspecs) method tagspec t = self#crush (match t with Tag (_, None) -> [] | Tag (_, Some e) | Extends e -> [self#expr e]) end class transform = object (self : 'self) method decl (name, params, rhs, constraints,g:decl) : decl = (name, params, self#rhs rhs, List.map (self # constraint_) constraints, g) method rhs = function | `Fresh (eopt, repr, p) -> `Fresh (Option.map (self # expr) eopt, self # repr repr, p) | `Expr e -> `Expr (self # expr e) | `Variant v -> `Variant (self # variant v) | `Nothing -> `Nothing method repr = function | Sum summands -> Sum (List.map (self # summand) summands) | Record fields -> Record (List.map (self # field) fields) method field (name, poly_expr, flag) = (name, self # poly_expr poly_expr, flag) method summand (name, exprs) = (name, List.map (self # expr) exprs) method constraint_ (e1, e2) = (self#expr e1, self#expr e2) method expr = function | `Object _ | `Class _ | `Param _ as e -> e | `Label (flag, name, e1, e2) -> `Label (flag, name, self # expr e1, self # expr e2) | `Function (e1, e2) -> `Function (self # expr e1, self # expr e2) | `Constr (qname, exprs) -> `Constr (qname, List.map (self # expr) exprs) | `Tuple exprs -> `Tuple (List.map self # expr exprs) method poly_expr (params, expr) = (params, self # expr expr) method variant (t, tagspecs) = (t, List.map (self # tagspec) tagspecs) method tagspec = function | Tag (name, eopt) -> Tag (name, Option.map (self # expr) eopt) | Extends e -> Extends (self # expr e) end module Translate = struct open Camlp4.PreCast let param = function | Ast.TyQuP (loc, name) -> name, Some `Plus | Ast.TyQuM (loc, name) -> name, Some `Minus | Ast.TyQuo (loc, name) -> name, None | _ -> assert false let params = List.map param let split_and = function | Ast.TyAnd (_,l,r) -> Left (l,r) | t -> Right t let split_comma = function | Ast.TyCom (_,l,r) -> Left (l,r) | t -> Right t let split_semi = function | Ast.TySem (_,l,r) -> Left (l,r) | t -> Right t let split_or = function | Ast.TyOr (_,l,r) -> Left (l,r) | t -> Right t let split_amp = function | Ast.TyAmp (_,l,r) -> Left (l,r) | t -> Right t let split_ofamp = function | Ast.TyOfAmp (_,l,r) -> Left (l,r) | t -> Right t let split_star = function | Ast.TySta (_,l,r) -> Left (l,r) | t -> Right t let list (one : Ast.ctyp -> 'a) (split : Ast.ctyp -> (Ast.ctyp * Ast.ctyp, Ast.ctyp) either) : Ast.ctyp -> 'a list = let rec aux = function | Ast.TyNil _ -> [] | ctyp -> match split ctyp with | Left (l,r) -> aux l @ aux r | Right item -> [one item] in aux let ident : Ast.ident -> name = function | Ast.IdAcc _ | Ast.IdAnt _ | Ast.IdApp _ -> assert false | Ast.IdLid (_, i) | Ast.IdUid (_, i) -> i let rec qident : Ast.ident -> qname = function | Ast.IdAcc (_,l,r) -> qident l @ qident r | Ast.IdAnt _ | Ast.IdApp _ -> assert false | Ast.IdLid _ | Ast.IdUid _ as i -> [ident i] type vmap = (name * variant * name option) list let fresh_name, set_name_prefix = let name_prefix = ref "" in let counter = ref 0 in ((fun () -> incr counter; "deriving_" ^ !name_prefix ^ "_" ^ string_of_int !counter), (fun name -> name_prefix := name; counter := 0)) module WithParams(P : sig val params : param list end) = struct include P let apply_t name = `Constr([name], List.map (fun p -> `Param p) params) let rec expr : Ast.ctyp -> expr * vmap = function | Ast.TyObj _ -> `Object `NYI, [] | Ast.TyCls _ -> `Class `NYI, [] | Ast.TyQuP (_,_) | Ast.TyQuM (_,_) | Ast.TyQuo (_,_) as p -> `Param (param p), [] | Ast.TySum _ | Ast.TyRec _ -> failwith "deriving: top level element found nested" | Ast.TyAny _ -> failwith "deriving does not support `_' in type definitions" | Ast.TyArr (_,f,t) -> let f, v1 = expr f and t,v2 = expr t in `Function (f, t), v1 @ v2 | Ast.TyApp _ as app -> let app, v = application app in `Constr app, v | Ast.TyId (_, i) -> `Constr (qident i, []), [] | Ast.TyTup (_, t) -> let es, vs = List.split (list expr split_star t) in `Tuple es, List.concat vs | Ast.TyVrnEq (_, t) -> variant t `Eq | Ast.TyVrnSup (_, t) -> variant t `Gt | Ast.TyVrnInf (_, t) -> variant t `Lt | Ast.TyAli (_, _, Ast.TyQuo (_,name)) when List.mem_assoc name params -> failwith ("Alias names must be distinct from parameter names for " ^"\nderived types, but '"^name^" is both an alias and a parameter") | Ast.TyAli (_, Ast.TyVrnEq (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Eq | Ast.TyAli (_, Ast.TyVrnSup (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Gt | Ast.TyAli (_, Ast.TyVrnInf (_, t), Ast.TyQuo (_,name)) -> variant t ~alias:name `Lt | Ast.TyVrnInfSup (_, _, _) -> failwith "deriving does not currently support [ < > ] variant types" | Ast.TyLab _ -> failwith "deriving does not support label types" | e -> failwith ("unexpected type at expr : " ^ Utils.DumpAst.ctyp e) and tagspec = function | Ast.TyVrn (_,tag) -> Tag (tag, None), [] | Ast.TyOf (_, Ast.TyVrn (_,tag), t) -> let es, vs = List.split (list expr split_comma t) in Tag (tag, Some (`Tuple es)), List.concat vs | t -> let e, v = expr t in Extends e, v and application : Ast.ctyp -> (qname * expr list) * vmap = function | Ast.TyApp (_, (Ast.TyApp _ as a), t) -> let (tcon, args), vs = application a in let e, vs' = expr t in (tcon, args @ [e]), vs @ vs' | Ast.TyApp (_, (Ast.TyId (_, tcon)), t) -> let e, v = expr t in (qident tcon, [e]), v | _ -> assert false and variant tags ?alias spec = let name = fresh_name () in let tags, vs = List.split (list tagspec split_or tags) in (apply_t name, [name, (spec, tags), alias] @ List.concat vs) let rec polyexpr : Ast.ctyp -> poly_expr * vmap = function | Ast.TyPol (_, ps, t) -> begin match polyexpr t with | (ps',t'), [] -> (list param split_comma ps @ ps', t'), [] | _ -> failwith ("deriving does not support polymorphic variant " ^"definitions within polymorphic record field types") end | t -> let e, v = expr t in ([], e), v let field : Ast.ctyp -> field * vmap = function | Ast.TyCol (_, Ast.TyId (_,name), Ast.TyMut (_, t)) -> let p, v = polyexpr t in (ident name, p, `Mutable), v | Ast.TyCol (_, Ast.TyId (_,name), t) -> let p, v = polyexpr t in (ident name, p, `Immutable), v | _ -> assert false let summand : Ast.ctyp -> summand * vmap = function | Ast.TyId (_, c) -> (ident c, []), [] | Ast.TyOf (_, Ast.TyId (_, c), t) -> let es, vs = List.split (list expr split_and t) in (ident c, es), List.concat vs | _ -> assert false let rec repr = function | Ast.TyRec (loc, fields) -> let fields, vs = List.split (list field split_semi fields) in Record fields, List.concat vs | Ast.TySum (loc, summands) -> let summands, vs = List.split (list summand split_or summands) in Sum summands, List.concat vs | e -> failwith ("deriving: unexpected representation type ("^Utils.DumpAst.ctyp e^")") let toplevel : Ast.ctyp -> rhs * vmap = function | Ast.TyPrv (_, (Ast.TyRec _ | Ast.TySum _ as r)) -> let repr, vs = repr r in `Fresh (None, repr, `Private), vs | Ast.TyRec _ | Ast.TySum _ as r -> let repr, vs = repr r in `Fresh (None, repr, `Public), vs | Ast.TyVrnEq (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant (`Eq, es), List.concat vs | Ast.TyVrnSup (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant (`Gt, es), List.concat vs | Ast.TyVrnInf (_, t) -> let es, vs = List.split (list tagspec split_or t) in `Variant (`Lt, es), List.concat vs | Ast.TyVrnInfSup (_, _, _) -> failwith "deriving does not currently support [ < > ] types" | Ast.TyNil _ -> `Nothing, [] | Ast.TyPrv _ -> failwith "deriving does not currently support private rows" | Ast.TyMan (_, eq, (Ast.TyRec _ | Ast.TySum _ as r)) -> let repr, v1 = repr r and ex, v2 = expr eq in `Fresh (Some ex, repr, `Public), v1 @ v2 | Ast.TyMan (_, eq, Ast.TyPrv (_, (Ast.TyRec _ | Ast.TySum _ as r))) -> let repr, v1 = repr r and ex, v2 = expr eq in `Fresh (Some ex, repr, `Private), v1 @ v2 | t -> let e, v = expr t in `Expr e, v let constraints : (Ast.ctyp * Ast.ctyp) list -> constraint_ list * vmap = fun cs -> List.fold_right (fun (c1,c2) (es,vs) -> let e1,v1 = expr c1 and e2,v2 = expr c2 in ((e1,e2)::es), (v1 @ v2 @ vs)) cs ([],[]) let declify = let declify1 (name, variant, alias) : decl * (name * expr) option = (name, params, `Variant variant, [], true), Option.map (fun a -> a, apply_t name) alias in List.map declify1 end type alias_map = expr NameMap.t let build_alias_map : (name * expr) option list -> alias_map = fun m -> NameMap.fromList (List.concat_map (function None -> [] | Some e -> [e]) m) let split : Ast.ctyp -> Ast.ctyp list = let rec aux t = match split_and t with | Left (l, r) -> aux l @ aux r | Right t -> [t] in aux let rec decl : Ast.ctyp -> decl list * alias_map = function | Ast.TyDcl (loc, name, ps, rhs, cs) -> set_name_prefix name; let module P = WithParams(struct let params = params ps end) in let tl, vs = P.toplevel rhs in let cs, vcs = P.constraints cs in let decls, aliases = List.split (P.declify (vs @ vcs)) in [(name, P.params, tl, cs, false)] @ decls, build_alias_map aliases | _ -> assert false let substitute_aliases : alias_map -> decl -> decl = fun map -> object inherit transform as super method expr = function | `Param (p,_) when NameMap.mem p map -> NameMap.find p map | e -> super#expr e end # decl let decls : Ast.ctyp -> decl list = fun ctyp -> let decls, aliases = List.split (List.map decl (split ctyp)) in List.concat (List.map (List.map (substitute_aliases (NameMap.union_disjoint aliases))) decls) end module Untranslate (C:sig val loc : Camlp4.PreCast.Ast.Loc.t end) = struct open Camlp4.PreCast open C let param = function | p, None -> <:ctyp< '$lid:p$ >> | p, Some `Plus -> <:ctyp< +'$lid:p$ >> | p, Some `Minus -> <:ctyp< -'$lid:p$ >> let rec qname = function | [] -> assert false | [x] -> <:ident< $lid:x$ >> | x::xs -> <:ident< $uid:x$.$qname xs$ >> let unlist join items translate = List.fold_right join (List.map translate items) (Ast.TyNil loc) let pair l r = Ast.TySta (loc, l,r) let bar l r = <:ctyp< $l$ | $r$ >> let semi l r = <:ctyp< $l$ ; $r$ >> let comma l r = <:ctyp< $l$ , $r$ >> let and_ l r = <:ctyp< $l$ and $r$ >> let expr = let rec expr : expr -> Ast.ctyp = function `Param p -> param p | `Function (f, t) -> <:ctyp< $expr f$ -> $expr t$ >> | `Tuple [t] -> expr t | `Tuple ts -> Ast.TyTup (loc, unlist pair ts expr) | `Constr (tcon, args) -> app (Ast.TyId (loc, qname tcon)) args | _ -> assert false and app f = function | [] -> f | [x] -> <:ctyp< $expr x$ $f$ >> | x::xs -> app (<:ctyp< $expr x$ $f$ >>) xs in expr let poly (params, t) = List.fold_right (fun (p : param) (t : Ast.ctyp) -> Ast.TyPol (loc, param p, t)) params (expr t) let rec rhs : rhs -> Ast.ctyp = function | `Fresh (None, t, `Private) -> <:ctyp< private $repr t$ >> | `Fresh (None, t, `Public) -> repr t | `Fresh (Some e, t, `Private) -> <:ctyp< $expr e$ = private $repr t$ >> | `Fresh (Some e, t, `Public) -> Ast.TyMan (loc, expr e, repr t) | `Expr t -> expr t | `Variant (`Eq, tags) -> <:ctyp< [ $unlist bar tags tagspec$ ] >> | `Variant (`Gt, tags) -> <:ctyp< [> $unlist bar tags tagspec$ ] >> | `Variant (`Lt, tags) -> <:ctyp< [< $unlist bar tags tagspec$ ] >> | `Nothing -> <:ctyp< >> and tagspec = function | Tag (c, None) -> <:ctyp< `$c$ >> | Tag (c, Some t) -> <:ctyp< `$c$ of $expr t$ >> | Extends t -> <:ctyp< $expr t$ >> and summand (name, (args : expr list)) = let args = unlist and_ args expr in <:ctyp< $uid:name$ of $args$ >> and field ((name, t, mut) : field) = match mut with | `Mutable -> <:ctyp< $lid:name$ : mutable $poly t$ >> (* mutable l : t doesn't work; perhaps a camlp4 bug *) | `Immutable -> <:ctyp< $lid:name$ : $poly t$ >> and repr = function | Sum summands -> Ast.TySum (loc, unlist bar summands summand) | Record fields -> <:ctyp< { $unlist semi fields field$ }>> let constraint_ (e1,e2) = (expr e1, expr e2) let decl ((name, params, r, constraints,_): decl) = Ast.TyDcl (loc, name, List.map param params, rhs r, List.map constraint_ constraints) let sigdecl ((name, params, r, constraints, _): decl) = [Ast.TyDcl (loc, name, List.map param params, rhs r, List.map constraint_ constraints)] end deriving-0.1.1/syntax/bounded_class.ml0000644000175000017500000000530010761620640017355 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) let classname = "Bounded" let instance = object (self) inherit make_module_expr ~classname ~allow_private:false method tuple ctxt ts = let minBounds, maxBounds = List.split (List.map (fun t -> let e = self#expr ctxt t in <:expr< let module M = $e$ in M.min_bound >>, <:expr< let module M = $e$ in M.max_bound >>) ts) in <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$ let min_bound = $tuple_expr minBounds$ let max_bound = $tuple_expr maxBounds$ end >> method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = let names = ListLabels.map summands ~f:(function | (name,[]) -> name | (name,_) -> raise (Underivable ("Bounded cannot be derived for the type "^ tname ^" because the constructor "^ name^" is not nullary"))) in <:module_expr< struct type a = $atype ctxt decl$ let min_bound = $uid:List.hd names$ and max_bound = $uid:List.last names$ end >> method variant ctxt decl (_, tags) = let names = ListLabels.map tags ~f:(function | Tag (name, None) -> name | Tag (name, _) -> raise (Underivable ("Bounded cannot be derived because the tag "^ name^" is not nullary")) | _ -> raise (Underivable ("Bounded cannot be derived for this " ^"polymorphic variant type"))) in <:module_expr< struct type a = $atype ctxt decl$ let min_bound = `$List.hd names$ and max_bound = `$List.last names$ end >> (* should perhaps implement this one *) method record ?eq _ (tname,_,_,_,_) = raise (Underivable ("Bounded cannot be derived for record types (i.e. "^ tname^")")) end end let _ = Base.register "Bounded" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~context ~decls ~classname:M.classname)) deriving-0.1.1/syntax/functor_class.ml0000644000175000017500000001406110761620652017424 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) open Camlp4.PreCast module InContext (C : sig val context : Base.context val loc : Camlp4.PreCast.Loc.t end) = struct open C open Type open Utils open Base include Base.InContext(C) let classname = "Functor" let param_map : string NameMap.t = List.fold_right (fun (name,_) map -> NameMap.add name ("f_" ^ name) map) context.params NameMap.empty let tdec, sigdec = let dec name = ("f", context.params, `Expr (`Constr ([name], List.map (fun p -> `Param p) context.params)), [], false) in (fun name -> Untranslate.decl (dec name)), (fun name -> Untranslate.sigdecl (dec name)) let wrapper name expr = let patts :Ast.patt list = List.map (fun (name,_) -> <:patt< $lid:NameMap.find name param_map$ >>) context.params in let rhs = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) patts expr in <:module_expr< struct open Functor type $tdec name$ let map = $rhs$ end >> (* prototype: [[t]] : t -> t[b_i/a_i] [[a_i]] = f_i [[C1|...CN]] = function [[C1]] ... [[CN]] sum [[`C1|...`CN]] = function [[`C1]] ... [[`CN]] variant [[{t1,...tn}]] = fun (t1,tn) -> ([[t1]],[[tn]]) tuple [[{l1:t1; ... ln:tn}]] = fun {l1=t1;...ln=tn} -> {l1=[[t1]];...ln=[[tn]]} record [[(t1,...tn) c]] = c_map [[t1]]...[[tn]] constructor [[a -> b]] = f . [[a]] (where a_i \notin fv(b)) function [[C0]] = C0->C0 nullary constructors [[C1 (t1...tn)]] = C1 t -> C0 ([[t1]] t1...[[tn]] tn) unary constructor [[`C0]] = `C0->`C0 nullary tag [[`C1 t]] = `C1 t->`C0 [[t]] t unary tag *) let rec polycase = function | Tag (name, None) -> <:match_case< `$name$ -> `$name$ >> | Tag (name, Some e) -> <:match_case< `$name$ x -> `$name$ ($expr e$ x) >> | Extends t -> let patt, guard, exp = cast_pattern context t in <:match_case< $patt$ when $guard$ -> $expr t$ $exp$ >> and expr : Type.expr -> Ast.expr = function | t when not (contains_tvars t) -> <:expr< fun x -> x >> | `Param (p,_) -> <:expr< $lid:NameMap.find p param_map$ >> | `Function (f,t) when not (contains_tvars t) -> <:expr< fun f x -> f ($expr f$ x) >> | `Constr (qname, ts) -> List.fold_left (fun fn arg -> <:expr< $fn$ $expr arg$ >>) <:expr< $id:modname_from_qname ~qname ~classname$.map >> ts | `Tuple ts -> tup ts | _ -> raise (Underivable "Functor cannot be derived for this type") and tup = function | [t] -> expr t | ts -> let args, exps = (List.fold_right2 (fun t n (p,e) -> let v = Printf.sprintf "t%d" n in Ast.PaCom (loc, <:patt< $lid:v$ >>, p), Ast.ExCom (loc, <:expr< $expr t$ $lid:v$ >>, e)) ts (List.range 0 (List.length ts)) (<:patt< >>, <:expr< >>)) in let pat, exp = Ast.PaTup (loc, args), Ast.ExTup (loc, exps) in <:expr< fun $pat$ -> $exp$ >> and case = function | (name, []) -> <:match_case< $uid:name$ -> $uid:name$ >> | (name, args) -> let f = tup args and tpatt, texp = tuple (List.length args) in <:match_case< $uid:name$ $tpatt$ -> let $tpatt$ = ($f$ $texp$) in $uid:name$ ($texp$) >> and field (name, (_,t), _) : Ast.expr = <:expr< $expr t$ $lid:name$ >> let rhs = function |`Fresh (_, _, `Private) -> raise (Underivable "Functor cannot be derived for private types") |`Fresh (_, Sum summands, _) -> <:expr< function $list:List.map case summands$ >> |`Fresh (_, Record fields, _) -> <:expr< fun $record_pattern fields$ -> $record_expr (List.map (fun ((l,_,_) as f) -> (l,field f)) fields)$ >> |`Expr e -> expr e |`Variant (_, tags) -> <:expr< function $list:List.map polycase tags$ | _ -> assert false >> | `Nothing -> raise (Underivable "Cannot generate functor instance for the empty type") let maptype name = let ctor_in = `Constr ([name], List.map (fun p -> `Param p) context.params) in let ctor_out = substitute param_map ctor_in (* c[f_i/a_i] *) in List.fold_right (* (a_i -> f_i) -> ... -> c[a_i] -> c[f_i/a_i] *) (fun (p,_) out -> (<:ctyp< ('$lid:p$ -> '$lid:NameMap.find p param_map$) -> $out$>>)) context.params (Untranslate.expr (`Function (ctor_in, ctor_out))) let signature name : Ast.sig_item list = [ <:sig_item< type $list:sigdec name$ >>; <:sig_item< val map : $maptype name$ >> ] let decl (name, _, r, _, _) : Camlp4.PreCast.Ast.module_binding = if name = "f" then raise (Underivable ("deriving: Functor cannot be derived for types called `f'.\n" ^"Please change the name of your type and try again.")) else <:module_binding< $uid:classname ^ "_" ^ name$ : sig $list:signature name$ end = $wrapper name (rhs r)$ >> let gen_sig (tname, params, _, _, generated) = if tname = "f" then raise (Underivable ("deriving: Functor cannot be derived for types called `f'.\n" ^"Please change the name of your type and try again.")) else if generated then <:sig_item< >> else <:sig_item< module $uid:classname ^ "_" ^ tname$ : sig type $tdec tname$ val map : $maptype tname$ end >> end let _ = Base.register "Functor" ((fun (loc, context, decls) -> let module F = InContext(struct let loc = loc and context = context end) in <:str_item< module rec $list:List.map F.decl decls$ >>), (fun (loc, context, decls) -> let module F = InContext(struct let loc = loc and context = context end) in <:sig_item< $list:List.map F.gen_sig decls$>>)) deriving-0.1.1/syntax/show_class.ml0000644000175000017500000001067710761620662016736 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) module InContext (L : Base.Loc) = struct open Base open Utils open Type open Camlp4.PreCast include Base.InContext(L) let classname = "Show" let wrap (ctxt:Base.context) (decl : Type.decl) matches = <:module_expr< struct type a = $atype ctxt decl$ let format formatter = function $list:matches$ end >> let in_a_box box e = <:expr< Format.$lid:box$ formatter 0; $e$; Format.pp_close_box formatter () >> let in_hovbox = in_a_box "pp_open_hovbox" and in_box = in_a_box "pp_open_box" let instance = object (self) inherit make_module_expr ~classname ~allow_private:true method polycase ctxt : Type.tagspec -> Ast.match_case = function | Tag (name, None) -> <:match_case< `$uid:name$ -> Format.pp_print_string formatter $str:"`" ^ name ^" "$ >> | Tag (name, Some e) -> <:match_case< `$uid:name$ x -> $in_hovbox <:expr< Format.pp_print_string formatter $str:"`" ^ name ^" "$; $mproject (self#expr ctxt e) "format"$ formatter x >>$ >> | Extends t -> let patt, guard, cast = cast_pattern ctxt t in <:match_case< $patt$ when $guard$ -> $in_hovbox <:expr< $mproject (self#expr ctxt t) "format"$ formatter $cast$ >>$ >> method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr = match exprs with | [id,t] -> <:expr< $mproject (self#expr ctxt t) "format"$ formatter $lid:id$ >> | exprs -> let fmt = "@[("^ String.concat ",@;" (List.map (fun _ -> "%a") exprs) ^")@]" in List.fold_left (fun f (id, t) -> <:expr< $f$ $mproject (self#expr ctxt t) "format"$ $lid:id$ >>) <:expr< Format.fprintf formatter $str:fmt$ >> exprs method tuple ctxt args = let n = List.length args in let tpatt, _ = tuple n in <:module_expr< Defaults (struct type a = $atype_expr ctxt (`Tuple args)$ let format formatter $tpatt$ = $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ end) >> method case ctxt : Type.summand -> Ast.match_case = fun (name, args) -> match args with | [] -> <:match_case< $uid:name$ -> Format.pp_print_string formatter $str:name$ >> | _ -> let patt, exp = tuple (List.length args) in <:match_case< $uid:name$ $patt$ -> $in_hovbox <:expr< Format.pp_print_string formatter $str:name$; Format.pp_print_break formatter 1 2; $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ >>$ >> method field ctxt : Type.field -> Ast.expr = function | (name, ([], t), _) -> <:expr< Format.pp_print_string formatter $str:name ^ " ="$; $mproject (self#expr ctxt t) "format"$ formatter $lid:name$ >> | f -> raise (Underivable ("Show cannot be derived for record types with polymorphic fields")) method sum ?eq ctxt decl summands = wrap ctxt decl (List.map (self#case ctxt) summands) method record ?eq ctxt decl fields = wrap ctxt decl [ <:match_case< $record_pattern fields$ -> $in_hovbox <:expr< Format.pp_print_char formatter '{'; $List.fold_left1 (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>) (List.map (self#field ctxt) fields)$; Format.pp_print_char formatter '}'; >>$ >>] method variant ctxt decl (_,tags) = wrap ctxt decl (List.map (self#polycase ctxt) tags @ [ <:match_case< _ -> assert false >> ]) end end let _ = Base.register "Show" ((fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.generate ~context ~decls ~make_module_expr:M.instance#rhs ~classname:M.classname ~default_module:"Defaults" ()), (fun (loc, context, decls) -> let module M = InContext(struct let loc = loc end) in M.gen_sigs ~classname:M.classname ~context ~decls)) deriving-0.1.1/syntax/Makefile0000644000175000017500000000220210636601562015657 0ustar jeremyjeremyOCAMLMAKEFILE = ../OCamlMakefile OCAMLC = ocamlc.opt OCAMLOPT = ocamlopt.opt OCAMLDEP = ocamldep.opt ANNOTATE = yes PPFLAGS = -loc loc USE_CAMLP4 = yes LIBS = camlp4lib unix CAMLP4_PRE_NOPRINTER = CAMLP4_PREFILES = Camlp4Parsers/Camlp4OCamlRevisedParser.cmo \ Camlp4Parsers/Camlp4OCamlParser.cmo \ Camlp4Printers/Camlp4AutoPrinter.cmo CAMLP4_POSTFILES = Camlp4Bin.cmo CAMLP4_NATIVE_PREFILES=$(CAMLP4_PREFILES:.cmo=.cmx) CAMLP4_NATIVE_POSTFILES=$(CAMLP4_POSTFILES:.cmo=.cmx) SOURCES = id.ml \ utils.ml \ type.ml \ base.ml \ extend.ml \ show_class.ml \ dump_class.ml \ enum_class.ml \ bounded_class.ml \ eq_class.ml \ typeable_class.ml \ functor_class.ml \ pickle_class.ml \ RESULT = deriving all: exe include $(OCAMLMAKEFILE) exe: $(IMPL_CMO) $(OCAMLC) -linkall $(ALL_LDFLAGS) $(CAMLP4_PREFILES) $(IMPL_CMO) -o deriving $(CAMLP4_POSTFILES) deriving-0.1.1/syntax/extend.ml0000644000175000017500000000670610761620647016061 0ustar jeremyjeremy(*pp camlp4of *) (* Copyright Jeremy Yallop 2007. This file is free software, distributed under the MIT license. See the file COPYING for details. *) (* Extend the OCaml grammar to include the `deriving' clause after type declarations in structure and signatures. *) open Utils module Deriving (Syntax : Camlp4.Sig.Camlp4Syntax) = struct open Camlp4.PreCast include Syntax let fatal_error loc msg = Syntax.print_warning loc msg; exit 1 let display_errors loc f p = try f p with Base.Underivable msg | Failure msg -> fatal_error loc msg let derive proj (loc : Loc.t) tdecls classname = let context = display_errors loc (Base.setup_context loc) tdecls in display_errors loc (proj (Base.find classname)) (loc, context, tdecls) let derive_str loc (tdecls : Type.decl list) classname : Ast.str_item = derive fst loc tdecls classname let derive_sig loc tdecls classname : Ast.sig_item = derive snd loc tdecls classname DELETE_RULE Gram str_item: "type"; type_declaration END DELETE_RULE Gram sig_item: "type"; type_declaration END open Ast EXTEND Gram str_item: [[ "type"; types = type_declaration -> <:str_item< type $types$ >> | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP ","; ")" -> let decls = display_errors loc Type.Translate.decls types in let module U = Type.Untranslate(struct let loc = loc end) in let tdecls = List.map U.decl decls in <:str_item< type $list:tdecls$ $list:List.map (derive_str loc decls) cl$ >> ]] ; sig_item: [[ "type"; types = type_declaration -> <:sig_item< type $types$ >> | "type"; types = type_declaration; "deriving"; "("; cl = LIST0 [x = UIDENT -> x] SEP "," ; ")" -> let decls = display_errors loc Type.Translate.decls types in let module U = Type.Untranslate(struct let loc = loc end) in let tdecls = List.concat_map U.sigdecl decls in let ms = List.map (derive_sig loc decls) cl in <:sig_item< type $list:tdecls$ $list:ms$ >> ]] ; END EXTEND Gram expr: LEVEL "simple" [ [e1 = val_longident ; "<" ; t = ctyp; ">" -> match e1 with | <:ident< $uid:classname$ . $lid:methodname$ >> -> if not (Base.is_registered classname) then fatal_error loc ("deriving: "^ classname ^" is not a known `class'") else let module U = Type.Untranslate(struct let loc = loc end) in let binding = Ast.TyDcl (loc, "inline", [], t, []) in let decls = display_errors loc Type.Translate.decls binding in if List.exists Base.contains_tvars_decl decls then fatal_error loc ("deriving: type variables cannot be used in `method' instantiations") else let tdecls = List.map U.decl decls in let m = derive_str loc decls classname in <:expr< let module $uid:classname$ = struct type $list:tdecls$ $m$ include $uid:classname ^ "_inline"$ end in $uid:classname$.$lid:methodname$ >> | _ -> fatal_error loc ("deriving: this looks a bit like a method application, but " ^"the syntax is not valid"); ]]; END end module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Deriving) deriving-0.1.1/CHANGES0000644000175000017500000000101510636601562013665 0ustar jeremyjeremy------------------------------------------------------------------------------ 0.1.1 Changes from 0.1: * Renamed serialisation classes: Pickle -> Dump Shelve -> Pickle * Made Dump and Pickle interface compatible with each other and more compatible with Marshal. * Bugfix in the tag hash function on 64-bit platforms. * Fixed a bug with a functor application quotation that used revised syntax. ------------------------------------------------------------------------------ 0.1 Initial release deriving-0.1.1/OCamlMakefile0000644000175000017500000007406010636601562015260 0ustar jeremyjeremy########################################################################### # OCamlMakefile # Copyright (C) 1999-2004 Markus Mottl # # For updates see: # http://www.ocaml.info/home/ocaml_sources.html # # $Id: OCamlMakefile,v 1.72 2005/12/09 15:30:50 mottl Exp $ # ########################################################################### # Modified by damien for .glade.ml compilation # Set these variables to the names of the sources to be processed and # the result variable. Order matters during linkage! ifndef SOURCES SOURCES := foo.ml endif export SOURCES ifndef RES_CLIB_SUF RES_CLIB_SUF := _stubs endif export RES_CLIB_SUF ifndef RESULT RESULT := foo endif export RESULT export LIB_PACK_NAME ifndef DOC_FILES DOC_FILES := $(filter %.mli, $(SOURCES)) endif export DOC_FILES export BCSUFFIX export NCSUFFIX ifndef TOPSUFFIX TOPSUFFIX := .top endif export TOPSUFFIX # Eventually set include- and library-paths, libraries to link, # additional compilation-, link- and ocamlyacc-flags # Path- and library information needs not be written with "-I" and such... # Define THREADS if you need it, otherwise leave it unset (same for # USE_CAMLP4)! export THREADS export VMTHREADS export ANNOTATE export USE_CAMLP4 export INCDIRS export LIBDIRS export EXTLIBDIRS export RESULTDEPS export OCAML_DEFAULT_DIRS export LIBS export CLIBS export OCAMLFLAGS export OCAMLNCFLAGS export OCAMLBCFLAGS export OCAMLLDFLAGS export OCAMLNLDFLAGS export OCAMLBLDFLAGS ifndef OCAMLCPFLAGS OCAMLCPFLAGS := a endif export OCAMLCPFLAGS export PPFLAGS export YFLAGS export IDLFLAGS export OCAMLDOCFLAGS export OCAMLFIND_INSTFLAGS export DVIPSFLAGS export STATIC # Add a list of optional trash files that should be deleted by "make clean" export TRASH #################### variables depending on your OCaml-installation ifdef MINGW export MINGW WIN32 := 1 CFLAGS_WIN32 := -mno-cygwin endif ifdef MSVC export MSVC WIN32 := 1 ifndef STATIC CPPFLAGS_WIN32 := -DCAML_DLL endif CFLAGS_WIN32 += -nologo EXT_OBJ := obj EXT_LIB := lib ifeq ($(CC),gcc) # work around GNU Make default value ifdef THREADS CC := cl -MT else CC := cl endif endif ifeq ($(CXX),g++) # work around GNU Make default value CXX := $(CC) endif CFLAG_O := -Fo endif ifdef WIN32 EXT_CXX := cpp EXE := .exe endif ifndef EXT_OBJ EXT_OBJ := o endif ifndef EXT_LIB EXT_LIB := a endif ifndef EXT_CXX EXT_CXX := cc endif ifndef EXE EXE := # empty endif ifndef CFLAG_O CFLAG_O := -o # do not delete this comment (preserves trailing whitespace)! endif export CC export CXX export CFLAGS export CXXFLAGS export LDFLAGS export CPPFLAGS ifndef RPATH_FLAG ifdef ELF_RPATH_FLAG RPATH_FLAG := $(ELF_RPATH_FLAG) else RPATH_FLAG := -R endif endif export RPATH_FLAG ifndef MSVC ifndef PIC_CFLAGS PIC_CFLAGS := -fPIC endif ifndef PIC_CPPFLAGS PIC_CPPFLAGS := -DPIC endif endif export PIC_CFLAGS export PIC_CPPFLAGS BCRESULT := $(addsuffix $(BCSUFFIX), $(RESULT)) NCRESULT := $(addsuffix $(NCSUFFIX), $(RESULT)) TOPRESULT := $(addsuffix $(TOPSUFFIX), $(RESULT)) ifndef OCAMLFIND OCAMLFIND := ocamlfind endif export OCAMLFIND ifndef OCAMLC OCAMLC := ocamlc endif export OCAMLC ifndef OCAMLOPT OCAMLOPT := ocamlopt endif export OCAMLOPT ifndef OCAMLMKTOP OCAMLMKTOP := ocamlmktop endif export OCAMLMKTOP ifndef OCAMLCP OCAMLCP := ocamlcp endif export OCAMLCP ifndef OCAMLDEP OCAMLDEP := ocamldep endif export OCAMLDEP ifndef OCAMLLEX OCAMLLEX := ocamllex endif export OCAMLLEX ifndef OCAMLYACC OCAMLYACC := ocamlyacc endif export OCAMLYACC ifndef OCAMLMKLIB OCAMLMKLIB := ocamlmklib endif export OCAMLMKLIB ifndef OCAML_GLADECC OCAML_GLADECC := lablgladecc2 endif export OCAML_GLADECC ifndef OCAML_GLADECC_FLAGS OCAML_GLADECC_FLAGS := endif export OCAML_GLADECC_FLAGS ifndef CAMELEON_REPORT CAMELEON_REPORT := report endif export CAMELEON_REPORT ifndef CAMELEON_REPORT_FLAGS CAMELEON_REPORT_FLAGS := endif export CAMELEON_REPORT_FLAGS ifndef CAMELEON_ZOGGY CAMELEON_ZOGGY := camlp4o pa_zog.cma pr_o.cmo endif export CAMELEON_ZOGGY ifndef CAMELEON_ZOGGY_FLAGS CAMELEON_ZOGGY_FLAGS := endif export CAMELEON_ZOGGY_FLAGS ifndef OXRIDL OXRIDL := oxridl endif export OXRIDL ifndef CAMLIDL CAMLIDL := camlidl endif export CAMLIDL ifndef CAMLIDLDLL CAMLIDLDLL := camlidldll endif export CAMLIDLDLL ifndef NOIDLHEADER MAYBE_IDL_HEADER := -header endif export NOIDLHEADER export NO_CUSTOM ifndef CAMLP4 CAMLP4 := camlp4 endif export CAMLP4 ifndef REAL_OCAMLFIND ifdef PACKS ifndef CREATE_LIB ifdef THREADS PACKS += threads endif endif empty := space := $(empty) $(empty) comma := , ifdef PREDS PRE_OCAML_FIND_PREDICATES := $(subst $(space),$(comma),$(PREDS)) PRE_OCAML_FIND_PACKAGES := $(subst $(space),$(comma),$(PACKS)) OCAML_FIND_PREDICATES := -predicates $(PRE_OCAML_FIND_PREDICATES) # OCAML_DEP_PREDICATES := -syntax $(PRE_OCAML_FIND_PREDICATES) OCAML_FIND_PACKAGES := $(OCAML_FIND_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) OCAML_DEP_PACKAGES := $(OCAML_DEP_PREDICATES) -package $(PRE_OCAML_FIND_PACKAGES) else OCAML_FIND_PACKAGES := -package $(subst $(space),$(comma),$(PACKS)) OCAML_DEP_PACKAGES := endif OCAML_FIND_LINKPKG := -linkpkg REAL_OCAMLFIND := $(OCAMLFIND) endif endif export OCAML_FIND_PACKAGES export OCAML_DEP_PACKAGES export OCAML_FIND_LINKPKG export REAL_OCAMLFIND ifndef OCAMLDOC OCAMLDOC := ocamldoc endif export OCAMLDOC ifndef LATEX LATEX := latex endif export LATEX ifndef DVIPS DVIPS := dvips endif export DVIPS ifndef PS2PDF PS2PDF := ps2pdf endif export PS2PDF ifndef OCAMLMAKEFILE OCAMLMAKEFILE := OCamlMakefile endif export OCAMLMAKEFILE ifndef OCAMLLIBPATH OCAMLLIBPATH := \ $(shell $(OCAMLC) 2>/dev/null -where || echo /usr/local/lib/ocaml) endif export OCAMLLIBPATH ifndef OCAML_LIB_INSTALL OCAML_LIB_INSTALL := $(OCAMLLIBPATH)/contrib endif export OCAML_LIB_INSTALL ########################################################################### #################### change following sections only if #################### you know what you are doing! # delete target files when a build command fails .PHONY: .DELETE_ON_ERROR .DELETE_ON_ERROR: # for pedants using "--warn-undefined-variables" export MAYBE_IDL export REAL_RESULT export CAMLIDLFLAGS export THREAD_FLAG export RES_CLIB export MAKEDLL export ANNOT_FLAG export C_OXRIDL export SUBPROJS export CFLAGS_WIN32 export CPPFLAGS_WIN32 INCFLAGS := SHELL := /bin/sh MLDEPDIR := ._d BCDIDIR := ._bcdi NCDIDIR := ._ncdi FILTER_EXTNS := %.mli %.ml %.mll %.mly %.idl %.oxridl %.c %.$(EXT_CXX) %.rep %.zog %.glade FILTERED := $(filter $(FILTER_EXTNS), $(SOURCES)) SOURCE_DIRS := $(filter-out ./, $(sort $(dir $(FILTERED)))) FILTERED_REP := $(filter %.rep, $(FILTERED)) DEP_REP := $(FILTERED_REP:%.rep=$(MLDEPDIR)/%.d) AUTO_REP := $(FILTERED_REP:.rep=.ml) FILTERED_ZOG := $(filter %.zog, $(FILTERED)) DEP_ZOG := $(FILTERED_ZOG:%.zog=$(MLDEPDIR)/%.d) AUTO_ZOG := $(FILTERED_ZOG:.zog=.ml) FILTERED_GLADE := $(filter %.glade, $(FILTERED)) DEP_GLADE := $(FILTERED_GLADE:%.glade=$(MLDEPDIR)/%.d) AUTO_GLADE := $(FILTERED_GLADE:.glade=.ml) FILTERED_ML := $(filter %.ml, $(FILTERED)) DEP_ML := $(FILTERED_ML:%.ml=$(MLDEPDIR)/%.d) FILTERED_MLI := $(filter %.mli, $(FILTERED)) DEP_MLI := $(FILTERED_MLI:.mli=.di) FILTERED_MLL := $(filter %.mll, $(FILTERED)) DEP_MLL := $(FILTERED_MLL:%.mll=$(MLDEPDIR)/%.d) AUTO_MLL := $(FILTERED_MLL:.mll=.ml) FILTERED_MLY := $(filter %.mly, $(FILTERED)) DEP_MLY := $(FILTERED_MLY:%.mly=$(MLDEPDIR)/%.d) $(FILTERED_MLY:.mly=.di) AUTO_MLY := $(FILTERED_MLY:.mly=.mli) $(FILTERED_MLY:.mly=.ml) FILTERED_IDL := $(filter %.idl, $(FILTERED)) DEP_IDL := $(FILTERED_IDL:%.idl=$(MLDEPDIR)/%.d) $(FILTERED_IDL:.idl=.di) C_IDL := $(FILTERED_IDL:%.idl=%_stubs.c) ifndef NOIDLHEADER C_IDL += $(FILTERED_IDL:.idl=.h) endif OBJ_C_IDL := $(FILTERED_IDL:%.idl=%_stubs.$(EXT_OBJ)) AUTO_IDL := $(FILTERED_IDL:.idl=.mli) $(FILTERED_IDL:.idl=.ml) $(C_IDL) FILTERED_OXRIDL := $(filter %.oxridl, $(FILTERED)) DEP_OXRIDL := $(FILTERED_OXRIDL:%.oxridl=$(MLDEPDIR)/%.d) $(FILTERED_OXRIDL:.oxridl=.di) AUTO_OXRIDL := $(FILTERED_OXRIDL:.oxridl=.mli) $(FILTERED_OXRIDL:.oxridl=.ml) $(C_OXRIDL) FILTERED_C_CXX := $(filter %.c %.$(EXT_CXX), $(FILTERED)) OBJ_C_CXX := $(FILTERED_C_CXX:.c=.$(EXT_OBJ)) OBJ_C_CXX := $(OBJ_C_CXX:.$(EXT_CXX)=.$(EXT_OBJ)) PRE_TARGETS += $(AUTO_MLL) $(AUTO_MLY) $(AUTO_IDL) $(AUTO_OXRIDL) $(AUTO_ZOG) $(AUTO_REP) $(AUTO_GLADE) ALL_DEPS := $(DEP_ML) $(DEP_MLI) $(DEP_MLL) $(DEP_MLY) $(DEP_IDL) $(DEP_OXRIDL) $(DEP_ZOG) $(DEP_REP) $(DEP_GLADE) MLDEPS := $(filter %.d, $(ALL_DEPS)) MLIDEPS := $(filter %.di, $(ALL_DEPS)) BCDEPIS := $(MLIDEPS:%.di=$(BCDIDIR)/%.di) NCDEPIS := $(MLIDEPS:%.di=$(NCDIDIR)/%.di) ALLML := $(filter %.mli %.ml %.mll %.mly %.idl %.oxridl %.rep %.zog %.glade, $(FILTERED)) IMPLO_INTF := $(ALLML:%.mli=%.mli.__) IMPLO_INTF := $(foreach file, $(IMPLO_INTF), \ $(basename $(file)).cmi $(basename $(file)).cmo) IMPLO_INTF := $(filter-out %.mli.cmo, $(IMPLO_INTF)) IMPLO_INTF := $(IMPLO_INTF:%.mli.cmi=%.cmi) IMPLX_INTF := $(IMPLO_INTF:.cmo=.cmx) INTF := $(filter %.cmi, $(IMPLO_INTF)) IMPL_CMO := $(filter %.cmo, $(IMPLO_INTF)) IMPL_CMX := $(IMPL_CMO:.cmo=.cmx) IMPL_ASM := $(IMPL_CMO:.cmo=.asm) IMPL_S := $(IMPL_CMO:.cmo=.s) OBJ_LINK := $(OBJ_C_IDL) $(OBJ_C_CXX) OBJ_FILES := $(IMPL_CMO:.cmo=.$(EXT_OBJ)) $(OBJ_LINK) EXECS := $(addsuffix $(EXE), \ $(sort $(TOPRESULT) $(BCRESULT) $(NCRESULT))) ifdef WIN32 EXECS += $(BCRESULT).dll $(NCRESULT).dll endif CLIB_BASE := $(RESULT)$(RES_CLIB_SUF) ifneq ($(strip $(OBJ_LINK)),) RES_CLIB := lib$(CLIB_BASE).$(EXT_LIB) endif ifdef WIN32 DLLSONAME := $(CLIB_BASE).dll else DLLSONAME := dll$(CLIB_BASE).so endif NONEXECS := $(INTF) $(IMPL_CMO) $(IMPL_CMX) $(IMPL_ASM) $(IMPL_S) \ $(OBJ_FILES) $(PRE_TARGETS) $(BCRESULT).cma $(NCRESULT).cmxa \ $(NCRESULT).$(EXT_LIB) $(BCRESULT).cmi $(BCRESULT).cmo \ $(NCRESULT).cmi $(NCRESULT).cmx $(NCRESULT).o \ $(RES_CLIB) $(IMPL_CMO:.cmo=.annot) \ $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(LIB_PACK_NAME).cmx $(LIB_PACK_NAME).o ifndef STATIC NONEXECS += $(DLLSONAME) endif ifndef LIBINSTALL_FILES LIBINSTALL_FILES := $(RESULT).mli $(RESULT).cmi $(RESULT).cma \ $(RESULT).cmxa $(RESULT).$(EXT_LIB) $(RES_CLIB) ifndef STATIC ifneq ($(strip $(OBJ_LINK)),) LIBINSTALL_FILES += $(DLLSONAME) endif endif endif export LIBINSTALL_FILES ifdef WIN32 # some extra stuff is created while linking DLLs NONEXECS += $(BCRESULT).$(EXT_LIB) $(BCRESULT).exp $(NCRESULT).exp $(CLIB_BASE).exp $(CLIB_BASE).lib endif TARGETS := $(EXECS) $(NONEXECS) # If there are IDL-files ifneq ($(strip $(FILTERED_IDL)),) MAYBE_IDL := -cclib -lcamlidl endif ifdef USE_CAMLP4 CAMLP4PATH := \ $(shell $(CAMLP4) -where 2>/dev/null || echo /usr/local/lib/camlp4) INCFLAGS := -I $(CAMLP4PATH) CINCFLAGS := -I$(CAMLP4PATH) endif DINCFLAGS := $(INCFLAGS) $(SOURCE_DIRS:%=-I %) $(OCAML_DEFAULT_DIRS:%=-I %) INCFLAGS := $(DINCFLAGS) $(INCDIRS:%=-I %) CINCFLAGS += $(SOURCE_DIRS:%=-I%) $(INCDIRS:%=-I%) $(OCAML_DEFAULT_DIRS:%=-I%) ifndef MSVC CLIBFLAGS += $(SOURCE_DIRS:%=-L%) $(LIBDIRS:%=-L%) \ $(EXTLIBDIRS:%=-L%) $(OCAML_DEFAULT_DIRS:%=-L%) ifeq ($(ELF_RPATH), yes) CLIBFLAGS += $(EXTLIBDIRS:%=-Wl,$(RPATH_FLAG)%) endif endif ifndef PROFILING INTF_OCAMLC := $(OCAMLC) else ifndef THREADS INTF_OCAMLC := $(OCAMLCP) -p $(OCAMLCPFLAGS) else # OCaml does not support profiling byte code # with threads (yet), therefore we force an error. ifndef REAL_OCAMLC $(error Profiling of multithreaded byte code not yet supported by OCaml) endif INTF_OCAMLC := $(OCAMLC) endif endif ifndef MSVC COMMON_LDFLAGS := $(LDFLAGS:%=-ccopt %) $(SOURCE_DIRS:%=-ccopt -L%) \ $(LIBDIRS:%=-ccopt -L%) $(EXTLIBDIRS:%=-ccopt -L%) \ $(EXTLIBDIRS:%=-ccopt -Wl $(OCAML_DEFAULT_DIRS:%=-ccopt -L%)) ifeq ($(ELF_RPATH),yes) COMMON_LDFLAGS += $(EXTLIBDIRS:%=-ccopt -Wl,$(RPATH_FLAG)%) endif else COMMON_LDFLAGS := -ccopt "/link -NODEFAULTLIB:LIBC $(LDFLAGS:%=%) $(SOURCE_DIRS:%=-LIBPATH:%) \ $(LIBDIRS:%=-LIBPATH:%) $(EXTLIBDIRS:%=-LIBPATH:%) \ $(OCAML_DEFAULT_DIRS:%=-LIBPATH:%) " endif CLIBS_OPTS := $(CLIBS:%=-cclib -l%) ifdef MSVC ifndef STATIC # MSVC libraries do not have 'lib' prefix CLIBS_OPTS := $(CLIBS:%=-cclib %.lib) endif endif ifneq ($(strip $(OBJ_LINK)),) ifdef CREATE_LIB OBJS_LIBS := -cclib -l$(CLIB_BASE) $(CLIBS_OPTS) $(MAYBE_IDL) else OBJS_LIBS := $(OBJ_LINK) $(CLIBS_OPTS) $(MAYBE_IDL) endif else OBJS_LIBS := $(CLIBS_OPTS) $(MAYBE_IDL) endif # If we have to make byte-code ifndef REAL_OCAMLC BYTE_OCAML := y # EXTRADEPS is added dependencies we have to insert for all # executable files we generate. Ideally it should be all of the # libraries we use, but it's hard to find the ones that get searched on # the path since I don't know the paths built into the compiler, so # just include the ones with slashes in their names. EXTRADEPS := $(addsuffix .cma,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) SPECIAL_OCAMLFLAGS := $(OCAMLBCFLAGS) REAL_OCAMLC := $(INTF_OCAMLC) REAL_IMPL := $(IMPL_CMO) REAL_IMPL_INTF := $(IMPLO_INTF) IMPL_SUF := .cmo DEPFLAGS := MAKE_DEPS := $(MLDEPS) $(BCDEPIS) ifdef CREATE_LIB override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) ifndef STATIC ifneq ($(strip $(OBJ_LINK)),) MAKEDLL := $(DLLSONAME) ALL_LDFLAGS := -dllib $(DLLSONAME) endif endif endif ifndef NO_CUSTOM ifneq "$(strip $(OBJ_LINK) $(THREADS) $(MAYBE_IDL) $(CLIBS))" "" ALL_LDFLAGS += -custom endif endif ALL_LDFLAGS += $(INCFLAGS) $(OCAMLLDFLAGS) $(OCAMLBLDFLAGS) \ $(COMMON_LDFLAGS) $(LIBS:%=%.cma) CAMLIDLDLLFLAGS := ifdef THREADS ifdef VMTHREADS THREAD_FLAG := -vmthread else THREAD_FLAG := -thread endif ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND ALL_LDFLAGS := unix.cma threads.cma $(ALL_LDFLAGS) endif endif endif # we have to make native-code else EXTRADEPS := $(addsuffix .cmxa,$(foreach i,$(LIBS),$(if $(findstring /,$(i)),$(i)))) ifndef PROFILING SPECIAL_OCAMLFLAGS := $(OCAMLNCFLAGS) PLDFLAGS := else SPECIAL_OCAMLFLAGS := -p $(OCAMLNCFLAGS) PLDFLAGS := -p endif REAL_IMPL := $(IMPL_CMX) REAL_IMPL_INTF := $(IMPLX_INTF) IMPL_SUF := .cmx override CPPFLAGS := -DNATIVE_CODE $(CPPFLAGS) DEPFLAGS := -native MAKE_DEPS := $(MLDEPS) $(NCDEPIS) ALL_LDFLAGS := $(PLDFLAGS) $(INCFLAGS) $(OCAMLLDFLAGS) \ $(OCAMLNLDFLAGS) $(COMMON_LDFLAGS) CAMLIDLDLLFLAGS := -opt ifndef CREATE_LIB ALL_LDFLAGS += $(LIBS:%=%.cmxa) else override CFLAGS := $(PIC_CFLAGS) $(CFLAGS) override CPPFLAGS := $(PIC_CPPFLAGS) $(CPPFLAGS) endif ifdef THREADS THREAD_FLAG := -thread ALL_LDFLAGS := $(THREAD_FLAG) $(ALL_LDFLAGS) ifndef CREATE_LIB ifndef REAL_OCAMLFIND ALL_LDFLAGS := unix.cmxa threads.cmxa $(ALL_LDFLAGS) endif endif endif endif export MAKE_DEPS ifdef ANNOTATE ANNOT_FLAG := -dtypes else endif ALL_OCAMLCFLAGS := $(THREAD_FLAG) $(ANNOT_FLAG) $(OCAMLFLAGS) \ $(INCFLAGS) $(SPECIAL_OCAMLFLAGS) ifdef make_deps -include $(MAKE_DEPS) PRE_TARGETS := endif ########################################################################### # USER RULES # Call "OCamlMakefile QUIET=" to get rid of all of the @'s. QUIET=@ # generates byte-code (default) byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes bc: byte-code byte-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(BCRESULT)" make_deps=yes bcnl: byte-code-nolink top: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(TOPRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes # generates native-code native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes nc: native-code native-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes ncnl: native-code-nolink # generates byte-code libraries byte-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" \ CREATE_LIB=yes \ make_deps=yes bcl: byte-code-library # generates native-code libraries native-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).cmxa \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ CREATE_LIB=yes \ make_deps=yes ncl: native-code-library ifdef WIN32 # generates byte-code dll byte-code-dll: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).dll \ REAL_RESULT="$(BCRESULT)" \ make_deps=yes bcd: byte-code-dll # generates native-code dll native-code-dll: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).dll \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ make_deps=yes ncd: native-code-dll endif # generates byte-code with debugging information debug-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dc: debug-code debug-code-nolink: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) nolink \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dcnl: debug-code-nolink # generates byte-code libraries with debugging information debug-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" make_deps=yes \ CREATE_LIB=yes \ OCAMLFLAGS="-g $(OCAMLFLAGS)" \ OCAMLLDFLAGS="-g $(OCAMLLDFLAGS)" dcl: debug-code-library # generates byte-code for profiling profiling-byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT) \ REAL_RESULT="$(BCRESULT)" PROFILING="y" \ make_deps=yes pbc: profiling-byte-code # generates native-code profiling-native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(NCRESULT) \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ PROFILING="y" \ make_deps=yes pnc: profiling-native-code # generates byte-code libraries profiling-byte-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(BCRESULT).cma \ REAL_RESULT="$(BCRESULT)" PROFILING="y" \ CREATE_LIB=yes \ make_deps=yes pbcl: profiling-byte-code-library # generates native-code libraries profiling-native-code-library: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(RES_CLIB) $(NCRESULT).cmxa \ REAL_RESULT="$(NCRESULT)" PROFILING="y" \ REAL_OCAMLC="$(OCAMLOPT)" \ CREATE_LIB=yes \ make_deps=yes pncl: profiling-native-code-library # packs byte-code objects pack-byte-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) $(BCRESULT).cmo \ REAL_RESULT="$(BCRESULT)" \ PACK_LIB=yes make_deps=yes pabc: pack-byte-code # packs native-code objects pack-native-code: $(PRE_TARGETS) $(QUIET)$(MAKE) -r -f $(OCAMLMAKEFILE) \ $(NCRESULT).cmx $(NCRESULT).o \ REAL_RESULT="$(NCRESULT)" \ REAL_OCAMLC="$(OCAMLOPT)" \ PACK_LIB=yes make_deps=yes panc: pack-native-code # generates HTML-documentation htdoc: doc/$(RESULT)/html # generates Latex-documentation ladoc: doc/$(RESULT)/latex # generates PostScript-documentation psdoc: doc/$(RESULT)/latex/doc.ps # generates PDF-documentation pdfdoc: doc/$(RESULT)/latex/doc.pdf # generates all supported forms of documentation doc: htdoc ladoc psdoc pdfdoc ########################################################################### # LOW LEVEL RULES $(REAL_RESULT): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) \ $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ $(REAL_IMPL) nolink: $(REAL_IMPL_INTF) $(OBJ_LINK) ifdef WIN32 $(REAL_RESULT).dll: $(REAL_IMPL_INTF) $(OBJ_LINK) $(CAMLIDLDLL) $(CAMLIDLDLLFLAGS) $(OBJ_LINK) $(CLIBS) \ -o $@ $(REAL_IMPL) endif %$(TOPSUFFIX): $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(REAL_OCAMLFIND) $(OCAMLMKTOP) \ $(OCAML_FIND_PACKAGES) $(OCAML_FIND_LINKPKG) \ $(ALL_LDFLAGS) $(OBJS_LIBS) -o $@$(EXE) \ $(REAL_IMPL) .SUFFIXES: .mli .ml .cmi .cmo .cmx .cma .cmxa .$(EXT_OBJ) \ .mly .di .d .$(EXT_LIB) .idl %.oxridl .c .$(EXT_CXX) .h .so \ .rep .zog .glade ifndef STATIC ifdef MINGW $(DLLSONAME): $(OBJ_LINK) $(CC) $(CFLAGS) $(CFLAGS_WIN32) $(OBJ_LINK) -shared -o $@ \ -Wl,--whole-archive $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/lib%.a))) \ $(OCAMLLIBPATH)/ocamlrun.a \ -Wl,--export-all-symbols \ -Wl,--no-whole-archive else ifdef MSVC $(DLLSONAME): $(OBJ_LINK) link /NOLOGO /DLL /OUT:$@ $(OBJ_LINK) \ $(wildcard $(foreach dir,$(LIBDIRS),$(CLIBS:%=$(dir)/%.lib))) \ $(OCAMLLIBPATH)/ocamlrun.lib else $(DLLSONAME): $(OBJ_LINK) $(OCAMLMKLIB) $(INCFLAGS) $(CLIBFLAGS) \ -o $(CLIB_BASE) $(OBJ_LINK) $(CLIBS:%=-l%) \ $(OCAMLMKLIB_FLAGS) endif endif endif ifndef LIB_PACK_NAME $(RESULT).cma: $(REAL_IMPL_INTF) $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(ALL_LDFLAGS) \ $(OBJS_LIBS) -o $@ $(OCAMLBLDFLAGS) $(REAL_IMPL) $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(REAL_IMPL_INTF) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(ALL_LDFLAGS) $(OBJS_LIBS) \ $(OCAMLNLDFLAGS) -o $@ $(REAL_IMPL) else ifdef BYTE_OCAML $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo: $(REAL_IMPL_INTF) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmo $(OCAMLLDFLAGS) $(REAL_IMPL) else $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx: $(REAL_IMPL_INTF) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack -o $(LIB_PACK_NAME).cmx $(OCAMLLDFLAGS) $(REAL_IMPL) endif $(RESULT).cma: $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmo $(MAKEDLL) $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -a $(ALL_LDFLAGS) \ $(OBJS_LIBS) -o $@ $(OCAMLBLDFLAGS) $(LIB_PACK_NAME).cmo $(RESULT).cmxa $(RESULT).$(EXT_LIB): $(LIB_PACK_NAME).cmi $(LIB_PACK_NAME).cmx $(EXTRADEPS) $(RESULTDEPS) $(REAL_OCAMLFIND) $(OCAMLOPT) -a $(ALL_LDFLAGS) $(OBJS_LIBS) \ $(OCAMLNLDFLAGS) -o $@ $(LIB_PACK_NAME).cmx endif $(RES_CLIB): $(OBJ_LINK) ifndef MSVC ifneq ($(strip $(OBJ_LINK)),) $(AR) rcs $@ $(OBJ_LINK) endif else ifneq ($(strip $(OBJ_LINK)),) lib -nologo -debugtype:cv -out:$(RES_CLIB) $(OBJ_LINK) endif endif .mli.cmi: $(EXTRADEPS) $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ else \ echo $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp \"$$pp $(PPFLAGS)\" $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ $(REAL_OCAMLFIND) $(INTF_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp "$$pp $(PPFLAGS)" $(THREAD_FLAG) $(ANNOT_FLAG) \ $(OCAMLFLAGS) $(INCFLAGS) $<; \ fi .ml.cmi .ml.$(EXT_OBJ) .ml.cmx .ml.cmo: $(EXTRADEPS) $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(ALL_OCAMLCFLAGS) $<; \ $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c $(ALL_OCAMLCFLAGS) $<; \ else \ echo $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp \"$$pp $(PPFLAGS)\" $(ALL_OCAMLCFLAGS) $<; \ $(REAL_OCAMLFIND) $(REAL_OCAMLC) $(OCAML_FIND_PACKAGES) \ -c -pp "$$pp $(PPFLAGS)" $(ALL_OCAMLCFLAGS) $<; \ fi ifdef PACK_LIB $(REAL_RESULT).cmo $(REAL_RESULT).cmx $(REAL_RESULT).o: $(REAL_IMPL_INTF) $(OBJ_LINK) $(EXTRADEPS) $(REAL_OCAMLFIND) $(REAL_OCAMLC) -pack $(ALL_LDFLAGS) \ $(OBJS_LIBS) -o $@ $(REAL_IMPL) endif .PRECIOUS: %.ml %.ml: %.mll $(OCAMLLEX) $< .PRECIOUS: %.ml %.mli %.ml %.mli: %.mly $(OCAMLYACC) $(YFLAGS) $< $(QUIET)pp=`sed -n -e 's/.*(\*pp \([^*]*\) \*).*/\1/p;q' $<`; \ if [ ! -z "$$pp" ]; then \ mv $*.ml $*.ml.temporary; \ echo "(*pp $$pp $(PPFLAGS)*)" > $*.ml; \ cat $*.ml.temporary >> $*.ml; \ rm $*.ml.temporary; \ mv $*.mli $*.mli.temporary; \ echo "(*pp $$pp $(PPFLAGS)*)" > $*.mli; \ cat $*.mli.temporary >> $*.mli; \ rm $*.mli.temporary; \ fi .PRECIOUS: %.ml %.ml: %.rep $(CAMELEON_REPORT) $(CAMELEON_REPORT_FLAGS) -gen $< .PRECIOUS: %.ml %.ml: %.zog $(CAMELEON_ZOGGY) $(CAMELEON_ZOGGY_FLAGS) -impl $< > $@ .PRECIOUS: %.ml %.ml: %.glade $(OCAML_GLADECC) $(OCAML_GLADECC_FLAGS) $< > $@ .PRECIOUS: %.ml %.mli %.ml %.mli: %.oxridl $(OXRIDL) $< .PRECIOUS: %.ml %.mli %_stubs.c %.h %.ml %.mli %_stubs.c %.h: %.idl $(CAMLIDL) $(MAYBE_IDL_HEADER) $(IDLFLAGS) \ $(CAMLIDLFLAGS) $< $(QUIET)if [ $(NOIDLHEADER) ]; then touch $*.h; fi .c.$(EXT_OBJ): $(OCAMLC) -c -cc "$(CC)" -ccopt "$(CFLAGS) \ $(CPPFLAGS) $(CPPFLAGS_WIN32) \ $(CFLAGS_WIN32) $(CINCFLAGS) $(CFLAG_O)$@ " $< .$(EXT_CXX).$(EXT_OBJ): $(CXX) -c $(CXXFLAGS) $(CINCFLAGS) $(CPPFLAGS) \ -I'$(OCAMLLIBPATH)' \ $< $(CFLAG_O)$@ $(MLDEPDIR)/%.d: %.ml $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ $(DINCFLAGS) $< > $@; \ else \ echo $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ -pp \"$$pp $(PPFLAGS)\" $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(OCAML_DEP_PACKAGES) \ -pp "$$pp $(PPFLAGS)" $(DINCFLAGS) $< > $@; \ fi $(BCDIDIR)/%.di $(NCDIDIR)/%.di: %.mli $(QUIET)if [ ! -d $(@D) ]; then mkdir -p $(@D); fi $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) $(DINCFLAGS) $< > $@; \ else \ echo $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ -pp \"$$pp $(PPFLAGS)\" $(DINCFLAGS) $< \> $@; \ $(REAL_OCAMLFIND) $(OCAMLDEP) $(DEPFLAGS) \ -pp "$$pp $(PPFLAGS)" $(DINCFLAGS) $< > $@; \ fi doc/$(RESULT)/html: $(DOC_FILES) rm -rf $@ mkdir -p $@ $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(OCAMLDOC) -html -d $@ $(OCAMLDOCFLAGS) $(INCFLAGS) $(DOC_FILES); \ $(OCAMLDOC) -html -d $@ $(OCAMLDOCFLAGS) $(INCFLAGS) $(DOC_FILES); \ else \ echo $(OCAMLDOC) -pp \"$$pp $(PPFLAGS)\" -html -d $@ $(OCAMLDOCFLAGS) \ $(INCFLAGS) $(DOC_FILES); \ $(OCAMLDOC) -pp "$$pp $(PPFLAGS)" -html -d $@ $(OCAMLDOCFLAGS) \ $(INCFLAGS) $(DOC_FILES); \ fi doc/$(RESULT)/latex: $(DOC_FILES) rm -rf $@ mkdir -p $@ $(QUIET)pp=`sed -n -e '/^#/d' -e 's/(\*pp \([^*]*\) \*)/\1/p;q' $<`; \ if [ -z "$$pp" ]; then \ echo $(OCAMLDOC) -latex $(OCAMLDOCFLAGS) $(INCFLAGS) \ $(DOC_FILES) -o $@/doc.tex; \ $(OCAMLDOC) -latex $(OCAMLDOCFLAGS) $(INCFLAGS) $(DOC_FILES) \ -o $@/doc.tex; \ else \ echo $(OCAMLDOC) -pp \"$$pp $(PPFLAGS)\" -latex $(OCAMLDOCFLAGS) \ $(INCFLAGS) $(DOC_FILES) -o $@/doc.tex; \ $(OCAMLDOC) -pp "$$pp $(PPFLAGS)" -latex $(OCAMLDOCFLAGS) \ $(INCFLAGS) $(DOC_FILES) -o $@/doc.tex; \ fi doc/$(RESULT)/latex/doc.ps: doc/$(RESULT)/latex cd doc/$(RESULT)/latex && \ $(LATEX) doc.tex && \ $(LATEX) doc.tex && \ $(DVIPS) $(DVIPSFLAGS) doc.dvi -o $(@F) doc/$(RESULT)/latex/doc.pdf: doc/$(RESULT)/latex/doc.ps cd doc/$(RESULT)/latex && $(PS2PDF) $(