Don't remove module aliases in module type of and with module

Changes

@@ -48,6 +48,10 @@ Working version
 - GPR#1628: Treat reraise and raise_notrace as nonexpansive.
   (Leo White, review by Alain Frisch)
 
+* GPR#1652: Don't remove module aliases in `module type of` and `with module`.
+  The old behaviour can be obtained using the `[@remove_aliases]` attribute.
+  (Leo White, review by Jacques Garrigue)
+
 ### Standard library:
 
 - GPR#1002: add a new `Seq` module defining a list-of-thunks style iterator.

testsuite/tests/lib-stdlabels/test_stdlabels.ml

@@ -7,8 +7,11 @@ module B : module type of Bytes = BytesLabels
 module L : module type of List = ListLabels
 module S : module type of String = StringLabels
 
-module M : module type of struct include Map end = MoreLabels.Map
-module Se : module type of struct include Set end = MoreLabels.Set
+module M : module type of struct include Map end [@remove_aliases] =
+  MoreLabels.Map
+
+module Se : module type of struct include Set end [@remove_aliases] =
+  MoreLabels.Set
 
 
 (* For  *)
@@ -35,7 +38,7 @@ module Indirection = struct
 end
 module type HS = sig
   type statistics = Indirection.t
-  include module type of struct include Hashtbl end
+  include module type of struct include Hashtbl end [@remove_aliases]
                          with type statistics := Indirection.t
 end
 module H : HS = MoreLabels.Hashtbl

testsuite/tests/typing-modules/aliases.ml

@@ -478,7 +478,7 @@ module A2 = struct end
 module L1 = struct module X = A1 end
 module L2 = struct module X = A2 end;;
 
-module F (L : (module type of L1)) = struct end;;
+module F (L : (module type of L1 [@remove_aliases])) = struct end;;
 
 module F1 = F(L1);; (* ok *)
 module F2 = F(L2);; (* should succeed too *)
@@ -502,7 +502,7 @@ module M = struct
   module I = Int
   type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
 end;;
-module type S = module type of M;; (* keep alias *)
+module type S = module type of M [@remove_aliases];; (* keep alias *)
 
 module Int2 = struct type t = int let compare x y = compare y x end;;
 module type S' = sig
@@ -597,7 +597,7 @@ module M = struct
     type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
   end
 end;;
