Improve Inlay Hints Handling with [@merlin.hide]

CHANGES.md

@@ -6,6 +6,7 @@ unreleased
       (#1888)
     - `locate` can now disambiguate between files with identical names and contents
       (#1882)
+    - Improve Inlay Hints Handling with [@merlin.hide] and remove support for "avoid-ghost-location" (#1894)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

doc/dev/PROTOCOL.md

@@ -552,14 +552,13 @@ This command is essentially useful for an LSP server, as it can be used to retur
 If no help is found, the command returns an empty object, otherwise it returns a structured object with signatures and active parameters.
 You can find more information here <https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#textDocument_signatureHelp>
 
-### `inlay-hints -start <position> -end <position> -let-binding <bool> -pattern-binding <bool> -avoid-ghost <bool>`
+### `inlay-hints -start <position> -end <position> -let-binding <bool> -pattern-binding <bool>`
 
 ```
       -start <position>  the start of the region where to activate the inlay-hints
         -end <position>  the end of the region where to activate the inlay-hints
     -let-binding <bool>  activate for `let-bindings
 -pattern-binding <bool>  activate for `pattern-bindings
-    -avoid-ghost <bool>  deactivate for node attached with a ghost location (mainly for tests)
 ```
 
 This command is essentially useful for an LSP server, and returns the list of inlay hints for a given region in a list of the following object:

src/analysis/inlay_hints.ml

@@ -4,8 +4,6 @@ let { Logger.log } = Logger.for_section "inlay-hints"
 
 module Iterator = Ocaml_typing.Tast_iterator
 
-let is_ghost_location avoid_ghost loc = loc.Location.loc_ghost && avoid_ghost
-
 let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) =
   List.exists
     ~f:(fun (extra, _, _) ->
@@ -16,27 +14,29 @@ let pattern_has_constraint (type a) (pattern : a Typedtree.general_pattern) =
       | Typedtree.Tpat_unpack -> false)
     pattern.pat_extra
 
-let structure_iterator hint_let_binding hint_pattern_binding
-    avoid_ghost_location typedtree range callback =
+let structure_iterator hint_let_binding hint_pattern_binding typedtree range
+    callback =
+  let super = Iterator.default_iterator in
+
   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
     let () = Option.iter ~f:(iterator.expr iterator) case.c_guard in
     iterator.expr iterator case.c_rhs
   in
 
-  let value_binding_iterator hint_lhs (iterator : Iterator.iterator) vb =
+  let value_binding_iterator (iterator : Iterator.iterator) vb =
     let () =
       log ~title:"value_binding" "%a" Logger.fmt (fun fmt ->
           Format.fprintf fmt "On value binding %a" (Printtyped.pattern 0)
             vb.Typedtree.vb_pat)
     in
     if Location_aux.overlap_with_range range vb.Typedtree.vb_loc then
-      if hint_lhs then
+      if hint_let_binding then
         let () = log ~title:"value_binding" "overlap" in
         match vb.vb_expr.exp_desc with
         | Texp_function _ -> iterator.expr iterator vb.vb_expr
-        | _ -> Iterator.default_iterator.value_binding iterator vb
+        | _ -> super.value_binding iterator vb
       else iterator.expr iterator vb.vb_expr
   in
 
@@ -50,11 +50,7 @@ let structure_iterator hint_let_binding hint_pattern_binding
       match expr.exp_desc with
       | Texp_let (_, bindings, body) ->
         let () = log ~title:"expression" "on let" in
-        let () =
-          List.iter
-            ~f:(value_binding_iterator hint_let_binding iterator)
-            bindings
-        in
+        let () = List.iter ~f:(iterator.value_binding iterator) bindings in
         iterator.expr iterator body
       | Texp_letop { body; _ } ->
         let () = log ~title:"expression" "on let-op" in
@@ -63,25 +59,7 @@ 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); _ };
-                      _
-                    }
-                  ];
-                _
-              } ) ->
-        let () = log ~title:"expression" "on function" in
-        let () = iterator.pat iterator vb_pat in
-        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 *)
-        log ~title:"ghost" "ghost-location found"
-      | _ -> Iterator.default_iterator.expr iterator expr
+      | _ -> super.expr iterator expr
   in
 
   let structure_item_iterator (iterator : Iterator.iterator) item =
