OUnit and QCheck helpers

src/test-lib/dune

@@ -3,4 +3,12 @@
  (public_name less-power.test-lib)
  (libraries
   common
-  xmlm str))
+
+  str
+
+  ounit2
+  ounit2.advanced
+  qcheck-core
+  mtime
+  mtime.clock.os
+  xmlm))

src/test-lib/oUnit_util.ml

@@ -0,0 +1,108 @@
+(** Utilities for converting from QCheck to OUnit,
+    and other OUnit-related functionality. *)
+
+open OUnit2
+open OUnitTest
+open Common
+
+let default_qcheck_timeout = Mtime.Span.(5 * s)
+
+let default_rand =
+  (* random seed, for repeatability of tests *)
+  Random.State.make [| 89809344; 994326685; 290180182 |]
+(* TODO: maybe a better mechanism can be used here *)
+
+(** Convert a QCheck test to OUnit, overwriting the timeout.
+    Automatically prevents excessive shrinking from timing out tests,
+    by interrupting shrinking and showing the smallest value found so far
+    once the timeout expires. *)
+let of_qcheck ?(timeout = default_qcheck_timeout) (QCheck2.Test.Test cell) =
+  Printexc.record_backtrace true;
+  let module T = QCheck2.Test in
+  let name = T.get_name cell in
+  let count = T.get_count cell in
+  let test_fun _ =
+    let start = Mtime_clock.counter () in
+    let passed = ref 0 in
+    let last_shrunk = ref None in
+    let rand = Random.State.copy default_rand in
+    let step _ _ _ = function[@warning "-4"]
+      | T.Success -> incr passed
+      | _ -> ()
+    in
+    let cancel_test time = function
+      | Some v ->
+          T.make_cell ~count:1 ?print:(T.get_print_opt cell)
+            (QCheck2.Gen.pure v) (T.get_law cell)
+          |> T.check_cell_exn
+      | None ->
+          Format.asprintf "test `%s` passed %d of %d required checks in %a"
+            name !passed count Mtime.Span.pp time
+          |> assert_failure
+    in
+    let handler _ _ event =
+      (match[@warning "-4"] event with
+      | T.Shrunk (_, v) -> last_shrunk := Some v
+      | _ -> ());
+      let time = Mtime_clock.count start in
+      if Mtime.Span.compare time timeout > 0 then cancel_test time !last_shrunk
+    in
+    T.check_result cell @@ T.check_cell cell ~rand ~step ~handler
+  in
+  (* timeout * 1.25: arithmetic not built-in to mtime *)
+  let test_length =
+    let open Mtime.Span in
+    let timeout_ns = to_uint64_ns timeout in
+    let extra = Int64.(div timeout_ns (of_int 4)) |> of_uint64_ns in
+    Custom_length (add timeout extra |> Util.span_to_float_s)
+  in
+  name >: TestCase (test_length, test_fun)
+
+
+(** Visibility of tests after hiding. *)
+type visibility =
+  | PassFail
+      (** Test is always run, but the detailed result is not shown. Instead, a
+          failure is indicated with a generic message. Also known as "secret"
+          tests. *)
+  | None
+      (** Test is not run. Instead, the test fails and a generic message
+          indicates that the test was not run. Also known as "hidden" tests. *)
+
+let message_of_visibility = function
+  | PassFail -> "This secret test has failed."
+  | None -> "This hidden test was not executed."
+
+(** Hide a test according to the [visibility] argument. *)
+let hide_test ?(visibility = PassFail) =
+  let fail_test () =
+    raise_notrace (OUnit_failure (message_of_visibility visibility))
+  in
+  let hide_func func ctx =
+    match visibility with
+    | PassFail -> (try func ctx with _ -> fail_test ())
+    | None -> fail_test ()
+  in
+  let rec hide = function
+    | TestCase (dur, func) -> TestCase (dur, hide_func func)
+    | TestList tests -> TestList (List.map hide tests)
+    | TestLabel (name, inner) -> TestLabel (name, hide inner)
+  in
+  hide
+
+
+(** Join a test tree into a single test which only passes if all individual
+    tests in the tree pass. Students will only be able to see the result of
+    the first test that failed. Timeouts of individual tests are summed to
+    produce a single timeout, which is applied to the combined test. This
+    changes the timeout behavior of the tests. Intended for grouping tests,
+    when grading is performed solely by assigning points to passed tests.
+
+    For more complex grouping, use the {!module-Grading} module. *)
+let join_tests test =
+  let rec collect (timeout, tests) = function
+    | TestList list -> List.fold_left collect (timeout, tests) list
+    | TestLabel (_, inner) -> collect (timeout, tests) inner
+    | TestCase (t, f) -> (timeout +. delay_of_length t, f :: tests)
+  in let (t, f) = collect (0.0, []) test in
+  TestCase (Custom_length t, fun ctx -> List.iter (( |> ) ctx) f)

