diff --git a/src/test-lib/dune b/src/test-lib/dune index 7f07168..e7e82e9 100644 --- a/src/test-lib/dune +++ b/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)) diff --git a/src/test-lib/oUnit_util.ml b/src/test-lib/oUnit_util.ml new file mode 100644 index 0000000..c427ebf --- /dev/null +++ b/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) diff --git a/src/test-lib/qCheck_util.ml b/src/test-lib/qCheck_util.ml new file mode 100644 index 0000000..c2c7a40 --- /dev/null +++ b/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 diff --git a/src/test-lib/test_lib.ml b/src/test-lib/test_lib.ml index c1852a3..9db5668 100644 --- a/src/test-lib/test_lib.ml +++ b/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