-module type S = module type of M ;;
+module type S = module type of M [@remove_aliases];;
 [%%expect{|
 module M :
   sig
@@ -622,7 +622,7 @@ module M = struct
     type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
   end
 end;;
-module type S = module type of M ;;
+module type S = module type of M [@remove_aliases];;
 [%%expect{|
 module M :
   sig

typing/mtype.ml

@@ -107,6 +107,21 @@ and strengthen_decl ~aliasable env md p =
 
 let () = Env.strengthen := strengthen
 
+let scrape_for_type_of env mty =
+  let rec loop env path mty =
+    match mty, path with
+    | Mty_alias(_, path), _ -> begin
+        try
+          let md = Env.find_module path env in
+          loop env (Some path) md.md_type
+        with Not_found -> mty
+      end
+    | mty, Some path ->
+        strengthen ~aliasable:false env mty path
+    | _ -> mty
+  in
+  loop env None mty
+
 (* In nondep_supertype, env is only used for the type it assigns to id.
    Hence there is no need to keep env up-to-date by adding the bindings
    traversed. *)
@@ -386,14 +401,14 @@ let collect_arg_paths mty =
   PathSet.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
     !paths Ident.Set.empty
 
-let rec remove_aliases env excl mty =
+let rec remove_aliases_mty env excl mty =
   match mty with
     Mty_signature sg ->
       Mty_signature (remove_aliases_sig env excl sg)
   | Mty_alias _ ->
       let mty' = Env.scrape_alias env mty in
       if mty' = mty then mty else
-      remove_aliases env excl mty'
+      remove_aliases_mty env excl mty'
   | mty ->
       mty
 
@@ -406,7 +421,7 @@ and remove_aliases_sig env excl sg =
           Mty_alias _ when Ident.Set.mem id excl ->
             md.md_type
         | mty ->
-            remove_aliases env excl mty
+            remove_aliases_mty env excl mty
       in
       Sig_module(id, {md with md_type = mty} , rs) ::
       remove_aliases_sig (Env.add_module id mty env) excl rem
@@ -416,12 +431,14 @@ and remove_aliases_sig env excl sg =
   | it :: rem ->
       it :: remove_aliases_sig env excl rem
 
-let remove_aliases env sg =
-  let excl = collect_arg_paths sg in
-  (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
-  Format.eprintf "@."; *)
-  remove_aliases env excl sg
 
+let scrape_for_type_of ~remove_aliases env mty =
+  if remove_aliases then begin
+    let excl = collect_arg_paths mty in
+    remove_aliases_mty env excl mty
+  end else begin
+    scrape_for_type_of env mty
+  end
 
 (* Lower non-generalizable type variables *)
 

typing/mtype.mli

@@ -21,6 +21,9 @@ val scrape: Env.t -> module_type -> module_type
         (* Expand toplevel module type abbreviations
            till hitting a "hard" module type (signature, functor,
            or abstract module type ident. *)
+val scrape_for_type_of:
+  remove_aliases:bool -> Env.t -> module_type -> module_type
+        (* Expand module aliases *)
 val freshen: module_type -> module_type
         (* Return an alpha-equivalent copy of the given module type
            where bound identifiers are fresh. *)
@@ -42,5 +45,4 @@ val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
   type_declaration
 val type_paths: Env.t -> Path.t -> module_type -> Path.t list
 val contains_type: Env.t -> module_type -> bool
-val remove_aliases: Env.t -> module_type -> module_type
 val lower_nongen: int -> module_type -> unit

typing/typemod.ml

@@ -320,7 +320,7 @@ let params_are_constrained =
   loop
 ;;
 
-let merge_constraint initial_env loc sg constr =
+let merge_constraint initial_env remove_aliases loc sg constr =
   let lid =
     match constr with
     | Pwith_type (lid, _) | Pwith_module (lid, _)
@@ -400,7 +400,9 @@ let merge_constraint initial_env loc sg constr =
     | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
-        let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
+        let mty = md'.md_type in
+        let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
+        let md'' = { md' with md_type = mty } in
         let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
         ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
         (Pident id, lid, Twith_module (path, lid')),
@@ -705,6 +707,15 @@ let simplify_signature sg =
   let (sg, _) = aux sg in
   sg
 
+let has_remove_aliases_attribute attr =
+  let remove_aliases =
+    Attr_helper.get_no_payload_attribute
+      ["remove_aliases"; "ocaml.remove_aliases"] attr
+  in
+  match remove_aliases with
+  | None -> false
+  | Some _ -> true
+
 (* Check and translate a module type expression *)
 
 let transl_modtype_longident loc env lid =
@@ -764,10 +775,12 @@ and transl_modtype_aux env smty =
   | Pmty_with(sbody, constraints) ->
       let body = transl_modtype env sbody in
       let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
+      let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in
       let (rev_tcstrs, final_sg) =
         List.fold_left
           (fun (rev_tcstrs,sg) sdecl ->
-            let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
+            let (tcstr, sg) =
+              merge_constraint env remove_aliases smty.pmty_loc sg sdecl
             in
             (tcstr :: rev_tcstrs, sg)
         )
@@ -1738,19 +1751,20 @@ and normalize_signature_item env = function
 (* Extract the module type of a module expression *)
 
 let type_module_type_of env smod =
+  let remove_aliases = has_remove_aliases_attribute smod.pmod_attributes in
   let tmty =
     match smod.pmod_desc with
     | Pmod_ident lid -> (* turn off strengthening in this case *)
         let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in
-        rm { mod_desc = Tmod_ident (path, lid);
-             mod_type = md.md_type;
-             mod_env = env;
-             mod_attributes = smod.pmod_attributes;
-             mod_loc = smod.pmod_loc }
-    | _ -> type_module env smod in
+          rm { mod_desc = Tmod_ident (path, lid);
+               mod_type = md.md_type;
+               mod_env = env;
+               mod_attributes = smod.pmod_attributes;
+               mod_loc = smod.pmod_loc }
+    | _ -> type_module env smod
+  in
   let mty = tmty.mod_type in
-  (* PR#6307: expand aliases at root and submodules *)
-  let mty = Mtype.remove_aliases env mty in
+  let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
   (* PR#5036: must not contain non-generalized type variables *)
   if not (closed_modtype env mty) then
     raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));