Repository: ocaml-multicore/picos
Pull request #179 (2024-07-16 07:18:31)

Add `Promise.terminate_after`
Also avoid use of raw Picos API in tests.


Patch:
diff --git a/lib/picos_structured/picos_structured.mli b/lib/picos_structured/picos_structured.mli
index aaec634..2348ae7 100644
--- a/lib/picos_structured/picos_structured.mli
+++ b/lib/picos_structured/picos_structured.mli
@@ -185,11 +185,24 @@ module Promise : sig
   (** [try_terminate promise] tries to terminate the promise by canceling it
       with the {{!Control.Terminate} [Terminate]} exception and returns [true]
       in case of success and [false] in case the promise had already completed,
-      i.e. either returned, raised, or canceled. *)
+      i.e. either returned, raised, or canceled.
+
+      The optional [callstack] argument specifies the number of callstack
+      entries to capture with the {{!Control.Terminate} [Terminate]} exception.
+      The default is [0]. *)
 
   val terminate : ?callstack:int -> 'a t -> unit
   (** [terminate promise] is equivalent to
       {{!try_terminate} [try_terminate promise |> ignore]}. *)
+
+  val terminate_after : ?callstack:int -> 'a t -> seconds:float -> unit
+  (** [terminate_after ~seconds promise] arranges to terminate the [promise] by
+      canceling it with the {{!Control.Terminate} [Terminate]} exception after
+      the specified number of [seconds].
+
+      The optional [callstack] argument specifies the number of callstack
+      entries to capture with the {{!Control.Terminate} [Terminate]} exception.
+      The default is [0]. *)
 end
 
 module Bundle : sig
diff --git a/lib/picos_structured/promise.ml b/lib/picos_structured/promise.ml
index 183047f..f9317a2 100644
--- a/lib/picos_structured/promise.ml
+++ b/lib/picos_structured/promise.ml
@@ -13,3 +13,7 @@ let try_terminate ?callstack t =
   Computation.try_cancel t terminate_bt
 
 let terminate ?callstack t = try_terminate ?callstack t |> ignore
+
+let terminate_after ?callstack t ~seconds =
+  let terminate_bt = Control.terminate_bt ?callstack () in
+  Computation.cancel_after t ~seconds terminate_bt


Test patch:
diff --git a/test/dune b/test/dune
index f1cad25..a51bfdb 100644
--- a/test/dune
+++ b/test/dune
@@ -47,7 +47,7 @@
  (modules test_lwt_unix)
  (build_if
   (>= %{ocaml_version} 5.0.0))
- (libraries picos.lwt_unix alcotest))
+ (libraries picos.lwt_unix picos.structured alcotest))
 
 ;;
 
diff --git a/test/test_lwt_unix.ml b/test/test_lwt_unix.ml
index c24eec6..2111bbf 100644
--- a/test/test_lwt_unix.ml
+++ b/test/test_lwt_unix.ml
@@ -1,21 +1,16 @@
-open Picos
+open Picos_structured
 
 let basics () =
   Lwt_main.run @@ Picos_lwt_unix.run
   @@ fun () ->
-  let computation = Computation.create () in
+  Bundle.join_after @@ fun bundle ->
   let child =
-    Computation.capture computation @@ fun () ->
+    Bundle.fork_as_promise bundle @@ fun () ->
     while true do
       Picos_lwt.await (Lwt_unix.sleep 0.01)
     done
   in
-  Fiber.spawn ~forbid:false computation [ child ];
-  Computation.cancel_after computation ~seconds:0.05
-    (Exn_bt.get_callstack 0 Exit);
-  match Computation.await computation with
-  | () -> assert false
-  | exception Exit -> ()
+  Promise.terminate_after ~seconds:0.05 child
 
 let () =
   [ ("Basics", [ Alcotest.test_case "" `Quick basics ]) ]