fix bug in first-class module unpacking

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

6 files changed, 201 insertions, 13 deletions

diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
index 4d8f4b933..78cea214c 100644
--- a/testsuite/tests/typing-gadts/pr5332.ml.reference
+++ b/testsuite/tests/typing-gadts/pr5332.ml.reference
@@ -15,5 +15,5 @@ Warning 8: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (Tbool, Tvar _)
 val f : ('a, 'b) typ -> ('a, 'b) typ -> int = <fun>
-#   Exception: Match_failure ("", 9, 1).
+#   Exception: Match_failure ("//toplevel//", 9, 1).
 # 
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
index db65dae3d..3910059fe 100644
--- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
@@ -114,3 +114,52 @@ let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
     | Pair (module P) ->
         let (x1, x2) = TypEq.apply P.eq x in
         Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module 
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
index 002d30c66..6e2f48617 100644
--- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
@@ -43,7 +43,124 @@ Error: Modules are not allowed in this pattern.
 # module M : S
 #   module type S' = sig val f : int -> int end
 #       - : int = 6
-#                                                                                                                         
-Characters 1465-1465:
-Error: Syntax error
+#                                                                                                                                                                                   module type S = sig type t type u val x : t * u end
+val f :
+  (module S with type t = int and type u = bool) list ->
+  (module S with type u = bool) list = <fun>
+module TypEq :
+  sig
+    type ('a, 'b) t
+    val apply : ('a, 'b) t -> 'a -> 'b
+    val refl : ('a, 'a) t
+    val sym : ('a, 'b) t -> ('b, 'a) t
+  end
+module rec Typ :
+  sig
+    module type PAIR =
+      sig
+        type t
+        and t1
+        and t2
+        val eq : (t, t1 * t2) TypEq.t
+        val t1 : t1 Typ.typ
+        val t2 : t2 Typ.typ
+      end
+    type 'a typ =
+        Int of ('a, int) TypEq.t
+      | String of ('a, string) TypEq.t
+      | Pair of (module PAIR with type t = 'a)
+  end
+val int : int Typ.typ = Int <abstr>
+val str : string Typ.typ = String <abstr>
+val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
+val to_string : 'a Typ.typ -> 'a -> string = <fun>
+module type MapT =
+  sig
+    type key
+    type +'a t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val max_binding : 'a t -> key * 'a
+    val choose : 'a t -> key * 'a
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data
+    type map
+    val of_t : data t -> map
+    val to_t : map -> data t
+  end
+type ('a, 'b, 'c) map =
+    (module MapT with type data = 'b and type key = 'a and type map = 'c)
+val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = <fun>
+module SSMap :
+  sig
+    type key = String.t
+    type 'a t = 'a Map.Make(String).t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val max_binding : 'a t -> key * 'a
+    val choose : 'a t -> key * 'a
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data = string
+    type map = data t
+    val of_t : 'a -> 'a
+    val to_t : 'a -> 'a
+  end
+val ssmap :
+  (module MapT with type data = SSMap.data and type key = SSMap.key and type map = 
+   SSMap.map) =
+  <module>
+#         val ssmap :
+  (module MapT with type data = SSMap.data and type key = String.t and type map = 
+   SSMap.map) =
+  <module>
+#           val ssmap :
+  (module MapT with type data = SSMap.data and type key = String.t and type map = 
+   SSMap.map) =
+  <module>
+#       val ssmap :
+  (module MapT with type data = SSMap.data and type key = SSMap.key and type map = 
+   SSMap.map) =
+  <module>
+#   val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = <module>
+#   - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = <fun>
 # 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 3fcef703d..b148ecfe3 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2043,9 +2043,7 @@ and type_expect ?in_function env sexp ty_expected =
         | _ ->
             raise (Error (loc, Not_a_packed_module ty_expected))
       in
-      let context = Typetexp.narrow () in
       let (modl, tl') = !type_package env m p nl tl in
-      Typetexp.widen context;
       rue {
         exp_desc = Texp_pack modl;
         exp_loc = loc;
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 4bf52b0c4..78cae50db 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -41,6 +41,7 @@ type error =
   | With_need_typeconstr
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
+  | Scoping_pack of string * type_expr
 
 exception Error of Location.t * error
 
@@ -1023,16 +1024,33 @@ let rec get_manifest_types = function
   | _ :: rem -> get_manifest_types rem
 
 let type_package env m p nl tl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  let lv = Ctype.get_current_level () in
+  Ctype.begin_def ();
+  Ident.set_current_time lv;
+  let context = Typetexp.narrow () in
   let modl = type_module env m in
-  if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
-  let msig = extract_sig env modl.mod_loc modl.mod_type in
-  let mtypes = get_manifest_types msig in
-  let tl' =
-    List.map2
-      (fun name ty -> try List.assoc name mtypes with Not_found -> ty)
-      nl tl
+  Ctype.init_def(Ident.current_time());
+  Typetexp.widen context;
+  let (mp, env) =
+    match modl.mod_desc with
+      Tmod_ident mp -> (mp, env)
+    | _ ->
+      let (id, new_env) = Env.enter_module "%M" modl.mod_type env in
+      (Pident id, new_env)
   in
+  let tl' =
+    List.map (fun name -> Ctype.newconstr (Pdot(mp, name, nopos)) []) nl in
+  (* go back to original level *)
+  Ctype.end_def ();
+  if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
   let mty = modtype_of_package env modl.mod_loc p nl tl' in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty))))
+    nl tl';
   (wrap_constraint env modl mty, tl')
 
 (* Fill in the forward declarations *)
@@ -1197,3 +1215,8 @@ let report_error ppf = function
       fprintf ppf
         "The type of this packed module contains variables:@ %a"
         type_expr ty
+  | Scoping_pack (id, ty) ->
+      fprintf ppf
+        "The type %s in this module cannot be exported.@ " id;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 5ca93ae0c..aa2626c6d 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -53,6 +53,7 @@ type error =
   | With_need_typeconstr
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
+  | Scoping_pack of string * type_expr
 
 exception Error of Location.t * error