use picos-based moonpool

.github/workflows/main.yml

@@ -18,7 +18,7 @@ jobs:
               #- macos-latest
               #- windows-latest
         ocaml-compiler:
-            - '4.12'
+            - '4.14'
             - '5.2'
 
     runs-on: ${{ matrix.os }}
@@ -63,7 +63,6 @@ jobs:
           dune-cache: true
           allow-prerelease-opam: true
 
-      - run: opam pin moonpool --dev -y -n
       - run: opam install -t imandrakit imandrakit-log imandrakit-io imandrakit-thread --deps-only
       - run: opam exec -- dune build @install -p imandrakit,imandrakit-io,imandrakit-log,imandrakit-thread
       - run: opam exec -- dune build @runtest -p imandrakit,imandrakit-io,imandrakit-log,imandrakit-thread
@@ -84,7 +83,7 @@ jobs:
           dune-cache: true
           allow-prerelease-opam: true
 
-      - run: opam install ocamlformat.0.24.1
+      - run: opam install ocamlformat.0.26.2
       - run: opam exec -- make format-check
 
 # vim:foldmethod=indent

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.26.2
 profile=conventional
 margin=80
 if-then-else=k-r

dune-project

@@ -22,7 +22,7 @@
  (synopsis "Core utils library for Imandra")
  (depends
   (ocaml
-   (>= 4.12))
+   (>= 4.14))
   dune
   (containers
    (>= 3.4))
@@ -33,6 +33,8 @@
   ptime
   atomic
   hmap
+  (moonpool
+   (>= 0.7))
   (yojson
    (>= 1.6))
   (mtime
@@ -67,13 +69,13 @@
  (synopsis "Logging utils for Imandra")
  (depends
   (ocaml
-   (>= 4.12))
+   (>= 4.14))
   (imandrakit
    (= :version))
   hmap
   dune
   (moonpool
-   (>= 0.6))
+   (>= 0.7))
   logs
   thread-local-storage
   (trace-tef :with-test)
@@ -84,7 +86,7 @@
  (synopsis "IO utils for Imandra")
  (depends
   (ocaml
-   (>= 4.12))
+   (>= 4.14))
   (imandrakit
    (= :version))
   (imandrakit-log
@@ -106,7 +108,7 @@
   hmap
   dune
   (moonpool
-   (>= 0.6))
+   (>= 0.7))
   thread-local-storage
   (trace-tef :with-test)
   (odoc :with-doc)))

imandrakit-io.opam

