exn: preserve backtraces

ahrefs · Aug 13, 2024 · 38c565f · 38c565f
1 parent 8451877
commit 38c565f
Show file tree

Hide file tree

Showing 2 changed files with 9 additions and 4 deletions.
diff --git a/exn.ml b/exn.ml
@@ -33,7 +33,14 @@ let to_string exn =
 let str = to_string
 
 let fail ?exn fmt =
-  let fails s = match exn with None -> failwith s | Some exn -> failwith (s ^ " : " ^ to_string exn) in
+  let fails s =
+    match exn with
+    | None -> failwith s
+    | Some original_exn ->
+      let orig_bt = Printexc.get_raw_backtrace () in
+      let exn = Failure (s ^ " : " ^ to_string original_exn) in
+      Printexc.raise_with_backtrace exn orig_bt
+  in
   ksprintf fails fmt
 
 let invalid_arg fmt = ksprintf invalid_arg fmt

diff --git a/exn_lwt.ml b/exn_lwt.ml
@@ -7,8 +7,6 @@ open Printf
 let catch f x = Lwt.try_bind (fun () -> f x) Lwt.return_some (fun _exn -> Lwt.return_none)
 let map f x = Lwt.try_bind (fun () -> f x) (fun r -> Lwt.return (`Ok r)) (fun exn -> Lwt.return (`Exn exn))
 
-let fail ?exn fmt =
-  let fails s = Lwt.fail_with @@ match exn with None -> s | Some exn -> s ^ " : " ^ Exn.to_string exn in
-  ksprintf fails fmt
+let fail = Exn.fail
 
 let invalid_arg fmt = ksprintf Lwt.fail_invalid_arg fmt