locate: use location coming from the environment for the local buffer only

src/analysis/locate.ml

@@ -236,6 +236,8 @@ module Utils = struct
       || List.exists Predef.builtin_values ~f
     | _ -> false
 
+  let is_ghost_loc { Location. loc_ghost; _ } = loc_ghost
+
   (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files
      matching, instead of the first one.
      This is only used when looking for ml files, not cmts. Indeed for cmts we
@@ -770,14 +772,15 @@ end = struct
       Some x
 end
 
-let locate ~config ~ml_or_mli ~path ~lazy_trie ~pos ~str_ident =
+let locate ~config ~ml_or_mli ~path ~lazy_trie ~pos ~str_ident loc =
   File_switching.reset ();
   Fallback.reset ();
   Preferences.set ml_or_mli;
   log ~title:"locate"
     "present in the environment, walking up the typedtree looking for '%s'"
     (Namespaced_path.to_unique_string path);
   try
+    if not (Utils.is_ghost_loc loc) then Fallback.set loc;
     let lazy trie = lazy_trie in
     match locate ~config ~context:(Initial pos) path trie with
     | Found (loc, doc) -> `Found (loc, doc)
@@ -790,21 +793,21 @@ let locate ~config ~ml_or_mli ~path ~lazy_trie ~pos ~str_ident =
   | Not_found -> `Not_found (str_ident, File_switching.where_am_i ())
 
 (* Only used to retrieve documentation *)
-let from_completion_entry ~config ~lazy_trie ~pos (namespace, path, _) =
+let from_completion_entry ~config ~lazy_trie ~pos (namespace, path, loc) =
   let str_ident = Path.name path in
   let tagged_path = Namespaced_path.of_path ~namespace path in
-  locate ~config ~ml_or_mli:`MLI ~path:tagged_path ~pos ~str_ident
+  locate ~config ~ml_or_mli:`MLI ~path:tagged_path ~pos ~str_ident loc
     ~lazy_trie
 
 let from_longident ~config ~env ~lazy_trie ~pos nss ml_or_mli ident =
   let str_ident = String.concat ~sep:"." (Longident.flatten ident) in
   match Env_lookup.in_namespaces nss ident env with
   | None -> `Not_in_env str_ident
-  | Some (path, tagged_path, _) ->
+  | Some (path, tagged_path, loc) ->
     if Utils.is_builtin_path path then
       `Builtin
     else
-      locate ~config ~ml_or_mli ~path:tagged_path ~lazy_trie ~pos ~str_ident
+      locate ~config ~ml_or_mli ~path:tagged_path ~lazy_trie ~pos ~str_ident loc
 
 let from_string ~config ~env ~local_defs ~pos ?namespaces switch path =
   let browse = Mbrowse.of_typedtree local_defs in

src/ocaml/typing/402/env.ml

@@ -413,16 +413,17 @@ let read_pers_struct modname filename =
   let sign = cmi.cmi_sign in
   let crcs = cmi.cmi_crcs in
   let flags = cmi.cmi_flags in
+  let id_subst = Subst.(make_loc_ghost identity) in
   let comps =
-    !components_of_module' empty Subst.identity
+    !components_of_module' empty id_subst
       (Pident(Ident.create_persistent name))
       (Mty_signature sign)
   in
   let ps_typemap, ps_sig = match !cmi_cache with
     | Cmi_cache_store (ps_typemap, ps_sig) -> ps_typemap, ps_sig
     | _ ->
       let ps_typemap = ref None in
-      let ps_sig = lazy (Subst.signature Subst.identity sign) in
+      let ps_sig = lazy (Subst.signature id_subst sign) in
       cmi_cache := Cmi_cache_store (ps_typemap, ps_sig);
       ps_typemap, ps_sig
   in

src/ocaml/typing/402/subst.ml

@@ -23,11 +23,12 @@ type t =
   { types: (Ident.t, Path.t) Tbl.t;
     modules: (Ident.t, Path.t) Tbl.t;
     modtypes: (Ident.t, module_type) Tbl.t;
-    for_saving: bool }
+    for_saving: bool;
+    make_loc_ghost: bool }
 
 let identity =
   { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
-    for_saving = false }
+    for_saving = false; make_loc_ghost = false }
 
 let add_type id p s = { s with types = Tbl.add id p s.types }
 
