Introduce typer interruption

.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

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

@@ -51,6 +51,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/liam923/ocaml-lsp.git#stale-occurrences
+          opam --cli=2.1 pin --with-version=dev --no-action https://github.com/ocaml/ocaml-lsp.git
           opam --cli=2.1 pin --with-version=5.4-503 --no-action .
           opam install ocaml-lsp-server --ignore-constraints-on=ocamlformat

CHANGES.md

@@ -1,12 +1,28 @@
-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`
       (#1888)
     - `locate` can now disambiguate between files with identical names and contents
       (#1882)
     - `occurrences` now reports stale files (#1885)
+    - `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)
+    - Introduce parallel typer (#1920)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

src/analysis/inlay_hints.ml

@@ -17,7 +17,7 @@ let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) =
     pattern.pat_extra
 
 let structure_iterator hint_let_binding hint_pattern_binding
-    avoid_ghost_location typedtree range callback =
+    hint_function_params avoid_ghost_location typedtree range callback =
   let case_iterator hint_lhs (iterator : Iterator.iterator) case =
     let () = log ~title:"case" "on case" in
     let () = if hint_lhs then iterator.pat iterator case.Typedtree.c_lhs in
@@ -63,20 +63,18 @@ let structure_iterator hint_let_binding hint_pattern_binding
         let () = log ~title:"expression" "on match" in
         let () = iterator.expr iterator expr in
         List.iter ~f:(case_iterator hint_pattern_binding iterator) cases
-      | Texp_function
-          ( _,
-            Tfunction_cases
-              { cases =
-                  [ { c_rhs =
-                        { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ };
-                      _
-                    }
-                  ];
-                _
-              } ) ->
+      | Texp_function (args, body) -> (
         let () = log ~title:"expression" "on function" in
-        let () = iterator.pat iterator vb_pat in
-        iterator.expr iterator body
+        if hint_function_params then
+          List.iter args ~f:(fun Typedtree.{ fp_kind; _ } ->
+              match fp_kind with
+              | Tparam_pat pat | Tparam_optional_default (pat, _) ->
+                iterator.pat iterator pat);
+        match body with
+        | Tfunction_cases { cases; _ } ->
+          List.iter cases ~f:(fun case ->
+              case_iterator hint_pattern_binding iterator case)
+        | Tfunction_body body -> iterator.expr iterator body)
       | _ when is_ghost_location avoid_ghost_location expr.exp_loc ->
         (* Stop iterating when we see a ghost location to avoid
            annotating generated code *)
@@ -138,21 +136,24 @@ let create_hint env typ loc =
   let position = loc.Location.loc_end in
   (position, label)
 
-let of_structure ~hint_let_binding ~hint_pattern_binding ~avoid_ghost_location
-    ~start ~stop structure =
+let of_structure ~hint_let_binding ~hint_pattern_binding ~hint_function_params
+    ~avoid_ghost_location ~start ~stop structure =
   let () =
     log ~title:"start" "%a" Logger.fmt (fun fmt ->
         Format.fprintf fmt
-          "Start on %s to %s with : let: %b, pat: %b, ghost: %b"
+          "Start on %s to %s with : let: %b, pat: %b, function_param: %b, \
+           ghost: %b"
           (Lexing.print_position () start)
           (Lexing.print_position () stop)
-          hint_let_binding hint_pattern_binding avoid_ghost_location)
+          hint_let_binding hint_pattern_binding hint_function_params
+          avoid_ghost_location)
   in
   let range = (start, stop) in
   let hints = ref [] in
   let () =
     structure_iterator hint_let_binding hint_pattern_binding
-      avoid_ghost_location structure range (fun env typ loc ->
+      hint_function_params avoid_ghost_location structure range
+      (fun env typ loc ->
         let () =
           log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt ->
               Format.fprintf fmt "%s - %a"

src/analysis/inlay_hints.mli

@@ -5,6 +5,7 @@ type hint = Lexing.position * string
 val of_structure :
   hint_let_binding:bool ->
   hint_pattern_binding:bool ->
+  hint_function_params:bool ->
   avoid_ghost_location:bool ->
   start:Lexing.position ->
   stop:Lexing.position ->

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 ()
 
@@ -620,14 +644,17 @@ let find_loc_of_comp_unit ~config uid comp_unit =
     log ~title "Failed to load the CU's cmt";
     `None
 
-let find_loc_of_uid ~config ~local_defs ~ident ?fallback (uid : Shape.Uid.t) =
+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) with
-    | Some { loc; txt }, _ when String.equal txt ident ->
+    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 _ | None), Some fallback ->
+    | 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))
     | _ -> None
@@ -670,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 () ->
@@ -705,7 +732,7 @@ let rec uid_of_result ~traverse_aliases = function
   | Approximated _ | Unresolved _ | Internal_error_missing_uid -> (None, true)
 
 (** This is the main function here *)
-let from_path ~config ~env ~local_defs ~decl path =
+let from_path ~config ~env ~local_defs ~decl ?ident:_ path =
   let title = "from_path" in
   let unalias (decl : Env_lookup.item) =
     if not config.traverse_aliases then (path, decl.uid)
@@ -752,11 +779,14 @@ let from_path ~config ~env ~local_defs ~decl path =
   in
   (* Step 2:  Uid => Location *)
   let loc =
-    let ident = Path.last path in
+    let ident =
+      (* TODO it might not be useful to check the ident without impl_uid *)
+      Path.last path
+    in
     match impl_uid with
     | Some impl_uid ->
       find_loc_of_uid ~config ~local_defs ~ident ~fallback:uid impl_uid
-    | None -> find_loc_of_uid ~config ~local_defs ~ident uid
+    | None -> find_loc_of_uid ~config ~local_defs uid
   in
   let loc =
     match loc with
@@ -792,7 +822,9 @@ let from_longident ~config ~env ~local_defs nss ident =
   in
   match Env_lookup.by_longident nss ident env with
   | None -> `Not_in_env str_ident
-  | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path
+  | Some (path, decl) ->
+    let ident = Longident.last ident in
+    from_path ~config ~env ~local_defs ~decl ~ident path
 
 let from_path ~config ~env ~local_defs ~namespace path =
   File_switching.reset ();