Allow polymorphic type fields for classes: Show, Dump and Eq.

lib/deriving_Dump.ml

@@ -220,6 +220,12 @@ module Dump_unit = Defaults (
   end
 )
 
+module Dump_alpha(P: sig type a end) = Defaults(struct
+  type a = P.a
+  let to_buffer _ _ = assert false
+  let from_stream _ = assert false
+end)
+
 module Dump_num = Defaults (
   struct
     (* TODO: a less wasteful dumper for nums.  A good start would be

lib/deriving_Dump.mli

@@ -31,7 +31,9 @@ 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) 
+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) 
+module Dump_via_marshal (P : sig type a end)
+  : Dump with type a = P.a
+module Dump_alpha (P : sig type a end)
   : Dump with type a = P.a

lib/deriving_Eq.ml

@@ -9,8 +9,6 @@ sig
   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
@@ -25,6 +23,7 @@ struct
   let eq = (==)
 end
 
+module Eq_alpha(S : sig type a end) = struct type a = S.a let eq _ _ = assert false 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)

lib/deriving_Eq.mli

@@ -8,11 +8,10 @@ sig
   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_alpha(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

lib/deriving_Pickle.ml

@@ -379,6 +379,7 @@ module Pickle_from_dump
   (E : Eq with type a = P.a)
   (T : Typeable with type a = P.a)
   : Pickle with type a = P.a
+           and type a = E.a
            and type a = T.a = Defaults
   (struct
      type a = T.a

syntax/base.ml

@@ -277,6 +277,31 @@ module Generator(Loc: Loc)(Desc : ClassDescription) = struct
 
     method call_expr ctxt ty name = Helpers.mproject (self#expr ctxt ty) name
 
+    method call_poly_expr ctxt (params, ty : Type.poly_expr) name =
+      match Desc.alpha with
+      | None when params <> [] ->
+	  raise (Underivable
+		 (Desc.classname ^ " cannot be derived for record types "
+		  ^ "with polymorphic fields"))
+      | None -> self#call_expr ctxt ty name
+      | Some mod_name ->
+	let ctxt =
+	  { ctxt with
+	    argmap = List.fold_left
+	      (fun argmap (pname, _) -> NameMap.add pname ["M_"^pname] argmap)
+	      ctxt.argmap params}
+	in
+	let expr = self#call_expr ctxt ty name in
+	List.fold_right
+	  (fun (pname,_) expr ->
+	    (* This is not a function... much more a scope for a type variable... *)
+	    <:expr< fun (type t) ->
+	              let module $uid:"M_"^pname$ =
+			    $uid:Desc.runtimename$.$uid:mod_name$(struct type a = t end) in
+		      $expr$ >>)
+	  params
+	  expr
+
     (* *)
 
     method class_sig argmap ty =

syntax/base.mli

@@ -72,6 +72,7 @@ module Generator(Loc: Loc)(Desc : ClassDescription) : sig
     method wrap: context -> ?default:Type.name option -> Type.expr -> Ast.str_item list -> Ast.module_expr
 
     method call_expr: context -> Type.expr -> string -> Ast.expr
+    method call_poly_expr: context -> Type.poly_expr -> string -> Ast.expr
 
     method virtual proxy: unit -> Type.name option * Ast.ident list
     method virtual sum:

syntax/classes/bounded_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Bounded"
   let runtimename = "Deriving_Bounded"
   let default_module = None
+  let alpha = None
   let allow_private = false
   let predefs = [
     ["unit"], "unit";

syntax/classes/dump_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Dump"
   let runtimename = "Deriving_Dump"
   let default_module = Some "Defaults"
+  let alpha = Some "Dump_alpha"
   let allow_private = false
   let predefs = [
     ["unit"], "unit";
@@ -101,17 +102,13 @@ module Builder(Loc : Defs.Loc) = struct
       wrap dumpers undumpers
 
 
-    method field ctxt (name, (vars, ty), mut) =
+    method field ctxt (name, ty, mut) =
       if mut = `Mutable then
         raise (Base.Underivable
 		 (classname ^ " cannot be derived for record types "
 		  ^ " with mutable fields (" ^ name ^ ")"));
-      if vars <> [] then
-	raise (Base.Underivable
-		 (classname ^ " cannot be derived for record types "
-		  ^ "with polymorphic fields"));
-      <:expr< $self#call_expr ctxt ty "to_buffer"$ buffer $lid:name$ >>,
-      <:binding< $lid:name$ = $self#call_expr ctxt ty "from_stream"$ stream >>
+      <:expr< $self#call_poly_expr ctxt ty "to_buffer"$ buffer $lid:name$ >>,
+      <:binding< $lid:name$ = $self#call_poly_expr ctxt ty "from_stream"$ stream >>
 
     method record ?eq ctxt tname params constraints fields =
        let dumpers, undumpers = List.split (List.map (self#field ctxt) fields) in

syntax/classes/enum_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Enum"
   let runtimename = "Deriving_Enum"
   let default_module = Some "Defaults"
+  let alpha = None
   let allow_private = false
   let predefs = [
     ["int"], "int";

syntax/classes/eq_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Eq"
   let runtimename = "Deriving_Eq"
   let default_module = None
+  let alpha = Some "Eq_alpha"
   let allow_private = true
   let predefs = [
     ["unit"], "unit";
@@ -84,13 +85,9 @@ module Builder(Loc : Defs.Loc) = struct
       wrap (List.map (self#case ctxt) summands @ wildcard)
 
 
-    method field ctxt (name, (vars, ty), mut) =
+    method field ctxt (name, ty, mut) =
       assert(mut <> `Mutable);
-      if vars <> [] then
-	raise (Base.Underivable
-		 (classname ^ " cannot be derived for record types "
-		  ^ "with polymorphic fields"));
-      <:expr< $self#call_expr ctxt ty "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >>
+      <:expr< $self#call_poly_expr ctxt ty "eq"$ $lid:lprefix ^ name$ $lid:rprefix ^ name$ >>
 
     method record ?eq ctxt tname params constraints fields =
       if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then

syntax/classes/functor_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Functor"
   let runtimename = "Deriving_Functor"
   let default_module = None
+  let alpha = None
   let allow_private = false
   let predefs = [
     ["list"], "list";

syntax/classes/pickle_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Pickle"
   let runtimename = "Deriving_Pickle"
   let default_module = Some "Defaults"
+  let alpha = None
   let allow_private = false
   let predefs = [
     ["int"], "int";
@@ -153,11 +154,8 @@ module Builder(Loc : Defs.Loc) = struct
       let ids = List.map (fun (id,_,_) -> <:expr< $lid:id$ >>) fields in
       let expr =
 	<:expr< (W.store_repr this ($uid:runtimename$.Repr.make $Helpers.expr_list ids$)) >> in
-      let bind_field (id,(vars,t),_) e =
-	if vars <> [] then
-	  raise (Base.Underivable (classname ^ " cannot be derived for record types "
-			      ^ "with polymorphic fields"));
-        <:expr< $bind$ ($self#call_expr ctxt t "pickle"$ $lid:id$)
+      let bind_field (id,t,_) e =
+        <:expr< $bind$ ($self#call_poly_expr ctxt t "pickle"$ $lid:id$)
                        (fun $lid:id$ -> $e$) >> in
       let inner = List.fold_right bind_field fields expr in
       <:match_case<
@@ -172,9 +170,8 @@ module Builder(Loc : Defs.Loc) = struct
             <:expr< this.Mutable.$lid:id$ <- $lid:id$; $exp$ >>)
           fields
 	  <:expr< return self >> in
-      let bind_field (id,(vars,t),_) exp =
-	assert (vars = []);
-	<:expr< $bind$ ($self#call_expr ctxt t "unpickle"$ $lid:id$)
+      let bind_field (id,t,_) exp =
+	<:expr< $bind$ ($self#call_poly_expr ctxt t "unpickle"$ $lid:id$)
                        (fun $lid:id$ -> $exp$) >> in
       let inner = List.fold_right bind_field fields assignments in
       let idpat = Helpers.patt_list (List.map (fun (id,_,_) -> <:patt< $lid:id$ >>) fields) in

syntax/classes/show_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Show"
   let runtimename = "Deriving_Show"
   let default_module = Some "Defaults"
+  let alpha = Some "Show_unprintable"
   let allow_private = true
   let predefs = [
     ["int"      ], "int";
@@ -105,13 +106,9 @@ module Builder(Loc : Defs.Loc) = struct
       wrap (List.map (self#case ctxt) summands)
 
 
-    method field ctxt (name, (vars, ty), mut) =
-      if vars <> [] then
-	raise (Base.Underivable (classname
-				 ^ " cannot be derived for record types "
-				 ^ "with polymorphic fields"));
+    method field ctxt (name, ty, mut) =
       <:expr< Format.pp_print_string formatter $str:name ^ " = "$;
-              $self#call_expr ctxt ty "format"$ formatter $lid:name$ >>
+              $self#call_poly_expr ctxt ty "format"$ formatter $lid:name$ >>
 
     method record ?eq ctxt tname params constraints fields =
       let format_fields =

syntax/classes/typeable_class.ml

@@ -10,6 +10,7 @@ module Description : Defs.ClassDescription = struct
   let classname = "Typeable"
   let runtimename = "Deriving_Typeable"
   let default_module = Some "Defaults"
+  let alpha = None
   let allow_private = true
   let predefs = [
     ["int"], "int";

syntax/defs.mli

@@ -33,6 +33,7 @@ module type ClassDescription = sig
   val classname: Type.name
   val runtimename: Type.name
   val default_module: Type.name option
+  val alpha: Type.name option
   val allow_private: bool
   val predefs: (Type.qname * Type.name) list
   val depends: (module FullClassBuilder) list

tests/.depend

@@ -4,22 +4,23 @@ bounded_tests.cmo: defs.cmo
 bounded_tests.cmx: defs.cmx
 defs.cmo:
 defs.cmx:
-defs_simple.cmo: defs_simple.cmi
-defs_simple.cmx: defs_simple.cmi
 dump_tests.cmo: defs.cmo
 dump_tests.cmx: defs.cmx
 enum_tests.cmo: defs.cmo
 enum_tests.cmx: defs.cmx
 eq_tests.cmo: defs.cmo
 eq_tests.cmx: defs.cmx
+exp.cmo: bimap.cmo
+exp.cmx: bimap.cmx
 functor_tests.cmo: defs.cmo
 functor_tests.cmx: defs.cmx
 inline.cmo:
 inline.cmx:
+pickle_tests.cmo: defs.cmo
+pickle_tests.cmx: defs.cmx
 show_tests.cmo:
 show_tests.cmx:
 sigs.cmo: defs.cmo
 sigs.cmx: defs.cmx
 typeable_tests.cmo:
 typeable_tests.cmx:
-defs_simple.cmi:

tests/defs.ml

@@ -24,7 +24,7 @@ type r3 = {
 (* polymorphic records *)
 type r4 = {
   r4_l1 : 'a . 'a list
-} (* deriving (Dump, Eq, Show, Typeable, Pickle) *)
+} deriving (Dump, Eq, Show)
 
 (* label types *)
 type label = x:int -> int
@@ -42,7 +42,7 @@ 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) 
+type uses_seqs = (intseq * float seq)
     deriving (Dump, Eq, Show, Typeable, Pickle)
 
 (* object and class types *)
@@ -63,10 +63,10 @@ type poly2 = P of int * [`T0 | `T1 of int] * float
 
 (* `as'-recursion *)
 type poly3 = [`Nil | `Cons of int * 'c] as 'c
-    deriving (Dump, Eq, Show, Typeable, Pickle) 
+    deriving (Dump, Eq, Show, Typeable, Pickle)
 
 type poly3b = int * ([`Nil | `Cons of int * 'c] as 'c) * [`F]
-    deriving (Dump, Eq, Show, Typeable, Pickle) 
+    deriving (Dump, Eq, Show, Typeable, Pickle)
 
 (* <, >, =, > < polymorphic variants *)
 type 'a poly7 = Foo of [`F of 'a]
@@ -94,6 +94,12 @@ 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 pmutrec_a' = ('a,'a) pmutrec_c'
+and ('a,'b) pmutrec_b' = { pl1' : ('b,'a) pmutrec_c' ; pl2' : 'a pmutrec_a' }
+and ('a,'b) pmutrec_c' = SS' of 'a * 'b pmutrec_a' * 'b | TT' of ('a * ('a,'b,'a) pmutrec_d' * 'b)
+and ('a,'b,'c) pmutrec_d' = [ `S of ('a,'b) pmutrec_b' | `T of ('b,'c) 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
@@ -117,20 +123,20 @@ type withref = WR of int * (int ref)
   deriving (Eq, Show, Typeable, Pickle)
 
 (* through module boundaries *)
-module rec M : sig 
+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 
+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 
+  type 'a t = [`N|`C of 'a P.t]
+(*Doesn't work: results in an unsafe module definition
 *)(*      deriving (Show)*)
 end
 
@@ -139,9 +145,9 @@ type 'a constrained = [`F of 'a] constraint 'a = int
     deriving (Functor) (* Show, etc. don't work here *)
 
 (* private datatypes *)
-type p1 = private P1 
+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 *)
@@ -153,7 +159,7 @@ struct
 end
 
 (* Reusing existing instances *)
-type t = int 
+type t = int
     deriving (Eq, Enum, Bounded, Dump, Show, Typeable, Pickle, Functor)
 
 (* Int32, etc. *)