@@ -36,9 +37,12 @@ let add_module id p s = { s with modules = Tbl.add id p s.modules }
 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 make_loc_ghost s = { s with make_loc_ghost = true }
 
 let loc s x =
-  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+  if s.for_saving && not !Clflags.keep_locs then Location.none
+  else if s.make_loc_ghost then { x with loc_ghost = true }
+  else x
 
 let remove_loc =
   let open Ast_mapper in
@@ -320,7 +324,10 @@ let extension_constructor s ext =
       ext_ret_type = may_map (typexp s) ext.ext_ret_type;
       ext_private = ext.ext_private;
       ext_attributes = attrs s ext.ext_attributes;
-      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+      ext_loc =
+        if s.for_saving then Location.none
+        else if s.make_loc_ghost then { ext.ext_loc with loc_ghost = true }
+        else ext.ext_loc; }
   in
     cleanup_types ();
     ext
@@ -413,4 +420,5 @@ let compose s1 s2 =
   { types = merge_tbls (type_path s2) s1.types s2.types;
     modules = merge_tbls (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
-    for_saving = false }
+    for_saving = false;
+    make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost }

src/ocaml/typing/402/subst.mli

@@ -34,6 +34,7 @@ val add_type: Ident.t -> Path.t -> t -> t
 val add_module: Ident.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val for_saving: t -> t
+val make_loc_ghost: t -> t
 val reset_for_saving: unit -> unit
 
 val module_path: t -> Path.t -> Path.t

src/ocaml/typing/403/env.ml

@@ -502,16 +502,17 @@ let read_pers_struct check modname filename =
     List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
       flags
   in
+  let id_subst = Subst.(make_loc_ghost identity) in
   let comps =
-    !components_of_module' ~deprecated empty Subst.identity
+    !components_of_module' ~deprecated empty id_subst
       (Pident(Ident.create_persistent name))
       (Mty_signature sign)
   in
   let ps_typemap, ps_sig = match !cmi_cache with
     | Cmi_cache_store (ps_typemap, ps_sig) -> ps_typemap, ps_sig
     | _ ->
       let ps_typemap = ref None in
-      let ps_sig = lazy (Subst.signature Subst.identity sign) in
+      let ps_sig = lazy (Subst.signature id_subst sign) in
       cmi_cache := Cmi_cache_store (ps_typemap, ps_sig);
       ps_typemap, ps_sig
   in

src/ocaml/typing/403/subst.ml

@@ -25,11 +25,12 @@ type t =
     modules: (Ident.t, Path.t) Tbl.t;
     modtypes: (Ident.t, module_type) Tbl.t;
     for_saving: bool;
-    nongen_level: int }
+    nongen_level: int;
+    make_loc_ghost: bool }
 
 let identity =
   { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
-    for_saving = false; nongen_level = generic_level }
+    for_saving = false; nongen_level = generic_level; make_loc_ghost = false }
 
 let add_type id p s = { s with types = Tbl.add id p s.types }
 
@@ -41,8 +42,12 @@ let for_saving s = { s with for_saving = true }
 
 let set_nongen_level s lev = { s with nongen_level = lev }
 
+let make_loc_ghost s = { s with make_loc_ghost = true }
+
 let loc s x =
-  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+  if s.for_saving && not !Clflags.keep_locs then Location.none
+  else if s.make_loc_ghost then { x with loc_ghost = true }
+  else x
 
 let remove_loc =
   let open Ast_mapper in
