add parameters to Pwith_typesubst

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/sigsubst@9635 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

7 files changed, 35 insertions, 22 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 033886c13f..ff8c6fa1b1 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1289,10 +1289,15 @@ with_constraint:
                          ptype_loc = symbol_rloc()}) }
     /* used label_longident instead of type_longident to disallow
        functor applications in type path */
-  | TYPE type_parameters label_longident COLONEQUAL type_longident
-      { if $2 <> [] then raise Parse_error;
-        (match $3 with Lident _ -> () | _ -> raise Parse_error);
-        ($3, Pwith_typesubst ($5, symbol_rloc())) }
+  | TYPE type_parameters label_longident COLONEQUAL core_type
+      { let params, variance = List.split $2 in
+        ($3, Pwith_typesubst {ptype_params = params;
+                              ptype_cstrs = [];
+                              ptype_kind = Ptype_abstract;
+                              ptype_manifest = Some $5;
+                              ptype_private = Public;
+                              ptype_variance = variance;
+                              ptype_loc = symbol_rloc()}) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { ($2, Pwith_module $4) }
   | MODULE mod_longident COLONEQUAL mod_ext_longident
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 1e2bc5e916..2f8060473a 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -233,7 +233,7 @@ and modtype_declaration =
 and with_constraint =
     Pwith_type of type_declaration
   | Pwith_module of Longident.t
-  | Pwith_typesubst of Longident.t * Location.t
+  | Pwith_typesubst of type_declaration
   | Pwith_modsubst of Longident.t
 
 (* value expressions for the module language *)
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 7d6fa53d26..cd9ba524dc 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -558,8 +558,9 @@ and with_constraint i ppf x =
   | Pwith_type (td) ->
       line i ppf "Pwith_type\n";
       type_declaration (i+1) ppf td;
-  | Pwith_typesubst (li,loc) ->
-      line i ppf "Pwith_module %a %a\n" fmt_longident li fmt_location loc;
+  | Pwith_typesubst (td) ->
+      line i ppf "Pwith_typesubst\n";
+      type_declaration (i+1) ppf td;
   | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
   | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
 
diff --git a/testlabl/sigsubst.ml b/testlabl/sigsubst.ml
index 53aba27e01..ffddfdfc42 100644
--- a/testlabl/sigsubst.ml
+++ b/testlabl/sigsubst.ml
@@ -20,10 +20,10 @@ module type S = sig type t val f : t -> t end
 module type S' = S with type t := int
 
 module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
-module type S1 = S with type t := list
+module type S1 = S with type 'a t := 'a list
 module type S2 = sig
   type 'a dict = (string * 'a) list
-  include S with type t := dict
+  include S with type 'a t := 'a dict
 end
 
 
diff --git a/tools/depend.ml b/tools/depend.ml
index 18687941f6..9ffac721ab 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -179,7 +179,7 @@ and add_modtype bv mty =
       List.iter
         (function (_, Pwith_type td) -> add_type_declaration bv td
                 | (_, Pwith_module lid) -> addmodule bv lid
-                | (_, Pwith_typesubst (c, _)) -> add bv c
+                | (_, Pwith_typesubst td) -> add_type_declaration bv td
                 | (_, Pwith_modsubst lid) -> addmodule bv lid)
         cstrl
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 74dcf41256..0a9a5395b2 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -40,6 +40,7 @@ type error =
   | Implementation_is_required of string
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
+  | With_need_typeconstr
 
 exception Error of Location.t * error
 
@@ -131,19 +132,9 @@ let merge_constraint initial_env loc sg lid constr =
     | (Tsig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
       when Ident.name id = s ^ "#row" ->
         merge env rem namelist (Some id)
-    | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_typesubst (lid, loc))
+    | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl)
       when Ident.name id = s ->
         (* Check as for a normal with constraint, but discard definition *)
-        let params = make_params 1 decl.type_params in
-        let sdecl =
-          {ptype_params = params;  ptype_cstrs = [];
-           ptype_kind = Ptype_abstract;
-           ptype_manifest = Some
-             {ptyp_desc=Ptyp_constr(lid, List.map wrap_param params);
-              ptyp_loc=loc};
-           ptype_private = Public;
-           ptype_variance = List.map (fun _ -> (false,false)) params;
-           ptype_loc = loc} in
         let newdecl =
           Typedecl.transl_with_constraint initial_env id None sdecl in
         check_type_decl env id row_id newdecl decl rs rem;
@@ -172,9 +163,21 @@ let merge_constraint initial_env loc sg lid constr =
     let names = Longident.flatten lid in
     let sg = merge initial_env sg names None in
     match names, constr with
-      [s], Pwith_typesubst (lid, loc) ->
+      [s], Pwith_typesubst sdecl ->
         let id =
           match !real_id with None -> assert false | Some id -> id in
+        let lid =
+          try match sdecl.ptype_manifest with
+          | Some {ptyp_desc = Ptyp_constr (lid, stl)} ->
+              let params =
+                List.map
+                  (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)
+                  stl in
+              if params <> sdecl.ptype_params then raise Exit;
+              lid
+          | _ -> raise Exit
+          with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
+        in
         let (path, _) =
           try Env.lookup_type lid initial_env with Not_found -> assert false
         in
@@ -1073,3 +1076,6 @@ let report_error ppf = function
   | Not_allowed_in_functor_body ->
       fprintf ppf
         "This kind of expression is not allowed within the body of a functor."
+  | With_need_typeconstr ->
+      fprintf ppf
+        "Only type constructors with identical parameters can be substituted."
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 8a1d28b91f..2dcbd2d608 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -52,6 +52,7 @@ type error =
   | Implementation_is_required of string
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
+  | With_need_typeconstr
 
 exception Error of Location.t * error