chore: improve metrics (#1013)

semantic highlighting, folding, diagnostics, completion

Signed-off-by: Rudi Grinberg <[email protected]>

Author: rgrinberg

ocaml-lsp-server/src/compl.ml

@@ -204,7 +204,10 @@ module Complete_by_prefix = struct
   let complete doc prefix pos ~deprecated ~resolve =
     let+ (completion : Query_protocol.completions) =
       let logical_pos = Position.logical pos in
-      Document.Merlin.with_pipeline_exn doc (dispatch_cmd ~prefix logical_pos)
+      Document.Merlin.with_pipeline_exn
+        ~name:"completion-prefix"
+        doc
+        (dispatch_cmd ~prefix logical_pos)
     in
     process_dispatch_resp ~deprecated ~resolve doc pos completion
 end
@@ -315,7 +318,10 @@ let complete (state : State.t)
                   { ci with CompletionItem.preselect = Some true } :: rest)
             in
             let+ construct_cmd_resp, compl_by_prefix_resp =
-              Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+              Document.Merlin.with_pipeline_exn
+                ~name:"completion"
+                merlin
+                (fun pipeline ->
                   let construct_cmd_resp =
                     Complete_with_construct.dispatch_cmd position pipeline
                   in

ocaml-lsp-server/src/diagnostics.ml

@@ -284,7 +284,10 @@ let merlin_diagnostics diagnostics merlin =
     let command =
       Query_protocol.Errors { lexing = true; parsing = true; typing = true }
     in
-    Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
+    Document.Merlin.with_pipeline_exn
+      ~name:"diagnostics"
+      merlin
+      (fun pipeline ->
         match Query_commands.dispatch pipeline command with
         | exception Merlin_extend.Extend_main.Handshake.Error error ->
           let message =

ocaml-lsp-server/src/document.ml

@@ -122,7 +122,8 @@ module Single_pipeline : sig
   val create : Lev_fiber.Thread.t -> t
 
   val use :
-       t
+       ?name:string
+    -> t
     -> doc:Text_document.t
     -> config:Merlin_config.t
     -> f:(Mpipeline.t -> 'a)
@@ -132,7 +133,7 @@ end = struct
 
   let create thread = { thread }
 
-  let use t ~doc ~config ~f =
+  let use ?name t ~doc ~config ~f =
     let* config = Merlin_config.config config in
     let make_pipeline =
       let source = Msource.make (Text_document.text doc) in
@@ -158,9 +159,11 @@ end = struct
         let module Event = Chrome_trace.Event in
         let dur = Event.Timestamp.of_float_seconds (stop -. start) in
         let fields =
+          let name = Option.value name ~default:"unknown" in
           Event.common_fields
+            ~cat:[ "merlin" ]
             ~ts:(Event.Timestamp.of_float_seconds start)
-            ~name:"merlin"
+            ~name
             ()
         in
         Event.complete ~dur fields
@@ -245,13 +248,13 @@ module Merlin = struct
 
   let kind t = Kind.of_fname (Uri.to_path (uri (Merlin t)))
 
-  let with_pipeline (t : t) f =
-    Single_pipeline.use t.pipeline ~doc:t.tdoc ~config:t.merlin_config ~f
+  let with_pipeline ?name (t : t) f =
+    Single_pipeline.use ?name t.pipeline ~doc:t.tdoc ~config:t.merlin_config ~f
 
   let mconfig (t : t) = Merlin_config.config t.merlin_config
 
-  let with_pipeline_exn doc f =
-    let+ res = with_pipeline doc f in
+  let with_pipeline_exn ?name doc f =
+    let+ res = with_pipeline ?name doc f in
     match res with
     | Ok s -> s
     | Error exn -> Exn_with_backtrace.reraise exn

ocaml-lsp-server/src/document.mli

@@ -53,7 +53,7 @@ module Merlin : sig
 
   val timer : t -> Lev_fiber.Timer.Wheel.task
 
-  val with_pipeline_exn : t -> (Mpipeline.t -> 'a) -> 'a Fiber.t
+  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

ocaml-lsp-server/src/folding_range.ml

@@ -305,7 +305,10 @@ let compute (state : State.t) (params : FoldingRangeParams.t) =
       | `Other -> Fiber.return None
       | `Merlin m ->
         let+ ranges =
-          Document.Merlin.with_pipeline_exn m (fun pipeline ->
+          Document.Merlin.with_pipeline_exn
+            ~name:"folding range"
+            m
+            (fun pipeline ->
               let parsetree = Mpipeline.reader_parsetree pipeline in
               fold_over_parsetree parsetree)
         in

ocaml-lsp-server/src/semantic_highlighting.ml

@@ -857,8 +857,10 @@ let gen_new_id =
 
 let compute_tokens doc =
   let+ parsetree, source =
-    Document.Merlin.with_pipeline_exn doc (fun p ->
-        (Mpipeline.reader_parsetree p, Mpipeline.raw_source p))
+    Document.Merlin.with_pipeline_exn
+      ~name:"semantic highlighting"
+      doc
+      (fun p -> (Mpipeline.reader_parsetree p, Mpipeline.raw_source p))
   in
   let module Fold = Parsetree_fold (struct
     let source = Msource.text source