module type S := ...: core

17 files changed, 122 insertions, 14 deletions

diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 529af8ef1c..29720e8c51 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -513,6 +513,7 @@ module Analyser =
            end
         | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
           if is_erased name.txt erased then acc else take_item m
+        | Parsetree.Psig_modtypesubst _  -> acc
         | Parsetree.Psig_recmodule mods ->
           (match List.filter
                    (fun pmd ->
@@ -1291,7 +1292,8 @@ module Analyser =
             let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in
             (maybe_more, new_env, mods)
 
-        | Parsetree.Psig_modtype {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} ->
+        | Parsetree.Psig_modtype {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl}
+        | Parsetree.Psig_modtypesubst {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} ->
             let complete_name = Name.concat current_module_name name.txt in
             let sig_mtype =
               try Signature_search.search_module_type table name.txt
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 2d51dda743..41f5fb9b8d 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -271,6 +271,7 @@ module Sig = struct
   let mod_subst ?loc a = mk ?loc (Psig_modsubst a)
   let rec_module ?loc a = mk ?loc (Psig_recmodule a)
   let modtype ?loc a = mk ?loc (Psig_modtype a)
+  let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a)
   let open_ ?loc a = mk ?loc (Psig_open a)
   let include_ ?loc a = mk ?loc (Psig_include a)
   let class_ ?loc a = mk ?loc (Psig_class a)
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index a498ece07d..42ce9e2e98 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -288,6 +288,7 @@ module Sig:
     val mod_subst: ?loc:loc -> module_substitution -> signature_item
     val rec_module: ?loc:loc -> module_declaration list -> signature_item
     val modtype: ?loc:loc -> module_type_declaration -> signature_item
+    val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item
     val open_: ?loc:loc -> open_description -> signature_item
     val include_: ?loc:loc -> include_description -> signature_item
     val class_: ?loc:loc -> class_description list -> signature_item
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 1cdb95310a..d1efda9782 100644
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -285,7 +285,7 @@ module MT = struct
     | Psig_modsubst x -> sub.module_substitution sub x
     | Psig_recmodule l ->
         List.iter (sub.module_declaration sub) l
-    | Psig_modtype x -> sub.module_type_declaration sub x
+    | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x
     | Psig_open x -> sub.open_description sub x
     | Psig_include x -> sub.include_description sub x
     | Psig_class l -> List.iter (sub.class_description sub) l
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 720c16af34..7575f47b0b 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -318,6 +318,8 @@ module MT = struct
     | Psig_recmodule l ->
         rec_module ~loc (List.map (sub.module_declaration sub) l)
     | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
+    | Psig_modtypesubst x ->
+        modtype_subst ~loc (sub.module_type_declaration sub x)
     | Psig_open x -> open_ ~loc (sub.open_description sub x)
     | Psig_include x -> include_ ~loc (sub.include_description sub x)
     | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
diff --git a/parsing/depend.ml b/parsing/depend.ml
index f1a155c1ba..d202ad3faf 100644
--- a/parsing/depend.ml
+++ b/parsing/depend.ml
@@ -382,7 +382,7 @@ and add_sig_item (bv, m) item =
       let bv' = add bv and m' = add m in
       List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
       (bv', m')
-  | Psig_modtype x ->
+  | Psig_modtype x | Psig_modtypesubst x->
       begin match x.pmtd_type with
         None -> ()
       | Some mty -> add_modtype bv mty
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 8337c289b3..8137de7470 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -769,6 +769,8 @@ and signature_item_desc =
   | Psig_modtype of module_type_declaration
         (* module type S = MT
            module type S *)
+  | Psig_modtypesubst of module_type_declaration
+        (* module type S :=  ...  *)
   | Psig_open of open_description
         (* open X *)
   | Psig_include of include_description
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 29351cc02a..d20ad646d4 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -1159,14 +1159,18 @@ and signature_item ctxt f x : unit =
       pp f "@[<hov2>include@ %a@]%a"
         (module_type ctxt) incl.pincl_mod
         (item_attributes ctxt) incl.pincl_attributes
-  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs}
+  | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} as p ->
       pp f "@[<hov2>module@ type@ %s%a@]%a"
         s.txt