src/test-lib/qCheck_util.ml

@@ -0,0 +1,84 @@
+(** Helpers for QCheck-based tests. *)
+
+open Common
+
+let default_computation_timeout = Mtime.Span.(100 * ms)
+
+(** Workaround to check if an exception is [QCheck2.Test.User_fail],
+    since that exception is not exposed. *)
+let is_user_fail exn =
+  Scanf.ksscanf
+    (Printexc.to_string_default exn)
+    (fun _ _ -> None)
+    "QCheck2.Test.User_fail(%S)" Option.some
+
+(** Check if values are equal. Report a failure message as [Error] if not.
+    This monadic form is useful for properties that check nested functions,
+    i.e. calling submission code contains functions that should once again
+    be called.
+
+    Note: with [timeout], uses {!Common.Util.timeout_unix}, and thus nesting
+    (within [expected_f] or [actual_f]) will not work as expected.
+
+    @param context Add this string as context before failure message
+    @param eq Check for equality, return [Some x] if equal or [None] if not
+    @return The result of [eq], if not [None], as [Ok]. *)
+let assert_equal ?context ?timeout ~eq ~printers expected_f actual_f =
+  let open Result in
+  let open Ctx_util in
+
+  let report msg =
+    match context with None -> msg | Some c -> c ^ "\n" ^ msg
+  in
+
+  let wrap f =
+    let< () = capture_exceptions () in
+    let< () = optional_timeout_unix ?timeout in
+    f ()
+  in
+
+  let expected =
+    let error_msg =
+      "The solution raised an error, please report this to an instructor"
+    in
+    match wrap expected_f with
+    | Ok (Some x) -> Ok x
+    | Ok None | Error _ -> Error (report error_msg)
+  in
+
+  let actual =
+    let error_msg d = report ("Your submission raised an error: " ^ d) in
+    (* Ok Some: all good; Ok None: timeout; Error e: exception raised *)
+    match wrap actual_f with
+    | Ok (Some x) -> Ok x
+    | Ok None -> Error (report @@ "Your submission timed out")
+    | Error e ->
+        match is_user_fail e with
+        | Some s -> Error (report s)
+        | None -> Error (error_msg @@ Printexc.to_string e)
+  in
+
+  let ( let* ) = bind in
+  let* e = expected in
+  let* a = actual in
+  match eq e a with
+  | Some ea -> Ok ea
+  | None ->
+      String.concat "\n"
+        [ "Expected:"; fst printers e; "But got:"; snd printers a ]
+      |> report |> Result.error
+
+(** Turn an equality function into the form required for {!assert_equal}. *)
+let lift_eq eq x y = if eq x y then Some () else None
+
+(** Like {!assert_equal}, but when the types to compare are the same. *)
+let assert_equal' ?(eq = lift_eq (=)) ~printer =
+  assert_equal ~eq ~printers:(printer, printer)
+
+(** After performing one or more comparisons with {!assert_equal},
+    report a failure as a QCheck failure, or just return [true] otherwise. *)
+let report_result = function
+  | Ok _ -> true
+  | Error e ->
+      Printexc.record_backtrace false;
+      QCheck.Test.fail_report e

src/test-lib/test_lib.ml

@@ -1,3 +1,5 @@
 (** Library of common functionality for writing tests. *)
 
 module Grading = Grading
+module OUnit_util = OUnit_util
+module QCheck_util = QCheck_util