Preliminary inlay hint support

CHANGES.md

@@ -36,6 +36,7 @@
 
 - Add mark/remove unused actions for open, types, for loop indexes, modules,
   match cases, rec, and constructors (#1141)
+- Add inlay hints for types on let bindings (#1159)
 
 - Offer auto-completion for the keyword `in` (#1217)
 

ocaml-lsp-server/src/config_data.ml

@@ -1,6 +1,104 @@
 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]
@@ -222,6 +320,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 ( = )]
   ; dune_diagnostics : DuneDiagnostics.t Json.Nullable_option.t
         [@key "duneDiagnostics"] [@default None] [@yojson_drop_default ( = )]
   }
@@ -235,6 +335,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 dune_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None
      and duplicates = ref []
      and extra = ref [] in
@@ -261,6 +362,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)
          | "duneDiagnostics" -> (
            match Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field with
            | Ppx_yojson_conv_lib.Option.None ->
@@ -291,9 +403,13 @@ let t_of_yojson =
            (Ppx_yojson_conv_lib.( ! ) extra)
            yojson
        | [] ->
-         let codelens_value, extended_hover_value, dune_diagnostics_value =
+         let ( codelens_value
+             , extended_hover_value
+             , inlay_hints_value
+             , dune_diagnostics_value ) =
            ( Ppx_yojson_conv_lib.( ! ) codelens_field
            , Ppx_yojson_conv_lib.( ! ) extended_hover_field
+           , Ppx_yojson_conv_lib.( ! ) inlay_hints_field
            , Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field )
          in
          { codelens =
@@ -304,6 +420,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)
          ; dune_diagnostics =
              (match dune_diagnostics_value with
              | Ppx_yojson_conv_lib.Option.None -> None
@@ -321,6 +441,7 @@ let yojson_of_t =
   (function
    | { codelens = v_codelens
      ; extended_hover = v_extended_hover
+     ; inlay_hints = v_inlay_hints
      ; dune_diagnostics = v_dune_diagnostics
      } ->
      let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
@@ -334,6 +455,16 @@ let yojson_of_t =
          let bnd = ("duneDiagnostics", arg) in
          bnd :: bnds
      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
@@ -363,5 +494,7 @@ let _ = yojson_of_t
 let default =
   { codelens = Some { enable = false }
   ; extended_hover = Some { enable = false }
+  ; inlay_hints =
+      Some { hint_pattern_variables = false; hint_let_bindings = false }
   ; dune_diagnostics = Some { enable = true }
   }

ocaml-lsp-server/src/import.ml

@@ -234,6 +234,9 @@ include struct
   module FoldingRangeParams = FoldingRangeParams
   module Hover = Hover
   module HoverParams = HoverParams
+  module InlayHint = InlayHint
+  module InlayHintKind = InlayHintKind
+  module InlayHintParams = InlayHintParams
   module InitializeParams = InitializeParams
   module InitializeResult = InitializeResult
   module Location = Location

ocaml-lsp-server/src/inlay_hints.ml

@@ -0,0 +1,137 @@
+open Import
+open Fiber.O
+
+let range_overlaps_loc range loc =
+  match Range.of_loc_opt loc with
+  | Some range' -> Range.overlaps range range'
+  | None -> false
+
+let outline_type ~env typ =
+  Ocaml_typing.Printtyp.wrap_printing_env env (fun () ->
+      Format.asprintf "@[<h>: %a@]" Ocaml_typing.Printtyp.type_scheme typ)
+  |> String.extract_words ~is_word_char:(function
+         | ' ' | '\t' | '\n' -> false
+         | _ -> true)
+  |> String.concat ~sep:" "
+
+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
+      | Texp_function
+          { arg_label = Optional _
+          ; cases =
+              [ { c_rhs =
+                    { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ }
+                ; _
+                }
+              ]
+          ; _
+          } ->
+        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
+      match item.str_desc with
+      | Typedtree.Tstr_value (_, vbs) ->
+        List.iter vbs ~f:(fun (vb : Typedtree.value_binding) ->
+            expr iter vb.vb_expr)
+      | _ -> I.default_iterator.structure_item iter item
+  in
+  let pat (type k) iter (pat : k Typedtree.general_pattern) =
+    if range_overlaps_loc range pat.pat_loc then
+      let has_constraint =
+        List.exists pat.pat_extra ~f:(fun (extra, _, _) ->
+            match extra with
+            | Typedtree.Tpat_constraint _ -> true
+            | _ -> false)
+      in
+      if not has_constraint then (
+        I.default_iterator.pat iter pat;
+        match pat.pat_desc with
+        | Tpat_var _ when not pat.pat_loc.loc_ghost ->
+          k pat.pat_env pat.pat_type pat.pat_loc
+        | _ -> ())
+  in
+  let iterator =
+    { 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
+  | `Merlin doc ->
+    let hints = ref [] in
+    let* () =
+      Document.Merlin.with_pipeline_exn doc (fun pipeline ->
+          match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with
+          | `Interface _ -> ()
+          | `Implementation typedtree ->
+            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
+                  let+ position = Position.of_lexical_position loc.loc_end in
+                  InlayHint.create
+                    ~kind:Type
+                    ~position
+                    ~label:(`String label)
+                    ~paddingLeft:false
+                    ~paddingRight:false
+                    ()
+                in
+                Option.iter hint ~f:(fun hint -> hints := hint :: !hints)))
+    in
+    Fiber.return (Some !hints)

ocaml-lsp-server/src/inlay_hints.mli

@@ -0,0 +1,3 @@
+open Import
+
+val compute : State.t -> InlayHintParams.t -> InlayHint.t list option Fiber.t

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -1,6 +1,7 @@
 open Import
 module Version = Version
 module Diagnostics = Diagnostics
+module Position = Position
 module Doc_to_md = Doc_to_md
 module Diff = Diff
 module Testing = Testing
@@ -152,6 +153,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
       ~semanticTokensProvider
       ~experimental
       ~renameProvider
+      ~inlayHintProvider:(`Bool true)
       ~workspace
       ~executeCommandProvider
       ?positionEncoding
@@ -591,7 +593,8 @@ let on_request :
             Compl.resolve doc ci resolve Document.Merlin.doc_comment ~markdown))
       ()
   | CodeAction params -> Code_actions.compute server params
-  | InlayHint _ -> now None
+  | InlayHint params ->
+    later (fun state () -> Inlay_hints.compute state params) ()
   | TextDocumentColor _ -> now []
   | TextDocumentColorPresentation _ -> now []
   | TextDocumentHover req ->

ocaml-lsp-server/src/ocaml_lsp_server.mli

@@ -2,5 +2,6 @@ val run : Lsp.Cli.Channel.t -> read_dot_merlin:bool -> unit -> unit
 
 module Diagnostics = Diagnostics
 module Version = Version
+module Position = Position
 module Doc_to_md = Doc_to_md
 module Testing = Testing