Add an internal test for STM on uncaught exceptions

Author: shym

test/dune

@@ -63,3 +63,12 @@
  (action
   (with-accepted-exit-codes 1
    (run %{test} --verbose --seed 260395858))))
+
+(test
+ (name uncaught_stm)
+ (package qcheck-stm)
+ (modules uncaught_stm)
+ (libraries qcheck-stm.sequential)
+ (action
+  (with-accepted-exit-codes 1
+   (run %{test} --verbose --seed 260395858))))

test/uncaught_stm.expected

@@ -0,0 +1,26 @@
+random seed: 260395858
+generated error fail pass / total     time test name
+[ ]    0    0    0    0 /   10     0.0s STM test of uncaught exceptions[ ]    0    0    0    0 /   10     0.0s STM test of uncaught exceptions (generating)[✗]    1    1    0    0 /   10     0.0s STM test of uncaught exceptions
+[ ]    0    0    0    0 /   10     0.0s neg STM test of uncaught exceptions[✗]    1    1    0    0 /   10     0.0s neg STM test of uncaught exceptions
+
+=== Error ======================================================================
+
+Test STM test of uncaught exceptions errored on (5 shrink steps):
+
+   AlwaysFail ()
+
+
+exception Failure("unexpected") raised but not caught while running AlwaysFail ()
+
+
+=== Error ======================================================================
+
+Test neg STM test of uncaught exceptions errored on (5 shrink steps):
+
+   AlwaysFail ()
+
+
+exception Failure("unexpected") raised but not caught while running AlwaysFail ()
+
+================================================================================
+failure (0 tests failed, 2 tests errored, ran 2 tests)

test/uncaught_stm.ml

@@ -0,0 +1,32 @@
+(* Test of the behaviour of STM tests with uncaught exceptions *)
+
+let always_fail () = failwith "unexpected"
+
+module UncaughtExcConf : STM.Spec = struct
+  open STM
+
+  type sut = unit
+  type state = unit
+  type cmd = AlwaysFail of sut
+
+  let show_cmd = function AlwaysFail () -> "AlwaysFail ()"
+  let arb_cmd _ = QCheck.(make ~print:show_cmd (Gen.pure (AlwaysFail ())))
+  let init_state = ()
+  let next_state _ _ = ()
+  let init_sut _ = ()
+  let cleanup _ = ()
+  let precond _ _ = true
+  let run c s = match c with AlwaysFail () -> Res (unit, always_fail s)
+
+  let postcond c _ r =
+    match (c, r) with AlwaysFail (), Res ((Unit, _), _) -> true | _ -> false
+end
+
+module UE = STM_sequential.Make (UncaughtExcConf)
+
+let _ =
+  QCheck_base_runner.run_tests_main
+    [
+      UE.agree_test ~count:10 ~name:"STM test of uncaught exceptions";
+      UE.neg_agree_test ~count:10 ~name:"neg STM test of uncaught exceptions";
+    ]