feat: add levels to Trace_core.

.github/workflows/gh-pages.yml

@@ -4,7 +4,6 @@ on:
   push:
     branches:
       - main # Set a branch name to trigger deployment
-  pull_request:
 
 jobs:
   deploy:
@@ -16,22 +15,22 @@ jobs:
       - name: Use OCaml
         uses: ocaml/setup-ocaml@v2
         with:
-          ocaml-compiler: '5.0.x'
+          ocaml-compiler: '5.1.x'
           allow-prerelease-opam: true
           dune-cache: true
 
       - run: opam pin odoc 2.2.2 -y -n
         # crash with 2.4, see https://github.com/ocaml/odoc/issues/1066
       - name: Deps
-        run: opam install trace trace-tef trace-fuchsia ppx_trace -d
+        run: opam install odig trace trace-tef trace-fuchsia ppx_trace
 
       - name: Build
-        run: opam exec -- dune build @doc
+        run: opam exec -- odig odoc --cache-dir=_doc/ trace trace-tef trace-fuchsia ppx_trace
 
       - name: Deploy
         uses: peaceiris/actions-gh-pages@v3
         with:
           github_token: ${{ secrets.GITHUB_TOKEN }}
-          publish_dir: ./_build/default/_doc/_html/
+          publish_dir: ./_doc/html
           destination_dir: .
-          enable_jekyll: true
+          enable_jekyll: false

.github/workflows/main.yml

@@ -20,7 +20,7 @@ jobs:
             - '4.08.x'
             - '4.12.x'
             - '4.14.x'
-            - '5.0.x'
+            - '5.1.x'
 
     runs-on: ${{ matrix.os }}
     steps:

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,40 +2,57 @@ 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 () =
   match A.get collector with
   | None -> false
   | Some _ -> true
 
+let[@inline] get_default_level () = A.get default_level_
+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,36 +66,38 @@ 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
-  | None -> ()
-  | Some (module C) -> C.exit_manual_span espan
+  if espan != Collector.dummy_explicit_span then (
+    match A.get collector with
+    | None -> ()
+    | Some (module C) -> C.exit_manual_span espan
+  )
 
 let[@inline] add_data_to_span sp data : unit =
-  if data <> [] then (
+  if sp != Collector.dummy_span && data <> [] then (
     match A.get collector with
     | None -> ()
     | Some (module C) -> C.add_data_to_span sp data
   )
 
 let[@inline] add_data_to_manual_span esp data : unit =
-  if data <> [] then (
+  if esp != Collector.dummy_explicit_span && data <> [] then (
     match A.get collector with
     | None -> ()
     | Some (module C) -> C.add_data_to_manual_span esp data
@@ -89,15 +108,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 +127,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