add hmap as a depopt

.github/workflows/main.yml

@@ -42,3 +42,7 @@ jobs:
       - run: opam install trace
       - run: opam exec -- dune runtest -p trace-tef,trace-fuchsia
 
+      # with depopts
+      - run: opam install hmap
+      - run: opam exec -- dune build '@install' -p trace,trace-tef,trace-fuchsia
+

dune-project

@@ -19,6 +19,7 @@
    (ocaml (>= 4.08))
    dune)
  (depopts
+   hmap
    (mtime (>= 2.0)))
  (tags
   (trace tracing observability profiling)))

src/core/dune

@@ -2,6 +2,9 @@
 (library
  (name trace_core)
  (public_name trace.core)
+ (libraries (select meta_map.ml from
+                    (hmap -> meta_map.hmap.ml)
+                    (-> meta_map.ourown.ml)))
  (synopsis "Lightweight stub for tracing")
 )
 

src/core/meta_map.hmap.ml

@@ -0,0 +1,3 @@
+include Hmap
+
+let find_exn = get

src/core/meta_map.ourown.ml

@@ -0,0 +1,91 @@
+module type KEY_IMPL = sig
+  type t
+
+  exception Store of t
+
+  val id : int
+end
+
+module Key = struct
+  type 'a t = (module KEY_IMPL with type t = 'a)
+
+  let _n = ref 0
+
+  let create (type k) () =
+    incr _n;
+    let id = !_n in
+    let module K = struct
+      type t = k
+
+      let id = id
+
+      exception Store of k
+    end in
+    (module K : KEY_IMPL with type t = k)
+
+  let[@inline] id (type k) (module K : KEY_IMPL with type t = k) = K.id
+
+  let equal : type a b. a t -> b t -> bool =
+   fun (module K1) (module K2) -> K1.id = K2.id
+end
+
+type 'a key = 'a Key.t
+type binding = B : 'a Key.t * 'a -> binding
+
+open struct
+  type exn_pair = E_pair : 'a Key.t * exn -> exn_pair
+
+  let pair_of_e_pair (E_pair (k, e)) =
+    let module K = (val k) in
+    match e with
+    | K.Store v -> B (k, v)
+    | _ -> assert false
+end
+
+module M = Map.Make (struct
+  type t = int
+
+  let compare (i : int) j = Stdlib.compare i j
+end)
+
+type t = { m: exn_pair M.t } [@@unboxed]
+
+let empty : t = { m = M.empty }
+let[@inline] mem k (self : t) = M.mem (Key.id k) self.m
+
+let find_exn (type a) (k : a Key.t) (self : t) : a =
+  let module K = (val k) in
+  let (E_pair (_, e)) = M.find K.id self.m in
+  match e with
+  | K.Store v -> v
+  | _ -> assert false
+
+let find k (self : t) = try Some (find_exn k self) with Not_found -> None
+
+open struct
+  let add_e_pair_ p self =
+    let (E_pair ((module K), _)) = p in
+    { m = M.add K.id p self.m }
+
+  let add_pair_ p (self : t) : t =
+    let (B (((module K) as k), v)) = p in
+    let p = E_pair (k, K.Store v) in
+    { m = M.add K.id p self.m }
+end
+
+let add (type a) (k : a Key.t) v (self : t) : t =
+  let module K = (val k) in
+  add_e_pair_ (E_pair (k, K.Store v)) self
+
+let remove (type a) (k : a Key.t) (self : t) : t =
+  let module K = (val k) in
+  { m = M.remove K.id self.m }
+
+let[@inline] cardinal (self : t) = M.cardinal self.m
+let length = cardinal
+let iter f (self : t) = M.iter (fun _ p -> f (pair_of_e_pair p)) self.m
+
+let to_list (self : t) : binding list =
+  M.fold (fun _ p l -> pair_of_e_pair p :: l) self.m []
+
+let add_list (self : t) l = List.fold_right add_pair_ l self

src/core/types.ml

@@ -17,6 +17,9 @@ type explicit_span = {
   span: span;
       (** Identifier for this span. Several explicit spans might share the same
       identifier since we can differentiate between them via [meta]. *)
-  mutable meta: Meta_map.t;  (** Metadata for this span (and its context) *)
+  mutable meta: Meta_map.t;
+      (** Metadata for this span (and its context). This can be used by collectors to
+        carry collector-specific information from the beginning
+        of the span, to the end of the span. *)
 }
 (** Explicit span, with collector-specific metadata *)

src/fuchsia/fcollector.ml

@@ -110,7 +110,7 @@ type async_span_info = {
   mutable data: (string * user_data) list;
 }
 
-let key_async_data : async_span_info Meta_map.Key.t = Meta_map.Key.create ()
+let key_async_data : async_span_info Meta_map.key = Meta_map.Key.create ()
 
 open struct
   let state_id_ = A.make 0

src/tef/trace_tef.ml

@@ -92,12 +92,12 @@ type span_info = {
 }
 
 (** key used to carry a unique "id" for all spans in an async context *)
-let key_async_id : int Meta_map.Key.t = Meta_map.Key.create ()
+let key_async_id : int Meta_map.key = Meta_map.Key.create ()
 
-let key_async_data : (string * [ `Sync | `Async ] option) Meta_map.Key.t =
+let key_async_data : (string * [ `Sync | `Async ] option) Meta_map.key =
   Meta_map.Key.create ()
 
-let key_data : (string * user_data) list ref Meta_map.Key.t =
+let key_data : (string * user_data) list ref Meta_map.key =
   Meta_map.Key.create ()
 
 (** Writer: knows how to write entries to a file in TEF format *)

trace.opam

@@ -15,6 +15,7 @@ depends: [
   "odoc" {with-doc}
 ]
 depopts: [
+  "hmap"
   "mtime" {>= "2.0"}
 ]
 build: [