From 5d0f9be05db03e93aa78c802782301d8627f1b4f Mon Sep 17 00:00:00 2001
From: Max Lang <17551908+just-max@users.noreply.github.com>
Date: Mon, 15 Jul 2024 04:39:43 +0200
Subject: [PATCH] Ctxlib: Move exn_info into Common, move syntax into submodule
 (#20)

---
 src/ast-check/ast_check.ml                    |  2 +-
 src/common/common.ml                          |  4 ---
 src/common/ctx_util.ml                        | 27 +++++--------------
 src/common/p_run.ml                           |  2 ++
 src/common/util.ml                            | 17 +++++++++---
 .../signature-builder/support/mk_intf_desc.ml |  2 +-
 src/test-lib/grading.ml                       |  4 +--
 src/test-lib/qCheck_util.ml                   |  3 ++-
 src/test-runner/std_task.ml                   |  2 +-
 src/test-runner/task.ml                       |  1 +
 10 files changed, 31 insertions(+), 33 deletions(-)

diff --git a/src/ast-check/ast_check.ml b/src/ast-check/ast_check.ml
index 2de581f..ce03aa4 100644
--- a/src/ast-check/ast_check.ml
+++ b/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
diff --git a/src/common/common.ml b/src/common/common.ml
index 97e0a8f..1028123 100644
--- a/src/common/common.ml
+++ b/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} *)
diff --git a/src/common/ctx_util.ml b/src/common/ctx_util.ml
index fce67e5..f2c6153 100644
--- a/src/common/ctx_util.ml
+++ b/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)
diff --git a/src/common/p_run.ml b/src/common/p_run.ml
index 0309ed6..7a48907 100644
--- a/src/common/p_run.ml
+++ b/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
diff --git a/src/common/util.ml b/src/common/util.ml
index 2d3382d..8cabc98 100644
--- a/src/common/util.ml
+++ b/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
diff --git a/src/stdlib-variants/signature-builder/support/mk_intf_desc.ml b/src/stdlib-variants/signature-builder/support/mk_intf_desc.ml
index f59bbfc..b678b4c 100644
--- a/src/stdlib-variants/signature-builder/support/mk_intf_desc.ml
+++ b/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;
diff --git a/src/test-lib/grading.ml b/src/test-lib/grading.ml
index d1ad685..c2b64f7 100644
--- a/src/test-lib/grading.ml
+++ b/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)
diff --git a/src/test-lib/qCheck_util.ml b/src/test-lib/qCheck_util.ml
index 9129679..3133861 100644
--- a/src/test-lib/qCheck_util.ml
+++ b/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)
diff --git a/src/test-runner/std_task.ml b/src/test-runner/std_task.ml
index e591c92..f71897c 100644
--- a/src/test-runner/std_task.ml
+++ b/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
diff --git a/src/test-runner/task.ml b/src/test-runner/task.ml
index 25f3859..c81808d 100644
--- a/src/test-runner/task.ml
+++ b/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