@@ -90,13 +68,17 @@ let structure_iterator hint_let_binding hint_pattern_binding
       match item.str_desc with
       | Tstr_value (_, bindings) ->
         List.iter
-          ~f:(fun binding -> expr_iterator iterator binding.Typedtree.vb_expr)
+          ~f:(fun binding ->
+            (* We do not annotate structure item let-bindings (even when hint_let_binding is enabled)
+               because they are already annotated by code lenses. *)
+            iterator.value_binding
+              { iterator with
+                expr = (fun _ -> iterator.expr iterator);
+                pat = (fun _ -> ignore)
+              }
+              binding)
           bindings
-      | _ when is_ghost_location avoid_ghost_location item.str_loc ->
-        (* Stop iterating when we see a ghost location to avoid
-           annotating generated code *)
-        log ~title:"ghost" "ghost-location found"
-      | _ -> Iterator.default_iterator.structure_item iterator item
+      | _ -> super.structure_item iterator item
   in
 
   let pattern_iterator (type a) iterator (pattern : a Typedtree.general_pattern)
@@ -110,21 +92,21 @@ let structure_iterator hint_let_binding hint_pattern_binding
       && not (pattern_has_constraint pattern)
     then
       let () = log ~title:"pattern" "overlap" in
-      let () = Iterator.default_iterator.pat iterator pattern in
+      let () = super.pat iterator pattern in
       match pattern.pat_desc with
       | Tpat_var _ when not pattern.pat_loc.loc_ghost ->
         let () = log ~title:"pattern" "found" in
         callback pattern.pat_env pattern.pat_type pattern.pat_loc
       | _ -> log ~title:"pattern" "not a var"
   in
-
   let iterator =
-    { Ocaml_typing.Tast_iterator.default_iterator with
-      expr = expr_iterator;
-      structure_item = structure_item_iterator;
-      pat = pattern_iterator;
-      value_binding = value_binding_iterator true
-    }
+    Ast_iterators.iter_only_visible
+      { Ocaml_typing.Tast_iterator.default_iterator with
+        expr = expr_iterator;
+        structure_item = structure_item_iterator;
+        pat = pattern_iterator;
+        value_binding = value_binding_iterator
+      }
   in
   iterator.structure iterator typedtree
 
@@ -138,21 +120,20 @@ 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 ~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"
+        Format.fprintf fmt "Start on %s to %s with : let: %b, pat: %b"
           (Lexing.print_position () start)
           (Lexing.print_position () stop)
-          hint_let_binding hint_pattern_binding avoid_ghost_location)
+          hint_let_binding hint_pattern_binding)
   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 ->
+    structure_iterator hint_let_binding hint_pattern_binding 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,7 +5,6 @@ type hint = Lexing.position * string
 val of_structure :
   hint_let_binding:bool ->
   hint_pattern_binding:bool ->
-  avoid_ghost_location:bool ->
   start:Lexing.position ->
   stop:Lexing.position ->
   Typedtree.structure ->

src/commands/new_commands.ml

