Inlay hint function params

CHANGES.md

@@ -7,6 +7,7 @@ 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)
   + 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/commands/new_commands.ml

@@ -618,34 +618,120 @@ 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,
+                   function_params,
+                   ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )));
           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,
+                   function_params,
+                   ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )));
           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)));
+                 ( start,
+                   stop,
+                   _let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )));
           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)));
+                 ( start,
+                   stop,
+                   let_binding,
+                   _pattern_binding,
+                   function_params,
+                   ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )));
+          optional "-function-params"
+            "<bool> Hint function parameters (default is false)"
+            (Marg.bool
+               (fun
+                 function_params
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   _function_params,
+                   ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   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)))
+               (fun
+                 ghost
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   _ghost )
+               ->
+                 ( start,
+                   stop,
+                   let_binding,
+                   pattern_binding,
+                   function_params,
+                   ghost )))
         ]
-      ~default:(`None, `None, false, false, true)
-      begin
-        fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) ->
+      ~default:(`None, `None, false, false, false, true)
+      begin
+        fun buffer
+          ( start,
+            stop,
+            let_binding,
+            pattern_binding,
+            function_params,
+            avoid_ghost )
+        ->
           match (start, stop) with
           | `None, `None -> failwith "-start <pos> and -end are mandatory"
           | `None, _ -> failwith "-start <pos> is mandatory"
@@ -654,7 +740,12 @@ 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,
+                   function_params,
+                   avoid_ghost ))
       end;
     command "shape"
       ~doc:

src/commands/query_json.ml

@@ -134,12 +134,19 @@ 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,
+        hint_function_params,
+        ghost ) ->
     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);
+        ("hint-function-params", `Bool hint_function_params);
         ("avoid-ghost-location", `Bool ghost)
       ]
   | Outline -> mk "outline" []

src/frontend/query_commands.ml

@@ -796,8 +796,12 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
     in
     (occurrences, status)
   | Inlay_hints
-      (start, stop, hint_let_binding, hint_pattern_binding, avoid_ghost_location)
-    ->
+      ( start,
+        stop,
+        hint_let_binding,
+        hint_pattern_binding,
+        hint_function_params,
+        avoid_ghost_location ) ->
     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
@@ -806,7 +810,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       | `Interface _ -> []
       | `Implementation structure ->
         Inlay_hints.of_structure ~hint_let_binding ~hint_pattern_binding
-          ~avoid_ghost_location ~start ~stop structure
+          ~hint_function_params ~avoid_ghost_location ~start ~stop structure
     end
   | Signature_help { position; _ } -> (
     (* Todo: additionnal contextual information could help us provide better

src/frontend/query_protocol.ml

@@ -202,7 +202,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 * bool * bool
       -> (Lexing.position * string) list t
   | Outline (* *) : outline t
   | Shape (* *) : Msource.position -> shape list t