feat: add levels to Trace_core.

these levels are used to control the verbosity levels.

src/core/level.ml

@@ -0,0 +1,34 @@
+(** Tracing levels.
+
+    This is similar to log levels in, say, [Logs].
+    In a thoroughly instrumented program, there will be a {b lot}
+    of spans, and enabling them all in production might slow
+    down the application or overwhelm the tracing system; yet
+    they might be useful in debug situations.
+
+    @since NEXT_RELEASE *)
+
+(** Level of tracing. These levels are in increasing order, i.e if
+    level [Debug1] is enabled, everything below it (Error, Warning, Info, etc.)
+    are also enabled.
+    @since NEXT_RELEASE *)
+type t =
+  | Error  (** Only errors *)
+  | Warning  (** Warnings *)
+  | Info
+  | Debug1  (** Least verbose debugging level *)
+  | Debug2  (** Intermediate verbosity debugging level *)
+  | Debug3  (** Maximum verbosity debugging level *)
+  | Trace  (** Enable everything (default level) *)
+
+(** @since NEXT_RELEASE *)
+let to_string : t -> string = function
+  | Error -> "error"
+  | Warning -> "warning"
+  | Info -> "info"
+  | Debug1 -> "debug1"
+  | Debug2 -> "debug2"
+  | Debug3 -> "debug3"
+  | Trace -> "trace"
+
+let[@inline] leq (a : t) (b : t) : bool = a <= b

src/core/trace_core.ml

@@ -2,12 +2,21 @@ include Types
 module A = Atomic_
 module Collector = Collector
 module Meta_map = Meta_map
+module Level = Level
 
 type collector = (module Collector.S)
 
