Merge branch 'main' into distinguish-files

.github/workflows/main.yml

@@ -40,7 +40,7 @@ jobs:
           - ubuntu-latest
           - windows-latest
         ocaml-compiler:
-          - ocaml-base-compiler.5.3.0~beta2
+          - ocaml-base-compiler.5.3.0
     # The type of runner that the job will run on
     runs-on: ${{ matrix.os }}
 

.github/workflows/ocaml-lsp-compat.yml

@@ -34,7 +34,7 @@ jobs:
         os:
           - ubuntu-latest
         ocaml-compiler:
-          - ocaml-base-compiler.5.3.0~alpha1
+          - ocaml-base-compiler.5.3.0
     # The type of runner that the job will run on
     runs-on: ${{ matrix.os }}
 
@@ -52,6 +52,6 @@ jobs:
       - name: Check that Merlin and OCaml-LSP are co-installable
         run: |
           opam --cli=2.1 pin --with-version=dev --no-action https://github.com/voodoos/ocaml-lsp.git#merlin-503-compat
-          opam --cli=2.1 pin --with-version=5.3-503 --no-action .
+          opam --cli=2.1 pin --with-version=5.4-503 --no-action .
           opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat
 

CHANGES.md

@@ -1,11 +1,21 @@
-unreleased
+merlin 5.4.1
+============
+Mon Jan 13 10:55:42 CET 2025
+
+  + ocaml-index
+    - Bump magic number after index file format change (#1886)
+
+merlin 5.4
 ==========
+Fri Jan 10 17:55:42 CET 2025
 
   + merlin binary
     - 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)
     - Perform less merges in the indexer (#1881)
+    - Add initial support for project-wide renaming: occurrences can now return
+      all usages of all related definitions. (#1877)
     - `locate` can now disambiguate between files with identical names and contents
   + vim plugin
     - Added support for search-by-type (#1846)

doc/dev/PROTOCOL.md

@@ -355,9 +355,13 @@ Returns either:
 
 Returns a list of locations `{'start': position, 'end': position}` of all
 occurrences in current buffer of the entity at the specified position. If scope
-is set to `project` the returned locations will also contain a field `file`:
+is set to `project` or `renaming`‡ the returned locations will also contain a field `file`:
 `{'file': string, 'start': position, 'end': position}`.
 
+When the scope is set to `renaming`, all usages of all the related definitions
+corresponding to an identifier will be returned. When scope is `project` only
+the usages of the current definition will be returned.
+
 ### `outline`
 
 

ocaml-index.opam

@@ -1,4 +1,3 @@
-# This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
 synopsis: "A tool that indexes value usages from cmt files"
 description:
@@ -10,8 +9,8 @@ homepage: "https://github.com/ocaml/merlin/ocaml-index"
 bug-reports: "https://github.com/ocaml/merlin/issues"
 depends: [
   "dune" {>= "3.0.0"}
-  "ocaml" {>= "5.2"}
-  "merlin-lib" {>= "5.1-502"}
+  "ocaml" {>= "5.3"}
+  "merlin-lib" {= version}
   "odoc" {with-doc}
 ]
 build: [

src/analysis/completion.ml

@@ -57,12 +57,13 @@ let raw_info_printer : raw_info -> _ = function
       (Out_sig_item
          (Out_type.tree_of_type_declaration id tdecl Types.Trec_first))
   | `Type_scheme te ->
-    `Print (Out_type (Out_type.tree_of_typexp Type_scheme te))
+    `Print (Out_type (Type_utils.Printtyp.tree_of_typ_scheme te))
   | `Variant (label, arg) -> begin
     match arg with
     | None -> `String label
     | Some te ->
-      `Concat (label ^ " of ", Out_type (Out_type.tree_of_typexp Type_scheme te))
+      `Concat
+        (label ^ " of ", Out_type (Type_utils.Printtyp.tree_of_typ_scheme te))
   end
 
 (* List methods of an object.

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:[] ~f:(fun x ->
+         x |> 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/analysis/type_utils.ml

@@ -134,6 +134,10 @@ module Printtyp = struct
     (select_by_verbosity ~default:type_scheme ~verbose:(verbose_type_scheme env))
       ppf ty
 
+  let tree_of_typ_scheme te =
+    Out_type.prepare_for_printing [ te ];
+    Out_type.tree_of_typexp Type_scheme te
+
   let type_declaration env id ppf =
     (select_by_verbosity ~default:type_declaration
        ~verbose:(verbose_type_declaration env))

src/analysis/type_utils.mli

@@ -40,6 +40,8 @@ module Printtyp : sig
 
   val type_scheme : Env.t -> Format.formatter -> Types.type_expr -> unit
 
+  val tree_of_typ_scheme : Types.type_expr -> Outcometree.out_type
+
   val modtype : Env.t -> Format.formatter -> Types.module_type -> unit
 
   val wrap_printing_env :

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,40 @@
+type 'a content =
+  | Root of { mutable value : 'a; mutable rank : int }
+  | Link of { mutable parent : 'a element }
+and 'a element = 'a content ref
+
+let make value = ref (Root { value; rank = 0 })
+
+let rec find x =
+  match !x 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
+  if x == y then x
+  else begin
+    match (!x, !y) with
+    | ( Root ({ rank = rank_x; value = value_x } as root_x),
+        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 := Link { parent = y };
+        root_y.value <- new_value;
+        y)
+      else (
+        y := Link { parent = x };
+        root_x.value <- new_value;
+        if rank_x = rank_y then root_x.rank <- root_x.rank + 1;
+        x)
+    | _ -> assert false
+  end
+
+let get elt =
+  match !(find elt) with
+  | Root { value; _ } -> value
+  | Link _ -> assert false