Introduction de "S with module ... = ..."

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

7 files changed, 39 insertions, 28 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 67a635a59..e0e72247b 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -576,13 +576,15 @@ with_constraints:
   | with_constraints AND with_constraint        { $3 :: $1 }
 ;
 with_constraint:
-    type_parameters label_longident EQUAL core_type
-      { ($2, {ptype_params = $1;
-              ptype_kind = Ptype_abstract;
-              ptype_manifest = Some $4;
-              ptype_loc = symbol_loc()}) }
+    TYPE type_parameters label_longident EQUAL core_type
+      { ($3, Pwith_type {ptype_params = $2;
+                         ptype_kind = Ptype_abstract;
+                         ptype_manifest = Some $5;
+                         ptype_loc = symbol_loc()}) }
     /* used label_longident instead of type_longident to disallow
        functor applications in type path */
+  | MODULE mod_longident EQUAL mod_ext_longident
+      { ($2, Pwith_module $4) }
 ;
 
 /* Core types */
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d2ead64e3..ab2bb20df 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -100,7 +100,7 @@ and module_type_desc =
     Pmty_ident of Longident.t
   | Pmty_signature of signature
   | Pmty_functor of string * module_type * module_type
-  | Pmty_with of module_type * (Longident.t * type_declaration) list
+  | Pmty_with of module_type * (Longident.t * with_constraint) list
 
 and signature = signature_item list
 
@@ -117,6 +117,10 @@ and modtype_declaration =
     Pmodtype_abstract
   | Pmodtype_manifest of module_type
 
+and with_constraint =
+    Pwith_type of type_declaration
+  | Pwith_module of Longident.t
+
 (* Value expressions for the module language *)
 
 type module_expr =
diff --git a/stdlib/map.mli b/stdlib/map.mli
index 99b2dd2db..eb624c8cd 100644
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -66,6 +66,6 @@ module type S =
            not specified. *)
   end
 
-module Make(Ord: OrderedType): (S with key = Ord.t)
+module Make(Ord: OrderedType): (S with type key = Ord.t)
         (* Functor building an implementation of the map structure
            given a totally ordered type. *)
diff --git a/stdlib/set.ml b/stdlib/set.ml
index e7aa9d643..140b7ff47 100644
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -40,7 +40,7 @@ module type S =
     val choose: t -> elt
   end
 
-module Make(Ord: OrderedType): (S with elt = Ord.t) =
+module Make(Ord: OrderedType) =
   struct
     type elt = Ord.t
     type t = Empty | Node of t * elt * t * int
diff --git a/stdlib/set.mli b/stdlib/set.mli
index 899226127..fbb62446d 100644
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -84,6 +84,6 @@ module type S =
            but equal elements will be chosen for equal sets. *)
   end
 
-module Make(Ord: OrderedType): (S with elt = Ord.t)
+module Make(Ord: OrderedType): (S with type elt = Ord.t)
         (* Functor building an implementation of the set structure
            given a totally ordered type. *)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index d6e5092f1..9bf03e1ce 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -28,7 +28,7 @@ type error =
   | Cannot_eliminate_dependency of module_type
   | Signature_expected
   | Structure_expected of module_type
-  | With_unbound_type of Longident.t
+  | With_no_component of Longident.t
   | With_not_abstract of string
   | With_arity_mismatch of string
   | Repeated_name of string * string
@@ -48,35 +48,40 @@ let extract_sig_open env loc mty =
     Tmty_signature sg -> sg
   | _ -> raise(Error(loc, Structure_expected mty))
 
+(* Lookup the type of a module path *)
+
+let type_module_path env loc lid =
+  try
+    Env.lookup_module lid env
+  with Not_found ->
+    raise(Error(loc, Unbound_module lid))
+
 (* Merge one "with" constraint in a signature *)
 
-let merge_constraint env loc sg lid sdecl =
+let merge_constraint env loc sg lid constr =
   let rec merge sg namelist =
-    match (sg, namelist) with
-      ([], _) ->
-        raise(Error(loc, With_unbound_type lid))
-    | (Tsig_type(id, decl) :: rem, [s]) when Ident.name id = s ->
+    match (sg, namelist, constr) with
+      ([], _, _) ->
+        raise(Error(loc, With_no_component lid))
+    | (Tsig_type(id, decl) :: rem, [s], Pwith_type sdecl)
+      when Ident.name id = s ->
         let newdecl = Typedecl.transl_with_constraint env sdecl in
         if decl.type_manifest <> None then
           raise(Error(loc, With_not_abstract s));
         if newdecl.type_arity <> decl.type_arity then
           raise(Error(loc, With_arity_mismatch s));
         Tsig_type(id, newdecl) :: rem
-    | (Tsig_module(id, mty) :: rem, s :: namelist) when Ident.name id = s ->
+    | (Tsig_module(id, mty) :: rem, [s], Pwith_module lid)
+      when Ident.name id = s ->
+        let (path, mty') = type_module_path env loc lid in
+        Tsig_module(id, Mtype.strengthen env mty' path) :: rem
+    | (Tsig_module(id, mty) :: rem, s :: namelist, _) when Ident.name id = s ->
         let newsg = merge (extract_sig env loc mty) namelist in
         Tsig_module(id, Tmty_signature newsg) :: rem
-    | (item :: rem, _) ->
+    | (item :: rem, _, _) ->
         item :: merge rem namelist in
   merge sg (Longident.flatten lid)
 
-(* Lookup and strengthen the type of a module path *)
-
-let type_module_path env loc lid =
-  try
-    Env.lookup_module lid env
-  with Not_found ->
-    raise(Error(loc, Unbound_module lid))
-
 (* Check and translate a module type expression *)
 
 let rec transl_modtype env smty =
@@ -360,8 +365,8 @@ let report_error = function
       print_string "This module is not a structure; it has type";
       print_space(); modtype mty;
       close_box()
-  | With_unbound_type lid ->
-      print_string "The signature constrained by `with' has no type component named";
+  | With_no_component lid ->
+      print_string "The signature constrained by `with' has no component named";
       print_space(); longident lid
   | With_not_abstract s ->
       print_string "In `with' constraint over type "; print_string s;
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 7f36569bf..b6ed35e52 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -30,7 +30,7 @@ type error =
   | Cannot_eliminate_dependency of module_type
   | Signature_expected
   | Structure_expected of module_type
-  | With_unbound_type of Longident.t
+  | With_no_component of Longident.t
   | With_not_abstract of string
   | With_arity_mismatch of string
   | Repeated_name of string * string