+(* ## globals ## *)
+
 (** Global collector. *)
 let collector : collector option A.t = A.make None
 
+(* default level for spans without a level *)
+let default_level_ = A.make Level.Trace
+let current_level_ = A.make Level.Trace
+
+(* ## implementation ## *)
+
 let data_empty_build_ () = []
 
 let[@inline] enabled () =
@@ -15,27 +24,34 @@ let[@inline] enabled () =
   | None -> false
   | Some _ -> true
 
+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 =
+  Level.leq level (A.get current_level_)
+
 let with_span_collector_ (module C : Collector.S) ?__FUNCTION__ ~__FILE__
     ~__LINE__ ?(data = data_empty_build_) name f =
   let data = data () in
   C.with_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name f
 
-let[@inline] with_span ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f =
+let[@inline] with_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name f =
   match A.get collector with
-  | None ->
-    (* fast path: no collector, no span *)
-    f Collector.dummy_span
-  | Some collector ->
+  | Some collector when check_level ?level () ->
     with_span_collector_ collector ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
       f
+  | _ ->
+    (* fast path: no collector, no span *)
+    f Collector.dummy_span
 
-let[@inline] enter_span ?__FUNCTION__ ~__FILE__ ~__LINE__
+let[@inline] enter_span ?level ?__FUNCTION__ ~__FILE__ ~__LINE__
     ?(data = data_empty_build_) name : span =
   match A.get collector with
-  | None -> Collector.dummy_span
-  | Some (module C) ->
+  | Some (module C) when check_level ?level () ->
     let data = data () in
     C.enter_span ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data name
+  | _ -> Collector.dummy_span
 
 let[@inline] exit_span sp : unit =
   match A.get collector with
@@ -49,21 +65,21 @@ let enter_explicit_span_collector_ (module C : Collector.S) ~parent ~flavor
   C.enter_manual_span ~parent ~flavor ~__FUNCTION__ ~__FILE__ ~__LINE__ ~data
     name
 
-let[@inline] enter_manual_sub_span ~parent ?flavor ?__FUNCTION__ ~__FILE__
-    ~__LINE__ ?data name : explicit_span =
+let[@inline] enter_manual_sub_span ~parent ?flavor ?level ?__FUNCTION__
+    ~__FILE__ ~__LINE__ ?data name : explicit_span =
   match A.get collector with
-  | None -> Collector.dummy_explicit_span
-  | Some coll ->
+  | Some coll when check_level ?level () ->
     enter_explicit_span_collector_ coll ~parent:(Some parent) ~flavor
       ?__FUNCTION__ ~__FILE__ ~__LINE__ ?data name
+  | _ -> Collector.dummy_explicit_span
 
-let[@inline] enter_manual_toplevel_span ?flavor ?__FUNCTION__ ~__FILE__
+let[@inline] enter_manual_toplevel_span ?flavor ?level ?__FUNCTION__ ~__FILE__
     ~__LINE__ ?data name : explicit_span =
   match A.get collector with
-  | None -> Collector.dummy_explicit_span
-  | Some coll ->
+  | Some coll when check_level ?level () ->
     enter_explicit_span_collector_ coll ~parent:None ~flavor ?__FUNCTION__
       ~__FILE__ ~__LINE__ ?data name
+  | _ -> Collector.dummy_explicit_span
 
 let[@inline] exit_manual_span espan : unit =
   match A.get collector with
@@ -89,15 +105,15 @@ let message_collector_ (module C : Collector.S) ?span
   let data = data () in
   C.message ?span ~data msg
 
-let[@inline] message ?span ?data msg : unit =
+let[@inline] message ?level ?span ?data msg : unit =
   match A.get collector with
-  | None -> ()
-  | Some coll -> message_collector_ coll ?span ?data msg
+  | Some coll when check_level ?level () ->
+    message_collector_ coll ?span ?data msg
+  | _ -> ()
 
-let messagef ?span ?data k =
+let messagef ?level ?span ?data k =
   match A.get collector with
-  | None -> ()
-  | Some (module C) ->
+  | Some (module C) when check_level ?level () ->
     k (fun fmt ->
         Format.kasprintf
           (fun str ->
@@ -108,20 +124,21 @@ let messagef ?span ?data k =
             in
             C.message ?span ~data str)
           fmt)
+  | _ -> ()
 
-let counter_int ?(data = data_empty_build_) name n : unit =
+let counter_int ?level ?(data = data_empty_build_) name n : unit =
   match A.get collector with
-  | None -> ()
-  | Some (module C) ->
+  | Some (module C) when check_level ?level () ->
     let data = data () in
     C.counter_int ~data name n
+  | _ -> ()
 
-let counter_float ?(data = data_empty_build_) name f : unit =
+let counter_float ?level ?(data = data_empty_build_) name f : unit =
   match A.get collector with
-  | None -> ()
-  | Some (module C) ->
+  | Some (module C) when check_level ?level () ->
     let data = data () in
     C.counter_float ~data name f
+  | _ -> ()
 
 let set_thread_name name : unit =
   match A.get collector with

src/core/trace_core.mli

@@ -3,6 +3,16 @@
 include module type of Types
 module Collector = Collector
 module Meta_map = Meta_map
+module Level = Level
+
+(**/**)
+
+(* no guarantee of stability *)
+module Internal_ : sig
+  module Atomic_ = Atomic_
+end
+
+(**/**)
 
 (** {2 Tracing} *)
 
@@ -12,7 +22,12 @@ val enabled : unit -> bool
     This is fast, so that the traced program can check it before creating
     any span or message. *)
 
+val set_default_level : Level.t -> unit
+(** Set level used for spans that do not specify it. The default
+    default value is [Level.Trace] *)
+
 val with_span :
+  ?level:Level.t ->
   ?__FUNCTION__:string ->
   __FILE__:string ->
   __LINE__:int ->
@@ -27,6 +42,9 @@ val with_span :
 
     This is the recommended way to instrument most code.
 
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
+
     {b NOTE} an important restriction is that this is only supposed to
     work for synchronous, direct style code. Monadic concurrency, Effect-based
     fibers, etc. might not play well with this style of spans on some
@@ -35,14 +53,22 @@ val with_span :
 *)
 
 val enter_span :
+  ?level:Level.t ->
   ?__FUNCTION__:string ->
   __FILE__:string ->
   __LINE__:int ->
   ?data:(unit -> (string * user_data) list) ->
   string ->
   span
+(** Enter a span manually.
+
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}. *)
 
 val exit_span : span -> unit
