Merge pull request #10405 from trefis/subst-locs

Update locations during destructive substitutions

.depend

@@ -1193,6 +1193,7 @@ typing/subst.cmx : \
 typing/subst.cmi : \
     typing/types.cmi \
     typing/path.cmi \
+    parsing/location.cmi \
     typing/ident.cmi
 typing/tast_iterator.cmo : \
     typing/typedtree.cmi \

Changes

@@ -235,6 +235,10 @@ Working version
 
 ### Compiler user-interface and warnings:
 
+- #1737, #2092, #7852, #7859, #10405: Update locations during destructive
+  substitutions
+  (Thomas Refis, review by Gabriel Radanne, report by Hugo Heuzard)
+
 - #8732, improved error messages for invalid private row type definitions.
   For instance, [ type t = private [< `A > `A ] ] .
   (Florian Angeletti, review by Jacques Garrigue, Thomas Refis,

testsuite/tests/typing-sigsubst/test_locations.compilers.reference

@@ -45,7 +45,8 @@ Error: Signature mismatch:
          val create : elt -> t
        is not included in
          val create : unit -> t
-       File "test_functor.ml", line 5, characters 2-23: Expected declaration
+       File "test_loc_type_subst.ml", line 1, characters 11-47:
+         Expected declaration
        File "test_functor.ml", line 5, characters 2-23: Actual declaration
 File "test_loc_modtype_type_subst.ml", line 3, characters 15-42:
 3 | module M : S = Test_functor.Apply (String)
@@ -63,5 +64,6 @@ Error: Signature mismatch:
          val create : elt -> t
        is not included in
          val create : unit -> t
-       File "test_functor.ml", line 5, characters 2-23: Expected declaration
+       File "test_loc_modtype_type_subst.ml", line 1, characters 16-52:
+         Expected declaration
        File "test_functor.ml", line 5, characters 2-23: Actual declaration

typing/subst.ml

@@ -31,13 +31,15 @@ type t =
     modules: Path.t Path.Map.t;
     modtypes: module_type Path.Map.t;
     for_saving: bool;
+    loc: Location.t option;
   }
 
 let identity =
   { types = Path.Map.empty;
     modules = Path.Map.empty;
     modtypes = Path.Map.empty;
     for_saving = false;
+    loc = None;
   }
 
 let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types }
@@ -54,8 +56,13 @@ let add_modtype id ty s = add_modtype_path (Pident id) ty s
 
 let for_saving s = { s with for_saving = true }
 
+let change_locs s loc = { s with loc = Some loc }
+
 let loc s x =
-  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+  match s.loc with
+  | Some l -> l
+  | None ->
+    if s.for_saving && not !Clflags.keep_locs then Location.none else x
 
 let remove_loc =
   let open Ast_mapper in
@@ -547,6 +554,11 @@ and modtype_declaration scoping s decl  =
 let merge_path_maps f m1 m2 =
   Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2
 
+let keep_latest_loc l1 l2 =
+  match l2 with
+  | None -> l1
+  | Some _ -> l2
+
 let type_replacement s = function
   | Path p -> Path (type_path s p)
   | Type_function { params; body } ->
@@ -563,4 +575,5 @@ let compose s1 s2 =
     modules = merge_path_maps (module_path s2) s1.modules s2.modules;
     modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes;
     for_saving = s1.for_saving || s2.for_saving;
+    loc = keep_latest_loc s1.loc s2.loc;
   }

typing/subst.mli

@@ -44,6 +44,7 @@ val add_modtype_path: Path.t -> module_type -> t -> t
 
 val for_saving: t -> t
 val reset_for_saving: unit -> unit
+val change_locs: t -> Location.t -> t
 
 val module_path: t -> Path.t -> Path.t
 val type_path: t -> Path.t -> Path.t

typing/typemod.ml

@@ -694,24 +694,27 @@ let merge_constraint initial_env loc sg lid constr =
                              With_cannot_remove_constrained_type));
             fun s path -> Subst.add_type_function path ~params ~body s
        in
-       let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in
+       let sub = Subst.change_locs Subst.identity loc in
+       let sub = List.fold_left how_to_extend_subst sub !real_ids in
        (* This signature will not be used directly, it will always be freshened
           by the caller. So what we do with the scope doesn't really matter. But
           making it local makes it unlikely that we will ever use the result of
           this function unfreshened without issue. *)
        Subst.signature Make_local sub sg
     | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub = Subst.change_locs Subst.identity loc in
        let sub =
          List.fold_left
            (fun s path -> Subst.add_module_path path real_path s)
-           Subst.identity
+           sub
            !real_ids
        in
        (* See explanation in the [Twith_typesubst] case above. *)
        Subst.signature Make_local sub sg
     | (_, _, Twith_modtypesubst tmty) ->
         let add s p = Subst.add_modtype_path p tmty.mty_type s in
-        let sub = List.fold_left add Subst.identity !real_ids in
+        let sub = Subst.change_locs Subst.identity loc in
+        let sub = List.fold_left add sub !real_ids in
         Subst.signature Make_local sub sg
     | _ ->
        sg