In the untyped parse tree, allow arbitrary module type constraints in package type. This already enables constraints on types defined in sub-modules, e.g. (module S with type X.t = int).

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

10 files changed, 114 insertions, 101 deletions

diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 8cae995930..1b255fb43b 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -100,7 +100,28 @@ type skind = [`Type|`Class|`Module|`Modtype]
 let found_sig = ref ([] : ((skind * Longident.t) * Env.t * Location.t) list)
 let add_found_sig = add_found ~found:found_sig
 
-let rec search_pos_type t ~pos ~env =
+let rec search_pos_type_decl td ~pos ~env =
+  if in_loc ~pos td.ptype_loc then begin
+    begin match td.ptype_manifest with
+      Some t -> search_pos_type t ~pos ~env
+    | None -> ()
+    end;
+    let rec search_tkind = function
+      Ptype_abstract -> ()
+    | Ptype_variant dl ->
+        List.iter dl
+          ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+    | Ptype_record dl ->
+        List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
+    search_tkind td.ptype_kind;
+    List.iter td.ptype_cstrs ~f:
+      begin fun (t1, t2, _) ->
+        search_pos_type t1 ~pos ~env;
+        search_pos_type t2 ~pos ~env
+      end
+  end
+
+and search_pos_type t ~pos ~env =
   if in_loc ~pos t.ptyp_loc then
   begin match t.ptyp_desc with
     Ptyp_any
@@ -130,8 +151,12 @@ let rec search_pos_type t ~pos ~env =
       add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc
   | Ptyp_alias (t, _)
   | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t
-  | Ptyp_package (_, stl) ->
-     List.iter stl ~f:(fun (_, ty) -> search_pos_type ty ~pos ~env)
+  | Ptyp_package (_, l) ->
+      List.iter l ~f:
+        begin function
+            _, Pwith_type t -> search_pos_type_decl t ~pos ~env
+          | _ -> ()
+        end
   end
 
 let rec search_pos_class_type cl ~pos ~env =
@@ -160,27 +185,6 @@ let rec search_pos_class_type cl ~pos ~env =
         search_pos_class_type cty ~pos ~env
     end
 
