lib: Provide new with_backtraces to avoid printing invalid backtraces

Instead it prints a message stating there is no backtrace. The new
function uses the standard stdlib

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>

Author: psafont

lib/backtrace.ml

@@ -155,7 +155,7 @@ let ( let@ ) f x = f x
 
 let try_result f = try Ok (f ()) with exn -> Error exn
 
-let with_backtraces f =
+let with_backtraces_common f with_table =
   let id = Thread.(id (self ())) in
   let tbl =
     let@ () =  with_lock in
@@ -172,10 +172,28 @@ let with_backtraces f =
   let finally () =
     with_lock (fun () -> Hashtbl.remove per_thread_backtraces id)
   in
-  let@ () = Fun.protect ~finally in
-  match try_result f with
-  | Ok ok -> `Ok ok
-  | Error e -> `Error (e, get tbl e)
+  Fun.protect ~finally (fun () -> with_table tbl (try_result f))
+
+module V1 = struct
+  let with_backtraces f = 
+    let with_table tbl = function
+      | Ok ok -> `Ok ok 
+      | Error e -> `Error (e, get tbl e)
+    in
+    with_backtraces_common f with_table
+end
+
+module V2 = struct
+  let with_backtraces ~finally f =
+    let with_table tbl result =
+      result
+      |> Result.map_error (function e -> (e, get tbl e))
+      |> finally
+    in
+    with_backtraces_common f with_table
+end
+
+let with_backtraces = V1.with_backtraces
 
 let with_table f default =
   let id = Thread.(id (self ())) in

lib/backtrace.mli

@@ -28,11 +28,24 @@ val to_string_hum: t -> string
     stash away a copy of the backtrace buffer if there is any risk
     of us raising another (or even the same) exception) *)
 
+module V1 : sig
+  val with_backtraces : (unit -> 'a) -> [ `Ok of 'a | `Error of (exn * t) ]
+  [@@deprecated "V2.with_backtraces"]
+end
+
+module V2 : sig
+  val with_backtraces : finally:(('a, exn * t) result -> 'a) -> (unit -> 'a) ->  'a
+  (** [with_backtraces thread finally] Allows backtraces to be recorded within
+      [thread]. [finally] is executed whenever [thread] finishes, this allows
+      users to use the stacktrace before it's dropped from the cache, for
+      example, to log it. *)
+end
+
 val with_backtraces: (unit -> 'a) -> [ `Ok of 'a | `Error of (exn * t) ]
 (** Allow backtraces to be recorded for this thread. All new threads
     must be wrapped in this for the backtrace tracking to work.
     It is acceptable to nest these wrappers; it will not affect the
-    backtrace recording behaviour. *)
+    backtrace recording behaviour. Please change to [V2.with_backtraces] *)
 
 val is_important: exn -> unit
 (** Declare that the backtrace is important for debugging and should be

test/log.ml

@@ -23,9 +23,9 @@ let log_backtrace_exn exn bt =
   output_log (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ;
   List.iter output_log all
 
-let with_thread_associated desc f x =
+let with_thread_associated_old desc f x =
   let result = 
-    let@ () = Backtrace.with_backtraces in
+    let@ () = begin [@alert "-deprecated"] Backtrace.V1.with_backtraces end in
     try f x with e -> Backtrace.is_important e ; raise e
   in
   match result with
@@ -38,3 +38,18 @@ let with_thread_associated desc f x =
         ) ;
       log_backtrace_exn exn bt ;
       raise exn
+
+let with_thread_associated desc f x =
+  let print_backtrace = function 
+    | Ok result ->
+        result
+    | Error (exn, bt) ->
+        output_log
+          (Printf.sprintf "%s failed with exception %s" desc
+             (Printexc.to_string exn)
+          ) ;
+        log_backtrace_exn exn bt ;
+        raise exn
+  in
+  let@ () = Backtrace.V2.with_backtraces ~finally:print_backtrace in
+  try f x with e -> Backtrace.is_important e ; raise e

test/log.mli

@@ -1,2 +1,5 @@
 val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b
 
+val with_thread_associated_old : string -> ('a -> 'b) -> 'a -> 'b
+(** Uses V1.with_backtrace *)
+

test/raiser.ml

@@ -16,13 +16,21 @@ let test_reraise () =
   Printexc.record_backtrace true ;
   try Test_lib.Log.with_thread_associated "Backtrace lab" bar () with _ -> ()
 
+let v1_with_backtrace = ref false
+
+let test_v1_with_backtrace () =
+  Printexc.record_backtrace false ;
+  try Test_lib.Log.with_thread_associated_old "Backtrace lab" foo () with _ -> ()
+
 let usage = Printf.sprintf "%s" Sys.argv.(0)
 let speclist = [
   ("-no-backtraces", Arg.Set no_backtraces, "Test no-backtraces")
 ; ("-reraise", Arg.Set reraise, "Test reraise")
+; ("-v1-with-backtrace", Arg.Set v1_with_backtrace, "Test v1-with-backtrace")
 ] 
 
 let () =
   Arg.parse speclist (Fun.const ()) usage ;
   if !no_backtraces then test_no_backtraces () ;
-  if !reraise then test_reraise ()
+  if !reraise then test_reraise () ;
+  if !v1_with_backtrace then test_v1_with_backtrace ()

test/reraise.t

@@ -1,12 +1,17 @@
   $ ./raiser.exe -no-backtraces
   Backtrace lab failed with exception Failure("foo")
   Raised Failure("foo")
-  1/1 raiser.exe Raised at file (Thread 0 has no backtrace table. Was with_backtraces called?, line 0
-  
+  raiser.exe: Thread 0 has no backtrace table
 
   $ ./raiser.exe -reraise
   Backtrace lab failed with exception Failure("bar")
   Raised Failure("bar")
-  1/2 raiser.exe Raised at file lib/backtrace.ml, line 201
-  2/2 raiser.exe Called from file test/log.ml, line 29
+  1/2 raiser.exe Raised at file lib/backtrace.ml, line 219
+  2/2 raiser.exe Called from file test/log.ml, line 55
+  
+
+  $ ./raiser.exe -v1-with-backtrace
+  Backtrace lab failed with exception Failure("foo")
+  Raised Failure("foo")
+  1/1 raiser.exe Raised at file (Thread 0 has no backtrace table. Was with_backtraces called?, line 0