@@ -9,7 +9,7 @@ homepage: "https://github.com/imandra-ai/imandrakit"
 bug-reports: "https://github.com/imandra-ai/imandrakit/issues"
 depends: [
   "dune" {>= "3.0"}
-  "ocaml" {>= "4.12"}
+  "ocaml" {>= "4.14"}
   "imandrakit" {= version}
   "imandrakit-log" {= version}
   "moonpool" {>= "0.6"}

imandrakit-log.opam

@@ -8,11 +8,11 @@ license: "MIT"
 homepage: "https://github.com/imandra-ai/imandrakit"
 bug-reports: "https://github.com/imandra-ai/imandrakit/issues"
 depends: [
-  "ocaml" {>= "4.12"}
+  "ocaml" {>= "4.14"}
   "imandrakit" {= version}
   "hmap"
   "dune" {>= "3.0"}
-  "moonpool" {>= "0.6"}
+  "moonpool" {>= "0.7"}
   "logs"
   "thread-local-storage"
   "trace-tef" {with-test}

imandrakit-thread.opam

@@ -13,7 +13,7 @@ depends: [
   "logs"
   "hmap"
   "dune" {>= "3.0"}
-  "moonpool" {>= "0.6"}
+  "moonpool" {>= "0.7"}
   "thread-local-storage"
   "trace-tef" {with-test}
   "odoc" {with-doc}

imandrakit.opam

@@ -9,7 +9,7 @@ tags: ["moonpool" "multicore" "thread" "logs" "logging"]
 homepage: "https://github.com/imandra-ai/imandrakit"
 bug-reports: "https://github.com/imandra-ai/imandrakit/issues"
 depends: [
-  "ocaml" {>= "4.12"}
+  "ocaml" {>= "4.14"}
   "dune" {>= "3.0"}
   "containers" {>= "3.4"}
   "iter" {>= "1.0"}
@@ -18,6 +18,7 @@ depends: [
   "ptime"
   "atomic"
   "hmap"
+  "moonpool" {>= "0.7"}
   "yojson" {>= "1.6"}
   "mtime" {>= "2.0"}
   "ppx_deriving"

src/core/core_classes.ml

@@ -1,11 +1,10 @@
 (** Some fundamental base classes *)
 
 (** Named object *)
-class type named =
-  object
-    method name : string
-    (** Name of this thing. *)
-  end
+class type named = object
+  method name : string
+  (** Name of this thing. *)
+end
 
 class virtual named' =
   object
@@ -16,11 +15,10 @@ class virtual named' =
 let () = ignore (fun (_x : named') : named -> (_x :> named))
 
 (** Statistics *)
-class type with_stats =
-  object
-    method add_stats : Stats.t -> unit
-    (** Add statistics. *)
-  end
+class type with_stats = object
+  method add_stats : Stats.t -> unit
+  (** Add statistics. *)
+end
 
 (** Default class for {!with_stats} *)
 class with_stats' : with_stats =

src/core/util.ml

@@ -111,11 +111,11 @@ let format_duration_s (f : float) : string =
     print_aux "d" n_day ^ print_aux "h" n_hour ^ print_aux "m" n_min
     ^ string_of_int n
     ^ (if f -. floor f >= 0.01 then (
-        let s = Printf.sprintf "%.1f" (f -. floor f) in
-        (* remove the leading "0." *)
-        "." ^ snd @@ CCString.Split.left_exn ~by:"." s
-      ) else
-        "")
+         let s = Printf.sprintf "%.1f" (f -. floor f) in
+         (* remove the leading "0." *)
+         "." ^ snd @@ CCString.Split.left_exn ~by:"." s
+       ) else
+         "")
     ^ "s"
   ) else if f < 0.010 then
     spf "%.2fms" (f *. 1000.)

src/error/dune

@@ -5,4 +5,4 @@
   (pps ppx_deriving.std imandrakit.twine.ppx imandrakit.typereg.ppx))
  (flags :standard -open Imandrakit_common)
  (synopsis "Error library for imandrakit")
- (libraries imandrakit.common imandrakit.twine hmap logs containers))
+ (libraries imandrakit.common imandrakit.twine moonpool hmap logs containers))

src/error/error.ml

@@ -32,6 +32,9 @@ let of_exn ?bt ~kind exn : t =
     let bt = Option.map Printexc.raw_backtrace_to_string bt in
     mk_error ?bt ~kind (Printexc.to_string exn)
 
+let[@inline] of_exn_bt ~kind (ebt : Moonpool.Exn_bt.t) : t =
+  of_exn ~bt:(Moonpool.Exn_bt.bt ebt) ~kind (Moonpool.Exn_bt.exn ebt)
+
 let[@inline] guardf ?let_pass k f =
   guard ?let_pass (fun () -> k (fun fmt -> Fmt.kasprintf message fmt)) f
 

src/error/error.mli

@@ -56,5 +56,8 @@ val guardf :
 val of_exn : ?bt:Printexc.raw_backtrace -> kind:Kind.t -> exn -> t
 (** Turn exception into an error. *)
 
+val of_exn_bt : kind:Kind.t -> Moonpool.Exn_bt.t -> t
+(** Turn exception into an error. *)
+
 val try_catch : kind:Kind.t -> unit -> (unit -> 'a) -> 'a result
 val unwrap_opt : 'a option -> 'a

src/leb128/imandrakit_leb128.ml

@@ -78,12 +78,12 @@ module Encode = struct
 
   external varint_size : (int64[@unboxed]) -> int
     = "caml_ix_leb128_varint_size_byte" "caml_ix_leb128_varint_size"
-    [@@noalloc]
+  [@@noalloc]
   (** Compute how many bytes this int would occupy as varint *)
 
   external varint_slice : bytes -> (int[@untagged]) -> (int64[@unboxed]) -> unit
     = "caml_ix_leb128_varint_byte" "caml_ix_leb128_varint"
-    [@@noalloc]
+  [@@noalloc]
   (** Write this int as varint into the given slice *)
 
   let[@inline] u64 (buf : Buf.t) (i : int64) =

src/log/log_ctx.ml

@@ -3,25 +3,18 @@ module LS = Moonpool.Task_local_storage
 type 'a tag = 'a Logs.Tag.def
 
 (** Storage key for the ambient context. *)
-let ctx_k : Logs.Tag.t Str_map.t LS.key =
-  LS.new_key ~init:(fun () -> Str_map.empty) ()
+let ctx_k : Logs.Tag.t Str_map.t LS.t = LS.create ()
 
 let create_tag ?doc name pp : _ tag = Logs.Tag.def ?doc name pp
 
 let get_tags_from_ctx () : Logs.Tag.set =
-  match LS.get ctx_k with
-  | exception Failure _ -> Logs.Tag.empty
-  | map ->
-    (* build the current set of tags *)
-    Str_map.fold
-      (fun _ (Logs.Tag.V (tag, v)) set -> Logs.Tag.add tag v set)
-      map Logs.Tag.empty
+  let map = LS.get ~default:Str_map.empty ctx_k in
+  (* build the current set of tags *)
+  Str_map.fold
+    (fun _ (Logs.Tag.V (tag, v)) set -> Logs.Tag.add tag v set)
+    map Logs.Tag.empty
 
 let with_tag (tag : _ tag) v (f : unit -> 'b) : 'b =
-  match LS.get ctx_k with
-  | exception Failure _ -> f ()
-  | old_map ->
-    let new_map =
-      Str_map.add (Logs.Tag.name tag) (Logs.Tag.V (tag, v)) old_map
-    in
-    LS.with_value ctx_k new_map f
+  let old_map = LS.get ~default:Str_map.empty ctx_k in
+  let new_map = Str_map.add (Logs.Tag.name tag) (Logs.Tag.V (tag, v)) old_map in
+  LS.with_value ctx_k new_map f

src/log/log_reader.ml

@@ -1,16 +1,15 @@
 module Log = (val Logger.mk_log_str "x.log-reader")
 module Err = Imandrakit_error.Error
 
-class type t =
-  object
-    inherit Core_classes.named
+class type t = object
+  inherit Core_classes.named
 
-    method read_events :
-      only_above_level:Logger.level option ->
-      filter_meta:(string * string) list ->
-      unit ->
-      Logger.Log_event.t Iter.t
-  end
+  method read_events :
+    only_above_level:Logger.level option ->
+    filter_meta:(string * string) list ->
+    unit ->
+    Logger.Log_event.t Iter.t
+end
 
 class dummy : t =
   object

src/log/log_reader.mli

@@ -4,20 +4,19 @@
     some storage (typically, to display them in the web UI).
 *)
 
-class type t =
-  object
-    inherit Core_classes.named
+class type t = object
+  inherit Core_classes.named
 
-    method read_events :
-      only_above_level:Logger.level option ->
-      filter_meta:(string * string) list ->
-      unit ->
-      Logger.Log_event.t Iter.t
-    (** Read events, in order, from the underlying log source.
+  method read_events :
+    only_above_level:Logger.level option ->
+    filter_meta:(string * string) list ->
+    unit ->
+    Logger.Log_event.t Iter.t
+  (** Read events, in order, from the underlying log source.
           @param only_above_level if [Some lvl], only events more important
           than this level (inclusive) are returned
           @param filter_meta a list of key/value pairs that must match *)
-  end
+end
 
 val pp : t Fmt.printer
 

src/log/trace_async.ml

@@ -2,12 +2,11 @@ module Trace = Trace_core
 module LS = Moonpool.Task_local_storage
 
 (** Current parent scope for async spans *)
-let k_parent_scope : Trace.explicit_span option LS.key =
-  LS.new_key ~init:(fun () -> None) ()
+let k_parent_scope : Trace.explicit_span Hmap.key = Hmap.Key.create ()
 
 (** Set the parent scope by hand *)
-let set_parent_scope (sp : Trace.explicit_span) =
-  LS.set k_parent_scope (Some sp)
+let[@inline] set_parent_scope (sp : Trace.explicit_span) =
+  LS.set_in_local_hmap k_parent_scope sp
 
 let add_exn_to_span (sp : Trace.explicit_span) (exn : exn) =
   Trace.add_data_to_manual_span sp
@@ -19,12 +18,7 @@ let add_bt_to_span (sp : Trace.explicit_span) (bt : Printexc.raw_backtrace) =
 
 open struct
   let with_span_real_ ~level ?data ?__FUNCTION__ ~__FILE__ ~__LINE__ name f =
-    let storage = LS.get_current () in
-    let parent =
-      CCOption.flat_map
-        (fun store -> LS.Direct.get store k_parent_scope)
-        storage
-    in
+    let parent = LS.get_in_local_hmap_opt k_parent_scope in
     let span =
       match parent with
       | None ->
@@ -36,14 +30,14 @@ open struct
     in
 
     (* set current span as parent, for children *)
-    LS.set k_parent_scope (Some span);
+    LS.set_in_local_hmap k_parent_scope span;
 
     (* cleanup *)
     let finally () =
       (* restore previous parent span *)
-      Option.iter
-        (fun store -> LS.Direct.set store k_parent_scope parent)
-        storage;
+      (match parent with
+      | None -> LS.remove_in_local_hmap k_parent_scope
+      | Some p -> LS.set_in_local_hmap k_parent_scope p);
       Trace.exit_manual_span span
     in
 

src/ser-pack/ppx/imandrakit_ser_pack_ppx.ml

@@ -193,9 +193,9 @@ let rec ser_expr_of_ty (e : expression) ~(ty : core_type) : expression =
     in
     by_full_ser
       (if args = [] then
-        f
-      else
-        A.Exp.apply f args)
+         f
+       else
+         A.Exp.apply f args)
   | { ptyp_desc = Ptyp_tuple args; ptyp_loc = loc; _ } ->
     let ser_args =
       args
@@ -314,9 +314,9 @@ let rec deser_expr_of_ty (e : expression) ~(ty : core_type) : expression =
     in
     by_full_deser
       (if args = [] then
-        f
-      else
-        A.Exp.apply f args)
+         f
+       else
+         A.Exp.apply f args)
   | { ptyp_desc = Ptyp_tuple args; ptyp_loc = loc; _ } ->
     let deser_args =
       args