Ctxlib: Move exn_info into Common, move syntax into submodule (#20)

src/ast-check/ast_check.ml

@@ -255,7 +255,7 @@ let file_violations ?prohibited ?limit path =
      expose the functionality we need to do this ourselves) *)
   Ocaml_common.Pparse.parse_implementation ~tool_name:"lp-ast-check" path |> ignore;
 
-  let open Common.Ctx_util in
+  let open Common.Ctx_util.Syntax in
   let structure =
     let< ch = In_channel.with_open_text path in
     let lexbuf = Lexing.from_channel ch in

src/common/common.ml

@@ -7,7 +7,3 @@ module Pp_util = Pp_util
 module Path_util = Path_util
 module Ctx_util = Ctx_util
 module P_run = P_run
-
-(* module Syntax = Syntax *)
-
-(* {!modules: Util Pp_util Path_util Ctx_util P_run} *)

src/common/ctx_util.ml

@@ -1,11 +1,5 @@
 (** Context managers, loosely inspired by Python *)
 
-(** Exception and its associated (raw) backtrace. *)
-type exn_info = {
-  exn : exn ;
-  backtrace : Printexc.raw_backtrace ;
-}
-
 (** A context manager of type [('a, 'b, 'c) t] takes a continuation, and
     should feed the continuation a value of type ['a]. Once the continuation
     returns with either a [Ok of 'b] or an {!exn_info}, the continuation should
@@ -14,23 +8,16 @@ type exn_info = {
 
     This representation has the advantage that some existing functions library
     already implement this type (e.g. {!In_channel.with_open_text}). *)
-type ('a, 'b, 'c) t = ('a -> ('b, exn_info) result) -> ('c, exn_info) result
+type ('a, 'b, 'c) t = ('a -> ('b, Util.exn_info) result) -> ('c, Util.exn_info) result
 
 (** [with_context cm f] runs [f] in the context manager [cm] *)
 let with_context (cm : _ t) f =
-  let k x =
-    try Ok (f x)
-    with exn ->
-      let backtrace = Printexc.get_raw_backtrace () in
-      Error { exn; backtrace }
-  in
-  match cm k with
-  | Ok x -> x
-  | Error { exn ; backtrace } ->
-      Printexc.raise_with_backtrace exn backtrace
+  cm (Util.try_to_result f) |> Util.unresult_exn
 
-(** Let-syntax for {!with_context} *)
-let ( let< ) = with_context
+module Syntax = struct
+  (** Let-syntax for {!with_context} *)
+  let ( let< ) = with_context
+end
 
 (* {1 Context managers} *)
 
@@ -75,7 +62,7 @@ let timed : _ t = fun k ->
 let capture_exceptions ?(filter = Fun.const true) () : _ t = fun k ->
   match k () with
   | Ok x -> Ok (Ok x)
-  | Error exn_info when filter exn_info.exn -> Ok (Error exn_info)
+  | Error exn_info when filter exn_info.Util.exn -> Ok (Error exn_info)
   | Error exn_info -> Error exn_info
 
 let empty_context x f : _ t = fun k -> Result.map f (k x)

src/common/p_run.ml

@@ -3,6 +3,7 @@
 (** Waits for the given process or times out. *)
 let wait_pid_timeout t pid =
   let open Ctx_util in
+  let open Ctx_util.Syntax in
   let< () = sigprocmask Unix.SIG_BLOCK [Sys.sigchld] in
 
   let exception Sigchld in
@@ -98,6 +99,7 @@ let build_env =
     Note: uses temporary files provided by {!Filename}. *)
 let p_run ?timeout:timeout_desc ?input ?(args = []) ?(env = []) command =
   let open Ctx_util in
+  let open Ctx_util.Syntax in
 
   let env =
     Array.append

src/common/util.ml

@@ -50,8 +50,19 @@ let string_contains ~needle haystack =
     returns [["c"; "ef"]] *)
 let ( ~$ ) = ( |> )
 
-let try_to_result f x = try Ok (f x) with e -> Error e
-let unresult_exn = function Ok x -> x | Error e -> raise e
+(** Exception and its associated (raw) backtrace. *)
+type exn_info = {
+  exn : exn ;
+  backtrace : Printexc.raw_backtrace ;
+}
+
+let raise_exn_info info = Printexc.raise_with_backtrace info.exn info.backtrace
+
+let try_to_result f x =
+  try Ok (f x)
+  with exn -> Error { exn; backtrace = Printexc.get_raw_backtrace () }
+
+let unresult_exn = function Ok x -> x | Error e -> raise_exn_info e
 
 let run_main main =
   Sys.argv
@@ -94,7 +105,7 @@ let timeout_unix ?(timer = Unix.ITIMER_REAL) t f x =
   let r =
     try
       Unix.setitimer timer { it_value = t_float; it_interval = 0. } |> ignore ;
-      let r0 = try Ok (Some (f x)) with e when e <> Timeout -> Error e in
+      let r0 = try Ok (Some (f x)) with e when e <> Timeout -> Error { exn = e; backtrace = Printexc.get_raw_backtrace () } in
       stop_timer () |> ignore;
       r0
     with Timeout -> Ok None

src/stdlib-variants/signature-builder/support/mk_intf_desc.ml

@@ -15,7 +15,7 @@ let loc = Location.none (* default location for metaquot *)
 module B = Ast_builder_Make (struct let loc = Location.none end)
 
 let parse_interface path =
-  let open Common.Ctx_util in
+  let open Common.Ctx_util.Syntax in
   let< ch = In_channel.with_open_text path in
   let lexbuf = Lexing.from_channel ch in
   Lexing.set_filename lexbuf path;

src/test-lib/grading.ml

@@ -191,13 +191,13 @@ let fold_tree_down f = fst (fold_down f)
 let fold_forest_down f = snd (fold_down f)
 
 let read_tree path =
-  let open Common.Ctx_util in
+  let open Common.Ctx_util.Syntax in
   let< ch = In_channel.with_open_bin path in
   let xml_in = Xmlm.make_input (`Channel ch) in
   in_tree xml_in
 
 let write_tree dtd tree path =
-  let open Common.Ctx_util in
+  let open Common.Ctx_util.Syntax in
   let< ch = Out_channel.with_open_bin path in
   let xml_out = Xmlm.make_output (`Channel ch) in
   out_tree xml_out (dtd, tree)

src/test-lib/qCheck_util.ml

@@ -28,6 +28,7 @@ let assert_equal
     expected_f actual_f =
   let open Result in
   let open Ctx_util in
+  let open Ctx_util.Syntax in
 
   let report msg =
     match context with None -> msg | Some c -> c ^ "\n" ^ msg
@@ -54,7 +55,7 @@ let assert_equal
     match wrap actual_f with
     | Ok (Some x) -> Ok x
     | Ok None -> Error (report @@ "Your submission timed out")
-    | Error { exn = e; _ } ->
+    | Error Util.{ exn = e; _ } ->
         match is_user_fail e with
         | Some s -> Error (report s)
         | None -> Error (error_msg @@ Printexc.to_string e)

src/test-runner/std_task.ml

@@ -2,7 +2,7 @@
 
 open Task
 open Common
-open Ctx_util
+open Ctx_util.Syntax
 open Util
 
 let f = Printf.sprintf

src/test-runner/task.ml

@@ -148,6 +148,7 @@ and run_tree : type a b. a st_in -> (a, b) tree -> b st_out * summary =
   in
 
   let open Ctx_util in
+  let open Ctx_util.Syntax in
 
   let result, t_elapsed =
     let< () = timed in