-let search_pos_type_decl td ~pos ~env =
-  if in_loc ~pos td.ptype_loc then begin
-    begin match td.ptype_manifest with
-      Some t -> search_pos_type t ~pos ~env
-    | None -> ()
-    end;
-    let rec search_tkind = function
-      Ptype_abstract -> ()
-    | Ptype_variant dl ->
-        List.iter dl
-          ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
-    | Ptype_record dl ->
-        List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
-    search_tkind td.ptype_kind;
-    List.iter td.ptype_cstrs ~f:
-      begin fun (t1, t2, _) ->
-        search_pos_type t1 ~pos ~env;
-        search_pos_type t2 ~pos ~env
-      end
-  end
-
 let rec search_pos_signature l ~pos ~env =
   ignore (
   List.fold_left l ~init:env ~f:
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 4f9bcc58b5..1e2fb4816c 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1423,14 +1423,7 @@ simple_core_type2:
 ;
 package_type:
     mty_longident { ($1, []) }
-  | mty_longident WITH package_type_cstrs { ($1, $3) }
-
-package_type_cstr:
-    TYPE LIDENT EQUAL core_type { ($2, $4) }
-;
-package_type_cstrs:
-    package_type_cstr { [$1] }
-  | package_type_cstr AND package_type_cstrs { $1::$3 }
+  | mty_longident WITH with_constraints { ($1, List.rev $3) }
 ;
 row_field_list:
     row_field                                   { [$1] }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd037..0fd7b15e2d 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 * with_constraint) list
 
 and core_field_type =
   { pfield_desc: core_field_desc;
@@ -51,7 +51,7 @@ and row_field =
 
 (* Type expressions for the class language *)
 
-type 'a class_infos =
+and 'a class_infos =
   { pci_virt: virtual_flag;
     pci_params: string list * Location.t;
     pci_name: string;
@@ -61,7 +61,7 @@ type 'a class_infos =
 
 (* Value expressions for the core language *)
 
-type pattern =
+and pattern =
   { ppat_desc: pattern_desc;
     ppat_loc: Location.t }
 
@@ -80,7 +80,7 @@ and pattern_desc =
   | Ppat_type of Longident.t
   | Ppat_lazy of pattern
 
-type expression =
+and expression =
   { pexp_desc: expression_desc;
     pexp_loc: Location.t }
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b879..d6f734915f 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -154,11 +154,7 @@ let rec core_type i ppf x =
       core_type i ppf ct;
   | Ptyp_package (s, l) ->
       line i ppf "Ptyp_package %a\n" fmt_longident s;
-      list i package_with ppf l
-
-and package_with i ppf (s, t) =
-  line i ppf "with type %s\n" s;
-  core_type i ppf t
+      list i longident_x_with_constraint ppf l
 
 and core_field_type i ppf x =
   line i ppf "core_field_type %a\n" fmt_location x.pfield_loc;
@@ -323,7 +319,7 @@ and expression i ppf x =
       expression i ppf e
   | Pexp_pack (me, (p,l)) ->
       line i ppf "Pexp_pack %a" fmt_longident p;
-      list i package_with ppf l;
+      list i longident_x_with_constraint ppf l;
       module_expr i ppf me
   | Pexp_open (m, e) ->
       line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
@@ -595,7 +591,7 @@ and module_expr i ppf x =
       module_type i ppf mt;
   | Pmod_unpack (e, (p, l)) ->
       line i ppf "Pmod_unpack %a\n" fmt_longident p;
-      list i package_with ppf l;
+      list i longident_x_with_constraint ppf l;
       expression i ppf e;
 
 and structure i ppf x = list i structure_item ppf x
diff --git a/tools/depend.ml b/tools/depend.ml
index 44e85702bd..d4c99c96dd 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -23,6 +23,10 @@ module StringSet = Set.Make(struct type t = string let compare = compare end)
 
 let free_structure_names = ref StringSet.empty
 
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
 let rec addmodule bv lid =
   match lid with
     Lident s ->
@@ -56,18 +60,14 @@ let rec add_type bv ty =
 
 and add_package_type bv (lid, l) =
   add bv lid;
-  List.iter (add_type bv) (List.map snd l)
+  add_modtype_constraints bv l
 
 and add_field_type bv ft =
   match ft.pfield_desc with
     Pfield(name, ty) -> add_type bv ty
   | Pfield_var -> ()
 
-let add_opt add_fn bv = function
-    None -> ()
-  | Some x -> add_fn bv x
-
-let add_type_declaration bv td =
+and add_type_declaration bv td =
   List.iter
     (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
     td.ptype_cstrs;
@@ -80,7 +80,7 @@ let add_type_declaration bv td =
       List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
   add_tkind td.ptype_kind
 
-let rec add_class_type bv cty =
+and add_class_type bv cty =
   match cty.pcty_desc with
     Pcty_constr(l, tyl) ->
       add bv l; List.iter (add_type bv) tyl
@@ -97,12 +97,12 @@ and add_class_type_field bv = function
   | Pctf_meth(_, _, ty, _) -> add_type bv ty
   | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
 
-let add_class_description bv infos =
+and add_class_description bv infos =
   add_class_type bv infos.pci_expr
 
-let add_class_type_declaration = add_class_description
+and add_class_type_declaration bv c = add_class_description bv c
 
-let rec add_pattern bv pat =
+and add_pattern bv pat =
   match pat.ppat_desc with
     Ppat_any -> ()
   | Ppat_var _ -> ()
@@ -119,7 +119,7 @@ let rec add_pattern bv pat =
   | Ppat_type (li) -> add bv li
   | Ppat_lazy p -> add_pattern bv p
 
-let rec add_expr bv exp =
+and add_expr bv exp =
   match exp.pexp_desc with
     Pexp_ident l -> add bv l
   | Pexp_constant _ -> ()
@@ -175,15 +175,17 @@ and add_modtype bv mty =
   | Pmty_functor(id, mty1, mty2) ->
       add_modtype bv mty1; add_modtype (StringSet.add id bv) mty2
   | Pmty_with(mty, cstrl) ->
-      add_modtype bv mty;
-      List.iter
-        (function (_, Pwith_type td) -> add_type_declaration bv td
-                | (_, Pwith_module lid) -> addmodule bv lid
-                | (_, Pwith_typesubst td) -> add_type_declaration bv td
-                | (_, Pwith_modsubst lid) -> addmodule bv lid)
-        cstrl
+      add_modtype bv mty; add_modtype_constraints bv cstrl
   | Pmty_typeof m -> add_module bv m
 
+and add_modtype_constraints bv l =
+  List.iter
+    (function (_, Pwith_type td) -> add_type_declaration bv td
+      | (_, Pwith_module lid) -> addmodule bv lid
+      | (_, Pwith_typesubst td) -> add_type_declaration bv td
+      | (_, Pwith_modsubst lid) -> addmodule bv lid)
+    l
+
 and add_signature bv = function
     [] -> ()
   | item :: rem -> add_signature (add_sig_item bv item) rem
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 486115488a..c928dc648d 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1002,13 +1002,6 @@ let generalizable level ty =
 (* Hack to allow coercion of self. Will clean-up later. *)
 let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
 
-(* Helpers for packaged modules. *)
-let create_package_type loc env (p, l) =
-  let s = !Typetexp.transl_modtype_longident loc env p in
-  newty (Tpackage (s,
-                   List.map fst l,
-                   List.map (Typetexp.transl_simple_type env false) (List.map snd l)))
-
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
@@ -1628,7 +1621,7 @@ let rec type_exp env sexp =
       re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
   | Pexp_pack (m, (p, l)) ->
       let loc = sexp.pexp_loc in
-      let l, mty = Typetexp.create_package_mty loc env (p, l) in
+      let ty, mty = Typetexp.transl_package_type loc env (p, l) (Typetexp.transl_simple_type env false) in
       let m = {pmod_desc = Pmod_constraint (m, mty); pmod_loc = loc} in
       let context = Typetexp.narrow () in
       let modl = !type_module env m in
@@ -1636,7 +1629,7 @@ let rec type_exp env sexp =
       re {
         exp_desc = Texp_pack modl;
         exp_loc = loc;
-        exp_type = create_package_type loc env (p, l);
+        exp_type = ty;
         exp_env = env }
   | Pexp_open (lid, e) ->
       type_exp (!type_open env sexp.pexp_loc lid) e
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3fb90ff34e..4ec3d6e85f 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -109,5 +109,3 @@ val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
 val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
    Typedtree.class_structure * class_signature * string 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 8ffc54a015..51d1d0d9ad 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -714,10 +714,9 @@ let rec type_module sttn funct_body anchor env smod =
   | Pmod_unpack (sexp, (p, l)) ->
       if funct_body then
         raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
-      let l, mty = Typetexp.create_package_mty smod.pmod_loc env (p, l) in
+      let ty, mty = Typetexp.transl_package_type smod.pmod_loc env (p, l) (Typetexp.transl_simple_type env false) in
       let mty = transl_modtype env mty in
-      let exp = Typecore.type_expect env sexp
-          (Typecore.create_package_type smod.pmod_loc env (p, l)) in
+      let exp = Typecore.type_expect env sexp ty in
       rm { mod_desc = Tmod_unpack(exp, mty);
            mod_type = mty;
            mod_env = env;
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 838719b7c4..3a72081bb2 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
@@ -48,6 +48,7 @@ type error =
   | Unbound_modtype of Longident.t
   | Unbound_cltype of Longident.t
   | Ill_typed_functor_application of Longident.t
+  | Invalid_constraint_in_package_type
 
 exception Error of Location.t * error
 
@@ -101,7 +102,7 @@ let find_cltype = find_component Env.lookup_cltype (fun lid -> Unbound_cltype li
 let transl_modtype_longident = ref (fun _ -> assert false)
 let transl_modtype = ref (fun _ -> assert false)
 
-let create_package_mty fake loc env (p, l) =
+let transl_package_type fake loc env (p, l) transl =
   let l =
     List.sort
       (fun (s1, t1) (s2, t2) ->
@@ -109,20 +110,47 @@ let create_package_mty fake loc env (p, l) =
          compare s1 s2)
       l
   in
-  l,
-  List.fold_left
-    (fun mty (s, t) ->
-      let d = {ptype_params = [];
-               ptype_cstrs = [];
-               ptype_kind = Ptype_abstract;
-               ptype_private = Asttypes.Public;
-               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_loc=loc}
-    )
-    {pmty_desc=Pmty_ident p; pmty_loc=loc}
-    l
+  let l' =
+    if fake then
+      List.map
+        (function (s, Pwith_type d) -> (s, Pwith_type {d with ptype_manifest = None}) | x -> x)
+        l
+    else l
+  in
+  let mty =
+    {
+     pmty_desc = Pmty_with ({pmty_desc=Pmty_ident p; pmty_loc=loc}, l');
+     pmty_loc = loc;
+    }
+  in
+  let s = !transl_modtype_longident loc env p in
+  let ids =
+    List.map
+      (fun (lid, _) -> String.concat "." (Longident.flatten lid))
+      l
+  in
+  let tys =
+    List.map
+      (fun (_, c) ->
+        match c with
+        | Pwith_type {ptype_params = [];
+                      ptype_cstrs = [];
+                      ptype_kind = Ptype_abstract;
+                      ptype_private = Asttypes.Public;
+                      ptype_manifest = Some t;
+                      ptype_variance = variance;
+                      ptype_loc = loc}
+            when List.for_all (function (false, false) -> true | _ -> false) variance ->
+              transl t
+        | Pwith_type {ptype_loc = loc}
+        | Pwith_typesubst {ptype_loc = loc} ->
+            raise (Error (loc, Invalid_constraint_in_package_type))
+        | _ ->
+            raise (Error (loc, Invalid_constraint_in_package_type))
+      )
+      l
+  in
+  newty (Tpackage (s, ids, tys)), mty
 
 (* Translation of type expressions *)
 
@@ -454,13 +482,11 @@ let rec transl_type env policy styp =
       unify_var env (newvar()) ty';
       ty'
   | Ptyp_package (p, l) ->
-      let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
+      let ty, mty = transl_package_type true styp.ptyp_loc env (p, l) (transl_type env policy) in
       let z = narrow () in
       ignore (!transl_modtype env mty);
       widen z;
-      newty (Tpackage (!transl_modtype_longident styp.ptyp_loc env p,
-                       List.map fst l,
-                       List.map (transl_type env policy) (List.map snd l)))
+      ty
 
 and transl_fields env policy seen =
   function
@@ -500,7 +526,7 @@ let make_fixed_univars ty =
   make_fixed_univars ty;
   Btype.unmark_type ty
 
-let create_package_mty = create_package_mty false
+let transl_package_type = transl_package_type false
 
 let globalize_used_variables env fixed =
   let r = ref [] in
@@ -573,7 +599,6 @@ let transl_type_scheme env styp =
   generalize typ;
   typ
 
-
 (* Error report *)
 
 open Format
@@ -638,8 +663,8 @@ let report_error ppf = function
         (if v.desc = Tvar then "it escapes this scope" else
          if v.desc = Tunivar then "it is aliased to another variable"
          else "it is not a variable")
-  | Multiple_constraints_on_type s ->
-      fprintf ppf "Multiple constraints for type %s" s
+  | Multiple_constraints_on_type lid ->
+      fprintf ppf "Multiple constraints for type %a" longident lid
   | Repeated_method_label s ->
       fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
         s "Multiple occurences are not allowed."
@@ -659,3 +684,5 @@ let report_error ppf = function
       fprintf ppf "Unbound class type %a" longident lid
   | Ill_typed_functor_application lid ->
       fprintf ppf "Ill-typed functor application %a" longident lid
+  | Invalid_constraint_in_package_type ->
+      fprintf ppf "This kind of constraint is not allowed in a package type"
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index ec9042ce8d..a4b0e4a5f5 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
@@ -63,6 +63,7 @@ type error =
   | Unbound_modtype of Longident.t
   | Unbound_cltype of Longident.t
   | Ill_typed_functor_application of Longident.t
+  | Invalid_constraint_in_package_type
 
 exception Error of Location.t * error
 
@@ -71,7 +72,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 transl_package_type: Location.t -> Env.t -> Parsetree.package_type -> (Parsetree.core_type -> Types.type_expr) -> Types.type_expr * 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