allow with constraints to add a type equation to a datatype definition

git-svn-id: http://caml.inria.fr/svn/ocaml/version/3.12@10669 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 25 insertions, 6 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index a722522d3c..005e79b1f9 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -866,6 +866,20 @@ let instance_parameterized_type_2 sch_args sch_lst sch =
   cleanup_types ();
   (ty_args, ty_lst, ty)
 
+let instance_declaration decl =
+  let decl =
+    {decl with type_params = List.map copy decl.type_params;
+     type_manifest = may_map copy decl.type_manifest;
+     type_kind = match decl.type_kind with
+     | Type_abstract -> Type_abstract
+     | Type_variant cl ->
+         Type_variant (List.map (fun (s,tl) -> (s, List.map copy tl)) cl)
+     | Type_record (fl, rr) ->
+         Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)}
+  in
+  cleanup_types ();
+  decl
+
 let instance_class params cty =
   let rec copy_class_type =
     function
diff --git a/typing/ctype.mli b/typing/ctype.mli
index af2c7fd0c2..d7a401841f 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -115,6 +115,7 @@ val instance_parameterized_type:
 val instance_parameterized_type_2:
         type_expr list -> type_expr list -> type_expr ->
         type_expr list * type_expr list * type_expr
+val instance_declaration: type_declaration -> type_declaration
 val instance_class:
         type_expr list -> class_type -> type_expr list * class_type
 val instance_poly:
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index bc2986c41b..f8a5818151 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -771,7 +771,7 @@ let transl_value_decl env valdecl =
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
-let transl_with_constraint env id row_path sdecl =
+let transl_with_constraint env id row_path orig_decl sdecl =
   reset_type_variables();
   Ctype.begin_def();
   let params =
@@ -779,6 +779,10 @@ let transl_with_constraint env id row_path sdecl =
       List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
     with Already_bound ->
       raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
+  let orig_decl = Ctype.instance_declaration orig_decl in
+  let arity_ok = List.length params = orig_decl.type_arity in
+  if arity_ok then
+    List.iter2 (Ctype.unify_var env) params orig_decl.type_params;
   List.iter
     (function (ty, ty', loc) ->
        try
@@ -791,7 +795,7 @@ let transl_with_constraint env id row_path sdecl =
   let decl =
     { type_params = params;
       type_arity = List.length params;
-      type_kind = Type_abstract;
+      type_kind = if arity_ok then orig_decl.type_kind else Type_abstract;
       type_private = sdecl.ptype_private;
       type_manifest =
         begin match sdecl.ptype_manifest with
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index fb7b219beb..f0e742bd89 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -30,7 +30,7 @@ val transl_value_decl:
     Env.t -> Parsetree.value_description -> value_description
 
 val transl_with_constraint:
-    Env.t -> Ident.t -> Path.t option ->
+    Env.t -> Ident.t -> Path.t option -> type_declaration ->
     Parsetree.type_declaration -> type_declaration
 
 val abstract_type_decl: int -> type_declaration
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 992a1cd03b..8ffc54a015 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -123,7 +123,7 @@ let merge_constraint initial_env loc sg lid constr =
         and id_row = Ident.create (s^"#row") in
         let initial_env = Env.add_type id_row decl_row initial_env in
         let newdecl = Typedecl.transl_with_constraint
-                        initial_env id (Some(Pident id_row)) sdecl in
+                        initial_env id (Some(Pident id_row)) decl sdecl in
         check_type_decl env id row_id newdecl decl rs rem;
         let decl_row = {decl_row with type_params = newdecl.type_params} in
         let rs' = if rs = Trec_first then Trec_not else rs in
@@ -131,7 +131,7 @@ let merge_constraint initial_env loc sg lid constr =
     | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
       when Ident.name id = s ->
         let newdecl =
-          Typedecl.transl_with_constraint initial_env id None sdecl in
+          Typedecl.transl_with_constraint initial_env id None decl sdecl in
         check_type_decl env id row_id newdecl decl rs rem;
         Tsig_type(id, newdecl, rs) :: rem
     | (Tsig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
@@ -141,7 +141,7 @@ let merge_constraint initial_env loc sg lid constr =
       when Ident.name id = s ->
         (* Check as for a normal with constraint, but discard definition *)
         let newdecl =
-          Typedecl.transl_with_constraint initial_env id None sdecl in
+          Typedecl.transl_with_constraint initial_env id None decl sdecl in
         check_type_decl env id row_id newdecl decl rs rem;
         real_id := Some id;
         make_next_first rs rem