@@ -338,7 +343,10 @@ let extension_constructor s ext =
       ext_ret_type = may_map (typexp s) ext.ext_ret_type;
       ext_private = ext.ext_private;
       ext_attributes = attrs s ext.ext_attributes;
-      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+      ext_loc =
+        if s.for_saving then Location.none
+        else if s.make_loc_ghost then { ext.ext_loc with loc_ghost = true }
+        else ext.ext_loc; }
   in
     cleanup_types ();
     ext
@@ -435,4 +443,5 @@ let compose s1 s2 =
     modules = merge_tbls (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
     for_saving = s1.for_saving || s2.for_saving;
-    nongen_level = min s1.nongen_level s2.nongen_level }
+    nongen_level = min s1.nongen_level s2.nongen_level;
+    make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost }

src/ocaml/typing/403/subst.mli

@@ -38,6 +38,7 @@ val add_module: Ident.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val set_nongen_level: t -> int -> t
 val for_saving: t -> t
+val make_loc_ghost: t -> t
 val reset_for_saving: unit -> unit
 
 val module_path: t -> Path.t -> Path.t

src/ocaml/typing/404/env.ml

@@ -509,17 +509,18 @@ let acknowledge_pers_struct check modname
     List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
       flags
   in
+  let id_subst = Subst.(make_loc_ghost identity) in
   let comps =
     !components_of_module' ~deprecated ~loc:Location.none
-      empty Subst.identity
+      empty id_subst
       (Pident(Ident.create_persistent name))
       (Mty_signature sign)
   in
   let ps_sig =
     match !cmi_cache with
     | Cmi_cache_store ps_sig -> ps_sig
     | _ ->
-      let ps_sig = lazy (Subst.signature Subst.identity sign) in
+      let ps_sig = lazy (Subst.signature id_subst sign) in
       cmi_cache := Cmi_cache_store ps_sig;
       ps_sig
   in

src/ocaml/typing/404/subst.ml

@@ -25,11 +25,12 @@ type t =
     modules: (Ident.t, Path.t) Tbl.t;
     modtypes: (Ident.t, module_type) Tbl.t;
     for_saving: bool;
-    nongen_level: int }
+    nongen_level: int;
+    make_loc_ghost: bool }
 
 let identity =
   { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
-    for_saving = false; nongen_level = generic_level }
+    for_saving = false; nongen_level = generic_level; make_loc_ghost = false }
 
 let add_type id p s = { s with types = Tbl.add id p s.types }
 
@@ -41,8 +42,12 @@ let for_saving s = { s with for_saving = true }
 
 let set_nongen_level s lev = { s with nongen_level = lev }
 
+let make_loc_ghost s = { s with make_loc_ghost = true }
+
 let loc s x =
-  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+  if s.for_saving && not !Clflags.keep_locs then Location.none
+  else if s.make_loc_ghost then { x with loc_ghost = true }
+  else x
 
 let remove_loc =
   let open Ast_mapper in
@@ -339,7 +344,10 @@ let extension_constructor s ext =
       ext_ret_type = may_map (typexp s) ext.ext_ret_type;
       ext_private = ext.ext_private;
       ext_attributes = attrs s ext.ext_attributes;
-      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+      ext_loc =
+        if s.for_saving then Location.none
+        else if s.make_loc_ghost then { ext.ext_loc with loc_ghost = true }
+        else ext.ext_loc; }
   in
     cleanup_types ();
     ext
@@ -436,4 +444,5 @@ let compose s1 s2 =
     modules = merge_tbls (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
     for_saving = s1.for_saving || s2.for_saving;
-    nongen_level = min s1.nongen_level s2.nongen_level }
+    nongen_level = min s1.nongen_level s2.nongen_level;
+    make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost }

src/ocaml/typing/404/subst.mli

@@ -38,6 +38,7 @@ val add_module: Ident.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val set_nongen_level: t -> int -> t
 val for_saving: t -> t
+val make_loc_ghost: t -> t
 val reset_for_saving: unit -> unit
 
 val module_path: t -> Path.t -> Path.t