-        (fun f md -> match md with
-           | None -> ()
-           | Some mt ->
+        (fun f md -> match md, p with
+           | None, _ -> ()
+           | Some mt, Psig_modtype _ ->
                pp_print_space f () ;
                pp f "@ =@ %a" (module_type ctxt) mt
+           | Some mt, _ ->
+               pp_print_space f () ;
+               pp f "@ :=@ %a" (module_type ctxt) mt
         ) md
         (item_attributes ctxt) attrs
   | Psig_class_type (l) -> class_type_declaration_list ctxt f l
diff --git a/parsing/printast.ml b/parsing/printast.ml
index c196256ecd..9469bf1720 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -730,6 +730,10 @@ and signature_item i ppf x =
       line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
       attributes i ppf x.pmtd_attributes;
       modtype_declaration i ppf x.pmtd_type
+  | Psig_modtypesubst x ->
+      line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name;
+      attributes i ppf x.pmtd_attributes;
+      modtype_declaration i ppf x.pmtd_type
   | Psig_open od ->
       line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override
         fmt_longident_loc od.popen_expr;
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index f11dc3bdeb..726cab337e 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -738,6 +738,10 @@ and signature_item i ppf x =
       line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id;
       attributes i ppf x.mtd_attributes;
       modtype_declaration i ppf x.mtd_type
+  | Tsig_modtypesubst x ->
+      line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id;
+      attributes i ppf x.mtd_attributes;
+      modtype_declaration i ppf x.mtd_type
   | Tsig_open od ->
       line i ppf "Tsig_open %a %a\n"
         fmt_override_flag od.open_override
diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml
index 90ed15be1c..eca7632f7d 100644
--- a/typing/tast_iterator.ml
+++ b/typing/tast_iterator.ml
@@ -284,6 +284,7 @@ let signature_item sub {sig_desc; sig_env; _} =
   | Tsig_modsubst x -> sub.module_substitution sub x
   | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list
   | Tsig_modtype x -> sub.module_type_declaration sub x
+  | Tsig_modtypesubst x -> sub.module_type_declaration sub x
   | Tsig_include incl -> include_infos (sub.module_type sub) incl
   | Tsig_class list -> List.iter (sub.class_description sub) list
   | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list
diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 555e09d7d3..d8241a7fe6 100644
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -416,7 +416,9 @@ let signature_item sub x =
         Tsig_recmodule (List.map (sub.module_declaration sub) list)
     | Tsig_modtype x ->
         Tsig_modtype (sub.module_type_declaration sub x)
-    | Tsig_include incl ->
+   | Tsig_modtypesubst x ->
+        Tsig_modtypesubst (sub.module_type_declaration sub x)
+   | Tsig_include incl ->
         Tsig_include (include_infos (sub.module_type sub) incl)
     | Tsig_class list ->
         Tsig_class (List.map (sub.class_description sub) list)
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 63ead794cb..46bc3297f0 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -355,6 +355,7 @@ and signature_item_desc =
   | Tsig_modsubst of module_substitution
   | Tsig_recmodule of module_declaration list
   | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
   | Tsig_open of open_description
   | Tsig_include of include_description
   | Tsig_class of class_description list
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index dcd69610e7..a4363d518d 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -494,6 +494,7 @@ and signature_item_desc =
   | Tsig_modsubst of module_substitution
   | Tsig_recmodule of module_declaration list
   | Tsig_modtype of module_type_declaration
+  | Tsig_modtypesubst of module_type_declaration
   | Tsig_open of open_description
   | Tsig_include of include_description
   | Tsig_class of class_description list
diff --git a/typing/typemod.ml b/typing/typemod.ml
index a1d46d1a0d..2453c98ab3 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -102,6 +102,7 @@ type error =
   | Badly_formed_signature of string * Typedecl.error
   | Cannot_hide_id of hiding_error
   | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -377,6 +378,20 @@ let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
   iterator.Btype.it_signature iterator signature;
   Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature
 
+(* When doing a module type destructive substitution [with module type T = RHS]
+   where RHS is not a module type path, we need to check that the module type
+   T was not used as a path for a packed module
+*)
+let check_usage_of_module_types ~error ~paths ~loc env super =
+  let it_do_type_expr it ty = match ty.desc with
+    | Tpackage (p, _, _) ->
+       begin match List.find_opt (Path.same p) paths with
+       | Some p -> raise (Error(loc,Lazy.force !env,error p))
+       | _ -> super.Btype.it_do_type_expr it ty
+       end
+    | _ -> super.Btype.it_do_type_expr it ty in
+  { super with Btype.it_do_type_expr }
+
 (* After substitution one also needs to re-check the well-foundedness
    of type declarations in recursive modules *)
 let rec extract_next_modules = function
@@ -854,6 +869,13 @@ and approx_sig env ssg =
             Env.enter_modtype ~scope d.pmtd_name.txt info env
           in
           Sig_modtype(id, info, Exported) :: approx_sig newenv srem
+      | Psig_modtypesubst d ->
+          let info = approx_modtype_info env d in
+          let scope = Ctype.create_scope () in
+          let (_id, newenv) =
+            Env.enter_modtype ~scope d.pmtd_name.txt info env
+          in
+          approx_sig newenv srem
       | Psig_open sod ->
           let _, env = type_open_descr env sod in
           approx_sig env srem
@@ -903,6 +925,7 @@ module Signature_names : sig
     | `From_open
     | `Shadowable of Ident.t * Location.t
     | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
   ]
 
   val create : unit -> t
