Preliminary inlay hint support

CHANGES.md

@@ -1,3 +1,9 @@
+# Unreleased
+
+## Features
+
+- Add inlay hints for types on let bindings (#1159)
+
 # 1.16.2
 
 ## Fixes

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/import.ml

@@ -227,6 +227,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,133 @@
+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
+      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

@@ -150,6 +150,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
       ~semanticTokensProvider
       ~experimental
       ~renameProvider
+      ~inlayHintProvider:(`Bool true)
       ~workspace
       ~executeCommandProvider
       ?positionEncoding
@@ -585,7 +586,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/range.ml

@@ -57,3 +57,9 @@ let resize_for_edit { TextEdit.range; newText } =
       { Position.line; character }
     in
     { range with end_ }
+
+let overlaps x y =
+  let open Ordering in
+  match (Position.compare x.start y.end_, Position.compare x.end_ y.start) with
+  | (Lt | Eq), (Gt | Eq) | (Gt | Eq), (Lt | Eq) -> true
+  | _ -> false

ocaml-lsp-server/src/range.mli

@@ -26,3 +26,6 @@ val of_loc : Loc.t -> t
     less characters than [edit.range], the new range is shrunk to fit
     [edit.newText] only. *)
 val resize_for_edit : TextEdit.t -> t
+
+(** [overlaps r1 r2] is true if [r1] and [r2] overlap. *)
+val overlaps : t -> t -> bool