Merge pull request #1737 from trefis/subst-locs

Update locations during destructive substitutions

Changes

@@ -42,6 +42,9 @@ Working version
   (Arthur Charguéraud and Armaël Guéneau, with help and advice
    from Gabriel Scherer, Frédéric Bour, Xavier Clerc and Leo White)
 
+- GPR#1737: Update locations during destructive substitutions
+  (Thomas Refis, review by Gabriel Radanne)
+
 - GPR#1748: do not error when instantiating polymorphic fields in patterns
   (Thomas Refis, review by Gabriel Scherer)
 

testsuite/tests/typing-sigsubst/ocamltests

@@ -1 +1,2 @@
 sigsubst.ml
+test_locations.ml

testsuite/tests/typing-sigsubst/test_functor.ml

@@ -0,0 +1,13 @@
+module type S = sig
+  type elt
+  type t
+
+  val create : elt -> t
+end
+
+module Apply (Arg : sig type t end) : S with type elt = Arg.t = struct
+  type elt = Arg.t
+  type t = elt list
+
+  let create x = [ x ]
+end

testsuite/tests/typing-sigsubst/test_loc_modtype_type_eq.ml

@@ -0,0 +1,4 @@
+module type S = Test_functor.S with type elt = unit
+
+module M : S = Test_functor.Apply (String)
+

testsuite/tests/typing-sigsubst/test_loc_modtype_type_subst.ml

@@ -0,0 +1,4 @@
+module type S = Test_functor.S with type elt := unit
+
+module M : S = Test_functor.Apply (String)
+

testsuite/tests/typing-sigsubst/test_loc_type_eq.ml

@@ -0,0 +1,2 @@
+module M : Test_functor.S with type elt = unit = Test_functor.Apply (String)
+

testsuite/tests/typing-sigsubst/test_loc_type_subst.ml

@@ -0,0 +1,2 @@
+module M : Test_functor.S with type elt := unit = Test_functor.Apply (String)
+

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

@@ -0,0 +1,68 @@
+File "test_loc_type_eq.ml", line 1, characters 49-76:
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         sig type elt = unit type t val create : elt -> t end
+       Type declarations do not match:
+         type elt = String.t
+       is not included in
+         type elt = unit
+       File "test_loc_type_eq.ml", line 1, characters 31-46:
+         Expected declaration
+       File "test_functor.ml", line 8, characters 45-61: Actual declaration
+File "test_loc_modtype_type_eq.ml", line 3, characters 15-42:
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         S
+       Type declarations do not match:
+         type elt = String.t
+       is not included in
+         type elt = unit
+       File "test_loc_modtype_type_eq.ml", line 1, characters 36-51:
+         Expected declaration
+       File "test_functor.ml", line 8, characters 45-61: Actual declaration
+File "test_loc_type_subst.ml", line 1, characters 50-77:
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         sig type t val create : unit -> t end
+       Values do not match:
+         val create : elt -> t
+       is not included in
+         val create : unit -> t
+       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:
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type elt = String.t
+           type t = Test_functor.Apply(String).t
+           val create : elt -> t
+         end
+       is not included in
+         S
+       Values do not match:
+         val create : elt -> t
+       is not included in
+         val create : unit -> t
+       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

testsuite/tests/typing-sigsubst/test_locations.ml

@@ -0,0 +1,20 @@
+(* TEST
+files = "test_functor.ml test_loc_modtype_type_eq.ml test_loc_modtype_type_subst.ml test_loc_type_eq.ml test_loc_type_subst.ml"
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+module = "test_functor.ml"
+** ocamlc.byte
+module = "test_loc_type_eq.ml"
+ocamlc_byte_exit_status = "2"
+** ocamlc.byte
+module = "test_loc_modtype_type_eq.ml"
+ocamlc_byte_exit_status = "2"
+** ocamlc.byte
+module = "test_loc_type_subst.ml"
+ocamlc_byte_exit_status = "2"
+** ocamlc.byte
+module = "test_loc_modtype_type_subst.ml"
+ocamlc_byte_exit_status = "2"
+** check-ocamlc.byte-output
+*)
+

typing/subst.ml

@@ -31,13 +31,15 @@ type t =
     modules: Path.t PathMap.t;
     modtypes: (Ident.t, module_type) Tbl.t;
     for_saving: bool;
+    loc: Location.t option;
   }
 
 let identity =
   { types = PathMap.empty;
     modules = PathMap.empty;
     modtypes = Tbl.empty;
     for_saving = false;
+    loc = None;
   }
 
 let add_type_path id p s = { s with types = PathMap.add id (Path p) s.types }
@@ -53,8 +55,13 @@ let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
 
 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
@@ -474,6 +481,11 @@ let merge_tbls f m1 m2 =
 let merge_path_maps f m1 m2 =
   PathMap.fold (fun k d accu -> PathMap.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 } ->
@@ -489,4 +501,5 @@ let compose s1 s2 =
     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;
+    loc = keep_latest_loc s1.loc s2.loc;
   }

typing/subst.mli

@@ -42,6 +42,7 @@ 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
+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

@@ -473,13 +473,15 @@ let merge_constraint initial_env remove_aliases loc sg constr =
             then raise(Error(loc, initial_env, 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
        Subst.signature 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
        Subst.signature sub sg