add config options for pattern variables and let bindings

Author: jfeser

ocaml-lsp-server/src/config_data.ml

@@ -1,6 +1,106 @@
 open Import
 open Import.Json.Conv
 
+module InlayHints = struct
+  type t =
+    { hint_pattern_variables : bool
+          [@key "hintPatternVariables"] [@default false]
+    ; hint_let_bindings : bool [@key "hintLetBindings"] [@default false]
+    }
+  [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
+
+  let _ = fun (_ : t) -> ()
+
+  
+let t_of_yojson =
+  (let _tp_loc = "ocaml-lsp-server/src/config_data.ml.InlayHints.t" in
+   function
+   | `Assoc field_yojsons as yojson ->
+       let hint_pattern_variables_field = ref Ppx_yojson_conv_lib.Option.None
+       and hint_let_bindings_field = ref Ppx_yojson_conv_lib.Option.None
+       and duplicates = ref []
+       and extra = ref [] in
+       let rec iter =
+         function
+         | (field_name, _field_yojson)::tail ->
+             ((match field_name with
+               | "hintPatternVariables" ->
+                   (match Ppx_yojson_conv_lib.(!)
+                            hint_pattern_variables_field
+                    with
+                    | Ppx_yojson_conv_lib.Option.None ->
+                        let fvalue = bool_of_yojson _field_yojson in
+                        hint_pattern_variables_field :=
+                          (Ppx_yojson_conv_lib.Option.Some fvalue)
+                    | Ppx_yojson_conv_lib.Option.Some _ ->
+                        duplicates := (field_name ::
+                          (Ppx_yojson_conv_lib.(!) duplicates)))
+               | "hintLetBindings" ->
+                   (match Ppx_yojson_conv_lib.(!) hint_let_bindings_field
+                    with
+                    | Ppx_yojson_conv_lib.Option.None ->
+                        let fvalue = bool_of_yojson _field_yojson in
+                        hint_let_bindings_field :=
+                          (Ppx_yojson_conv_lib.Option.Some fvalue)
+                    | Ppx_yojson_conv_lib.Option.Some _ ->
+                        duplicates := (field_name ::
+                          (Ppx_yojson_conv_lib.(!) duplicates)))
+               | _ -> ());
+              iter tail)
+         | [] -> () in
+       (iter field_yojsons;
+        (match Ppx_yojson_conv_lib.(!) duplicates with
+         | _::_ ->
+             Ppx_yojson_conv_lib.Yojson_conv_error.record_duplicate_fields
+               _tp_loc (Ppx_yojson_conv_lib.(!) duplicates) yojson
+         | [] ->
+             (match Ppx_yojson_conv_lib.(!) extra with
+              | _::_ ->
+                  Ppx_yojson_conv_lib.Yojson_conv_error.record_extra_fields
+                    _tp_loc (Ppx_yojson_conv_lib.(!) extra) yojson
+              | [] ->
+                  let (hint_pattern_variables_value, hint_let_bindings_value)
+                    =
+                    ((Ppx_yojson_conv_lib.(!) hint_pattern_variables_field),
+                      (Ppx_yojson_conv_lib.(!) hint_let_bindings_field)) in
+                  {
+                    hint_pattern_variables =
+                      ((match hint_pattern_variables_value with
+                        | Ppx_yojson_conv_lib.Option.None -> false
+                        | Ppx_yojson_conv_lib.Option.Some v -> v));
+                    hint_let_bindings =
+                      ((match hint_let_bindings_value with
+                        | Ppx_yojson_conv_lib.Option.None -> false
+                        | Ppx_yojson_conv_lib.Option.Some v -> v))
+                  })))
+   | _ as yojson ->
+       Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom _tp_loc
+         yojson : Ppx_yojson_conv_lib.Yojson.Safe.t -> t)
+
+  let _ = t_of_yojson
+
+  let yojson_of_t =
+    (function
+     | { hint_pattern_variables = v_hint_pattern_variables
+       ; hint_let_bindings = v_hint_let_bindings
+       } ->
+       let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
+       let bnds =
+         let arg = yojson_of_bool v_hint_let_bindings in
+         ("hintLetBindings", arg) :: bnds
+       in
+       let bnds =
+         let arg = yojson_of_bool v_hint_pattern_variables in
+         ("hintPatternVariables", arg) :: bnds
+       in
+       `Assoc bnds
+      : t -> Ppx_yojson_conv_lib.Yojson.Safe.t)
+
+  let _ = yojson_of_t
+
+  [@@@end]
+end
+
 module Lens = struct
   type t = { enable : bool [@default true] }
   [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
@@ -150,6 +250,8 @@ type t =
         [@default None] [@yojson_drop_default ( = )]
   ; extended_hover : ExtendedHover.t Json.Nullable_option.t
         [@key "extendedHover"] [@default None] [@yojson_drop_default ( = )]
+  ; inlay_hints : InlayHints.t Json.Nullable_option.t
+        [@key "inlayHints"] [@default None] [@yojson_drop_default ( = )]
   }
 [@@deriving_inline yojson] [@@yojson.allow_extra_fields]
 
@@ -161,6 +263,7 @@ let t_of_yojson =
    | `Assoc field_yojsons as yojson -> (
      let codelens_field = ref Ppx_yojson_conv_lib.Option.None
      and extended_hover_field = ref Ppx_yojson_conv_lib.Option.None
+     and inlay_hints_field = ref Ppx_yojson_conv_lib.Option.None
      and duplicates = ref []
      and extra = ref [] in
      let rec iter = function
@@ -186,6 +289,17 @@ let t_of_yojson =
              extended_hover_field := Ppx_yojson_conv_lib.Option.Some fvalue
            | Ppx_yojson_conv_lib.Option.Some _ ->
              duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
+         | "inlayHints" -> (
+           match Ppx_yojson_conv_lib.( ! ) inlay_hints_field with
+           | Ppx_yojson_conv_lib.Option.None ->
+             let fvalue =
+               Json.Nullable_option.t_of_yojson
+                 InlayHints.t_of_yojson
+                 _field_yojson
+             in
+             inlay_hints_field := Ppx_yojson_conv_lib.Option.Some fvalue
+           | Ppx_yojson_conv_lib.Option.Some _ ->
+             duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
          | _ -> ());
          iter tail
        | [] -> ()
@@ -205,9 +319,10 @@ let t_of_yojson =
            (Ppx_yojson_conv_lib.( ! ) extra)
            yojson
        | [] ->
-         let codelens_value, extended_hover_value =
+         let codelens_value, extended_hover_value, inlay_hints_value =
            ( Ppx_yojson_conv_lib.( ! ) codelens_field
-           , Ppx_yojson_conv_lib.( ! ) extended_hover_field )
+           , Ppx_yojson_conv_lib.( ! ) extended_hover_field
+           , Ppx_yojson_conv_lib.( ! ) inlay_hints_field )
          in
          { codelens =
              (match codelens_value with
@@ -217,6 +332,10 @@ let t_of_yojson =
              (match extended_hover_value with
              | Ppx_yojson_conv_lib.Option.None -> None
              | Ppx_yojson_conv_lib.Option.Some v -> v)
+         ; inlay_hints =
+             (match inlay_hints_value with
+             | Ppx_yojson_conv_lib.Option.None -> None
+             | Ppx_yojson_conv_lib.Option.Some v -> v)
          }))
    | _ as yojson ->
      Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom
@@ -228,8 +347,21 @@ let _ = t_of_yojson
 
 let yojson_of_t =
   (function
-   | { codelens = v_codelens; extended_hover = v_extended_hover } ->
+   | { codelens = v_codelens
+     ; extended_hover = v_extended_hover
+     ; inlay_hints = v_inlay_hints
+     } ->
      let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
+     let bnds =
+       if None = v_inlay_hints then bnds
+       else
+         let arg =
+           (Json.Nullable_option.yojson_of_t InlayHints.yojson_of_t)
+             v_inlay_hints
+         in
+         let bnd = ("inlayHints", arg) in
+         bnd :: bnds
+     in
      let bnds =
        if None = v_extended_hover then bnds
        else
@@ -259,4 +391,6 @@ let _ = yojson_of_t
 let default =
   { codelens = Some { enable = false }
   ; extended_hover = Some { enable = false }
+  ; inlay_hints =
+      Some { hint_pattern_variables = true; hint_let_bindings = true }
   }

ocaml-lsp-server/src/inlay_hints.ml

@@ -14,8 +14,26 @@ let outline_type ~env typ =
          | _ -> true)
   |> String.concat ~sep:" "
 
-let hint_binding_iter typedtree range k =
+let hint_binding_iter ?(hint_let_bindings = false)
+    ?(hint_pattern_variables = false) typedtree range k =
   let module I = Ocaml_typing.Tast_iterator in
+  (* to be used for pattern variables in match cases, but not for function
+     arguments *)
+  let case hint_lhs (iter : I.iterator) (case : _ Typedtree.case) =
+    if hint_lhs then iter.pat iter case.c_lhs;
+    Option.iter case.c_guard ~f:(iter.expr iter);
+    iter.expr iter case.c_rhs
+  in
+  let value_binding hint_lhs (iter : I.iterator) (vb : Typedtree.value_binding)
+      =
+    if range_overlaps_loc range vb.vb_loc then
+      if not hint_lhs then iter.expr iter vb.vb_expr
+      else
+        match vb.vb_expr.exp_desc with
+        | Texp_function _ -> iter.expr iter vb.vb_expr
+        | _ -> I.default_iterator.value_binding iter vb
+  in
+
   let expr (iter : I.iterator) (e : Typedtree.expression) =
     if range_overlaps_loc range e.exp_loc then
       match e.exp_desc with
@@ -31,19 +49,20 @@ let hint_binding_iter typedtree range k =
           } ->
         iter.pat iter vb_pat;
         iter.expr iter body
+      | Texp_let (_, vbs, body) ->
+        List.iter vbs ~f:(value_binding hint_let_bindings iter);
+        iter.expr iter body
+      | Texp_letop { body; _ } -> case hint_let_bindings iter body
+      | Texp_match (expr, cases, _) ->
+        iter.expr iter expr;
+        List.iter cases ~f:(case hint_pattern_variables iter)
       | _ -> I.default_iterator.expr iter e
   in
 
   let structure_item (iter : I.iterator) (item : Typedtree.structure_item) =
     if range_overlaps_loc range item.str_loc then
       I.default_iterator.structure_item iter item
   in
-  let value_binding (iter : I.iterator) (vb : Typedtree.value_binding) =
-    if range_overlaps_loc range vb.vb_loc then
-      match vb.vb_expr.exp_desc with
-      | Texp_function _ -> iter.expr iter vb.vb_expr
-      | _ -> I.default_iterator.value_binding iter vb
-  in
   let pat (type k) iter (pat : k Typedtree.general_pattern) =
     if range_overlaps_loc range pat.pat_loc then
       let has_constraint =
@@ -60,14 +79,27 @@ let hint_binding_iter typedtree range k =
         | _ -> ())
   in
   let iterator =
-    { I.default_iterator with expr; structure_item; pat; value_binding }
+    { I.default_iterator with
+      expr
+    ; structure_item
+    ; pat
+    ; value_binding = value_binding true
+    }
   in
   iterator.structure iterator typedtree
 
 let compute (state : State.t)
     { InlayHintParams.range; textDocument = { uri }; _ } =
   let store = state.store in
   let doc = Document_store.get store uri in
+  let hint_let_bindings =
+    Option.map state.configuration.data.inlay_hints ~f:(fun c ->
+        c.hint_let_bindings)
+  in
+  let hint_pattern_variables =
+    Option.map state.configuration.data.inlay_hints ~f:(fun c ->
+        c.hint_pattern_variables)
+  in
   match Document.kind doc with
   | `Other -> Fiber.return None
   | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None
@@ -78,7 +110,12 @@ let compute (state : State.t)
           match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with
           | `Interface _ -> ()
           | `Implementation typedtree ->
-            hint_binding_iter typedtree range (fun env type_ loc ->
+            hint_binding_iter
+              ?hint_let_bindings
+              ?hint_pattern_variables
+              typedtree
+              range
+              (fun env type_ loc ->
                 let open Option.O in
                 let hint =
                   let label = outline_type ~env type_ in