@@ -618,34 +618,26 @@ let all_commands =
       ~spec:
         [ arg "-start" "<position> Where inlay-hints generation start"
             (marg_position
-               (fun start (_start, stop, let_binding, pattern_binding, ghost) ->
-                 (start, stop, let_binding, pattern_binding, ghost)));
+               (fun start (_start, stop, let_binding, pattern_binding) ->
+                 (start, stop, let_binding, pattern_binding)));
           arg "-end" "<position> Where inlay-hints generation stop"
             (marg_position
-               (fun stop (start, _stop, let_binding, pattern_binding, ghost) ->
-                 (start, stop, let_binding, pattern_binding, ghost)));
+               (fun stop (start, _stop, let_binding, pattern_binding) ->
+                 (start, stop, let_binding, pattern_binding)));
           optional "-let-binding" "<bool> Hint let-binding (default is false)"
             (Marg.bool
-               (fun
-                 let_binding
-                 (start, stop, _let_binding, pattern_binding, ghost)
-               -> (start, stop, let_binding, pattern_binding, ghost)));
+               (fun let_binding (start, stop, _let_binding, pattern_binding) ->
+                 (start, stop, let_binding, pattern_binding)));
           optional "-pattern-binding"
             "<bool> Hint pattern-binding (default is false)"
             (Marg.bool
                (fun
-                 pattern_binding
-                 (start, stop, let_binding, _pattern_binding, ghost)
-               -> (start, stop, let_binding, pattern_binding, ghost)));
-          optional "-avoid-ghost-location"
-            "<bool> Avoid hinting ghost location (default is true)"
-            (Marg.bool
-               (fun ghost (start, stop, let_binding, pattern_binding, _ghost) ->
-                 (start, stop, let_binding, pattern_binding, ghost)))
+                 pattern_binding (start, stop, let_binding, _pattern_binding) ->
+                 (start, stop, let_binding, pattern_binding)))
         ]
-      ~default:(`None, `None, false, false, true)
+      ~default:(`None, `None, false, false)
       begin
-        fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) ->
+        fun buffer (start, stop, let_binding, pattern_binding) ->
           match (start, stop) with
           | `None, `None -> failwith "-start <pos> and -end are mandatory"
           | `None, _ -> failwith "-start <pos> is mandatory"
@@ -654,7 +646,7 @@ let all_commands =
             let start, stop = position in
             run buffer
               (Query_protocol.Inlay_hints
-                 (start, stop, let_binding, pattern_binding, avoid_ghost))
+                 (start, stop, let_binding, pattern_binding))
       end;
     command "shape"
       ~doc:

src/commands/query_json.ml

@@ -134,13 +134,12 @@ let dump (type a) : a t -> json =
           | Some `Local -> `String "local" );
         ("depth", `Int depth)
       ]
-  | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var, ghost) ->
+  | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var) ->
     mk "inlay-hints"
       [ ("start", mk_position start);
         ("stop", mk_position stop);
         ("hint-let-binding", `Bool hint_let_binding);
-        ("hint-pattern-variable", `Bool hint_pattern_var);
-        ("avoid-ghost-location", `Bool ghost)
+        ("hint-pattern-variable", `Bool hint_pattern_var)
       ]
   | Outline -> mk "outline" []
   | Errors { lexing; parsing; typing } ->

src/frontend/query_commands.ml

@@ -795,18 +795,16 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       Occurrences.locs_of ~config ~env ~typer_result ~pos ~scope path
     in
     (locs, status)
-  | Inlay_hints
-      (start, stop, hint_let_binding, hint_pattern_binding, avoid_ghost_location)
-    ->
+  | Inlay_hints (start, stop, hint_let_binding, hint_pattern_binding) ->
     let start = Mpipeline.get_lexing_pos pipeline start
     and stop = Mpipeline.get_lexing_pos pipeline stop in
     let typer_result = Mpipeline.typer_result pipeline in
     begin
       match Mtyper.get_typedtree typer_result with
       | `Interface _ -> []
       | `Implementation structure ->
-        Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding
-          ~avoid_ghost_location ~start ~stop structure
+        Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding ~start
+          ~stop structure
     end
   | Signature_help { position; _ } -> (
     (* Todo: additionnal contextual information could help us provide better

src/frontend/query_protocol.ml

@@ -200,7 +200,7 @@ type _ t =
       Msource.position * [ `None | `Local ] option * int option
       -> (Location.t * string list) t
   | Inlay_hints :
-      Msource.position * Msource.position * bool * bool * bool
+      Msource.position * Msource.position * bool * bool
       -> (Lexing.position * string) list t
   | Outline (* *) : outline t
   | Shape (* *) : Msource.position -> shape list t