From 16013b0b275c93256d0c63109bc35ff8683144b6 Mon Sep 17 00:00:00 2001
From: Samuel Hym <samuel.hym@rustyne.lautre.net>
Date: Mon, 5 Jun 2023 17:03:29 +0200
Subject: [PATCH] Add an internal test for STM on uncaught exceptions

---
 test/dune                  |  9 +++++++++
 test/uncaught_stm.expected | 26 ++++++++++++++++++++++++++
 test/uncaught_stm.ml       | 32 ++++++++++++++++++++++++++++++++
 3 files changed, 67 insertions(+)
 create mode 100644 test/uncaught_stm.expected
 create mode 100644 test/uncaught_stm.ml

diff --git a/test/dune b/test/dune
index 94b756c9..2a96726b 100644
--- a/test/dune
+++ b/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))))
diff --git a/test/uncaught_stm.expected b/test/uncaught_stm.expected
new file mode 100644
index 00000000..3120436d
--- /dev/null
+++ b/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)
diff --git a/test/uncaught_stm.ml b/test/uncaught_stm.ml
new file mode 100644
index 00000000..5402094d
--- /dev/null
+++ b/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";
+    ]