[503] Project-wide renaming

CHANGES.md

@@ -5,6 +5,8 @@ unreleased
     - Support for OCaml 5.3
     - Use new 5.3 features to improve locate behavior in some cases. Merlin no
       longer confuses uids from interfaces and implementations. (#1857)
+    - Add initial support for project-wide renaming: occurrences can now return
+      all usages of all related definitions. (#1877)
   + vim plugin
     - Added support for search-by-type (#1846)
       This is exposed through the existing `:MerlinSearch` command, that

src/analysis/occurrences.ml

@@ -155,26 +155,54 @@ let get_external_locs ~(config : Mconfig.t) ~current_buffer_path uid =
               locs,
             Stat_check.get_outdated_files stats )))
 
-let find_linked_uids ~config ~name uid =
+let lookup_related_uids_in_indexes ~(config : Mconfig.t) uid =
+  let title = "lookup_related_uids_in_indexes" in
+  let open Index_format in
+  let related_uids =
+    List.fold_left ~init:Uid_map.empty config.merlin.index_files
+      ~f:(fun acc index_file ->
+        try
+          let index = Index_cache.read index_file in
+          Uid_map.union
+            (fun _ a b -> Some (Union_find.union ~f:Uid_set.union a b))
+            index.related_uids acc
+        with Index_format.Not_an_index _ | Sys_error _ ->
+          log ~title "Could not load index %s" index_file;
+          acc)
+  in
+  Uid_map.find_opt uid related_uids
+  |> Option.value_map ~default:Uid_set.empty ~f:Union_find.get
+  |> Uid_set.to_list
+
+let find_linked_uids ~config ~scope ~name uid =
   let title = "find_linked_uids" in
   match uid with
-  | Shape.Uid.Item { from = _; comp_unit; _ } -> (
-    let config =
+  | Shape.Uid.Item { from = _; comp_unit; _ } ->
+    let locate_config =
       { Locate.mconfig = config; ml_or_mli = `ML; traverse_aliases = false }
     in
-    match Locate.get_linked_uids ~config ~comp_unit uid with
-    | [ uid' ] ->
-      log ~title "Found linked uid: %a" Logger.fmt (fun fmt ->
-          Shape.Uid.print fmt uid');
-      let name_check =
-        Locate.lookup_uid_decl ~config:config.mconfig uid'
-        |> Option.bind ~f:(Typedtree_utils.location_of_declaration ~uid:uid')
-        |> Option.value_map
-             ~f:(fun { Location.txt; _ } -> String.equal name txt)
-             ~default:false
-      in
-      if name_check then [ uid' ] else []
-    | _ -> [])
+    let check_name uid =
+      Locate.lookup_uid_decl ~config uid
+      |> Option.bind ~f:(Typedtree_utils.location_of_declaration ~uid)
+      |> Option.value_map
+           ~f:(fun { Location.txt; _ } ->
+             let result = String.equal name txt in
+             if not result then
+               log ~title "Found clashing idents %S <> %S. Ignoring UID %a."
+                 name txt Logger.fmt
+                 (Fun.flip Shape.Uid.print uid);
+             result)
+           ~default:false
+    in
+    let related_uids =
+      match scope with
+      | `Buffer -> []
+      | `Project -> Locate.get_linked_uids ~config:locate_config ~comp_unit uid
+      | `Renaming -> lookup_related_uids_in_indexes ~config uid
+    in
+    log ~title "Found related uids: [%a]" Logger.fmt (fun fmt ->
+        List.iter ~f:(fprintf fmt "%a;" Shape.Uid.print) related_uids);
+    List.filter ~f:check_name related_uids
   | _ -> []
 
 let locs_of ~config ~env ~typer_result ~pos ~scope path =
@@ -230,7 +258,7 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
         let name =
           String.split_on_char ~sep:'.' path |> List.last |> Option.get
         in
-        let additional_uids = find_linked_uids ~config ~name def_uid in
+        let additional_uids = find_linked_uids ~config ~scope ~name def_uid in
         List.concat_map
           (def_uid :: additional_uids)
           ~f:(get_external_locs ~config ~current_buffer_path)
@@ -284,9 +312,9 @@ let locs_of ~config ~env ~typer_result ~pos ~scope path =
     in
     let status =
       match (scope, String.Set.to_list out_of_sync_files) with
-      | `Project, [] -> `Included
-      | `Project, l -> `Out_of_sync l
       | `Buffer, _ -> `Not_requested
+      | _, [] -> `Included
+      | _, l -> `Out_of_sync l
     in
     if not def_uid_is_in_current_unit then { locs; status }
     else

src/analysis/occurrences.mli

@@ -6,6 +6,6 @@ val locs_of :
   env:Env.t ->
   typer_result:Mtyper.result ->
   pos:Lexing.position ->
-  scope:[ `Project | `Buffer ] ->
+  scope:[ `Project | `Buffer | `Renaming ] ->
   string ->
   t

src/commands/new_commands.ml

@@ -509,6 +509,7 @@ let all_commands =
                  match scope with
                  | "buffer" -> (pos, `Buffer)
                  | "project" -> (pos, `Project)
+                 | "renaming" -> (pos, `Renaming)
                  | _ -> failwith "-scope should be one of buffer or project"))
         ]
       ~doc:

src/commands/query_json.ml

@@ -192,7 +192,8 @@ let dump (type a) : a t -> json =
         ( "scope",
           match scope with
           | `Buffer -> `String "local"
-          | `Project -> `String "project" )
+          | `Project -> `String "project"
+          | `Renaming -> `String "renaming" )
       ]
   | Refactor_open (action, pos) ->
     mk "refactor-open"
@@ -488,7 +489,7 @@ let json_of_response (type a) (query : a t) (response : a) : json =
   | Extension_list _, strs -> `List (List.map ~f:Json.string strs)
   | Path_list _, strs -> `List (List.map ~f:Json.string strs)
   | Occurrences (_, scope), (locations, _project) ->
-    let with_file = scope = `Project in
+    let with_file = scope = `Project || scope = `Renaming in
     `List (List.map locations ~f:(fun loc -> with_location ~with_file loc []))
   | Signature_help _, s -> json_of_signature_help s
   | Version, version -> `String version

src/frontend/query_protocol.ml

@@ -212,7 +212,7 @@ type _ t =
   | Extension_list : [ `All | `Enabled | `Disabled ] -> string list t
   | Path_list : [ `Build | `Source ] -> string list t
   | Occurrences (* *) :
-      [ `Ident_at of Msource.position ] * [ `Project | `Buffer ]
+      [ `Ident_at of Msource.position ] * [ `Project | `Buffer | `Renaming ]
       -> (Location.t list * occurrences_status) t
   | Signature_help : signature_help -> signature_help_result option t
       (** In current version, Merlin only uses the parameter [position] to answer

src/index-format/index_format.ml

@@ -18,6 +18,7 @@ end
 module Lid_set = Set.Make (Lid)
 module Uid_map = Shape.Uid.Map
 module Stats = Map.Make (String)
+module Uid_set = Shape.Uid.Set
 
 let add map uid locs =
   Uid_map.update uid
@@ -33,7 +34,8 @@ type index =
     approximated : Lid_set.t Uid_map.t;
     cu_shape : (string, Shape.t) Hashtbl.t;
     stats : stat Stats.t;
-    root_directory : string option
+    root_directory : string option;
+    related_uids : Uid_set.t Union_find.element Uid_map.t
   }
 
 let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) =
@@ -52,6 +54,26 @@ let pp_partials (fmt : Format.formatter) (partials : Lid_set.t Uid_map.t) =
     partials;
   Format.fprintf fmt "@]}"
 
+let pp_related_uids (fmt : Format.formatter)
+    (related_uids : Uid_set.t Union_find.element Uid_map.t) =
+  let rec gather acc map =
+    match Uid_map.choose_opt map with
+    | Some (_key, union) ->
+      let group = Union_find.get union |> Uid_set.to_list in
+      List.fold_left (fun acc key -> Uid_map.remove key acc) map group
+      |> gather (group :: acc)
+    | None -> acc
+  in
+  Format.pp_print_list
+    ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;")
+    (fun fmt group ->
+      Format.fprintf fmt "(%a)"
+        (Format.pp_print_list
+           ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
+           Shape.Uid.print)
+        group)
+    fmt (gather [] related_uids)
+
 let pp (fmt : Format.formatter) pl =
   Format.fprintf fmt "%i uids:@ {@[" (Uid_map.cardinal pl.defs);
   Uid_map.iter
@@ -71,7 +93,8 @@ let pp (fmt : Format.formatter) pl =
     (Uid_map.cardinal pl.approximated)
     pp_partials pl.approximated;
   Format.fprintf fmt "and shapes for CUS %s.@ "
-    (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq))
+    (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq));
+  Format.fprintf fmt "and related uids:@[{%a}@]" pp_related_uids pl.related_uids
 
 let ext = "ocaml-index"
 

src/index-format/index_format.mli

@@ -7,6 +7,7 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc
 module Lid_set : Set.S with type elt = Lid.t
 module Stats : Map.S with type key = String.t
 module Uid_map = Shape.Uid.Map
+module Uid_set = Shape.Uid.Set
 
 type stat = { mtime : float; size : int; source_digest : string option }
 
@@ -15,7 +16,8 @@ type index =
     approximated : Lid_set.t Uid_map.t;
     cu_shape : (string, Shape.t) Hashtbl.t;
     stats : stat Stats.t;
-    root_directory : string option
+    root_directory : string option;
+    related_uids : Uid_set.t Union_find.element Uid_map.t
   }
 
 val pp : Format.formatter -> index -> unit

src/index-format/union_find.ml

@@ -0,0 +1,38 @@
+type 'a content =
+  | Root of { mutable value : 'a; mutable rank : int }
+  | Link of { mutable parent : 'a element }
+and 'a element = { mutable content : 'a content }
+
+let make value = { content = Root { value; rank = 0 } }
+
+let rec find x =
+  match x.content with
+  | Root _ -> x
+  | Link ({ parent; _ } as link) ->
+    let root = find parent in
+    if root != parent then link.parent <- root;
+    root
+
+let union ~f x y =
+  let x = find x in
+  let y = find y in
+  match (x, y) with
+  | x, y when x == y -> x
+  | ( { content = Root ({ rank = rank_x; value = value_x } as root_x); _ },
+      { content = Root ({ rank = rank_y; value = value_y } as root_y); _ } ) ->
+    let new_value = f value_x value_y in
+    if rank_x < rank_y then (
+      x.content <- Link { parent = y };
+      root_y.value <- new_value;
+      y)
+    else (
+      y.content <- Link { parent = x };
+      root_x.value <- new_value;
+      if rank_x = rank_y then root_x.rank <- root_x.rank + 1;
+      x)
+  | _ -> assert false
+
+let get elt =
+  match (find elt).content with
+  | Root { value; _ } -> value
+  | Link _ -> assert false

src/ocaml-index/lib/index.ml

@@ -82,6 +82,7 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath
         cmt_initial_env;
         cmt_sourcefile;
         cmt_source_digest;
+        cmt_declaration_dependencies;
         _
       } =
     cmt_infos
@@ -128,15 +129,33 @@ let index_of_cmt ~root ~rewrite_root ~build_path ~do_not_use_cmt_loadpath
           }
       with Unix.Unix_error _ -> Stats.empty)
   in
-  { defs; approximated; cu_shape; stats; root_directory = None }
+  let related_uids =
+    List.fold_left
+      (fun acc (_, uid1, uid2) ->
+        let union = Union_find.make (Uid_set.of_list [ uid1; uid2 ]) in
+        let map_update uid =
+          Uid_map.update uid (function
+            | None -> Some union
+            | Some union' ->
+              Some (Union_find.union ~f:Uid_set.union union' union))
+        in
+        acc |> map_update uid1 |> map_update uid2)
+      Uid_map.empty cmt_declaration_dependencies
+  in
+  { defs; approximated; cu_shape; stats; root_directory = None; related_uids }
 
 let merge_index ~store_shapes ~into index =
   let defs = merge index.defs into.defs in
   let approximated = merge index.approximated into.approximated in
   let stats = Stats.union (fun _ f1 _f2 -> Some f1) into.stats index.stats in
+  let related_uids =
+    Uid_map.union
+      (fun _ a b -> Some (Union_find.union ~f:Uid_set.union a b))
+      index.related_uids into.related_uids
+  in
   if store_shapes then
     Hashtbl.add_seq index.cu_shape (Hashtbl.to_seq into.cu_shape);
-  { into with defs; approximated; stats }
+  { into with defs; approximated; stats; related_uids }
 
 let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path
     ~do_not_use_cmt_loadpath files =
@@ -146,7 +165,8 @@ let from_files ~store_shapes ~output_file ~root ~rewrite_root ~build_path
       approximated = Shape.Uid.Map.empty;
       cu_shape = Hashtbl.create 64;
       stats = Stats.empty;
-      root_directory = root
+      root_directory = root;
+      related_uids = Uid_map.empty
     }
   in
   let final_index =

src/ocaml-index/tests/tests-dirs/index-project.t

@@ -58,6 +58,7 @@
      "+": File "main.ml", line 2, characters 14-15;
      "+": File "main.ml", line 4, characters 26-27
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}
 
   $ ocaml-index dump foo.uideps
   5 uids:
@@ -71,6 +72,7 @@
      "+": File "foo.ml", line 3, characters 11-12;
      "+": File "foo.ml", line 3, characters 19-20
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}
 
 
 
@@ -116,6 +118,7 @@
      "+": File "main.ml", line 2, characters 14-15;
      "+": File "main.ml", line 4, characters 26-27
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}
 
   $ ocaml-index stats foo.uideps test.uideps
   Index "test.uideps" contains:

src/ocaml-index/tests/tests-dirs/interfaces.t

@@ -22,3 +22,4 @@
    uid: Stdlib__Float.81; locs:
      "Float.t": File "main.mli", line 1, characters 9-16
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}

src/ocaml-index/tests/tests-dirs/local-shape-and-include.t

@@ -36,6 +36,7 @@
    uid: Stdlib__String.174; locs:
      "String.equal": File "main.ml", line 1, characters 8-20
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{(Main.3 Main.4)}
 
 
   $ ocaml-index dump test.uideps
@@ -53,4 +54,5 @@
    uid: Stdlib__String.174; locs:
      "String.equal": File "main.ml", line 1, characters 8-20
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{(Main.3 Main.4)}
 

src/ocaml-index/tests/tests-dirs/transitive-deps.t

@@ -33,11 +33,13 @@
    uid: Stdlib__List.45; locs:
      "List.init": File "main.ml", line 1, characters 8-17
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}
 
   $ ocaml-index dump lib1/foo.uideps
   1 uids:
   {uid: Bar; locs: "Bar": File "lib1/foo.ml", line 1, characters 8-11 },
   0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}
 
   $ ocaml-index dump test.uideps
   5 uids:
@@ -50,4 +52,5 @@
    uid: Stdlib__List.45; locs:
      "List.init": File "main.ml", line 1, characters 8-17
    }, 0 approx shapes: {}, and shapes for CUS .
+  and related uids:{}