Disable trigger-character completions and signature help in comments (#1246)

Author: awilliambauer

CHANGES.md

@@ -26,6 +26,8 @@
 
 - Correctly accept the `--clientProcessId` flag. (#1242)
 
+- Disable automatic completion and signature help inside comments (#1246)
+
 # 1.17.0
 
 ## Fixes

ocaml-lsp-server/src/check_for_comments.ml

@@ -0,0 +1,16 @@
+open Import
+
+let position_in_comment ~position ~merlin =
+  let loc_contains_position (_, (loc : Loc.t)) =
+    let start = Position.of_lexical_position loc.loc_start in
+    let end_ = Position.of_lexical_position loc.loc_end in
+    match Option.both start end_ with
+    | Some (start, end_) -> (
+      let range = Range.create ~start ~end_ in
+      match Position.compare_inclusion position range with
+      | `Inside -> true
+      | `Outside _ -> false)
+    | None -> false
+  in
+  Document.Merlin.with_pipeline_exn ~name:"get-comments" merlin (fun pipeline ->
+      Mpipeline.reader_comments pipeline |> List.exists ~f:loc_contains_position)

ocaml-lsp-server/src/check_for_comments.mli

@@ -0,0 +1,3 @@
+(** Returns [true] if [position] occurs inside a comment in the document *)
+val position_in_comment :
+  position:Position.t -> merlin:Document.Merlin.t -> bool Fiber.t

ocaml-lsp-server/src/compl.ml

@@ -242,12 +242,13 @@ module Complete_with_construct = struct
 end
 
 let complete (state : State.t)
-    ({ textDocument = { uri }; position = pos; _ } : CompletionParams.t) =
+    ({ textDocument = { uri }; position = pos; context; _ } :
+      CompletionParams.t) =
   Fiber.of_thunk (fun () ->
       let doc = Document_store.get state.store uri in
       match Document.kind doc with
       | `Other -> Fiber.return None
-      | `Merlin merlin ->
+      | `Merlin merlin -> (
         let completion_item_capability =
           let open Option.O in
           let capabilities = State.client_capabilities state in
@@ -265,75 +266,98 @@ let complete (state : State.t)
           | Some { properties } ->
             List.mem properties ~equal:String.equal "documentation"
         in
-        let+ items =
-          let position = Position.logical pos in
-          let prefix =
-            prefix_of_position ~short_path:false (Document.source doc) position
-          in
-          let deprecated =
-            Option.value
-              ~default:false
-              (let open Option.O in
-               let* item = completion_item_capability in
-               item.deprecatedSupport)
-          in
-          if not (Typed_hole.can_be_hole prefix) then
-            Complete_by_prefix.complete merlin prefix pos ~resolve ~deprecated
-          else
-            let reindex_sortText completion_items =
-              List.mapi completion_items ~f:(fun idx (ci : CompletionItem.t) ->
-                  let sortText = Some (sortText_of_index idx) in
-                  { ci with sortText })
-            in
-            let preselect_first =
-              match
-                let open Option.O in
-                let* item = completion_item_capability in
-                item.preselectSupport
-              with
-              | None | Some false -> fun x -> x
-              | Some true -> (
-                function
-                | [] -> []
-                | ci :: rest ->
-                  { ci with CompletionItem.preselect = Some true } :: rest)
-            in
-            let+ construct_cmd_resp, compl_by_prefix_resp =
-              Document.Merlin.with_pipeline_exn
-                ~name:"completion"
-                merlin
-                (fun pipeline ->
-                  let construct_cmd_resp =
-                    Complete_with_construct.dispatch_cmd position pipeline
-                  in
-                  let compl_by_prefix_resp =
-                    Complete_by_prefix.dispatch_cmd ~prefix position pipeline
-                  in
-                  (construct_cmd_resp, compl_by_prefix_resp))
-            in
-            let construct_completionItems =
-              let supportsJumpToNextHole =
-                State.experimental_client_capabilities state
-                |> Client.Experimental_capabilities.supportsJumpToNextHole
+        let* should_provide_completions =
+          match context with
+          | Some context -> (
+            match context.triggerKind with
+            | TriggerCharacter -> (
+              let+ inside_comment =
+                Check_for_comments.position_in_comment ~position:pos ~merlin
               in
-              Complete_with_construct.process_dispatch_resp
-                ~supportsJumpToNextHole
-                construct_cmd_resp
+              match inside_comment with
+              | true -> `Ignore
+              | false -> `Provide_completions)
+            | Invoked | TriggerForIncompleteCompletions ->
+              Fiber.return `Provide_completions)
+          | None -> Fiber.return `Provide_completions
+        in
+        match should_provide_completions with
+        | `Ignore -> Fiber.return None
+        | `Provide_completions ->
+          let+ items =
+            let position = Position.logical pos in
+            let prefix =
+              prefix_of_position
+                ~short_path:false
+                (Document.source doc)
+                position
             in
-            let compl_by_prefix_completionItems =
-              Complete_by_prefix.process_dispatch_resp
-                ~resolve
-                ~deprecated
-                merlin
-                pos
-                compl_by_prefix_resp
+            let deprecated =
+              Option.value
+                ~default:false
+                (let open Option.O in
+                 let* item = completion_item_capability in
+                 item.deprecatedSupport)
             in
-            construct_completionItems @ compl_by_prefix_completionItems
-            |> reindex_sortText |> preselect_first
-        in
-        Some
-          (`CompletionList
-            (CompletionList.create ~isIncomplete:false ~items ())))
+            if not (Typed_hole.can_be_hole prefix) then
+              Complete_by_prefix.complete merlin prefix pos ~resolve ~deprecated
+            else
+              let reindex_sortText completion_items =
+                List.mapi
+                  completion_items
+                  ~f:(fun idx (ci : CompletionItem.t) ->
+                    let sortText = Some (sortText_of_index idx) in
+                    { ci with sortText })
+              in
+              let preselect_first =
+                match
+                  let open Option.O in
+                  let* item = completion_item_capability in
+                  item.preselectSupport
+                with
+                | None | Some false -> fun x -> x
+                | Some true -> (
+                  function
+                  | [] -> []
+                  | ci :: rest ->
+                    { ci with CompletionItem.preselect = Some true } :: rest)
+              in
+              let+ construct_cmd_resp, compl_by_prefix_resp =
+                Document.Merlin.with_pipeline_exn
+                  ~name:"completion"
+                  merlin
+                  (fun pipeline ->
+                    let construct_cmd_resp =
+                      Complete_with_construct.dispatch_cmd position pipeline
+                    in
+                    let compl_by_prefix_resp =
+                      Complete_by_prefix.dispatch_cmd ~prefix position pipeline
+                    in
+                    (construct_cmd_resp, compl_by_prefix_resp))
+              in
+              let construct_completionItems =
+                let supportsJumpToNextHole =
+                  State.experimental_client_capabilities state
+                  |> Client.Experimental_capabilities.supportsJumpToNextHole
+                in
+                Complete_with_construct.process_dispatch_resp
+                  ~supportsJumpToNextHole
+                  construct_cmd_resp
+              in
+              let compl_by_prefix_completionItems =
+                Complete_by_prefix.process_dispatch_resp
+                  ~resolve
+                  ~deprecated
+                  merlin
+                  pos
+                  compl_by_prefix_resp
+              in
+              construct_completionItems @ compl_by_prefix_completionItems
+              |> reindex_sortText |> preselect_first
+          in
+          Some
+            (`CompletionList
+              (CompletionList.create ~isIncomplete:false ~items ()))))
 
 let format_doc ~markdown doc =
   match markdown with

ocaml-lsp-server/src/import.ml

@@ -108,6 +108,7 @@ module Asttypes = Ocaml_parsing.Asttypes
 module Cmt_format = Ocaml_typing.Cmt_format
 module Ident = Ocaml_typing.Ident
 module Env = Ocaml_typing.Env
+module Merlin_parsing = Ocaml_parsing
 
 module Loc = struct
   module T = struct

ocaml-lsp-server/src/signature_help.ml

@@ -197,11 +197,17 @@ let run (state : State.t)
     Fiber.return help
   | `Merlin merlin -> (
     let* application_signature =
-      Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
-          let typer = Mpipeline.typer_result pipeline in
-          let pos = Mpipeline.get_lexing_pos pipeline pos in
-          let node = Mtyper.node_at typer pos in
-          application_signature node ~prefix)
+      let* inside_comment =
+        Check_for_comments.position_in_comment ~position ~merlin
+      in
+      match inside_comment with
+      | true -> Fiber.return None
+      | false ->
+        Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+            let typer = Mpipeline.typer_result pipeline in
+            let pos = Mpipeline.get_lexing_pos pipeline pos in
+            let node = Mtyper.node_at typer pos in
+            application_signature node ~prefix)
     in
     match application_signature with
     | None ->

ocaml-lsp-server/test/e2e/__tests__/textDocument-signatureHelp.ts

@@ -327,7 +327,7 @@ describe_opt("textDocument/completion", () => {
     `,
     );
 
-    let items = await querySignatureHelp(Types.Position.create(23, 13));
+    let items = await querySignatureHelp(Types.Position.create(80, 13));
     expect(items).toMatchObject({
       activeSignature: 0,
       activeParameter: 0,