+(** Exit a span manually. This must run on the same thread
+    as the corresponding {!enter_span}, and spans must nest
+    correctly. *)
 
 val add_data_to_span : span -> (string * user_data) list -> unit
 (** Add structured data to the given active span (see {!with_span}).
@@ -52,6 +78,7 @@ val add_data_to_span : span -> (string * user_data) list -> unit
 val enter_manual_sub_span :
   parent:explicit_span ->
   ?flavor:[ `Sync | `Async ] ->
+  ?level:Level.t ->
   ?__FUNCTION__:string ->
   __FILE__:string ->
   __LINE__:int ->
@@ -66,10 +93,13 @@ val enter_manual_sub_span :
       start and stop on one thread, and are nested purely by their timestamp;
       and [`Async] spans can overlap, migrate between threads, etc. (as happens in
       Lwt, Eio, Async, etc.) which impacts how the collector might represent them.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
     @since 0.3 *)
 
 val enter_manual_toplevel_span :
   ?flavor:[ `Sync | `Async ] ->
+  ?level:Level.t ->
   ?__FUNCTION__:string ->
   __FILE__:string ->
   __LINE__:int ->
@@ -80,6 +110,8 @@ val enter_manual_toplevel_span :
     [explicit_span] around until it's exited with {!exit_manual_span}.
     The span can be used as a parent in {!enter_manual_sub_span}.
     @param flavor see {!enter_manual_sub_span} for more details.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
     @since 0.3 *)
 
 val exit_manual_span : explicit_span -> unit
@@ -96,19 +128,28 @@ val add_data_to_manual_span : explicit_span -> (string * user_data) list -> unit
     @since 0.4 *)
 
 val message :
-  ?span:span -> ?data:(unit -> (string * user_data) list) -> string -> unit
+  ?level:Level.t ->
+  ?span:span ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  unit
 (** [message msg] logs a message [msg] (if a collector is installed).
     Additional metadata can be provided.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
     @param span the surrounding span, if any. This might be ignored by the collector. *)
 
 val messagef :
+  ?level:Level.t ->
   ?span:span ->
   ?data:(unit -> (string * user_data) list) ->
   ((('a, Format.formatter, unit, unit) format4 -> 'a) -> unit) ->
   unit
 (** [messagef (fun k->k"hello %s %d!" "world" 42)] is like
     [message "hello world 42!"] but only computes the string formatting
-    if a collector is installed. *)
+    if a collector is installed.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}. *)
 
 val set_thread_name : string -> unit
 (** Give a name to the current thread.
@@ -121,14 +162,26 @@ val set_process_name : string -> unit
     to display traces in a more informative way. *)
 
 val counter_int :
-  ?data:(unit -> (string * user_data) list) -> string -> int -> unit
+  ?level:Level.t ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  int ->
+  unit
 (** Emit a counter of type [int]. Counters represent the evolution of some quantity
     over time.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
     @param data metadata for this metric (since 0.4) *)
 
 val counter_float :
-  ?data:(unit -> (string * user_data) list) -> string -> float -> unit
+  ?level:Level.t ->
+  ?data:(unit -> (string * user_data) list) ->
+  string ->
+  float ->
+  unit
 (** Emit a counter of type [float]. See {!counter_int} for more details.
+    @param level optional level for this span. since NEXT_RELEASE.
+      Default is set via {!set_default_level}.
     @param data metadata for this metric (since 0.4) *)
 
 (** {2 Collector} *)
@@ -143,15 +196,16 @@ val setup_collector : collector -> unit
     @raise Invalid_argument if there already is an established
     collector. *)
 
+val get_current_level : unit -> Level.t
+(** Get current level. This is only meaningful if
+    a collector was set up with {!setup_collector}.
+    @since NEXT_RELEASE *)
+
+val set_current_level : Level.t -> unit
+(** Set the current level of tracing. This only has a visible
+    effect if a collector was installed with {!setup_collector}.
+    @since NEXT_RELEASE *)
+
 val shutdown : unit -> unit
 (** [shutdown ()] shutdowns the current collector, if one was installed,
     and waits for it to terminate before returning. *)
-
-(**/**)
-
-(* no guarantee of stability *)
-module Internal_ : sig
-  module Atomic_ = Atomic_
-end
-
-(**/**)