diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 30b1dae..35a149d 100644 --- a/.github/workflows/gh-pages.yml +++ b/.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 diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index d7fc0c5..ade416d 100644 --- a/.github/workflows/main.yml +++ b/.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: diff --git a/src/core/level.ml b/src/core/level.ml new file mode 100644 index 0000000..6ba351f --- /dev/null +++ b/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 diff --git a/src/core/trace_core.ml b/src/core/trace_core.ml index 9b63b15..841004a 100644 --- a/src/core/trace_core.ml +++ 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,35 @@ let[@inline] enabled () = | 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 diff --git a/src/core/trace_core.mli b/src/core/trace_core.mli index afcf5ec..85b4b8f 100644 --- a/src/core/trace_core.mli +++ b/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,17 @@ val enabled : unit -> bool This is fast, so that the traced program can check it before creating any span or message. *) +val get_default_level : unit -> Level.t +(** Current default level for spans. + @since NEXT_RELEASE *) + +val set_default_level : Level.t -> unit +(** Set level used for spans that do not specify it. The default + default value is [Level.Trace]. + @since NEXT_RELEASE *) + val with_span : + ?level:Level.t -> ?__FUNCTION__:string -> __FILE__:string -> __LINE__:int -> @@ -27,6 +47,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 +58,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 +83,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 +98,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 +115,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 +133,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 +167,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 +201,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 - -(**/**)