extensible metric; pass level around in collector

src/core/collector.ml

@@ -19,6 +19,7 @@ module Callbacks = struct
       __FUNCTION__:string option ->
       __FILE__:string ->
       __LINE__:int ->
+      level:Level.t ->
       params:extension_parameter list ->
       data:(string * user_data) list ->
       parent:parent ->
@@ -31,29 +32,24 @@ module Callbacks = struct
     add_data_to_span: 'st -> span -> (string * user_data) list -> unit;
     message:
       'st ->
+      level:Level.t ->
       params:extension_parameter list ->
       data:(string * user_data) list ->
       span:span option ->
       string ->
       unit;
         (** Emit a message or log *)
-    counter_int:
+    metric:
       'st ->
+      level:Level.t ->
       params:extension_parameter list ->
       data:(string * user_data) list ->
       string ->
-      int ->
+      metric ->
       unit;
-        (** Integer counter. *)
+        (** Metric . *)
-    counter_float:
+    extension: 'st -> level:Level.t -> extension_event -> unit;
-      'st ->
+        (** Collector-specific extension. It now has a level as well. *)
-      params:extension_parameter list ->
-      data:(string * user_data) list ->
-      string ->
-      float ->
-      unit;
-    extension: 'st -> extension_event -> unit;
-        (** Collector-specific extension *)
     init: 'st -> unit;  (** Called on initialization *)
     shutdown: 'st -> unit;
         (** Shutdown collector, possibly waiting for it to finish sending data.
@@ -62,16 +58,15 @@ module Callbacks = struct
   (** Callbacks taking a state ['st] *)
 
   (** Helper to create backends in a future-proof way *)
-  let make ~enter_span ~exit_span ~add_data_to_span ~message ~counter_int
+  let make ~enter_span ~exit_span ~add_data_to_span ~message ~metric
-      ~counter_float ?(extension = fun _ _ -> ()) ?(init = ignore)
+      ?(extension = fun _ ~level:_ _ -> ()) ?(init = ignore)
       ?(shutdown = ignore) () : _ t =
     {
       enter_span;
       exit_span;
       add_data_to_span;
       message;
-      counter_int;
+      metric;
-      counter_float;
       extension;
       init;
       shutdown;

src/core/core_ext.ml

@@ -13,3 +13,8 @@ type extension_event +=
 type extension_parameter +=
   | Extension_span_flavor of [ `Sync | `Async ]
         (** Tell the backend if this is a sync or async span *)
+
+type metric +=
+  | Metric_int of int  (** Int counter or gauge, supported by tracy, TEF, etc *)
+  | Metric_float of float
+        (** Float counter or gauge, supported by tracy, TEF, etc *)

src/core/trace_core.ml

@@ -24,7 +24,7 @@ let[@inline] set_default_level l = A.set default_level_ l
 let[@inline] set_current_level l = A.set current_level_ l
 let[@inline] get_current_level () = A.get current_level_
 
-let[@inline] check_level ?(level = A.get default_level_) () : bool =
+let[@inline] check_level_ ~level () : bool =
   Level.leq level (A.get current_level_)
 
 let parent_of_span_opt_opt = function
@@ -33,16 +33,18 @@ let parent_of_span_opt_opt = function
   | Some (Some p) -> P_some p
 
 let enter_span_st st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__ ~__FILE__
-    ~__LINE__ ?parent ?(params = []) ?(data = data_empty_build_) name : span =
+    ~__LINE__ ~level ?parent ?(params = []) ?(data = data_empty_build_) name :
+    span =
   let parent = parent_of_span_opt_opt parent in
   let data = data () in
-  cbs.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~parent ~params ~data name
+  cbs.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~parent ~params
+    ~data name
 
 let with_span_collector_ st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__
-    ~__FILE__ ~__LINE__ ?parent ?params ?data name f =
+    ~__FILE__ ~__LINE__ ~level ?parent ?params ?data name f =
   let sp : span =
-    enter_span_st st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ?parent ?params ?data
+    enter_span_st st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ~level ?parent
-      name
+      ?params ?data name
   in
   match f sp with
   | res ->
@@ -53,27 +55,27 @@ let with_span_collector_ st (cbs : _ Collector.Callbacks.t) ?__FUNCTION__
     cbs.exit_span st sp;
     Printexc.raise_with_backtrace exn bt
 
-let[@inline] with_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?parent ?params
+let[@inline] with_span ?(level = A.get default_level_) ?__FUNCTION__ ~__FILE__
-    ?data name f =
+    ~__LINE__ ?parent ?params ?data name f =
   match A.get collector with
-  | C_some (st, cbs) when check_level ?level () ->
+  | C_some (st, cbs) when check_level_ ~level () ->
-    with_span_collector_ st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ?parent
+    with_span_collector_ st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__ ~level ?parent
       ?params ?data name f
   | _ ->
     (* fast path: no collector, no span *)
     f Collector.dummy_span
 
-let[@inline] enter_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?flavor ?parent
+let[@inline] enter_span ?(level = A.get default_level_) ?__FUNCTION__ ~__FILE__
-    ?(params = []) ?data name : span =
+    ~__LINE__ ?flavor ?parent ?(params = []) ?data name : span =
   match A.get collector with
-  | C_some (st, cbs) when check_level ?level () ->
+  | C_some (st, cbs) when check_level_ ~level () ->
     let params =
       match flavor with
       | None -> params
       | Some f -> Core_ext.Extension_span_flavor f :: params
     in
     (enter_span_st [@inlined never]) st cbs ?__FUNCTION__ ~__FILE__ ~__LINE__
-      ?parent ~params ?data name
+      ~level ?parent ~params ?data name
   | _ -> Collector.dummy_span
 
 let[@inline] exit_span sp : unit =
@@ -88,41 +90,40 @@ let[@inline] add_data_to_span sp data : unit =
     | C_some (st, cbs) -> cbs.add_data_to_span st sp data
   )
 
-let message_collector_ st (cbs : _ Collector.Callbacks.t) ?span ?(params = [])
+let message_collector_ st (cbs : _ Collector.Callbacks.t) ~level ?span
-    ?(data = data_empty_build_) msg : unit =
+    ?(params = []) ?(data = data_empty_build_) msg : unit =
   let data = data () in
-  cbs.message st ~span ~params ~data msg
+  cbs.message st ~level ~span ~params ~data msg
 
-let[@inline] message ?level ?span ?params ?data msg : unit =
+let[@inline] message ?(level = A.get default_level_) ?span ?params ?data msg :
+    unit =
   match A.get collector with
-  | C_some (st, cbs) when check_level ?level () ->
+  | C_some (st, cbs) when check_level_ ~level () ->
-    (message_collector_ [@inlined never]) st cbs ?span ?params ?data msg
+    (message_collector_ [@inlined never]) st cbs ~level ?span ?params ?data msg
   | _ -> ()
 
-let messagef ?level ?span ?params ?data k =
+let messagef ?(level = A.get default_level_) ?span ?params ?data k =
   match A.get collector with
-  | C_some (st, cbs) when check_level ?level () ->
+  | C_some (st, cbs) when check_level_ ~level () ->
     k (fun fmt ->
         Format.kasprintf
-          (fun str -> message_collector_ st cbs ?span ?params ?data str)
+          (fun str -> message_collector_ st cbs ~level ?span ?params ?data str)
           fmt)
   | _ -> ()
 
-let counter_int ?level ?(params = []) ?(data = data_empty_build_) name n : unit
+let metric ?(level = A.get default_level_) ?(params = [])
-    =
+    ?(data = data_empty_build_) name m : unit =
   match A.get collector with
-  | C_some (st, cbs) when check_level ?level () ->
+  | C_some (st, cbs) when check_level_ ~level () ->
     let data = data () in
-    cbs.counter_int st ~params ~data name n
+    cbs.metric st ~level ~params ~data name m
   | _ -> ()
 
-let counter_float ?level ?(params = []) ?(data = data_empty_build_) name f :
+let counter_int ?level ?params ?data name n : unit =
-    unit =
+  metric ?level ?params ?data name (Core_ext.Metric_int n)
-  match A.get collector with
+
-  | C_some (st, cbs) when check_level ?level () ->
+let counter_float ?level ?params ?data name n : unit =
-    let data = data () in
+  metric ?level ?params ?data name (Core_ext.Metric_float n)
-    cbs.counter_float st ~params ~data name f
-  | _ -> ()
 
 let setup_collector c : unit =
   while
@@ -150,10 +151,10 @@ let with_setup_collector c f =
 
 type extension_event = Types.extension_event = ..
 
-let[@inline] extension_event ev : unit =
+let[@inline] extension_event ?(level = A.get default_level_) ev : unit =
   match A.get collector with
-  | C_none -> ()
+  | C_some (st, cbs) when check_level_ ~level () -> cbs.extension st ~level ev
-  | C_some (st, cbs) -> cbs.extension st ev
+  | _ -> ()
 
 let set_thread_name name : unit =
   extension_event @@ Core_ext.Extension_set_thread_name name

src/core/trace_core.mli

@@ -141,6 +141,17 @@ val set_process_name : string -> unit
 
     Uses {!Core_ext.Extension_set_process_name} since NEXT_RELEASE *)
 
+val metric :
+  ?level:Level.t ->
+  ?params:extension_parameter list ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  metric ->
+  unit
+(** Emit a metric. Metrics are an extensible type, each collector might support
+    a different subset.
+    @since NEXT_RELEASE *)
+
 val counter_int :
   ?level:Level.t ->
   ?params:extension_parameter list ->
@@ -148,8 +159,8 @@ val counter_int :
   string ->
   int ->
   unit
-(** Emit a counter of type [int]. Counters represent the evolution of some
+(** Emit a counter of type [int] via {!metric}. Counters represent the evolution
-    quantity over time.
+    of some quantity over time.
     @param level
       optional level for this span. since 0.7. Default is set via
       {!set_default_level}.
@@ -162,7 +173,8 @@ val counter_float :
   string ->
   float ->
   unit
-(** Emit a counter of type [float]. See {!counter_int} for more details.
+(** Emit a counter of type [float] via {!metric}. See {!counter_int} for more
+    details.
     @param level
       optional level for this span. since 0.7. Default is set via
       {!set_default_level}.
@@ -202,10 +214,11 @@ type extension_event = Types.extension_event = ..
 (** Extension event
     @since 0.8 *)
 
-val extension_event : extension_event -> unit
+val extension_event : ?level:Level.t -> extension_event -> unit
 (** Trigger an extension event, whose meaning depends on the library that
     defines it. Some collectors will simply ignore it. This does nothing if no
     collector is setup.
+    @param level filtering level, since NEXT_RELEASE
     @since 0.8 *)
 
 (** {2 Core extensions} *)

src/core/types.ml

@@ -25,10 +25,15 @@ type explicit_span_ctx = span [@@deprecated "use span"]
 
 type extension_event = ..
 (** An extension event, used to add features that are backend specific or simply
-    not envisioned by [trace].
+    not envisioned by [trace]. See {!Core_ext} for some builtin extension
+    events.
     @since 0.8 *)
 
 type extension_parameter = ..
 (** An extension parameter, used to carry information for spans/messages/metrics
     that can be backend-specific or just not envisioned by [trace].
     @since NEXT_RELEASE *)
+
+type metric = ..
+(** A metric, can be of many types. See {!Core_ext} for some builtin metrics.
+    @since NEXT_RELEASE *)

src/debug/track_spans.ml

@@ -46,11 +46,11 @@ open struct
     Mutex.lock mut;
     Fun.protect f ~finally:(fun () -> Mutex.unlock mut)
 
-  let enter_span (self : _ st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params ~data
+  let enter_span (self : _ st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params
-      ~parent name : span =
+      ~data ~parent name : span =
     let span =
-      self.cbs.enter_span self.state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params
+      self.cbs.enter_span self.state ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level
-        ~data ~parent name
+        ~params ~data ~parent name
     in
     let id = A.fetch_and_add self.gen_id 1 in
     (let@ () = with_mutex self.mutex in
@@ -108,19 +108,16 @@ open struct
       emit self unclosed_spans
     )
 
-  let message self ~params ~data ~span msg =
+  let message self ~level ~params ~data ~span msg =
     let span =
       match span with
       | Some (Span_tracked (_, sp)) -> Some sp
       | _ -> span
     in
-    self.cbs.message self.state ~params ~data ~span msg
+    self.cbs.message self.state ~level ~params ~data ~span msg
 
-  let counter_int self ~params ~data name v =
+  let metric self ~level ~params ~data name v =
-    self.cbs.counter_int self.state ~params ~data name v
+    self.cbs.metric self.state ~level ~params ~data name v
-
-  let counter_float self ~params ~data name v =
-    self.cbs.counter_float self.state ~params ~data name v
 
   let init (self : _ st) = self.cbs.init self.state
 
@@ -128,7 +125,7 @@ open struct
     print_non_closed_spans_warning self;
     self.cbs.shutdown self.state
 
-  let extension self ev = self.cbs.extension self.state ev
+  let extension self ~level ev = self.cbs.extension self.state ~level ev
 
   let track_callbacks : _ st Collector.Callbacks.t =
     {
@@ -136,8 +133,7 @@ open struct
       exit_span;
       add_data_to_span;
       message;
-      counter_int;
+      metric;
-      counter_float;
       init;
       shutdown;
       extension;

src/fuchsia/collector_fuchsia.ml

@@ -89,8 +89,8 @@ open struct
     | Core_ext.Extension_span_flavor f :: _ -> f
     | _ :: tl -> flavor_of_params tl
 
-  let enter_span (self : t) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params ~data
+  let enter_span (self : t) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level:_ ~params
-      ~parent name : span =
+      ~data ~parent name : span =
     let flavor = flavor_of_params params in
     let time_ns = Trace_util.Mock_.now_ns () in
     let tid = Trace_util.Mock_.get_tid () in
@@ -150,7 +150,7 @@ open struct
     | Span_fuchsia_async sp -> sp.args <- List.rev_append data sp.args
     | _ -> ()
 
-  let message (self : t) ~params:_ ~data ~span:_ msg : unit =
+  let message (self : t) ~level:_ ~params:_ ~data ~span:_ msg : unit =
     let time_ns = Trace_util.Mock_.now_ns () in
     let tid = Trace_util.Mock_.get_tid () in
     Writer.(
@@ -159,7 +159,7 @@ open struct
         ~name:msg ~time_ns ~args:(args_of_user_data data) ());
     write_ready_ self
 
-  let counter_float (self : t) ~params:_ ~data name n : unit =
+  let counter_float_ (self : t) ~data name n : unit =
     let tid = Trace_util.Mock_.get_tid () in
     let time_ns = Trace_util.Mock_.now_ns () in
     Writer.(
@@ -170,7 +170,7 @@ open struct
         ());
     write_ready_ self
 
-  let counter_int self ~params:_ ~data name n =
+  let counter_int_ self ~data name n =
     let tid = Trace_util.Mock_.get_tid () in
     let time_ns = Trace_util.Mock_.now_ns () in
     Writer.(
@@ -181,6 +181,12 @@ open struct
         ());
     write_ready_ self
 
+  let metric self ~level:_ ~params:_ ~data name m =
+    match m with
+    | Core_ext.Metric_int i -> counter_int_ self ~data name i
+    | Core_ext.Metric_float n -> counter_float_ self ~data name n
+    | _ -> ()
+
   let name_process_ (self : t) name : unit =
     Writer.Kernel_object.(
       encode self.buf_chain ~name ~ty:ty_process ~kid:self.pid ~args:[] ());
@@ -193,7 +199,7 @@ open struct
         ());
     write_ready_ self
 
-  let extension (self : t) ev =
+  let extension (self : t) ~level:_ ev =
     match ev with
     | Core_ext.Extension_set_thread_name name ->
       let tid = Trace_util.Mock_.get_tid () in
@@ -204,6 +210,6 @@ end
 
 let callbacks : t Collector.Callbacks.t =
   Collector.Callbacks.make ~init ~shutdown ~enter_span ~exit_span
-    ~add_data_to_span ~message ~counter_int ~counter_float ~extension ()
+    ~add_data_to_span ~message ~metric ~extension ()
 
 let collector (self : t) : Collector.t = Collector.C_some (self, callbacks)

src/tef/collector_tef.ml

@@ -60,8 +60,8 @@ open struct
     | None -> data
     | Some f -> ("function", `String f) :: data
 
-  let enter_span (self : st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params ~data
+  let enter_span (self : st) ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level:_ ~params
-      ~parent name : span =
+      ~data ~parent name : span =
     let start_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
     let flavor = flavor_of_params params in
 
@@ -104,7 +104,7 @@ open struct
 
     if did_write then self.exporter.on_json buf
 
-  let message (self : st) ~params:_ ~data ~span:_ msg : unit =
+  let message (self : st) ~level:_ ~params:_ ~data ~span:_ msg : unit =
     let tid = Trace_util.Mock_.get_tid () in
     let time_us = time_us_of_time_ns @@ Trace_util.Mock_.now_ns () in
     let@ buf = Trace_util.Rpool.with_ self.buf_pool in
@@ -119,8 +119,12 @@ open struct
     Writer.emit_counter buf ~pid:self.pid ~name ~tid ~ts:time_us n;
     self.exporter.on_json buf
 
-  let counter_int (self : st) ~params ~data name n : unit =
+  let metric (self : st) ~level:_ ~params ~data name m : unit =
-    counter_float self ~params ~data name (float_of_int n)
+    match m with
+    | Core_ext.Metric_float n -> counter_float self ~params ~data name n
+    | Core_ext.Metric_int i ->
+      counter_float self ~params ~data name (float_of_int i)
+    | _ -> ()
 
   let add_data_to_span _st sp data =
     match sp with
@@ -138,7 +142,7 @@ open struct
     Writer.emit_name_process ~pid:self.pid ~name buf;
     self.exporter.on_json buf
 
-  let extension (self : st) ev =
+  let extension (self : st) ~level:_ ev =
     match ev with
     | Core_ext.Extension_set_thread_name name ->
       let tid = Trace_util.Mock_.get_tid () in
@@ -149,7 +153,7 @@ end
 
 let callbacks_collector : _ Collector.Callbacks.t =
   Collector.Callbacks.make ~init ~shutdown ~enter_span ~exit_span ~message
-    ~add_data_to_span ~counter_int ~counter_float ~extension ()
+    ~add_data_to_span ~metric ~extension ()
 
 let collector (self : t) : Collector.t =
   Collector.C_some (self, callbacks_collector)

src/util/multi_collector.ml

@@ -18,14 +18,14 @@ open struct
     done
     [@ocaml.warning "-8"]
 
-  let enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params ~data ~parent name
+  let enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params ~data
-      : span =
+      ~parent name : span =
     let spans =
       Array.map
         (fun [@ocaml.warning "-8"] coll ->
           let (Collector.C_some (st, cb)) = coll in
-          cb.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~params ~data
+          cb.enter_span st ~__FUNCTION__ ~__FILE__ ~__LINE__ ~level ~params
-            ~parent name)
+            ~data ~parent name)
         st
     in
     Span_combine spans
@@ -52,31 +52,24 @@ open struct
       [@ocaml.warning "-8"]
     | _ -> ()
 
-  let message st ~params ~data ~span msg =
+  let message st ~level ~params ~data ~span msg =
     for i = 0 to Array.length st - 1 do
       let (Collector.C_some (st, cb)) = Array.get st i in
-      cb.message st ~span ~params ~data msg
+      cb.message st ~level ~span ~params ~data msg
     done
     [@ocaml.warning "-8"]
 
-  let counter_int st ~params ~data name n =
+  let metric st ~level ~params ~data name m =
     for i = 0 to Array.length st - 1 do
       let (Collector.C_some (st, cb)) = Array.get st i in
-      cb.counter_int st ~params ~data name n
+      cb.metric st ~level ~params ~data name m
     done
     [@ocaml.warning "-8"]
 
-  let counter_float st ~params ~data name n =
+  let extension st ~level ev : unit =
     for i = 0 to Array.length st - 1 do
       let (Collector.C_some (st, cb)) = Array.get st i in
-      cb.counter_float st ~params ~data name n
+      cb.extension st ~level ev
-    done
-    [@ocaml.warning "-8"]
-
-  let extension st ev : unit =
-    for i = 0 to Array.length st - 1 do
-      let (Collector.C_some (st, cb)) = Array.get st i in
-      cb.extension st ev
     done
     [@ocaml.warning "-8"]
 
@@ -87,8 +80,7 @@ open struct
       exit_span;
       message;
       add_data_to_span;
-      counter_int;
+      metric;
-      counter_float;
       extension;
       shutdown;
     }