Merge f4f5130 into 1970a76

ocaml-lsp-server/src/code_actions.ml

@@ -61,6 +61,7 @@ let compute_ocaml_code_actions (params : CodeActionParams.t) state doc =
     if List.is_empty batchable then Fiber.return []
     else
       Document.Merlin.with_pipeline_exn
+        ~name:"batched-code-actions"
         (Document.merlin_exn doc)
         (fun pipeline ->
           List.filter_map batchable ~f:(fun ca ->

ocaml-lsp-server/src/code_actions/action_destruct.ml

@@ -48,7 +48,7 @@ let code_action (state : State.t) doc (params : CodeActionParams.t) =
       let finish = Position.logical params.range.end_ in
       Query_protocol.Case_analysis (start, finish)
     in
-    let* res = Document.Merlin.dispatch merlin command in
+    let* res = Document.Merlin.dispatch ~name:"destruct" merlin command in
     match res with
     | Ok (loc, newText) ->
       let+ newText =

ocaml-lsp-server/src/custom_requests/req_typed_holes.ml

@@ -63,7 +63,7 @@ let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) =
              ()
       | Some doc ->
         let+ holes =
-          Document.Merlin.dispatch_exn (Document.merlin_exn doc) Holes
+          Document.Merlin.dispatch_exn ~name:"typed-holes" (Document.merlin_exn doc) Holes
         in
         Json.yojson_of_list
           (fun (loc, _type) -> loc |> Range.of_loc |> Range.yojson_of_t)

ocaml-lsp-server/src/custom_requests/req_wrapping_ast_node.ml

@@ -44,7 +44,7 @@ let on_request ~params state =
       | `Merlin doc -> (
         let pos = Position.logical cursor_position in
         let+ node =
-          Document.Merlin.with_pipeline_exn doc (fun pipeline ->
+          Document.Merlin.with_pipeline_exn ~name:"wrapping-ast-node" doc (fun pipeline ->
               let typer = Mpipeline.typer_result pipeline in
               let pos = Mpipeline.get_lexing_pos pipeline pos in
               let enclosing_nodes (* from smallest node to largest *) =

ocaml-lsp-server/src/definition_query.ml

@@ -34,14 +34,14 @@ let run kind (state : State.t) uri position =
   match Document.kind doc with
   | `Other -> Fiber.return None
   | `Merlin doc -> (
-    let command =
+    let command, name =
       let pos = Position.logical position in
       match kind with
-      | `Definition -> Query_protocol.Locate (None, `ML, pos)
-      | `Declaration -> Query_protocol.Locate (None, `MLI, pos)
-      | `Type_definition -> Query_protocol.Locate_type pos
+      | `Definition -> Query_protocol.Locate (None, `ML, pos), "definition"
+      | `Declaration -> Query_protocol.Locate (None, `MLI, pos), "declaration"
+      | `Type_definition -> Query_protocol.Locate_type pos, "type definition"
     in
-    let* result = Document.Merlin.dispatch_exn doc command in
+    let* result = Document.Merlin.dispatch_exn ~name doc command in
     match location_of_merlin_loc uri result with
     | Ok s -> Fiber.return s
     | Error err_msg ->

ocaml-lsp-server/src/document.ml

@@ -284,11 +284,11 @@ module Merlin = struct
     | Ok s -> s
     | Error exn -> Exn_with_backtrace.reraise exn
 
-  let dispatch t command =
-    with_pipeline t (fun pipeline -> Query_commands.dispatch pipeline command)
+  let dispatch ?name t command =
+    with_pipeline ?name t (fun pipeline -> Query_commands.dispatch pipeline command)
 
-  let dispatch_exn t command =
-    with_pipeline_exn t (fun pipeline ->
+  let dispatch_exn ?name t command =
+    with_pipeline_exn ?name t (fun pipeline ->
         Query_commands.dispatch pipeline command)
 
   let doc_comment pipeline pos =
@@ -316,8 +316,8 @@ module Merlin = struct
     ; syntax_doc : Query_protocol.syntax_doc_result option
     }
 
-  let type_enclosing doc pos verbosity ~with_syntax_doc =
-    with_pipeline_exn doc (fun pipeline ->
+  let type_enclosing ?name doc pos verbosity ~with_syntax_doc =
+    with_pipeline_exn ?name doc (fun pipeline ->
         let command = Query_protocol.Type_enclosing (None, pos, Some 0) in
         let pipeline =
           match verbosity with
@@ -344,8 +344,8 @@ module Merlin = struct
           in
           Some { loc; typ; doc; syntax_doc })
 
-  let doc_comment doc pos =
-    with_pipeline_exn doc (fun pipeline -> doc_comment pipeline pos)
+  let doc_comment ?name doc pos =
+    with_pipeline_exn ?name doc (fun pipeline -> doc_comment pipeline pos)
 end
 
 let edit t text_edits =

ocaml-lsp-server/src/document.mli

@@ -56,12 +56,18 @@ module Merlin : sig
   val with_pipeline_exn : ?name:string -> t -> (Mpipeline.t -> 'a) -> 'a Fiber.t
 
   val dispatch :
-    t -> 'a Query_protocol.t -> ('a, Exn_with_backtrace.t) result Fiber.t
+       ?name:string
+    -> t
+    -> 'a Query_protocol.t
+    -> ('a, Exn_with_backtrace.t) result Fiber.t
 
-  val dispatch_exn : t -> 'a Query_protocol.t -> 'a Fiber.t
+  val dispatch_exn : ?name:string -> t -> 'a Query_protocol.t -> 'a Fiber.t
 
   val doc_comment :
-    t -> Msource.position -> (* doc string *) string option Fiber.t
+       ?name:string
+    -> t
+    -> Msource.position
+    -> (* doc string *) string option Fiber.t
 
   val syntax_doc :
     Mpipeline.t -> Msource.position -> Query_protocol.syntax_doc_result option
@@ -74,7 +80,8 @@ module Merlin : sig
     }
 
   val type_enclosing :
-       t
+       ?name:string
+    -> t
     -> Msource.position
     -> (* verbosity *) int
     -> with_syntax_doc:bool

ocaml-lsp-server/src/hover_req.ml

@@ -266,6 +266,7 @@ let type_enclosing_hover ~(server : State.t Server.t) ~(doc : Document.t)
   in
   let* type_enclosing =
     Document.Merlin.type_enclosing
+      ~name:"hover-enclosing"
       merlin
       (Position.logical position)
       verbosity

ocaml-lsp-server/src/inference.ml

@@ -12,7 +12,7 @@ let infer_intf_for_impl doc =
       "expected an implementation document, got an interface instead"
       []
   | `Merlin doc ->
-    Document.Merlin.with_pipeline_exn doc (fun pipeline ->
+    Document.Merlin.with_pipeline_exn ~name:"infer-interface" doc (fun pipeline ->
         let typer = Mpipeline.typer_result pipeline in
         let sig_ : Types.signature =
           let typedtree = Mtyper.get_typedtree typer in

ocaml-lsp-server/src/inlay_hints.ml

@@ -110,7 +110,7 @@ let compute (state : State.t)
   | `Merlin doc ->
     let hints = ref [] in
     let* () =
-      Document.Merlin.with_pipeline_exn doc (fun pipeline ->
+      Document.Merlin.with_pipeline_exn ~name:"inlay-hints" doc (fun pipeline ->
           match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with
           | `Interface _ -> ()
           | `Implementation typedtree ->

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -374,7 +374,7 @@ let text_document_lens (state : State.t)
   | `Other -> Fiber.return []
   | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return []
   | `Merlin doc ->
-    let+ outline = Document.Merlin.dispatch_exn doc Outline in
+    let+ outline = Document.Merlin.dispatch_exn ~name:"outline" doc Outline in
     let rec symbol_info_of_outline_item (item : Query_protocol.item) =
       let children =
         List.concat_map item.children ~f:symbol_info_of_outline_item
@@ -427,7 +427,7 @@ let selection_range (state : State.t)
     let+ ranges =
       Fiber.sequential_map positions ~f:(fun x ->
           let+ shapes =
-            Document.Merlin.dispatch_exn merlin (Shape (Position.logical x))
+            Document.Merlin.dispatch_exn ~name:"shape" merlin (Shape (Position.logical x))
           in
           selection_range_of_shapes x shapes)
     in
@@ -441,6 +441,7 @@ let references (state : State.t)
   | `Merlin doc ->
     let+ locs =
       Document.Merlin.dispatch_exn
+        ~name:"occurrences"
         doc
         (Occurrences (`Ident_at (Position.logical position), `Buffer))
     in
@@ -459,6 +460,7 @@ let highlight (state : State.t)
   | `Merlin m ->
     let+ locs =
       Document.Merlin.dispatch_exn
+        ~name:"occurrences"
         m
         (Occurrences (`Ident_at (Position.logical position), `Buffer))
     in
@@ -599,7 +601,12 @@ let on_request :
           match Document.kind doc with
           | `Other -> Fiber.return ci
           | `Merlin doc ->
-            Compl.resolve doc ci resolve Document.Merlin.doc_comment ~markdown))
+            Compl.resolve
+              doc
+              ci
+              resolve
+              (Document.Merlin.doc_comment ~name:"completion-resolve")
+              ~markdown))
       ()
   | CodeAction params -> Code_actions.compute server params
   | InlayHint params ->
@@ -645,6 +652,7 @@ let on_request :
         | `Merlin doc ->
           let+ locs =
             Document.Merlin.dispatch_exn
+              ~name:"occurrences"
               doc
               (Occurrences (`Ident_at (Position.logical position), `Buffer))
           in

ocaml-lsp-server/src/rename.ml

@@ -10,7 +10,7 @@ let rename (state : State.t)
     let command =
       Query_protocol.Occurrences (`Ident_at (Position.logical position), `Buffer)
     in
-    let+ locs = Document.Merlin.dispatch_exn merlin command in
+    let+ locs = Document.Merlin.dispatch_exn ~name:"rename" merlin command in
     let version = Document.version doc in
     let source = Document.source doc in
     let edits =

ocaml-lsp-server/src/signature_help.ml

@@ -203,7 +203,7 @@ let run (state : State.t)
       match inside_comment with
       | true -> Fiber.return None
       | false ->
-        Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+        Document.Merlin.with_pipeline_exn ~name:"signature-help" 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
@@ -223,6 +223,7 @@ let run (state : State.t)
       let offset = String.length prefix in
       let+ doc =
         Document.Merlin.doc_comment
+          ~name:"signature help-position"
           merlin
           application_signature.function_position
       in