Add an internal test for STM on uncaught exceptions

test/dune

@@ -68,3 +68,16 @@
    ; filter out output that is not deterministic enough across
    ; versions and platforms
    (run sed -e "/^[[]/d" -e "s/ ([0-9]* shrink steps)//"))))
+
+(test
+ (name uncaught_stm)
+ (package qcheck-stm)
+ (modules uncaught_stm)
+ (libraries qcheck-stm.sequential)
+ (action
+  (pipe-outputs
+   (with-accepted-exit-codes 1
+    (run %{test} --no-colors --verbose --seed 260395858))
+   ; filter out output that is not deterministic enough across
+   ; versions and platforms
+   (run sed -e "/^[[]/d" -e "s/ ([0-9]* shrink steps)//"))))

test/uncaught_stm.expected

@@ -0,0 +1,24 @@
+random seed: 260395858
+generated error fail pass / total     time test name
+
+=== Error ======================================================================
+
+Test STM test of uncaught exceptions errored on:
+
+   AlwaysFail ()
+
+
+exception Failure("unexpected") raised but not caught while running AlwaysFail ()
+
+
+=== Error ======================================================================
+
+Test neg STM test of uncaught exceptions errored on:
+
+   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";
+    ]