first attempt at signature substitution

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

4 files changed, 48 insertions, 2 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index a21fdd8590..d9b9d9e881 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1289,6 +1289,10 @@ 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())) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { ($2, Pwith_module $4) }
 ;
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 0307cea547..d74129ef8b 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -233,6 +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
 
 (* Value expressions for the module language *)
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index d35f74949c..1f829f129d 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -559,6 +559,8 @@ and with_constraint i ppf x =
       line i ppf "Pwith_type\n";
       type_declaration (i+1) ppf td;
   | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
+  | Pwith_typesubst (li,loc) ->
+      line i ppf "Pwith_module %a %a\n" fmt_longident li fmt_location loc;
 
 and module_expr i ppf x =
   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 8c590b4588..0d0a6135d4 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -89,7 +89,14 @@ let check_type_decl env id row_id newdecl decl rs rem =
   let env = if rs = Trec_not then env else add_rec_types env rem in
   Includemod.type_declarations env id newdecl decl
 
+let rec make_params n = function
+    [] -> []
+  | _ :: l -> ("a" ^ string_of_int n) :: make_params (n+1) l
+
+let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none}
+
 let merge_constraint initial_env loc sg lid constr =
+  let real_id = ref None in
   let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
       ([], _, _) ->
@@ -121,9 +128,27 @@ let merge_constraint initial_env loc sg lid constr =
           Typedecl.transl_with_constraint initial_env id None 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 sdecl)
+    | (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))
+      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;
+        real_id := Some id;
+        rem
     | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
       when Ident.name id = s ->
         let (path, mty') = type_module_path initial_env loc lid in
@@ -137,7 +162,21 @@ let merge_constraint initial_env loc sg lid constr =
     | (item :: rem, _, _) ->
         item :: merge (Env.add_item item env) rem namelist row_id in
   try
-    merge initial_env sg (Longident.flatten lid) None
+    let names = Longident.flatten lid in
+    let sg = merge initial_env sg names None in
+    match names, constr with
+      [s], Pwith_typesubst (lid, loc) ->
+        let id =
+          match !real_id with None -> assert false | Some id -> id in
+        let (path, _) =
+          try Env.lookup_type lid initial_env
+          with Not_found ->
+            raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
+        in
+        let sub = Subst.add_type id path Subst.identity in
+        Subst.signature sub sg
+    | _ ->
+        sg
   with Includemod.Error explanation ->
     raise(Error(loc, With_mismatch(lid, explanation)))