Merge PR #6808: Add unit tests to test-suite

2 files changed, 86 insertions, 0 deletions

diff --git a/test-suite/unit-tests/src/utest.ml b/test-suite/unit-tests/src/utest.ml
new file mode 100644
index 0000000000..069e6a4bf3
--- /dev/null
+++ b/test-suite/unit-tests/src/utest.ml
@@ -0,0 +1,74 @@
+open OUnit
+
+(* general case to build a test *)
+let mk_test nm test = nm >: test
+
+(* common cases for building tests *)
+let mk_eq_test nm descr expected actual =
+  mk_test nm (TestCase (fun _ -> assert_equal ~msg:descr expected actual))
+
+let mk_bool_test nm descr actual =
+  mk_test nm (TestCase (fun _ -> assert_bool descr actual))
+
+let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "\n%!") oc)
+
+(* given test result, print message, return success boolean *)
+let logger out_ch result =
+  let cprintf s = cfprintf out_ch s in
+  match result with
+  | RSuccess path ->
+     cprintf "TEST SUCCEEDED: %s" (string_of_path path);
+     true
+  | RError (path,msg)
+  | RFailure (path,msg) ->
+     cprintf "TEST FAILED: %s (%s)" (string_of_path path) msg;
+     false
+  | RSkip (path,msg)
+  | RTodo (path,msg) ->
+     cprintf "TEST DID NOT SUCCEED: %s (%s)" (string_of_path path) msg;
+     false
+
+(* run one OUnit test case, return successes, no. of tests *)
+(* notionally one test, which might be a TestList *)
+let run_one logit test =
+  let rec process_results rs =
+    match rs with
+      [] -> (0,0)
+    | (r::rest) ->
+       let succ = if logit r then 1 else 0 in
+       let succ_results,tot_results = process_results rest in
+       (succ + succ_results,tot_results + 1)
+  in
+  let results = perform_test (fun _ -> ()) test in
+  process_results results
+
+(* run list of OUnit test cases, log results *)
+let run_tests ml_fn tests =
+  let log_fn = ml_fn ^ ".log" in
+  let out_ch = open_out log_fn in
+  let cprintf s = cfprintf out_ch s in
+  let ceprintf s = cfprintf stderr s in
+  let logit = logger out_ch in
+  let rec run_some tests succ tot =
+    match tests with
+      [] -> (succ,tot)
+    | (t::ts) ->
+       let succ_one,tot_one = run_one logit t in
+       run_some ts (succ + succ_one) (tot + tot_one)
+  in
+  (* format for test-suite summary to find status
+     success if all tests succeeded, else failure
+   *)
+  let succ,tot = run_some tests 0 0 in
+  cprintf
+      "*** Ran %d tests, with %d successes and %d failures ***"
+      tot succ (tot - succ);
+  if succ = tot then
+    cprintf
+      "==========> SUCCESS <==========\n    %s...Ok" ml_fn
+  else begin
+    cprintf
+      "==========> FAILURE <==========\n    %s...Error!" ml_fn;
+    ceprintf "FAILED    %s.log" ml_fn
+  end;
+  close_out out_ch
diff --git a/test-suite/unit-tests/src/utest.mli b/test-suite/unit-tests/src/utest.mli
new file mode 100644
index 0000000000..70928228bf
--- /dev/null
+++ b/test-suite/unit-tests/src/utest.mli
@@ -0,0 +1,12 @@
+(** give a name to a unit test *)
+val mk_test : string -> OUnit.test -> OUnit.test
+
+(** simple ways to build a test *)
+val mk_eq_test : string -> string -> 'a -> 'a -> OUnit.test
+val mk_bool_test : string -> string -> bool -> OUnit.test
+
+(** run unit tests *)
+(* the string argument should be the name of the .ml file
+   containing the tests; use __FILE__ for that purpose.
+ *)
+val run_tests : string -> OUnit.test list -> unit