#5358: package types allow constraints on typed in sub-modules. Camlp4 compiles but does not support this new feature yet.

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

16 files changed, 47 insertions, 30 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 29b2110fd..066862f66 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index bf492825b..92b3df8f4 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index ec5302a3d..52e01fce9 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index e377b5f28..a1a6eff18 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -287,7 +287,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     match wc with
     [ <:with_constr<>> -> acc
     | <:with_constr< type $lid:id$ = $ct$ >> ->
-        [(id, ctyp ct) :: acc]
+        [(Lident id, ctyp ct) :: acc]
     | <:with_constr< $wc1$ and $wc2$ >> ->
         package_type_constraints wc1 (package_type_constraints wc2 acc)
     | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ]
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 45e2c1859..3967ba21b 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14422,7 +14422,7 @@ module Struct =
               match wc with
               | Ast.WcNil _ -> acc
               | Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) ->
-                  (id, (ctyp ct)) :: acc
+                  (Lident id, (ctyp ct)) :: acc
               | Ast.WcAnd (_, wc1, wc2) ->
                   package_type_constraints wc1
                     (package_type_constraints wc2 acc)
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 7ac680432..885a581d4 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1601,7 +1601,7 @@ package_type:
   | mty_longident WITH package_type_cstrs { ($1, $3) }
 ;
 package_type_cstr:
-    TYPE LIDENT EQUAL core_type { ($2, $4) }
+    TYPE label_longident EQUAL core_type { ($2, $4) }
 ;
 package_type_cstrs:
     package_type_cstr { [$1] }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index b8d7da9fc..e67e3ebfe 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -35,7 +35,7 @@ and core_type_desc =
   | Ptyp_poly of string list * core_type
   | Ptyp_package of package_type
 
-and package_type = Longident.t * (string * core_type) list
+and package_type = Longident.t * (Longident.t * core_type) list
 
 and core_field_type =
   { pfield_desc: core_field_desc;
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 6329f5302..7aafabb39 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -155,7 +155,7 @@ let rec core_type i ppf x =
       list i package_with ppf l;
 
 and package_with i ppf (s, t) =
-  line i ppf "with type %s\n" s;
+  line i ppf "with type %a\n" fmt_longident s;
   core_type i ppf t
 
 and core_field_type i ppf x =
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index b74bbe3cc..75a179382 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -446,6 +446,7 @@ let rec tree_of_typexp sch ty =
     | Tunivar _ ->
         Otyp_var (false, name_of_type ty)
     | Tpackage (p, n, tyl) ->
+        let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in
         Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
   in
   if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
diff --git a/typing/typecore.mli b/typing/typecore.mli
index e8082d3a8..8b9ce86f0 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -117,7 +117,7 @@ val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
    Typedtree.class_structure * class_signature * string list) ref
 val type_package:
-  (Env.t -> Parsetree.module_expr -> Path.t -> string list -> type_expr list ->
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> type_expr list ->
    Typedtree.module_expr * type_expr list) ref
 
 val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 3b1405287..f29c6bffb 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -41,7 +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
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 
@@ -650,21 +650,32 @@ let check_recmodule_inclusion env bindings =
 
 (* Helper for unpack *)
 
+let rec package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else let sg = extract_sig env loc mty in
+  let sg' =
+    List.map
+      (function
+        | Tsig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs ->
+            let ty = List.assoc [Ident.name id] constrs in
+            Tsig_type (id, {td with type_manifest = Some ty}, rs)
+        | Tsig_module (id, mty, rs) ->
+            let rec aux = function
+              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest
+              | _ :: rest -> aux rest
+              | [] -> []
+            in
+            Tsig_module (id, package_constraints env loc mty (aux constrs), rs)
+        | item -> item
+      )
+      sg
+  in
+  Tmty_signature sg'
+
 let modtype_of_package env loc p nl tl =
   try match Env.find_modtype p env with
   | Tmodtype_manifest mty when nl <> [] ->
