Support syntax: S with module M.N := ..

ocamldoc/odoc_sig.ml

@@ -417,11 +417,9 @@ module Analyser =
       List.fold_right (fun constraint_ acc ->
         match constraint_ with
         | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc
-        | Parsetree.Pwith_typesubst (s, _) ->
+        | Parsetree.Pwith_typesubst (s, _) | Parsetree.Pwith_modsubst (s, _) ->
            (* wrong *)
-           Name.Set.add (List.hd (Longident.flatten s.txt)) acc
-        | Parsetree.Pwith_modsubst (s, _) ->
-           Name.Set.add s.txt acc)
+           Name.Set.add (List.hd (Longident.flatten s.txt)) acc)
         constraints acc
 
     let filter_out_erased_items_from_signature erased signature =

parsing/parser.mly

@@ -2148,7 +2148,7 @@ with_constraint:
              ~loc:(symbol_rloc()))) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { Pwith_module (mkrhs $2 2, mkrhs $4 4) }
-  | MODULE UIDENT COLONEQUAL mod_ext_longident
+  | MODULE mod_longident COLONEQUAL mod_ext_longident
       { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) }
 ;
 with_type_binder:

parsing/parsetree.mli

@@ -765,8 +765,8 @@ and with_constraint =
         (* with module X.Y = Z *)
   | Pwith_typesubst of Longident.t loc * type_declaration
         (* with type X.t := ..., same format as [Pwith_type] *)
-  | Pwith_modsubst of string loc * Longident.t loc
-        (* with module X := Z *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
 
 (* Value expressions for the module language *)
 

parsing/pprintast.ml

@@ -955,8 +955,8 @@ and module_type ctxt f x =
                 (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
                 ls longident_loc li
                 (type_declaration ctxt) td
-          | Pwith_modsubst (s, li2) ->
-              pp f "module %s :=@ %a" s.txt longident_loc li2 in
+          | Pwith_modsubst (li, li2) ->
+             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
         (match l with
          | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
          | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"

parsing/printast.ml

@@ -726,10 +726,10 @@ and with_constraint i ppf x =
       line i ppf "Pwith_module %a = %a\n"
         fmt_longident_loc lid1
         fmt_longident_loc lid2;
-  | Pwith_modsubst (s, li) ->
+  | Pwith_modsubst (lid1, lid2) ->
       line i ppf "Pwith_modsubst %a = %a\n"
-        fmt_string_loc s
-        fmt_longident_loc li;
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
 
 and module_expr i ppf x =
   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;

testsuite/tests/typing-sigsubst/sigsubst.ml

@@ -179,3 +179,39 @@ module type S2 =
     type t = F(M).t
   end
 |}]
+
+(* Deep destructive module substitution: *)
+
+module A = struct module P = struct type t let x = 1 end end
+module type S = sig
+  module M : sig
+    module N : sig
+      module P : sig
+        type t
+      end
+    end
+  end
+  type t = M.N.P.t
+end with module M.N := A
+[%%expect {|
+module A : sig module P : sig type t val x : int end end
+module type S = sig module M : sig  end type t = A.P.t end
+|}]
+
+(* Same as for types, not all substitutions are accepted *)
+
+module type S = sig
+  module M : sig
+    module N : sig
+      module P : sig
+        type t
+      end
+    end
+  end
+  module Alias = M
+end with module M.N := A
+[%%expect {|
+Line _, characters 16-159:
+Error: This `with' constraint on M.N changes M, which is aliased
+       in the constrained signature (as Alias).
+|}]

typing/subst.ml

@@ -28,14 +28,14 @@ module PathMap = Map.Make(Path)
 
 type t =
   { types: type_replacement PathMap.t;
-    modules: (Ident.t, Path.t) Tbl.t;
+    modules: Path.t PathMap.t;
     modtypes: (Ident.t, module_type) Tbl.t;
     for_saving: bool;
   }
 
 let identity =
   { types = PathMap.empty;
-    modules = Tbl.empty;
+    modules = PathMap.empty;
     modtypes = Tbl.empty;
     for_saving = false;
   }
@@ -46,7 +46,8 @@ let add_type id p s = add_type_path (Pident id) p s
 let add_type_function id ~params ~body s =
   { s with types = PathMap.add id (Type_function { params; body }) s.types }
 
-let add_module id p s = { s with modules = Tbl.add id p s.modules }
+let add_module_path id p s = { s with modules = PathMap.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
 
 let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
 
@@ -76,13 +77,15 @@ let attrs s x =
     then remove_loc.Ast_mapper.attributes remove_loc x
     else x
 
-let rec module_path s = function
-    Pident id as p ->
-      begin try Tbl.find id s.modules with Not_found -> p end
-  | Pdot(p, n, pos) ->
-      Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
-      Papply(module_path s p1, module_path s p2)
+let rec module_path s path =
+  try PathMap.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n, pos) ->
+       Pdot(module_path s p, n, pos)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
 
 let modtype_path s = function
     Pident id as p ->
@@ -471,7 +474,7 @@ let type_replacement s = function
 
 let compose s1 s2 =
   { types = merge_path_maps (type_replacement s2) s1.types s2.types;
-    modules = merge_tbls (module_path s2) s1.modules s2.modules;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
     for_saving = s1.for_saving || s2.for_saving;
   }

typing/subst.mli

@@ -38,6 +38,7 @@ val add_type_path: Path.t -> Path.t -> t -> t
 val add_type_function:
   Path.t -> params:type_expr list -> body:type_expr -> t -> t
 val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val for_saving: t -> t
 val reset_for_saving: unit -> unit

typing/typemod.ml

@@ -252,16 +252,13 @@ let merge_constraint initial_env loc sg constr =
   let lid =
     match constr with
     | Pwith_type (lid, _) | Pwith_module (lid, _)
-    | Pwith_typesubst (lid, _) -> lid
-    | Pwith_modsubst (s, _) ->
-        {loc = s.loc; txt=Lident s.txt}
+    | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid
   in
   let destructive_substitution =
     match constr with
     | Pwith_type _ | Pwith_module _ -> false
     | Pwith_typesubst _ | Pwith_modsubst _ -> true
   in
-  let real_id = ref None in
   let real_ids = ref [] in
   let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
@@ -340,7 +337,6 @@ let merge_constraint initial_env loc sg constr =
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
         let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
         ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
-        real_id := Some id;
         real_ids := [Pident id];
         (Pident id, lid, Twith_modsubst (path, lid')),
         update_rec_next rs rem
@@ -380,10 +376,13 @@ let merge_constraint initial_env loc sg constr =
            !real_ids
        in
        Subst.signature sub sg
-    | (_, _, Twith_modsubst (path, _)) ->
-       assert (List.length !real_ids = 1);
-       let id = match !real_id with None -> assert false | Some id -> id in
-       let sub = Subst.add_module id path Subst.identity in
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           Subst.identity
+           !real_ids
+       in
        Subst.signature sub sg
     | _ ->
        sg

typing/untypeast.ml

@@ -576,9 +576,7 @@ let with_constraint sub (_path, lid, cstr) =
   | Twith_typesubst decl ->
      Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
   | Twith_modsubst (_path, lid2) ->
-      Pwith_modsubst
-        ({loc = sub.location sub lid.loc; txt=Longident.last lid.txt},
-         map_loc sub lid2)
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
 
 let module_expr sub mexpr =
   let loc = sub.location sub mexpr.mod_loc; in