WIP: Introduce typer interruption

.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

.ocamlformat

@@ -1,5 +1,6 @@
 version=0.27.0
 disable=false
+ocaml-version = 5.3
 
 break-cases=fit-or-vertical
 doc-comments=before

CHANGES.md

@@ -7,6 +7,8 @@ unreleased
     - `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)
   + 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

@@ -620,14 +620,16 @@ 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
@@ -705,7 +707,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 +754,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 +797,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 ();

src/analysis/typed_hole.ml

@@ -14,4 +14,3 @@ let is_a_hole = function
   | (_, Browse_raw.Module_expr { mod_desc = Tmod_typed_hole; _ }) :: (_, _) :: _
   | (_, Browse_raw.Expression { exp_desc = Texp_typed_hole; _ }) :: _ -> true
   | [] | (_, _) :: _ -> false
-;;