tests for trace.lwt

test/lwt/dune

@@ -0,0 +1,21 @@
+(executable
+ (name t_lwt)
+ (modules t_lwt)
+ (libraries
+  trace
+  test_trace_common
+  (select
+   t_lwt.ml
+   from
+   (trace.lwt lwt.unix -> t_lwt.real.ml)
+   (-> t_lwt.quine.ml))))
+
+(rule
+ (alias runtest)
+ (package trace)
+ (action
+  (progn
+   (with-stdout-to
+    t_lwt.output
+    (run %{exe:t_lwt.exe} %{dep:t_lwt.expected}))
+   (diff t_lwt.expected t_lwt.output))))

test/lwt/t_lwt.expected

@@ -0,0 +1,10 @@
+=== ambient span (Lwt) ===
+before any span: none
+sync outer: sync-outer
+sync inner: sync-inner
+after sync: none
+lwt outer: lwt-outer
+lwt inner: lwt-inner
+after lwt inner: lwt-outer
+after lwt outer: none
+after binds: bind-test

test/lwt/t_lwt.quine.ml

@@ -0,0 +1,10 @@
+(* When trace.lwt is unavailable, echo the expected file
+   so the diff always passes. The file is passed as argv[1] by the dune rule. *)
+let () =
+  let ic = open_in Sys.argv.(1) in
+  (try
+     while true do
+       print_char (input_char ic)
+     done
+   with End_of_file -> ());
+  close_in ic

test/lwt/t_lwt.real.ml

@@ -0,0 +1,49 @@
+(* Test ambient span tracking via Lwt key provider *)
+
+open Test_trace_common
+
+let ( let@ ) = ( @@ )
+
+let () =
+  print_endline "=== ambient span (Lwt) ===";
+  Trace_core.set_ambient_context_provider Trace_lwt.ambient_span_provider;
+  let coll = make_recorder () in
+  let@ () = Trace_core.with_setup_collector coll in
+
+  (* sync with_span works with the Lwt provider *)
+  Printf.printf "before any span: %s\n" (current_name ());
+
+  (let@ _outer = Trace_core.with_span ~__FILE__ ~__LINE__ "sync-outer" in
+   Printf.printf "sync outer: %s\n" (current_name ());
+   let@ _inner = Trace_core.with_span ~__FILE__ ~__LINE__ "sync-inner" in
+   Printf.printf "sync inner: %s\n" (current_name ()));
+
+  Printf.printf "after sync: %s\n" (current_name ());
+
+  (* Lwt-specific tests *)
+  Lwt_main.run
+    (let open Lwt.Syntax in
+     (* nested Trace_lwt.with_span *)
+     let* () =
+       Trace_lwt.with_span ~__FILE__ ~__LINE__ "lwt-outer" (fun _outer ->
+           Printf.printf "lwt outer: %s\n" (current_name ());
+           let* () =
+             Trace_lwt.with_span ~__FILE__ ~__LINE__ "lwt-inner" (fun _inner ->
+                 Printf.printf "lwt inner: %s\n" (current_name ());
+                 Lwt.return_unit)
+           in
+           Printf.printf "after lwt inner: %s\n" (current_name ());
+           Lwt.return_unit)
+     in
+     Printf.printf "after lwt outer: %s\n" (current_name ());
+
+     (* context survives Lwt.bind chain *)
+     let* () =
+       Trace_lwt.with_span ~__FILE__ ~__LINE__ "bind-test" (fun _sp ->
+           let* () = Lwt.return_unit in
+           let* () = Lwt.return_unit in
+           Printf.printf "after binds: %s\n" (current_name ());
+           Lwt.return_unit)
+     in
+
+     Lwt.return_unit)