@@ -929,6 +952,7 @@ end = struct
   type info = [
     | `From_open
     | `Substituted_away of Subst.t
+    | `Unpackable_modtype_substituted_away of Ident.t * Subst.t
     | bound_info
   ]
 
@@ -939,6 +963,7 @@ end = struct
   type to_be_removed = {
     mutable subst: Subst.t;
     mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t;
+    mutable unpackable_modtypes: Ident.Set.t;
   }
 
   type names_infos = (string, bound_info) Hashtbl.t
@@ -973,6 +998,7 @@ end = struct
     to_be_removed = {
       subst = Subst.identity;
       hide = Ident.Map.empty;
+      unpackable_modtypes = Ident.Set.empty;
     };
   }
 
@@ -991,7 +1017,11 @@ end = struct
     let to_be_removed = t.to_be_removed in
     match info with
     | `Substituted_away s ->
-        to_be_removed.subst <- Subst.compose s to_be_removed.subst
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+    | `Unpackable_modtype_substituted_away (id,s) ->
+        to_be_removed.subst <- Subst.compose s to_be_removed.subst;
+        to_be_removed.unpackable_modtypes <-
+          Ident.Set.add id to_be_removed.unpackable_modtypes
     | `From_open ->
         to_be_removed.hide <-
           Ident.Map.add id (cl, loc, From_open) to_be_removed.hide
@@ -1048,6 +1078,30 @@ end = struct
     in
     check component_kind names loc id info
 
+  (*
+    Before applying local module type substitutions where the
+    right-hand side is not a path, we need to check that those module types
+    where never used to pack modules. For instance
+    {[
+    module type T := sig end
+    val x: (module T)
+    ]}
+    should raise an error.
+   *)
+  let check_unpackable_modtypes ~loc ~env to_remove component =
+    if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then
+       let iterator =
+         let error p = Unpackable_local_modtype_subst p in
+         let paths =
+           List.map (fun id -> Pident id)
+             (Ident.Set.elements to_remove.unpackable_modtypes)
+         in
+         check_usage_of_module_types ~loc ~error ~paths
+           (ref (lazy env)) Btype.type_iterators
+       in
+       iterator.Btype.it_signature_item iterator component;
+       Btype.(unmark_iterators.it_signature_item unmark_iterators) component
+
   (* We usually require name uniqueness of signature components (e.g. types,
      modules, etc), however in some situation reusing the name is allowed: if
      the component is a value or an extension, or if the name is introduced by
@@ -1088,7 +1142,10 @@ end = struct
           if to_remove.subst == Subst.identity then
             component
           else
-            Subst.signature_item Keep to_remove.subst component
+            begin
+              check_unpackable_modtypes ~loc:user_loc ~env to_remove component;
+              Subst.signature_item Keep to_remove.subst component
+            end
         in
         let component =
           match ids_to_remove with
@@ -1432,6 +1489,22 @@ and transl_signature env sg =
             mksig (Tsig_modtype mtd) env loc :: trem,
             sg :: rem,
             final_env
+        | Psig_modtypesubst pmtd ->
+            let info id tmty =
+              let mty = match tmty with
+                | Some tmty -> tmty.mty_type
+                | None -> assert false (* unparsable *)
+              in
+              let subst = Subst.add_modtype id mty Subst.identity in
+              match mty with
+              | Mty_ident _ -> `Substituted_away subst
+              | _ -> `Unpackable_modtype_substituted_away (id,subst)
+            in
+            let newenv, mtd, _sg = transl_modtype_decl ~info names env pmtd in
+            let (trem, rem, final_env) = transl_sig newenv srem in
+            mksig (Tsig_modtypesubst mtd) env loc :: trem,
+            rem,
+            final_env
         | Psig_open sod ->
             let (od, newenv) = type_open_descr env sod in
             let (trem, rem, final_env) = transl_sig newenv srem in
@@ -1537,11 +1610,11 @@ and transl_signature env sg =
        sg
     )
 
-and transl_modtype_decl names env pmtd =
+and transl_modtype_decl ?info names env pmtd =
   Builtin_attributes.warning_scope pmtd.pmtd_attributes
-    (fun () -> transl_modtype_decl_aux names env pmtd)
+    (fun () -> transl_modtype_decl_aux ?info names env pmtd)
 
-and transl_modtype_decl_aux names env
+and transl_modtype_decl_aux ?info names env
     {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
   let tmty =
     Option.map (transl_modtype (Env.in_signature true env)) pmtd_type
@@ -1556,7 +1629,8 @@ and transl_modtype_decl_aux names env
   in
   let scope = Ctype.create_scope () in
   let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in
-  Signature_names.check_modtype names pmtd_loc id;
+  let info = Option.map (fun info -> info id tmty) info in
+  Signature_names.check_modtype ?info names pmtd_loc id;
   let mtd =
     {
      mtd_id=id;
@@ -2962,6 +3036,12 @@ let report_error ppf = function
         Ident.print opened_item_id
   | Invalid_type_subst_rhs ->
       fprintf ppf "Only type synonyms are allowed on the right of :="
+  | Unpackable_local_modtype_subst p ->
+      fprintf ppf
+        "The module type@ %s@ is not a valid type for a packed module:@ \
+         it is defined as a local substitution for a non-path module type."
+        (Path.name p)
+
 
 let report_error env ppf err =
   Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err)
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 87ebd8f1fe..6f79637d87 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -131,6 +131,7 @@ type error =
   | Badly_formed_signature of string * Typedecl.error
   | Cannot_hide_id of hiding_error
   | Invalid_type_subst_rhs
+  | Unpackable_local_modtype_subst of Path.t
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index bff1e29a06..3cc2b34023 100644
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -559,6 +559,8 @@ let signature_item sub item =
         Psig_recmodule (List.map (sub.module_declaration sub) list)
     | Tsig_modtype mtd ->
         Psig_modtype (sub.module_type_declaration sub mtd)
+    | Tsig_modtypesubst mtd ->
+        Psig_modtypesubst (sub.module_type_declaration sub mtd)
     | Tsig_open od ->
         Psig_open (sub.open_description sub od)
     | Tsig_include incl ->