-      let sg = extract_sig env loc mty in
-      let ntl = List.combine nl tl in
-      let sg' =
-        List.map
-          (function
-              Tsig_type (id, ({type_params=[]} as td), rs) 
-              when List.mem (Ident.name id) nl ->
-                let ty = List.assoc (Ident.name id) ntl in
-                Tsig_type (id, {td with type_manifest = Some ty}, rs)
-            | item -> item)
-          sg in
-      Tmty_signature sg'
+      package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl)
   | _ ->
       if nl = [] then Tmty_ident p
       else raise(Error(loc, Signature_expected))
@@ -1041,8 +1052,13 @@ let type_package env m p nl tl =
       let (id, new_env) = Env.enter_module "%M" modl.mod_type env in
       (Pident id, new_env)
   in
+  let rec mkpath mp = function
+    | Lident name -> Pdot(mp, name, nopos)
+    | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
+    | _ -> assert false
+  in
   let tl' =
-    List.map (fun name -> Ctype.newconstr (Pdot(mp, name, nopos)) []) nl in
+    List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in
   (* go back to original level *)
   Ctype.end_def ();
   if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
@@ -1216,8 +1232,8 @@ let report_error ppf = function
       fprintf ppf
         "The type of this packed module contains variables:@ %a"
         type_expr ty
-  | Scoping_pack (id, ty) ->
+  | Scoping_pack (lid, ty) ->
       fprintf ppf
-        "The type %s in this module cannot be exported.@ " id;
+        "The type %a in this module cannot be exported.@ " longident lid;
       fprintf ppf
         "Its type contains local dependencies:@ %a" type_expr ty
diff --git a/typing/typemod.mli b/typing/typemod.mli
index aa2626c6d..a2c03aaa8 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -53,7 +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
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 
diff --git a/typing/types.ml b/typing/types.ml
index ef958501a..1342bb293 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -37,7 +37,7 @@ and type_desc =
   | Tvariant of row_desc
   | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
diff --git a/typing/types.mli b/typing/types.mli
index 64ed12847..1dc67ac08 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -36,7 +36,7 @@ and type_desc =
   | Tvariant of row_desc
   | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 1a13da5cb..131b12a79 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -38,7 +38,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -127,7 +127,7 @@ let create_package_mty fake loc env (p, l) =
                ptype_manifest = if fake then None else Some t;
                ptype_variance = [];
                ptype_loc = loc} in
-      {pmty_desc=Pmty_with (mty, [ Longident.Lident s, Pwith_type d ]);
+      {pmty_desc=Pmty_with (mty, [ s, Pwith_type d ]);
        pmty_loc=loc}
     )
     {pmty_desc=Pmty_ident p; pmty_loc=loc}
@@ -676,7 +676,7 @@ let report_error ppf = function
          if Btype.is_Tunivar v then "it is already bound to another variable"
          else "it is not a variable")
   | Multiple_constraints_on_type s ->
-      fprintf ppf "Multiple constraints for type %s" s
+      fprintf ppf "Multiple constraints for type %a" longident s
   | Repeated_method_label s ->
       fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
         s "Multiple occurences are not allowed."
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 529e008e7..79082d5f5 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -53,7 +53,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * Types.type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -71,7 +71,7 @@ val report_error: formatter -> error -> unit
 (* Support for first-class modules. *)
 val transl_modtype_longident: (Location.t -> Env.t -> Longident.t -> Path.t) ref  (* from Typemod *)
 val transl_modtype: (Env.t -> Parsetree.module_type -> Types.module_type) ref (* from Typemod *)
-val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (string * Parsetree.core_type) list * Parsetree.module_type
+val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t * Parsetree.core_type) list * Parsetree.module_type
 
 val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
 val find_constructor: Env.t -> Location.t -> Longident.t -> Types.constructor_description