src/ocaml/typing/405/env.ml

@@ -509,17 +509,18 @@ let acknowledge_pers_struct check modname
     List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
       flags
   in
+  let id_subst = Subst.(make_loc_ghost identity) in
   let comps =
     !components_of_module' ~deprecated ~loc:Location.none
-      empty Subst.identity
+      empty id_subst
                            (Pident(Ident.create_persistent name))
                            (Mty_signature sign)
   in
   let ps_sig =
     match !cmi_cache with
     | Cmi_cache_store ps_sig -> ps_sig
     | _ ->
-      let ps_sig = lazy (Subst.signature Subst.identity sign) in
+      let ps_sig = lazy (Subst.signature id_subst sign) in
       cmi_cache := Cmi_cache_store ps_sig;
       ps_sig
   in

src/ocaml/typing/405/subst.ml

@@ -24,11 +24,12 @@ type t =
   { types: (Ident.t, Path.t) Tbl.t;
     modules: (Ident.t, Path.t) Tbl.t;
     modtypes: (Ident.t, module_type) Tbl.t;
-    for_saving: bool }
+    for_saving: bool;
+    make_loc_ghost: bool }
 
 let identity =
   { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
-    for_saving = false }
+    for_saving = false; make_loc_ghost = false }
 
 let add_type id p s = { s with types = Tbl.add id p s.types }
 
@@ -37,9 +38,12 @@ let add_module id p s = { s with modules = Tbl.add id p s.modules }
 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 make_loc_ghost s = { s with make_loc_ghost = true }
 
 let loc s x =
-  if s.for_saving && not !Clflags.keep_locs then Location.none else x
+  if s.for_saving && not !Clflags.keep_locs then Location.none
+  else if s.make_loc_ghost then { x with loc_ghost = true }
+  else x
 
 let remove_loc =
   let open Ast_mapper in
@@ -341,7 +345,10 @@ let extension_constructor s ext =
       ext_ret_type = may_map (typexp s) ext.ext_ret_type;
       ext_private = ext.ext_private;
       ext_attributes = attrs s ext.ext_attributes;
-      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+      ext_loc =
+        if s.for_saving then Location.none
+        else if s.make_loc_ghost then { ext.ext_loc with loc_ghost = true }
+        else ext.ext_loc; }
   in
     cleanup_types ();
     ext
@@ -437,4 +444,5 @@ let compose s1 s2 =
   { types = merge_tbls (type_path s2) s1.types s2.types;
     modules = merge_tbls (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
-    for_saving = s1.for_saving || s2.for_saving }
+    for_saving = s1.for_saving || s2.for_saving;
+    make_loc_ghost = s1.make_loc_ghost || s2.make_loc_ghost }

src/ocaml/typing/405/subst.mli

@@ -37,6 +37,7 @@ val add_type: Ident.t -> Path.t -> t -> t
 val add_module: Ident.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val for_saving: t -> t
+val make_loc_ghost: t -> t
 val reset_for_saving: unit -> unit
 
 val module_path: t -> Path.t -> Path.t

src/ocaml/typing/406/env.ml

@@ -759,17 +759,18 @@ let acknowledge_pers_struct check modname
     List.fold_left (fun acc -> function Deprecated s -> Some s | _ -> acc) None
       flags
   in
+  let id_subst = Subst.(make_loc_ghost identity) in
   let comps =
     !components_of_module' ~deprecated ~loc:Location.none
-      empty Subst.identity
+      empty id_subst
                            (Pident(Ident.create_persistent name))
                            (Mty_signature sign)
   in
   let ps_sig =
     match !cmi_cache with
     | Cmi_cache_store ps_sig -> ps_sig
     | _ ->
-      let ps_sig = lazy (Subst.signature Subst.identity sign) in
+      let ps_sig = lazy (Subst.signature id_subst sign) in
       cmi_cache := Cmi_cache_store ps_sig;
       ps_sig
   in