Add Util.tag_exn_with

Add the utilitary function tag_exn_with to run a function while wrapping
all uncaught exceptions into an internal exception that will track what
was run and not only the uncaught exception
This will allow STM and Lin to run commands that should not raise
exceptions and, in case they do raise an exception, display the faulty
command along with the exception

Author: shym

lib/util.ml

@@ -75,6 +75,25 @@ let protect (f : 'a -> 'b) (a : 'a) : ('b, exn) result =
   try Result.Ok (f a)
   with e -> Result.Error e
 
+exception Uncaught_exception of string * exn
+
+let print_uncaught_exception e =
+  match e with
+  | Uncaught_exception (cmd, exc) ->
+      Some
+        (Format.sprintf "%s raised but not caught while running %s"
+           (Printexc.to_string exc) cmd)
+  | _ -> None
+
+let _ =
+  Printexc.register_printer print_uncaught_exception
+
+let tag_exn_with show run x =
+  try run x
+  with e ->
+    let bt = Printexc.get_raw_backtrace () in
+    Printexc.raise_with_backtrace (Uncaught_exception (show x, e)) bt
+
 module Pp = struct
   open Format
 

lib/util.mli

@@ -41,6 +41,12 @@ val print_triple_vertical :
 val protect : ('a -> 'b) -> 'a -> ('b, exn) result
 (** [protect f] turns an [exception] throwing function into a [result] returning function. *)
 
+val tag_exn_with : ('a -> string) -> ('a -> 'b) -> 'a -> 'b
+(** [tag_exn_with show run x] behaves as [run x] unless raises an
+    uncaught exception in which case it will wrap that exception along
+    with [show x] into an internal exception. That exception will be
+    printed as: ["... raised but not caught while running " ^ show x]. *)
+
 module Pp : sig
   (** Pretty-printing combinators that generate valid OCaml syntax for common
       types along with combinators for user-defined types *)