Merge branch 'main' into refactor-extraction

Author: Tim-ats-d

.github/workflows/changelog.yml

@@ -8,6 +8,6 @@ on:
 jobs:
   Changelog-Entry-Check:
     name: Check Changelog Action
-    runs-on: ubuntu-20.04
+    runs-on: ubuntu-latest
     steps:
       - uses: tarides/changelog-check-action@v3

.github/workflows/nix.yml

@@ -31,7 +31,7 @@ jobs:
       with:
         submodules: true
     - name: nix
-      uses: cachix/install-nix-action@V28
+      uses: cachix/install-nix-action@31.3.0
       with:
         nix_path: nixpkgs=channel:nixos-unstable
     - run: nix develop -c dune build @check @runtest -p merlin-lib,dot-merlin-reader,ocaml-index,merlin

CHANGES.md

@@ -1,5 +1,6 @@
-unreleased
+merlin 5.5
 ==========
+Tue Jun 24 16:10:42 CEST 2025
 
   + merlin library
     - Expose utilities to manipulate typed-holes in `Merlin_analysis.Typed_hole`
@@ -10,6 +11,17 @@ unreleased
     - `inlay-hints` fix inlay hints on function parameters (#1923)
     - Fix issues with ident validation and Lid comparison for occurrences (#1924)
     - Handle class type in outline (#1932)
+    - Handle locally defined value in outline (#1936)
+    - Fix a typer issue triggering assertions in the short-paths graph (#1935,
+      fixes #1913)
+    - Downstreamed a typer fix from 5.3.X that would trigger assertions linked
+      to scopes bit masks when backtracking the typer cache (#1935)
+    - Add a new selection field to outline results that contains the location of
+      the symbol itself. (#1942)
+    - Fix destruct hanging when printing patterns with (::). (#1944, fixes
+      ocaml/ocaml-lsp#1489)
+    - Reproduce and fix a handful of jump-to-definition (locate) issues  (#1930,
+      fixes #1580 and #1588, workaround for #1934)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

src/analysis/locate.ml

@@ -294,14 +294,38 @@ module Utils = struct
     | CMT _ | CMTI _ -> Mconfig.cmt_path config
 end
 
-let move_to filename cmt_infos =
+let reroot_build_dir ~root path =
+  let sep =
+    try String.get Filename.dir_sep 0 with Invalid_argument _ -> '/'
+  in
+  let segments = path |> String.split_on_char ~sep in
+  let rec strip_prefix = function
+    | [] -> []
+    | "_build" :: _ as l -> l
+    | _ :: tl -> strip_prefix tl
+  in
+  match strip_prefix segments with
+  | [] -> path
+  | l ->
+    let sep = Printf.sprintf "%c" sep in
+    Filename.concat root (String.concat ~sep l)
+
+let move_to (config : Mconfig.t) filename cmt_infos =
   let digest =
     (* [None] only for packs, and we wouldn't have a trie if the cmt was for a
        pack. *)
     let sourcefile_in_builddir =
       Filename.concat cmt_infos.Cmt_format.cmt_builddir
         (Option.get cmt_infos.cmt_sourcefile)
     in
+    let sourcefile_in_builddir =
+      (* This workaround is meant to fix issues with Dune's BUILD_PREFIX_MAP It
+         will not work when the [_build] folder is not located at the source
+         root. See [#1934](https://github.com/ocaml/merlin/issues/1934). *)
+      match config.merlin.source_root with
+      | None -> sourcefile_in_builddir
+      | Some root -> reroot_build_dir ~root sourcefile_in_builddir
+    in
     match
       sourcefile_in_builddir |> String.split_on_char ~sep:'.' |> List.rev
     with
@@ -332,7 +356,7 @@ let load_cmt ~config ?(with_fallback = true) comp_unit =
     let cmt_infos = (Cmt_cache.read path).cmt_infos in
     let source_file = cmt_infos.cmt_sourcefile in
     let source_file = Option.value ~default:"*pack*" source_file in
-    move_to path cmt_infos;
+    move_to config.mconfig path cmt_infos;
     Ok (source_file, cmt_infos)
   | None -> Error ()
 
@@ -622,13 +646,14 @@ let find_loc_of_comp_unit ~config uid comp_unit =
 
 let find_loc_of_uid ~config ~local_defs ?ident ?fallback (uid : Shape.Uid.t) =
   let find_loc_of_item ~comp_unit =
-    match find_loc_of_item ~config ~local_defs uid comp_unit, fallback, ident with
+    match
+      (find_loc_of_item ~config ~local_defs uid comp_unit, fallback, ident)
+    with
     | Some { loc; txt }, _, Some ident when String.equal txt ident ->
       (* Checking the ident prevent returning nonsensical results when some uid
          were swaped but the cmt files were not rebuilt. *)
       Some (uid, loc)
-    | Some { loc; _ }, _, None ->
-        Some (uid, loc)
+    | Some { loc; _ }, _, None -> Some (uid, loc)
     | (Some _ | None), Some fallback, _ ->
       find_loc_of_item ~config ~local_defs fallback comp_unit
       |> Option.map ~f:(fun { Location.loc; _ } -> (fallback, loc))
@@ -672,7 +697,7 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
           ~with_fallback:false unit_name
       with
       | Ok (filename, cmt_infos) ->
-        move_to filename cmt_infos;
+        move_to config.mconfig filename cmt_infos;
         log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
         cmt_infos.cmt_impl_shape
       | Error () ->

src/analysis/outline.ml

@@ -35,16 +35,18 @@ open Typedtree
 open Browse_raw
 open Browse_tree
 
-let id_of_patt = function
-  | { pat_desc = Tpat_var (id, _, _); _ } -> Some id
+let name_of_patt = function
+  | { pat_desc = Tpat_var (_, name, _); _ } -> Some name
   | _ -> None
 
-let mk ?(children = []) ~location ~deprecated outline_kind outline_type id =
+let mk ?(children = []) ~location ~deprecated outline_kind outline_type
+    (name : string Location.loc) =
   { Query_protocol.outline_kind;
     outline_type;
     location;
+    selection = name.loc;
     children;
-    outline_name = Ident.name id;
+    outline_name = name.txt;
     deprecated
   }
 
@@ -69,38 +71,38 @@ let rec summarize node =
     in
     let deprecated = Type_utils.is_deprecated vb.vb_attributes in
     begin
-      match id_of_patt vb.vb_pat with
+      match name_of_patt vb.vb_pat with
       | None -> None
-      | Some ident ->
+      | Some name ->
         let typ = outline_type ~env:node.t_env vb.vb_pat.pat_type in
-        Some (mk ~children ~location ~deprecated `Value typ ident)
+        Some (mk ~children ~location ~deprecated `Value typ name)
     end
   | Value_description vd ->
     let deprecated = Type_utils.is_deprecated vd.val_attributes in
     let typ = outline_type ~env:node.t_env vd.val_val.val_type in
-    Some (mk ~location ~deprecated `Value typ vd.val_id)
+    Some (mk ~location ~deprecated `Value typ vd.val_name)
   | Module_declaration md ->
     let children = get_mod_children node in
     begin
-      match md.md_id with
-      | None -> None
-      | Some id ->
+      match md.md_name with
+      | { txt = None; _ } -> None
+      | { txt = Some txt; loc } ->
         let deprecated = Type_utils.is_deprecated md.md_attributes in
-        Some (mk ~children ~location ~deprecated `Module None id)
+        Some (mk ~children ~location ~deprecated `Module None { txt; loc })
     end
   | Module_binding mb ->
     let children = get_mod_children node in
     begin
-      match mb.mb_id with
-      | None -> None
-      | Some id ->
+      match mb.mb_name with
+      | { txt = None; _ } -> None
+      | { txt = Some txt; loc } ->
         let deprecated = Type_utils.is_deprecated mb.mb_attributes in
-        Some (mk ~children ~location ~deprecated `Module None id)
+        Some (mk ~children ~location ~deprecated `Module None { txt; loc })
     end
   | Module_type_declaration mtd ->
     let children = get_mod_children node in
     let deprecated = Type_utils.is_deprecated mtd.mtd_attributes in
-    Some (mk ~deprecated ~children ~location `Modtype None mtd.mtd_id)
+    Some (mk ~deprecated ~children ~location `Modtype None mtd.mtd_name)
   | Type_declaration td ->
     let children =
       List.concat_map (Lazy.force node.t_children) ~f:(fun child ->
@@ -110,15 +112,15 @@ let rec summarize node =
                 match x.t_node with
                 | Constructor_declaration c ->
                   let deprecated = Type_utils.is_deprecated c.cd_attributes in
-                  mk `Constructor None c.cd_id ~deprecated ~location:c.cd_loc
+                  mk `Constructor None c.cd_name ~deprecated ~location:c.cd_loc
                 | Label_declaration ld ->
                   let deprecated = Type_utils.is_deprecated ld.ld_attributes in
-                  mk `Label None ld.ld_id ~deprecated ~location:ld.ld_loc
+                  mk `Label None ld.ld_name ~deprecated ~location:ld.ld_loc
                 | _ -> assert false (* ! *))
           | _ -> [])
     in
     let deprecated = Type_utils.is_deprecated td.typ_attributes in
-    Some (mk ~children ~location ~deprecated `Type None td.typ_id)
+    Some (mk ~children ~location ~deprecated `Type None td.typ_name)
   | Type_extension te ->
     let name = Path.name te.tyext_path in
     let children =
@@ -132,65 +134,58 @@ let rec summarize node =
         outline_kind = `Type;
         outline_type = None;
         location;
+        selection = te.tyext_txt.loc;
         children;
         deprecated
       }
   | Extension_constructor ec ->
     let deprecated = Type_utils.is_deprecated ec.ext_attributes in
-    Some (mk ~location `Exn None ec.ext_id ~deprecated)
+    Some (mk ~location `Exn None ec.ext_name ~deprecated)
   | Class_declaration cd ->
     let children =
       List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
     in
     let deprecated = Type_utils.is_deprecated cd.ci_attributes in
-    Some (mk ~children ~location `Class None cd.ci_id_class_type ~deprecated)
+    Some (mk ~children ~location `Class None cd.ci_id_name ~deprecated)
   | Class_type_declaration ctd ->
     let children =
       List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
     in
     let deprecated = Type_utils.is_deprecated ctd.ci_attributes in
-    Some
-      (mk ~children ~location `ClassType None ctd.ci_id_class_type ~deprecated)
+    Some (mk ~children ~location `ClassType None ctd.ci_id_name ~deprecated)
   | _ -> None
 
 and get_val_elements node =
   match node.t_node with
   | Expression _ ->
     List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
-  | Value_binding vb ->
-    let children =
-      List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
-    in
-    let deprecated = Type_utils.is_deprecated vb.vb_attributes in
-    begin
-      match id_of_patt vb.vb_pat with
-      | None -> []
-      | Some ident ->
-        [ mk ~children ~location:node.t_loc ~deprecated `Value None ident ]
-    end
   | Class_expr _ | Class_structure _ -> get_class_elements node
-  | _ -> []
+  | _ -> Option.to_list (summarize node)
 
 and get_class_elements node =
   match node.t_node with
   | Class_expr _ ->
     List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+  | Class_field cf ->
+    let children =
+      List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
+    in
+    cf.cf_desc |> get_class_field_desc_infos
+    |> Option.map ~f:(fun (str_loc, outline_kind) ->
+           let deprecated = Type_utils.is_deprecated cf.cf_attributes in
+           { Query_protocol.outline_name = str_loc.Location.txt;
+             outline_kind;
+             outline_type = None;
+             location = cf.cf_loc;
+             selection = str_loc.loc;
+             children;
+             deprecated
+           })
+    |> Option.to_list
+  | Class_field_kind _ ->
+    List.concat_map (Lazy.force node.t_children) ~f:get_val_elements
   | Class_structure _ ->
-    List.filter_map (Lazy.force node.t_children) ~f:(fun child ->
-        match child.t_node with
-        | Class_field cf -> begin
-          cf.cf_desc |> get_class_field_desc_infos
-          |> Option.map ~f:(fun (str_loc, outline_kind, children) ->
-                 let deprecated = Type_utils.is_deprecated cf.cf_attributes in
-                 { Query_protocol.outline_name = str_loc.Location.txt;
-                   outline_kind;
-                   outline_type = None;
-                   location = str_loc.Location.loc;
-                   children;
-                   deprecated
-                 })
-        end
-        | _ -> None)
+    List.concat_map (Lazy.force node.t_children) ~f:get_class_elements
   | Class_type { cltyp_desc = Tcty_signature { csig_fields; _ }; _ } ->
     List.filter_map csig_fields ~f:(fun field ->
         get_class_signature_field_desc_infos field.ctf_desc
@@ -200,49 +195,18 @@ and get_class_elements node =
                  outline_kind;
                  outline_type = None;
                  location = field.ctf_loc;
+                 selection = field.ctf_loc;
                  (* TODO: could we have more precised location information? *)
                  children = [];
                  deprecated
                }))
   | _ -> []
 
 and get_class_field_desc_infos = function
-  | Typedtree.Tcf_val (str_loc, _, _, field_kind, _) ->
-    Some (str_loc, `Value, get_class_field_kind_elements field_kind)
-  | Typedtree.Tcf_method (str_loc, _, field_kind) ->
-    Some (str_loc, `Method, get_class_field_kind_elements field_kind)
+  | Typedtree.Tcf_val (str_loc, _, _, _field_kind, _) -> Some (str_loc, `Value)
+  | Typedtree.Tcf_method (str_loc, _, _field_kind) -> Some (str_loc, `Method)
   | _ -> None
 
-and get_class_field_kind_elements = function
-  | Tcfk_virtual _ -> []
-  | Tcfk_concrete (_, expr) -> get_expr_elements expr
-
-and get_expr_elements expr =
-  match expr.exp_desc with
-  | Texp_let (_, vbs, expr) ->
-    List.filter_map vbs ~f:(fun vb ->
-        id_of_patt vb.vb_pat
-        |> Option.map ~f:(fun ident ->
-               let children = get_expr_elements vb.vb_expr in
-               let deprecated = Type_utils.is_deprecated vb.vb_attributes in
-
-               mk ~children ~location:vb.vb_loc ~deprecated `Value None ident))
-    @ get_expr_elements expr
-  | Texp_object ({ cstr_fields; _ }, _) ->
-    List.filter_map cstr_fields ~f:(fun field ->
-        field.cf_desc |> get_class_field_desc_infos
-        |> Option.map ~f:(fun (str_loc, outline_kind, children) ->
-               let deprecated = Type_utils.is_deprecated field.cf_attributes in
-               { Query_protocol.outline_name = str_loc.Location.txt;
-                 outline_kind;
-                 outline_type = None;
-                 location = str_loc.Location.loc;
-                 children;
-                 deprecated
-               }))
-  | Texp_function (_, Tfunction_body expr) -> get_expr_elements expr
-  | _ -> []
-
 and get_mod_children node =
   List.concat_map (Lazy.force node.t_children) ~f:remove_mod_indir
 

src/analysis/test.ml

@@ -0,0 +1,10 @@
+module Foo = struct
+  type t = { foo : int; bar : int }
+
+  let foo = "hello"
+end
+
+let _ =
+  let foo = 10 in
+  let bar = 10 in
+  ({ Foo.foo; bar } : Foo.t)

src/commands/query_json.ml

@@ -326,6 +326,7 @@ let rec json_of_outline outline =
         outline_kind;
         outline_type;
         location;
+        selection;
         children;
         deprecated
       } =
@@ -337,7 +338,8 @@ let rec json_of_outline outline =
           | None -> `Null
           | Some typ -> `String typ );
         ("children", `List (json_of_outline children));
-        ("deprecated", `Bool deprecated)
+        ("deprecated", `Bool deprecated);
+        ("selection", with_location selection [])
       ]
   in
   List.map ~f:json_of_item outline

src/frontend/query_protocol.ml

@@ -92,7 +92,8 @@ and item =
       | `Method ];
     outline_type : string option;
     deprecated : bool;
-    location : Location_aux.t;
+    location : Location.t;
+    selection : Location.t;
     children : outline
   }