Merge 7f1a0f5 into ca325e7

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/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,114 @@
+open Import
+open Fiber.O
+
+module Config = struct
+  type t =
+    { hint_let_function : bool
+    ; hint_letop_module : bool
+    }
+
+  let default = { hint_let_function = false; hint_letop_module = true }
+end
+
+let overlaps (x : Range.t) (y : Range.t) =
+  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
+
+let range_overlaps_loc range loc =
+  match Range.of_loc_opt loc with
+  | Some range' -> overlaps range range'
+  | None -> false
+
+let outline_type ~env typ =
+  let ppf, to_string = Format.to_string () in
+  Ocaml_typing.Printtyp.wrap_printing_env env (fun () ->
+      Merlin_analysis.Type_utils.print_type_with_decl
+        ~verbosity:(Mconfig.Verbosity.Lvl 0)
+        env
+        ppf
+        typ);
+  Some (sprintf ": %s" (to_string ()))
+
+let hint_binding_iter (config : Config.t) typedtree range k =
+  let module I = Ocaml_typing.Tast_iterator in
+  let expr iter (e : Typedtree.expression) =
+    if range_overlaps_loc range e.exp_loc then
+      match e.exp_desc with
+      | Texp_let (_, vbs, body) ->
+        if config.hint_let_function then I.default_iterator.expr iter e
+        else (
+          List.iter vbs ~f:(fun (vb : Typedtree.value_binding) ->
+              match vb.vb_expr.exp_desc with
+              | Texp_function _ -> iter.expr iter vb.vb_expr
+              | _ -> iter.value_binding iter vb);
+          iter.expr iter body)
+      | _ -> I.default_iterator.expr iter e
+  in
+
+  let structure_item iter (item : Typedtree.structure_item) =
+    if range_overlaps_loc range item.str_loc then
+      if config.hint_let_function then
+        I.default_iterator.structure_item iter item
+      else
+        match item.str_desc with
+        | Tstr_value (_, vbs) ->
+          List.iter vbs ~f:(fun (vb : Typedtree.value_binding) ->
+              match vb.vb_expr.exp_desc with
+              | Texp_function _ -> iter.expr iter vb.vb_expr
+              | _ -> iter.value_binding iter vb)
+        | _ -> 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 } 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
+  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
+              Config.default
+              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/test/e2e-new/start_stop.ml

@@ -95,6 +95,7 @@ let%expect_test "start/stop" =
           },
           "foldingRangeProvider": true,
           "hoverProvider": true,
+          "inlayHintProvider": true,
           "referencesProvider": true,
           "renameProvider": { "prepareProvider": true },
           "selectionRangeProvider": true,