Add poc files
This commit is contained in:
Joey Yakimowich-Payne
parent
30da2412e3
commit
fa600b98f7
220 changed files with 45679 additions and 0 deletions
462
commons/oUnit.ml
Normal file
462
commons/oUnit.ml
Normal file
|
|
@ -0,0 +1,462 @@
|
|||
(***********************************************************************)
|
||||
(* The OUnit library *)
|
||||
(* *)
|
||||
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *)
|
||||
(* Maas-Maarten Zeeman. *)
|
||||
|
||||
(*
|
||||
The package OUnit is copyright by Maas-Maarten Zeeman.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this document and the OUnit software ("the Software"), to
|
||||
deal in the Software without restriction, including without limitation
|
||||
the rights to use, copy, modify, merge, publish, distribute,
|
||||
sublicense, and/or sell copies of the Software, and to permit persons
|
||||
to whom the Software is furnished to do so, subject to the following
|
||||
conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be
|
||||
included in all copies or substantial portions of the Software.
|
||||
|
||||
The Software is provided ``as is'', without warranty of any kind,
|
||||
express or implied, including but not limited to the warranties of
|
||||
merchantability, fitness for a particular purpose and noninfringement.
|
||||
In no event shall Maas-Maarten Zeeman be liable for any claim, damages
|
||||
or other liability, whether in an action of contract, tort or
|
||||
otherwise, arising from, out of or in connection with the Software or
|
||||
the use or other dealings in the software.
|
||||
*)
|
||||
|
||||
(***********************************************************************)
|
||||
(* pad: just harmonized some APIs regarding the 'msg' label *)
|
||||
|
||||
let bracket set_up f tear_down () =
|
||||
let fixture = set_up () in
|
||||
try
|
||||
f fixture;
|
||||
tear_down fixture
|
||||
with
|
||||
e ->
|
||||
tear_down fixture;
|
||||
raise e
|
||||
|
||||
exception Skip of string
|
||||
let skip_if b msg =
|
||||
if b then
|
||||
raise (Skip msg)
|
||||
|
||||
exception Todo of string
|
||||
let todo msg =
|
||||
raise (Todo msg)
|
||||
|
||||
let assert_failure msg =
|
||||
failwith ("OUnit: " ^ msg)
|
||||
|
||||
let assert_bool ~msg b =
|
||||
if not b then assert_failure msg
|
||||
|
||||
let assert_string str =
|
||||
if not (str = "") then assert_failure str
|
||||
|
||||
let assert_equal ?(cmp = ( = )) ?printer ?msg expected actual =
|
||||
(* pad: better to use dump by default *)
|
||||
let p = Dumper.dump in
|
||||
|
||||
let get_error_string _ =
|
||||
match printer, msg with
|
||||
None, None ->
|
||||
(Format.sprintf "expected: %s but got: %s"
|
||||
(p expected) (p actual))
|
||||
| None, Some s ->
|
||||
(Format.sprintf "%s\nnot equal, expected: %s but got: %s" s
|
||||
(p expected) (p actual))
|
||||
| Some p, None -> (Format.sprintf "expected: %s but got: %s"
|
||||
(p expected) (p actual))
|
||||
| Some p, Some s -> (Format.sprintf "%s\nexpected: %s but got: %s"
|
||||
s (p expected) (p actual))
|
||||
in
|
||||
if not (cmp expected actual) then
|
||||
assert_failure (get_error_string ())
|
||||
|
||||
let raises f =
|
||||
try
|
||||
f ();
|
||||
None
|
||||
with
|
||||
e -> Some e
|
||||
|
||||
let assert_raises ?msg exn (f: unit -> 'a) =
|
||||
let pexn = Printexc.to_string in
|
||||
let get_error_string _ =
|
||||
let str = Format.sprintf
|
||||
"expected exception %s, but no exception was raised." (pexn exn)
|
||||
in
|
||||
match msg with
|
||||
None -> assert_failure str
|
||||
| Some s -> assert_failure (Format.sprintf "%s\n%s" s str)
|
||||
in
|
||||
match raises f with
|
||||
None -> assert_failure (get_error_string ())
|
||||
| Some e -> assert_equal ?msg ~printer:pexn exn e
|
||||
|
||||
(* Compare floats up to a given relative error *)
|
||||
let cmp_float ?(epsilon = 0.00001) a b =
|
||||
abs_float (a -. b) <= epsilon *. (abs_float a) ||
|
||||
abs_float (a -. b) <= epsilon *. (abs_float b)
|
||||
|
||||
(* Now some handy shorthands *)
|
||||
let (@?) msg a = assert_bool msg a
|
||||
|
||||
(* The type of test function *)
|
||||
type test_fun = unit -> unit
|
||||
|
||||
(* The type of tests *)
|
||||
type test =
|
||||
TestCase of test_fun
|
||||
| TestList of test list
|
||||
| TestLabel of string * test
|
||||
|
||||
(* Some shorthands which allows easy test construction *)
|
||||
let (>:) s t = TestLabel(s, t) (* infix *)
|
||||
let (>::) s f = TestLabel(s, TestCase(f)) (* infix *)
|
||||
let (>:::) s l = TestLabel(s, TestList(l)) (* infix *)
|
||||
|
||||
(* Utility function to manipulate test *)
|
||||
let rec test_decorate g tst =
|
||||
match tst with
|
||||
| TestCase f ->
|
||||
TestCase (g f)
|
||||
| TestList tst_lst ->
|
||||
TestList (List.map (test_decorate g) tst_lst)
|
||||
| TestLabel (str, tst) ->
|
||||
TestLabel (str, test_decorate g tst)
|
||||
|
||||
(* Return the number of available tests *)
|
||||
let rec test_case_count test =
|
||||
match test with
|
||||
TestCase _ -> 1
|
||||
| TestLabel (_, t) -> test_case_count t
|
||||
| TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l
|
||||
|
||||
type node = ListItem of int | Label of string
|
||||
type path = node list
|
||||
|
||||
let string_of_node node =
|
||||
match node with
|
||||
ListItem n -> (string_of_int n)
|
||||
| Label s -> s
|
||||
|
||||
let string_of_path path =
|
||||
List.fold_left
|
||||
(fun a l ->
|
||||
if a = "" then
|
||||
l
|
||||
else
|
||||
l ^ ":" ^ a) "" (List.map string_of_node path)
|
||||
|
||||
(* Some helper function, they are generally applicable *)
|
||||
(* Applies function f in turn to each element in list. Function f takes
|
||||
one element, and integer indicating its location in the list *)
|
||||
let mapi f l =
|
||||
let rec rmapi cnt l =
|
||||
match l with
|
||||
[] -> []
|
||||
| h::t -> (f h cnt)::(rmapi (cnt + 1) t)
|
||||
in
|
||||
rmapi 0 l
|
||||
|
||||
let fold_lefti f accu l =
|
||||
let rec rfold_lefti cnt accup l =
|
||||
match l with
|
||||
[] -> accup
|
||||
| h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t
|
||||
in
|
||||
rfold_lefti 0 accu l
|
||||
|
||||
(* Returns all possible paths in the test. The order is from test case
|
||||
to root
|
||||
*)
|
||||
let test_case_paths test =
|
||||
let rec tcps path test =
|
||||
match test with
|
||||
TestCase _ -> [path]
|
||||
| TestList tests ->
|
||||
List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests)
|
||||
| TestLabel (l, t) -> tcps ((Label l)::path) t
|
||||
in
|
||||
tcps [] test
|
||||
|
||||
(* Test filtering with their path *)
|
||||
module SetTestPath = Set.Make(String)
|
||||
|
||||
let test_filter only test =
|
||||
let set_test =
|
||||
List.fold_left
|
||||
(fun st str -> SetTestPath.add str st)
|
||||
SetTestPath.empty
|
||||
only
|
||||
in
|
||||
let foldi f acc lst =
|
||||
List.fold_left
|
||||
(fun (i, acc) e ->
|
||||
let nacc =
|
||||
f i acc e
|
||||
in
|
||||
(i + 1), nacc
|
||||
)
|
||||
acc
|
||||
lst
|
||||
in
|
||||
let rec filter_test path tst =
|
||||
if SetTestPath.mem (string_of_path path) set_test then
|
||||
(
|
||||
Some tst
|
||||
)
|
||||
else
|
||||
(
|
||||
match tst with
|
||||
| TestCase _ ->
|
||||
None
|
||||
| TestList tst_lst ->
|
||||
let (_, ntst_lst) =
|
||||
foldi
|
||||
(fun i ntst_lst tst ->
|
||||
let nntst_lst =
|
||||
match filter_test ((ListItem i) :: path) tst with
|
||||
| Some tst ->
|
||||
tst :: ntst_lst
|
||||
| None ->
|
||||
ntst_lst
|
||||
in
|
||||
nntst_lst
|
||||
)
|
||||
(0, [])
|
||||
tst_lst
|
||||
in
|
||||
if ntst_lst = [] then
|
||||
None
|
||||
else
|
||||
Some (TestList ntst_lst)
|
||||
| TestLabel (lbl, tst) ->
|
||||
let ntst =
|
||||
filter_test
|
||||
((Label lbl) :: path)
|
||||
tst
|
||||
in
|
||||
match ntst with
|
||||
| Some tst ->
|
||||
Some (TestLabel (lbl, tst))
|
||||
| None ->
|
||||
None
|
||||
)
|
||||
in
|
||||
filter_test [] test
|
||||
|
||||
|
||||
(* The possible test results *)
|
||||
type test_result =
|
||||
RSuccess of path
|
||||
| RFailure of path * string
|
||||
| RError of path * string
|
||||
| RSkip of path * string
|
||||
| RTodo of path * string
|
||||
|
||||
let is_success = function
|
||||
RSuccess _ -> true
|
||||
| RFailure _ | RError _ | RSkip _ | RTodo _ -> false
|
||||
|
||||
let is_failure = function
|
||||
RFailure _ -> true
|
||||
| RSuccess _ | RError _ | RSkip _ | RTodo _ -> false
|
||||
|
||||
let is_error = function
|
||||
RError _ -> true
|
||||
| RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false
|
||||
|
||||
let is_skip = function
|
||||
RSkip _ -> true
|
||||
| RSuccess _ | RFailure _ | RError _ | RTodo _ -> false
|
||||
|
||||
let is_todo = function
|
||||
RTodo _ -> true
|
||||
| RSuccess _ | RFailure _ | RError _ | RSkip _ -> false
|
||||
|
||||
let result_flavour = function
|
||||
RError _ -> "Error"
|
||||
| RFailure _ -> "Failure"
|
||||
| RSuccess _ -> "Success"
|
||||
| RSkip _ -> "Skip"
|
||||
| RTodo _ -> "Todo"
|
||||
|
||||
let result_path = function
|
||||
RSuccess path
|
||||
| RError (path, _)
|
||||
| RFailure (path, _)
|
||||
| RSkip (path, _)
|
||||
| RTodo (path, _) -> path
|
||||
|
||||
let result_msg = function
|
||||
RSuccess _ -> "Success"
|
||||
| RError (_, msg)
|
||||
| RFailure (_, msg)
|
||||
| RSkip (_, msg)
|
||||
| RTodo (_, msg) -> msg
|
||||
|
||||
(* Returns true if the result list contains successes only *)
|
||||
let rec was_successful results =
|
||||
match results with
|
||||
[] -> true
|
||||
| RSuccess _::t
|
||||
| RSkip _::t -> was_successful t
|
||||
| RFailure _::_
|
||||
| RError _::_
|
||||
| RTodo _::_ -> false
|
||||
|
||||
(* Events which can happen during testing *)
|
||||
type test_event =
|
||||
EStart of path
|
||||
| EEnd of path
|
||||
| EResult of test_result
|
||||
|
||||
(* Run all tests, report starts, errors, failures, and return the results *)
|
||||
let perform_test report test =
|
||||
let run_test_case f path =
|
||||
try
|
||||
f ();
|
||||
RSuccess path
|
||||
with
|
||||
Failure s -> RFailure (path, s)
|
||||
| Skip s -> RSkip (path, s)
|
||||
| Todo s -> RTodo (path, s)
|
||||
| s -> RError (path, (Printexc.to_string s ^ " " ^
|
||||
Printexc.get_backtrace ()))
|
||||
in
|
||||
let rec run_test path results test =
|
||||
match test with
|
||||
TestCase(f) ->
|
||||
report (EStart path);
|
||||
let result = run_test_case f path in
|
||||
report (EResult result);
|
||||
report (EEnd path);
|
||||
result::results
|
||||
| TestList (tests) ->
|
||||
fold_lefti
|
||||
(fun results t cnt -> run_test ((ListItem cnt)::path) results t)
|
||||
results tests
|
||||
| TestLabel (label, t) ->
|
||||
run_test ((Label label)::path) results t
|
||||
in
|
||||
run_test [] [] test
|
||||
|
||||
(* Function which runs the given function and returns the running time
|
||||
of the function, and the original result in a tuple *)
|
||||
let time_fun f x y =
|
||||
let begin_time = Unix.gettimeofday () in
|
||||
(Unix.gettimeofday () -. begin_time, f x y)
|
||||
|
||||
(* A simple (currently too simple) text based test runner *)
|
||||
let run_test_tt ?(verbose=false) test =
|
||||
let printf = Format.printf in
|
||||
let separator1 =
|
||||
"======================================================================" in
|
||||
let separator2 =
|
||||
"----------------------------------------------------------------------" in
|
||||
let string_of_result = function
|
||||
RSuccess _ ->
|
||||
if verbose then "ok\n" else "."
|
||||
| RFailure (_, _) ->
|
||||
if verbose then "FAIL\n" else "F"
|
||||
| RError (_, _) ->
|
||||
if verbose then "ERROR\n" else "E"
|
||||
| RSkip (_, _) ->
|
||||
if verbose then "SKIP\n" else "S"
|
||||
| RTodo (_, _) ->
|
||||
if verbose then "TODO\n" else "T"
|
||||
in
|
||||
let report_event = function
|
||||
EStart p ->
|
||||
if verbose then printf "%s ... " (string_of_path p)
|
||||
| EEnd _ -> ()
|
||||
| EResult result ->
|
||||
printf "%s@?" (string_of_result result);
|
||||
in
|
||||
let print_result_list results =
|
||||
List.iter
|
||||
(fun result -> printf "%s\n%s: %s\n\n%s\n%s\n"
|
||||
separator1
|
||||
(result_flavour result)
|
||||
(string_of_path (result_path result))
|
||||
(result_msg result)
|
||||
separator2)
|
||||
results
|
||||
in
|
||||
|
||||
(* Now start the test *)
|
||||
let running_time, results = time_fun perform_test report_event test in
|
||||
let errors = List.filter is_error results in
|
||||
let failures = List.filter is_failure results in
|
||||
let skips = List.filter is_skip results in
|
||||
let todos = List.filter is_todo results in
|
||||
|
||||
if not verbose then printf "\n";
|
||||
|
||||
(* Print test report *)
|
||||
print_result_list errors;
|
||||
print_result_list failures;
|
||||
printf "Ran: %d tests in: %.2f seconds.\n"
|
||||
(List.length results) running_time;
|
||||
|
||||
(* Print final verdict *)
|
||||
if was_successful results then
|
||||
(
|
||||
if skips = [] then
|
||||
printf "OK"
|
||||
else
|
||||
printf "OK: Cases: %d Skip: %d\n"
|
||||
(test_case_count test) (List.length skips)
|
||||
)
|
||||
else
|
||||
printf "FAILED: Cases: %d Tried: %d Errors: %d Failures: %d Skip:%d Todo:%d\n"
|
||||
(test_case_count test) (List.length results)
|
||||
(List.length errors) (List.length failures)
|
||||
(List.length skips) (List.length todos);
|
||||
|
||||
(* Return the results possibly for further processing *)
|
||||
results
|
||||
|
||||
(* Call this one from you test suites *)
|
||||
let run_test_tt_main suite =
|
||||
let verbose = ref false in
|
||||
let only_test = ref [] in
|
||||
|
||||
Arg.parse
|
||||
(Arg.align
|
||||
[("-verbose", Arg.Set verbose, " Run the test in verbose mode.");
|
||||
("-only-test", Arg.String (fun str -> only_test := str :: !only_test),
|
||||
"path Run only the selected test");
|
||||
]
|
||||
)
|
||||
(fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
|
||||
("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*");
|
||||
|
||||
let nsuite =
|
||||
if !only_test = [] then
|
||||
(
|
||||
suite
|
||||
)
|
||||
else
|
||||
(
|
||||
match test_filter !only_test suite with
|
||||
| Some tst ->
|
||||
tst
|
||||
| None ->
|
||||
failwith ("Filtering test "^
|
||||
(String.concat ", " !only_test)^
|
||||
" lead to no test")
|
||||
)
|
||||
in
|
||||
let result = run_test_tt ~verbose:!verbose nsuite in
|
||||
if not (was_successful result) then
|
||||
exit 1
|
||||
else
|
||||
result
|
||||
Loading…
Add table
Add a link
Reference in a new issue