Page MenuHomeHEPForge
Files F7877124

No OneTemporary
Actions

View Options

Index: trunk/src/omega/tests/oUnit.ml
===================================================================
--- trunk/src/omega/tests/oUnit.ml (revision 0)
+++ trunk/src/omega/tests/oUnit.ml (revision 4001)
@@ -0,0 +1,803 @@
+(***********************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(***********************************************************************)
+
+(* Version 1.1.2, with minor modifications by Thorsten Ohl *)
+
+(************************************************************************
+
+The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL.
+
+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.
+
+************************************************************************)
+
+open Format
+
+(* TODO: really use Format in printf call. Most of the time, not
+ * cuts/spaces/boxes are used
+ *)
+
+let global_verbose = ref false
+
+let buff_printf f =
+ let buff = Buffer.create 13 in
+ let fmt = formatter_of_buffer buff in
+ f fmt;
+ pp_print_flush fmt ();
+ Buffer.contents buff
+
+let bracket set_up f tear_down () =
+ let fixture =
+ set_up ()
+ in
+ let () =
+ try
+ let () = f fixture in
+ tear_down fixture
+ with e ->
+ let () =
+ tear_down fixture
+ in
+ raise e
+ in
+ ()
+
+let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f =
+ bracket
+ (fun () ->
+ Filename.open_temp_file ?mode prefix suffix)
+ f
+ (fun (fn, chn) ->
+ begin
+ try
+ close_out chn
+ with _ ->
+ ()
+ end;
+ begin
+ try
+ Sys.remove fn
+ with _ ->
+ ()
+ end)
+
+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 ?pp_diff ?msg expected actual =
+ let get_error_string () =
+(* let max_len = pp_get_margin fmt () in *)
+(* let ellipsis_text = "[...]" in *)
+ let print_ellipsis p fmt s =
+ (* TODO: find a way to do this
+ let res = p s in
+ let len = String.length res in
+ if diff <> None && len > max_len then
+ begin
+ let len_with_ellipsis =
+ (max_len - (String.length ellipsis_text)) / 2
+ in
+ (* TODO: we should use %a here to print values *)
+ fprintf fmt
+ "@[%s[...]%s@]"
+ (String.sub res
+ 0
+ len_with_ellipsis)
+ (String.sub res
+ (len - len_with_ellipsis)
+ len_with_ellipsis)
+ end
+ else
+ begin
+ (* TODO: we should use %a here to print values *)
+ fprintf fmt "@[%s@]" res
+ end
+ *)
+ pp_print_string fmt (p s)
+ in
+
+ let res =
+ buff_printf
+ (fun fmt ->
+ pp_open_vbox fmt 0;
+ begin
+ match msg with
+ | Some s ->
+ pp_open_box fmt 0;
+ pp_print_string fmt s;
+ pp_close_box fmt ();
+ pp_print_cut fmt ()
+ | None ->
+ ()
+ end;
+
+ begin
+ match printer with
+ | Some p ->
+ let p_ellipsis = print_ellipsis p in
+ fprintf fmt
+ "@[expected: @[%a@]@ but got: @[%a@]@]@,"
+ p_ellipsis expected
+ p_ellipsis actual
+
+ | None ->
+ fprintf fmt "@[not equal@]@,"
+ end;
+
+ begin
+ match pp_diff with
+ | Some d ->
+ fprintf fmt
+ "@[differences: %a@]@,"
+ d (expected, actual)
+
+ | None ->
+ ()
+ end;
+
+ pp_close_box fmt ())
+ in
+ let len =
+ String.length res
+ in
+ if len > 0 && res.[len - 1] = '\n' then
+ String.sub res 0 (len - 1)
+ else
+ res
+
+ in
+
+ if not (cmp expected actual) then
+ assert_failure (get_error_string ())
+
+let assert_command
+ ?(exit_code=Unix.WEXITED 0)
+ ?(sinput=Stream.of_list [])
+ ?(foutput=ignore)
+ ?(use_stderr=true)
+ ?env
+ ?verbose
+ prg args =
+
+ let verbose =
+ match verbose with
+ | Some v -> v
+ | None -> !global_verbose
+ in
+
+ bracket_tmpfile
+ (fun (fn_out, chn_out) ->
+ let cmd_print fmt =
+ let () =
+ match env with
+ | Some e ->
+ begin
+ pp_print_string fmt "env";
+ Array.iter (fprintf fmt "@ %s") e;
+ pp_print_space fmt ()
+ end
+
+ | None ->
+ ()
+ in
+ pp_print_string fmt prg;
+ List.iter (fprintf fmt "@ %s") args
+ in
+
+ (* Start the process *)
+ let in_write =
+ Unix.dup (Unix.descr_of_out_channel chn_out)
+ in
+ let (out_read, out_write) =
+ Unix.pipe ()
+ in
+ let err =
+ if use_stderr then
+ in_write
+ else
+ Unix.stderr
+ in
+ let args =
+ Array.of_list (prg :: args)
+ in
+ let pid =
+ Unix.set_close_on_exec out_write;
+ if verbose then
+ printf "@[Starting command '%t'@]\n" cmd_print;
+ match env with
+ | Some e ->
+ Unix.create_process_env prg args e out_read in_write err
+ | None ->
+ Unix.create_process prg args out_read in_write err
+ in
+ let () =
+ Unix.close out_read;
+ Unix.close in_write
+ in
+ let () =
+ (* Dump sinput into the process stdin *)
+ let buff = " " in
+ Stream.iter
+ (fun c ->
+ let _i : int =
+ buff.[0] <- c;
+ Unix.write out_write buff 0 1
+ in
+ ())
+ sinput;
+ Unix.close out_write
+ in
+ let _, real_exit_code =
+ let rec wait_intr () =
+ try
+ Unix.waitpid [] pid
+ with Unix.Unix_error (Unix.EINTR, _, _) ->
+ wait_intr ()
+ in
+ wait_intr ()
+ in
+ let exit_code_printer =
+ function
+ | Unix.WEXITED n ->
+ Printf.sprintf "exit code %d" n
+ | Unix.WSTOPPED n ->
+ Printf.sprintf "stopped by signal %d" n
+ | Unix.WSIGNALED n ->
+ Printf.sprintf "killed by signal %d" n
+ in
+
+ (* Dump process output to stderr *)
+ if verbose then
+ begin
+ let chn =
+ open_in fn_out
+ in
+ let buff = String.make 4096 'X' in
+ let len = ref (-1) in
+ while !len <> 0 do
+ len := input chn buff 0 (String.length buff);
+ printf "%s" (String.sub buff 0 !len);
+ done;
+ printf "@?";
+ close_in chn
+ end;
+
+ (* Check process status *)
+ assert_equal
+ ~msg:(buff_printf
+ (fun fmt ->
+ fprintf fmt
+ "@[Exit status of command '%t'@]" cmd_print))
+ ~printer:exit_code_printer
+ exit_code
+ real_exit_code;
+
+ begin
+ let chn =
+ open_in fn_out
+ in
+ try
+ foutput (Stream.of_channel chn)
+ with e ->
+ close_in chn;
+ raise e
+ end)
+ ()
+
+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 (@?) = assert_bool
+
+(* 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 =
+ function
+ | 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 =
+ function
+ | 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 =
+ function
+ | ListItem n ->
+ string_of_int n
+ | Label s ->
+ s
+
+let string_of_path path =
+ String.concat ":" (List.rev_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 ?(skip=false) only test =
+ let set_test =
+ List.fold_left
+ (fun st str -> SetTestPath.add str st)
+ SetTestPath.empty
+ only
+ in
+ let rec filter_test path tst =
+ if SetTestPath.mem (string_of_path path) set_test then
+ begin
+ Some tst
+ end
+
+ else
+ begin
+ match tst with
+ | TestCase f ->
+ begin
+ if skip then
+ Some
+ (TestCase
+ (fun () ->
+ skip_if true "Test disabled";
+ f ()))
+ else
+ None
+ end
+
+ | TestList tst_lst ->
+ begin
+ let ntst_lst =
+ fold_lefti
+ (fun ntst_lst tst i ->
+ let nntst_lst =
+ match filter_test ((ListItem i) :: path) tst with
+ | Some tst ->
+ tst :: ntst_lst
+ | None ->
+ ntst_lst
+ in
+ nntst_lst)
+ []
+ tst_lst
+ in
+ if not skip && ntst_lst = [] then
+ None
+ else
+ Some (TestList (List.rev ntst_lst))
+ end
+
+ | TestLabel (lbl, tst) ->
+ begin
+ let ntst_opt =
+ filter_test
+ ((Label lbl) :: path)
+ tst
+ in
+ match ntst_opt with
+ | Some ntst ->
+ Some (TestLabel (lbl, ntst))
+ | None ->
+ if skip then
+ Some (TestLabel (lbl, tst))
+ else
+ None
+ end
+ end
+ 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 =
+ function
+ | [] -> 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
+
+let maybe_backtrace () =
+ if Printexc.backtrace_status () then
+ "\n" ^ Printexc.get_backtrace ()
+ else ""
+
+(* 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 ^ maybe_backtrace ())
+
+ | Skip s ->
+ RSkip (path, s)
+
+ | Todo s ->
+ RTodo (path, s)
+
+ | s ->
+ RError (path, Printexc.to_string s ^ maybe_backtrace ())
+ in
+ let rec run_test path results =
+ function
+ | TestCase(f) ->
+ begin
+ let result =
+ report (EStart path);
+ run_test_case f path
+ in
+ report (EResult result);
+ report (EEnd path);
+ result::results
+ end
+
+ | TestList (tests) ->
+ begin
+ fold_lefti
+ (fun results t cnt ->
+ run_test
+ ((ListItem cnt)::path)
+ results t)
+ results tests
+ end
+
+ | TestLabel (label, t) ->
+ begin
+ run_test ((Label label)::path) results t
+ end
+ 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 test =
+ let verbose =
+ match verbose with
+ | Some v -> v
+ | None -> !global_verbose
+ in
+ let printf = Format.printf in
+ let separator1 =
+ String.make (get_margin ()) '='
+ in
+ let separator2 =
+ String.make (get_margin ()) '-'
+ 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 ...\n" (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 ?(arg_specs=[]) ?(set_verbose=ignore) suite =
+ let only_test = ref [] in
+ let () =
+ Arg.parse
+ (Arg.align
+ [
+ "-verbose",
+ Arg.Set global_verbose,
+ " Run the test in verbose mode.";
+
+ "-only-test",
+ Arg.String (fun str -> only_test := str :: !only_test),
+ "path Run only the selected test";
+
+ "-list-test",
+ Arg.Unit
+ (fun () ->
+ List.iter
+ (fun pth ->
+ print_endline (string_of_path pth))
+ (test_case_paths suite);
+ exit 0),
+ " List tests";
+ ] @ arg_specs
+ )
+ (fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
+ ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*")
+ in
+ let nsuite =
+ if !only_test = [] then
+ suite
+ else
+ begin
+ match test_filter ~skip:true !only_test suite with
+ | Some test ->
+ test
+ | None ->
+ failwith ("Filtering test "^
+ (String.concat ", " !only_test)^
+ " lead to no test")
+ end
+ in
+
+ let result =
+ set_verbose !global_verbose;
+ run_test_tt ~verbose:!global_verbose nsuite
+ in
+ if not (was_successful result) then
+ exit 1
+ else
+ result
Index: trunk/src/omega/tests/omega_unit.ml
===================================================================
--- trunk/src/omega/tests/omega_unit.ml (revision 0)
+++ trunk/src/omega/tests/omega_unit.ml (revision 4001)
@@ -0,0 +1,14 @@
+open OUnit
+
+let trivial_test =
+ bracket
+ (fun () -> true)
+ (fun b -> assert_bool "always true" b)
+ (fun b -> ())
+
+let suite =
+ "O'Mega Unit Test Suite" >:::
+ ["trivial" >:: trivial_test]
+
+let _ =
+ run_test_tt_main suite
Index: trunk/src/omega/tests/oUnitDiff.ml
===================================================================
--- trunk/src/omega/tests/oUnitDiff.ml (revision 0)
+++ trunk/src/omega/tests/oUnitDiff.ml (revision 4001)
@@ -0,0 +1,210 @@
+(***********************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(***********************************************************************)
+
+(* Version 1.1.2, with minor modifications by Thorsten Ohl *)
+
+(************************************************************************
+
+The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL.
+
+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.
+
+************************************************************************)
+
+open Format
+
+module type DIFF_ELEMENT =
+sig
+ type t
+
+ val pp_printer: Format.formatter -> t -> unit
+
+ val compare: t -> t -> int
+
+ val pp_print_sep: Format.formatter -> unit -> unit
+end
+
+module type S =
+sig
+ type e
+
+ type t
+
+ val compare: t -> t -> int
+
+ val pp_printer: Format.formatter -> t -> unit
+
+ val pp_diff: Format.formatter -> (t * t) -> unit
+
+ val assert_equal: ?msg:string -> t -> t -> unit
+
+ val of_list: e list -> t
+end
+
+let assert_equal ?msg compare pp_printer pp_diff exp act =
+ OUnit.assert_equal
+ ~cmp:(fun t1 t2 -> (compare t1 t2) = 0)
+ ~printer:(fun t ->
+ let buff = Buffer.create 13 in
+ let fmt = formatter_of_buffer buff in
+ pp_printer fmt t;
+ pp_print_flush fmt ();
+ Buffer.contents buff)
+ ~pp_diff
+ ?msg
+ exp act
+
+module SetMake (D: DIFF_ELEMENT) : S with type e = D.t =
+struct
+ module Set = Set.Make(D)
+
+ type e = D.t
+
+ type t = Set.t
+
+ let compare =
+ Set.compare
+
+ let pp_printer fmt t =
+ let first = ref true in
+ pp_open_box fmt 0;
+ Set.iter
+ (fun e ->
+ if not !first then
+ D.pp_print_sep fmt ();
+ D.pp_printer fmt e;
+ first := false)
+ t;
+ pp_close_box fmt ()
+
+ let pp_diff fmt (t1, t2) =
+ let first = ref true in
+ let print_list c t =
+ Set.iter
+ (fun e ->
+ if not !first then
+ D.pp_print_sep fmt ();
+ pp_print_char fmt c;
+ D.pp_printer fmt e;
+ first := false)
+ t
+ in
+ pp_open_box fmt 0;
+ print_list '+' (Set.diff t2 t1);
+ print_list '-' (Set.diff t1 t2);
+ pp_close_box fmt ()
+
+ let assert_equal ?msg exp act =
+ assert_equal ?msg compare pp_printer pp_diff exp act
+
+ let of_list lst =
+ List.fold_left
+ (fun acc e ->
+ Set.add e acc)
+ Set.empty
+ lst
+
+end
+
+module ListSimpleMake (D: DIFF_ELEMENT) : S with type e = D.t and type t = D.t list =
+struct
+ type e = D.t
+
+ type t = e list
+
+ let rec compare t1 t2 =
+ match t1, t2 with
+ | e1 :: tl1, e2 :: tl2 ->
+ begin
+ match D.compare e1 e2 with
+ | 0 ->
+ compare tl1 tl2
+ | n ->
+ n
+ end
+
+ | [], [] ->
+ 0
+
+ | _, [] ->
+ -1
+
+ | [], _ ->
+ 1
+
+ let pp_print_gen pre fmt t =
+ let first = ref true in
+ pp_open_box fmt 0;
+ List.iter
+ (fun e ->
+ if not !first then
+ D.pp_print_sep fmt ();
+ fprintf fmt "%s%a" pre D.pp_printer e;
+ first := false)
+ t;
+ pp_close_box fmt ()
+
+ let pp_printer fmt t =
+ pp_print_gen "" fmt t
+
+ let pp_diff fmt (t1, t2) =
+ let rec pp_diff' n t1 t2 =
+ match t1, t2 with
+ | e1 :: tl1, e2 :: tl2 ->
+ begin
+ match D.compare e1 e2 with
+ | 0 ->
+ pp_diff' (n + 1) tl1 tl2
+ | _ ->
+ fprintf fmt
+ "element number %d differ (%a <> %a)"
+ n
+ D.pp_printer e1
+ D.pp_printer e2
+ end
+
+ | [], [] ->
+ ()
+
+ | [], lst ->
+ fprintf fmt "at end,@ ";
+ pp_print_gen "+" fmt lst
+
+ | lst, [] ->
+ fprintf fmt "at end,@ ";
+ pp_print_gen "-" fmt lst
+ in
+ pp_open_box fmt 0;
+ pp_diff' 0 t1 t2;
+ pp_close_box fmt ()
+
+ let assert_equal ?msg exp act =
+ assert_equal ?msg compare pp_printer pp_diff exp act
+
+ let of_list lst =
+ lst
+end
+
+let pp_comma_separator fmt () =
+ fprintf fmt ",@ "
Index: trunk/src/omega/tests/oUnitDiff.mli
===================================================================
--- trunk/src/omega/tests/oUnitDiff.mli (revision 0)
+++ trunk/src/omega/tests/oUnitDiff.mli (revision 4001)
@@ -0,0 +1,137 @@
+(***********************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(***********************************************************************)
+
+(* Version 1.1.2, with minor modifications by Thorsten Ohl *)
+
+(************************************************************************
+
+The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL.
+
+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.
+
+************************************************************************)
+
+(** Unit tests for collection of elements
+
+ This module allows to define a more precise way to display differences
+ between collection of elements. When collection differ, the tester is
+ interested by what are the missing/extra elements. This module provides
+ a [diff] operation to spot the difference quickly between two sets of
+ elements.
+
+ Example:
+{[
+open OUnit;;
+
+module EInt =
+struct
+ type t = int
+ let compare = ( - )
+ let pp_print = Format.pp_print_int
+ let pp_print_sep = OUnitDiff.comma_separator
+end
+
+module ListInt = OUnitDiff.ListSimpleMake(EInt);;
+
+let test_diff () =
+ ListInt.assert_equal
+ [1; 2; 3; 4; 5]
+ [1; 2; 5; 4]
+;;
+
+let _ =
+ run_test_tt_main ("test_diff" >:: test_diff)
+;;
+]}
+
+when run this test outputs:
+{[
+OUnit: expected: 1, 2, 3, 4, 5 but got: 1, 2, 5, 4
+differences: element number 2 differ (3 <> 5)
+]}
+
+ @since 1.1.0
+ @author Sylvain Le Gall
+ *)
+
+(** {2 Signatures} *)
+
+(** Definition of an element
+ *)
+module type DIFF_ELEMENT =
+ sig
+ (** Type of an element *)
+ type t
+
+ (** Pretty printer for an element *)
+ val pp_printer : Format.formatter -> t -> unit
+
+ (** Element comparison *)
+ val compare : t -> t -> int
+
+ (** Pretty print element separator *)
+ val pp_print_sep : Format.formatter -> unit -> unit
+ end
+
+(** Definition of standard operations
+ *)
+module type S =
+ sig
+ (** Type of an element *)
+ type e
+
+ (** Type of a collection of element *)
+ type t
+
+ (** Compare a collection of element *)
+ val compare : t -> t -> int
+
+ (** Pretty printer a collection of element *)
+ val pp_printer : Format.formatter -> t -> unit
+
+ (** Pretty printer for collection differences *)
+ val pp_diff : Format.formatter -> t * t -> unit
+
+ (** {!assert_equal} with [~diff], [~cmp] and [~printer] predefined for
+ this collection events
+ *)
+ val assert_equal : ?msg:string -> t -> t -> unit
+
+ (** Create [t] using of list *)
+ val of_list : e list -> t
+ end
+
+(** {2 Implementations} *)
+
+(** Collection of elements based on a Set, elements order doesn't matter *)
+module SetMake : functor (D : DIFF_ELEMENT) -> S
+ with type e = D.t
+
+(** Collection of elements based on a List, order matters but difference display
+ is very simple. It stops at the first element which differs.
+ *)
+module ListSimpleMake : functor (D: DIFF_ELEMENT) -> S
+ with type e = D.t and type t = D.t list
+
+val pp_comma_separator : Format.formatter -> unit -> unit
Index: trunk/src/omega/tests/Makefile.am
===================================================================
--- trunk/src/omega/tests/Makefile.am (revision 4000)
+++ trunk/src/omega/tests/Makefile.am (revision 4001)
@@ -1,323 +1,361 @@
# Makefile.am -- Makefile for O'Mega within and without WHIZARD
# $Id$
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2012 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# Christian Speckner <christian.speckner@physik.uni-freiburg.de>
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
SUBDIRS = MSSM SM people
# OMEGA_SPLIT = -target:single_function
OMEGA_SPLIT = -target:split_function 10
# OMEGA_SPLIT = -target:split_module 10
# OMEGA_SPLIT = -target:split_file 10
OMEGA_QED = $(top_builddir)/bin/omega_QED.opt
OMEGA_QED_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QED
OMEGA_QCD = $(top_builddir)/bin/omega_QCD.opt
OMEGA_QCD_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QCD
OMEGA_SYM = $(top_builddir)/bin/omega_SYM.opt
OMEGA_SYM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SYM
OMEGA_XXX = $(top_builddir)/bin/omega_%%%.opt
OMEGA_XXX_OPTS = -target:parameter_module parameters_%%%
AM_FCFLAGS = -I$(top_builddir)/src
AM_LDFLAGS =
########################################################################
## Default Fortran compiler options
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
########################################################################
-TESTS = test_omega95 test_omega95_bispinors
+TESTS =
XFAIL_TESTS =
-EXTRA_PROGRAMS = test_omega95 test_omega95_bispinors
+EXTRA_PROGRAMS =
EXTRA_DIST =
+########################################################################
+
+include $(top_srcdir)/src/Makefile.ocaml
+
+if OCAML_AVAILABLE
+
+TESTS += omega_unit
+EXTRA_PROGRAMS += omega_unit
+
+omega_unit: oUnit.cmx oUnitDiff.cmx omega_unit.cmx
+ $(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o omega_unit unix.cmxa \
+ oUnit.cmx oUnitDiff.cmx omega_unit.cmx
+
+omega_unit.cmx: omega_unit.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+oUnit.cmi: oUnit.mli
+ $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+oUnit.cmx: oUnit.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+oUnitDiff.cmi: oUnitDiff.mli
+ $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+oUnitDiff.cmx: oUnitDiff.ml
+ $(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+ocaml_unit.cmx oUnit.cmx oUnitDiff.cmx: oUnit.cmi
+ocaml_unit.cmx oUnitDiff.cmx: oUnitDiff.cmi
+
+endif
+
+########################################################################
+
+TESTS += test_omega95 test_omega95_bispinors
+EXTRA_PROGRAMS += test_omega95 test_omega95_bispinors
+
test_omega95_SOURCES = test_omega95.f90 omega_testtools.f90
test_omega95_LDADD = $(top_builddir)/src/libomega_core.la
test_omega95_bispinors_SOURCES = test_omega95_bispinors.f90 omega_testtools.f90
test_omega95_bispinors_LDADD = $(top_builddir)/src/libomega_core.la
test_omega95.o test_omega95_bispinors.o: omega_testtools.o
if NOWEB_AVAILABLE
test_omega95.f90: $(top_srcdir)/src/omegalib.nw
$(NOTANGLE) -R[[$@]] $< | $(CPIF) $@
test_omega95_bispinors.f90: $(top_srcdir)/src/omegalib.nw
$(NOTANGLE) -R[[$@]] $< | $(CPIF) $@
omega_testtools.f90: $(top_srcdir)/src/omegalib.nw
$(NOTANGLE) -R[[$@]] $< | $(CPIF) $@
endif NOWEB_AVAILABLE
########################################################################
TESTS += test_qed_eemm
EXTRA_PROGRAMS += test_qed_eemm
test_qed_eemm_SOURCES = test_qed_eemm.f90 parameters_QED.f90
nodist_test_qed_eemm_SOURCES = amplitude_qed_eemm.f90
test_qed_eemm_LDADD = $(top_builddir)/src/libomega_core.la
amplitude_qed_eemm.f90: $(OMEGA_QED) Makefile
$(OMEGA_QED) $(OMEGA_QED_OPTS) -target:module amplitude_qed_eemm \
-scatter "e+ e- -> m+ m-" > $@
test_qed_eemm.o: amplitude_qed_eemm.o
test_qed_eemm.o: parameters_QED.o
amplitude_qed_eemm.o: parameters_QED.o
########################################################################
EXTENDED_COLOR_TESTS = \
fc_s.ects \
fc_a.ects cf_a.ects fa_f.ects ca_c.ects af_f.ects ac_c.ects \
aa_a.ects \
fc_fc.ects \
aa_s.ects as_a.ects sa_a.ects
TESTS += ects
EXTRA_PROGRAMS += ects
EXTRA_DIST += ects_driver.sh $(EXTENDED_COLOR_TESTS)
ects.f90: ects_driver.sh $(EXTENDED_COLOR_TESTS)
$(SHELL) $(srcdir)/ects_driver.sh $(OMEGA_XXX) $^ > $@
ects_SOURCES = color_test_lib.f90 \
parameters_SM.f90 parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90
nodist_ects_SOURCES = ects.f90
ects_LDADD = $(top_builddir)/src/libomega_core.la
########################################################################
TESTS += ward
EXTRA_PROGRAMS += ward
EXTRA_DIST += ward_driver.sh
EXTRA_DIST += ward_identities.list
WARD_SUPPORT_F90 = \
omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90 \
parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 \
parameters_SM.f90 parameters_SM_top_anom.f90
WARD_SUPPORT_O = $(WARD_SUPPORT_F90:.f90=.o)
ward_lib.o: $(WARD_SUPPORT_O)
WARD_LIB_F90 = ward_lib.f90 $(WARD_SUPPORT_F90)
WARD_LIB_O = $(WARD_LIB_F90:.f90=.o)
run_ward: ward
./ward
ward.f90: ward_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM)
ward.f90: ward_identities.list
$(SHELL) $(srcdir)/ward_driver.sh $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@
ward_SOURCES = $(WARD_LIB_F90)
nodist_ward_SOURCES = ward.f90
ward_LDADD = $(top_builddir)/src/libomega_core.la
ward.o: $(WARD_LIB_O)
########################################################################
EXTRA_PROGRAMS += ward_long
EXTRA_DIST += ward_identities_long.list
run_ward_long: ward_long
./ward_long
ward_long.f90: ward_driver.sh
ward_long.f90: ward_identities_long.list
$(SHELL) $(srcdir)/ward_driver.sh $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@
ward_long_SOURCES = $(WARD_LIB_F90)
nodist_ward_long_SOURCES = ward_long.f90
ward_long_LDADD = $(top_builddir)/src/libomega_core.la
# ward_long.o: ward_long.f90
# $(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $<
ward_long.o: $(WARD_LIB_O)
########################################################################
EXTRA_PROGRAMS += ward_fail
EXTRA_DIST += ward_identities_fail.list
run_ward_fail: ward_fail
./ward_fail
ward_fail.f90: ward_driver.sh
ward_fail.f90: ward_identities_fail.list
$(SHELL) $(srcdir)/ward_driver.sh $(OMEGA_XXX) $(OMEGA_SPLIT) < $< > $@
ward_fail_SOURCES = $(WARD_LIB_F90)
nodist_ward_fail_SOURCES = ward_fail.f90
ward_fail_LDADD = $(top_builddir)/src/libomega_core.la
ward_fail.o: ward_fail.f90
$(FCCOMPILE) -c -o $@ $(FCFLAGS_f90) -O0 $<
ward_fail.o: $(WARD_LIB_O)
########################################################################
TESTS += compare_split_function compare_split_module
EXTRA_PROGRAMS += compare_split_function compare_split_module
EXTRA_DIST += compare_driver.sh
EXTRA_DIST += comparisons.list
COMPARE_SUPPORT_F90 = $(WARD_SUPPORT_F90)
COMPARE_SUPPORT_O = $(WARD_SUPPORT_O)
compare_lib.o: $(COMPARE_SUPPORT_O)
COMPARE_LIB_F90 = compare_lib.f90 $(COMPARE_SUPPORT_F90)
COMPARE_LIB_O = $(COMPARE_LIB_F90:.f90=.o)
run_compare: compare_split_function compare_split_module
./compare_split_function
./compare_split_module
compare_split_function.f90: comparisons.list
$(SHELL) $(srcdir)/compare_driver.sh SF \
"$(OMEGA_XXX) -target:single_function" \
"$(OMEGA_XXX) -target:split_function 10" < $< > $@
compare_split_module.f90: comparisons.list
$(SHELL) $(srcdir)/compare_driver.sh SM \
"$(OMEGA_XXX) -target:single_function" \
"$(OMEGA_XXX) -target:split_module 10" < $< > $@
compare_split_function.f90 compare_split_module.f90: \
compare_driver.sh $(OMEGA_QED) $(OMEGA_QCD) $(OMEGA_SYM)
compare_split_function_SOURCES = $(COMPARE_LIB_F90)
nodist_compare_split_function_SOURCES = compare_split_function.f90
compare_split_function_LDADD = $(top_builddir)/src/libomega_core.la
compare_split_module_SOURCES = $(COMPARE_LIB_F90)
nodist_compare_split_module_SOURCES = compare_split_module.f90
compare_split_module_LDADD = $(top_builddir)/src/libomega_core.la
compare_split_function.o compare_split_module.o: $(COMPARE_LIB_O)
########################################################################
if FC_USE_OPENMP
TESTS += test_openmp
EXTRA_PROGRAMS += test_openmp
test_openmp_SOURCES = test_openmp.f90 parameters_QCD.f90
nodist_test_openmp_SOURCES = amplitude_openmp.f90
test_openmp_LDADD = $(top_builddir)/src/libomega_core.la
amplitude_openmp.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:openmp -target:module amplitude_openmp \
-scatter "gl gl -> gl gl gl" > $@
test_openmp.o: amplitude_openmp.o
test_openmp.o: parameters_QCD.o
amplitude_openmp.o: parameters_QCD.o
endif
########################################################################
EXTRA_PROGRAMS += benchmark
run_benchmark: benchmark
./benchmark
BENCHMARK_PROCESS = -scatter "gl gl -> gl gl gl"
BENCHMARK_SPLIT_SIZE = 10
benchmark_SOURCES = benchmark.f90 parameters_QCD.f90
nodist_benchmark_SOURCES = \
amplitude_benchmark_v1.f90 amplitude_benchmark_v2.f90 \
amplitude_benchmark_v3.f90 # amplitude_benchmark_v4.f90
benchmark_LDADD = $(top_builddir)/src/libomega_core.la
amplitude_benchmark_v1.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v1 \
$(BENCHMARK_PROCESS) -target:single_function > $@
amplitude_benchmark_v2.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v2 \
$(BENCHMARK_PROCESS) -target:split_function $(BENCHMARK_SPLIT_SIZE) > $@
amplitude_benchmark_v3.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v3 \
$(BENCHMARK_PROCESS) -target:split_module $(BENCHMARK_SPLIT_SIZE) > $@
amplitude_benchmark_v4.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v4 \
$(BENCHMARK_PROCESS) -target:split_file $(BENCHMARK_SPLIT_SIZE) > $@
benchmark.o: \
amplitude_benchmark_v1.o amplitude_benchmark_v2.o \
amplitude_benchmark_v3.o # amplitude_benchmark_v4.o
benchmark.o: parameters_QCD.o
amplitude_benchmark_v1.o amplitude_benchmark_v2.o \
amplitude_benchmark_v3.o amplitude_benchmark_v4.o: parameters_QCD.o
########################################################################
installcheck-local:
PATH=$(DESTDIR)$(bindir):$$PATH; export PATH; \
LD_LIBRARY_PATH=$(DESTDIR)$(libdir):$(DESTDIR)$(pkglibdir):$$LD_LIBRARY_PATH; export LD_LIBRARY_PATH; \
omega_QED.opt $(OMEGA_QED_OPTS) -scatter "e+ e- -> m+ m-" \
-target:module amplitude_qed_eemm > amplitude_qed_eemm.f90; \
$(FC) $(AM_FCFLAGS) $(FCFLAGS) -I$(pkgincludedir) \
-L$(DESTDIR)$(libdir) -L$(DESTDIR)$(pkglibdir) \
$(srcdir)/parameters_QED.f90 amplitude_qed_eemm.f90 \
$(srcdir)/test_qed_eemm.f90 -lomega_core; \
./a.out
########################################################################
### Remove DWARF debug information on MAC OS X
clean-macosx:
-rm -rf a.out.dSYM
.PHONY: clean-macosx
clean-local: clean-macosx
rm -f a.out gmon.out $(OMEGA_CACHES) *.$(FC_MODULE_EXT) *.o amplitude_*.f90 \
$(EXTRA_PROGRAMS) ects.f90 ward.f90 compare_split_*.f90 \
omega_testtools.f90 test_omega95*.f90
########################################################################
## The End.
########################################################################
Index: trunk/src/omega/tests/oUnit.mli
===================================================================
--- trunk/src/omega/tests/oUnit.mli (revision 0)
+++ trunk/src/omega/tests/oUnit.mli (revision 4001)
@@ -0,0 +1,281 @@
+(***********************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(***********************************************************************)
+
+(* Version 1.1.2, with minor modifications by Thorsten Ohl *)
+
+(************************************************************************
+
+The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL.
+
+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.
+
+************************************************************************)
+
+(** Unit test building blocks
+
+ @author Maas-Maarten Zeeman
+ @author Sylvain Le Gall
+ *)
+
+(** {2 Assertions}
+
+ Assertions are the basic building blocks of unittests. *)
+
+(** Signals a failure. This will raise an exception with the specified
+ string.
+
+ @raise Failure signal a failure *)
+val assert_failure : string -> 'a
+
+(** Signals a failure when bool is false. The string identifies the
+ failure.
+
+ @raise Failure signal a failure *)
+val assert_bool : string -> bool -> unit
+
+(** Shorthand for assert_bool
+
+ @raise Failure to signal a failure *)
+val ( @? ) : string -> bool -> unit
+
+(** Signals a failure when the string is non-empty. The string identifies the
+ failure.
+
+ @raise Failure signal a failure *)
+val assert_string : string -> unit
+
+(** [assert_command prg args] Run the command provided.
+
+ @param exit_code expected exit code
+ @param sinput provide this [char Stream.t] as input of the process
+ @param foutput run this function on output, it can contains an
+ [assert_equal] to check it
+ @param use_stderr redirect [stderr] to [stdout]
+ @param env Unix environment
+ @param verbose if a failure arise, dump stdout/stderr of the process to stderr
+
+ @since 1.1.0
+ *)
+val assert_command :
+ ?exit_code:Unix.process_status ->
+ ?sinput:char Stream.t ->
+ ?foutput:(char Stream.t -> unit) ->
+ ?use_stderr:bool ->
+ ?env:string array ->
+ ?verbose:bool ->
+ string -> string list -> unit
+
+(** [assert_equal expected real] Compares two values, when they are not equal a
+ failure is signaled.
+
+ @param cmp customize function to compare, default is [=]
+ @param printer value printer, don't print value otherwise
+ @param pp_diff if not equal, ask a custom display of the difference
+ using [diff fmt exp real] where [fmt] is the formatter to use
+ @param msg custom message to identify the failure
+
+ @raise Failure signal a failure
+
+ @version 1.1.0
+ *)
+val assert_equal :
+ ?cmp:('a -> 'a -> bool) ->
+ ?printer:('a -> string) ->
+ ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) ->
+ ?msg:string -> 'a -> 'a -> unit
+
+(** Asserts if the expected exception was raised.
+
+ @param msg identify the failure
+
+ @raise Failure description *)
+val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit
+
+(** {2 Skipping tests }
+
+ In certain condition test can be written but there is no point running it, because they
+ are not significant (missing OS features for example). In this case this is not a failure
+ nor a success. Following functions allow you to escape test, just as assertion but without
+ the same error status.
+
+ A test skipped is counted as success. A test todo is counted as failure.
+ *)
+
+(** [skip cond msg] If [cond] is true, skip the test for the reason explain in [msg].
+ For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on windows"].
+
+ @since 1.0.3
+ *)
+val skip_if : bool -> string -> unit
+
+(** The associated test is still to be done, for the reason given.
+
+ @since 1.0.3
+ *)
+val todo : string -> unit
+
+(** {2 Compare Functions} *)
+
+(** Compare floats up to a given relative error.
+
+ @param epsilon if the difference is smaller [epsilon] values are equal
+ *)
+val cmp_float : ?epsilon:float -> float -> float -> bool
+
+(** {2 Bracket}
+
+ A bracket is a functional implementation of the commonly used
+ setUp and tearDown feature in unittests. It can be used like this:
+
+ ["MyTestCase" >:: (bracket test_set_up test_fun test_tear_down)]
+
+ *)
+
+(** [bracket set_up test tear_down] The [set_up] function runs first, then
+ the [test] function runs and at the end [tear_down] runs. The
+ [tear_down] function runs even if the [test] failed and help to clean
+ the environment.
+ *)
+val bracket: (unit -> 'a) -> ('a -> unit) -> ('a -> unit) -> unit -> unit
+
+(** [bracket_tmpfile test] The [test] function takes a temporary filename
+ and matching output channel as arguments. The temporary file is created
+ before the test and removed after the test.
+
+ @param prefix see [Filename.open_temp_file]
+ @param suffix see [Filename.open_temp_file]
+ @param mode see [Filename.open_temp_file]
+
+ @since 1.1.0
+ *)
+val bracket_tmpfile:
+ ?prefix:string ->
+ ?suffix:string ->
+ ?mode:open_flag list ->
+ ((string * out_channel) -> unit) -> unit -> unit
+
+(** {2 Constructing Tests} *)
+
+(** 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
+
+(** Create a TestLabel for a test *)
+val (>:) : string -> test -> test
+
+(** Create a TestLabel for a TestCase *)
+val (>::) : string -> test_fun -> test
+
+(** Create a TestLabel for a TestList *)
+val (>:::) : string -> test list -> test
+
+(** Some shorthands which allows easy test construction.
+
+ Examples:
+
+ - ["test1" >: TestCase((fun _ -> ()))] =>
+ [TestLabel("test2", TestCase((fun _ -> ())))]
+ - ["test2" >:: (fun _ -> ())] =>
+ [TestLabel("test2", TestCase((fun _ -> ())))]
+ - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] =>
+ [TestLabel("test-suite", TestSuite([TestLabel("test2", TestCase((fun _ -> ())))]))]
+*)
+
+(** [test_decorate g tst] Apply [g] to test function contains in [tst] tree.
+
+ @since 1.0.3
+ *)
+val test_decorate : (test_fun -> test_fun) -> test -> test
+
+(** [test_filter paths tst] Filter test based on their path string representation.
+
+ @param skip] if set, just use [skip_if] for the matching tests.
+ @since 1.0.3
+ *)
+val test_filter : ?skip:bool -> string list -> test -> test option
+
+(** {2 Retrieve Information from Tests} *)
+
+(** Returns the number of available test cases *)
+val test_case_count : test -> int
+
+(** Types which represent the path of a test *)
+type node = ListItem of int | Label of string
+type path = node list (** The path to the test (in reverse order). *)
+
+(** Make a string from a node *)
+val string_of_node : node -> string
+
+(** Make a string from a path. The path will be reversed before it is
+ tranlated into a string *)
+val string_of_path : path -> string
+
+(** Returns a list with paths of the test *)
+val test_case_paths : test -> path list
+
+(** {2 Performing Tests} *)
+
+(** The possible results of a test *)
+type test_result =
+ RSuccess of path
+ | RFailure of path * string
+ | RError of path * string
+ | RSkip of path * string
+ | RTodo of path * string
+
+(** Events which occur during a test run *)
+type test_event =
+ EStart of path
+ | EEnd of path
+ | EResult of test_result
+
+(** Perform the test, allows you to build your own test runner *)
+val perform_test : (test_event -> 'a) -> test -> test_result list
+
+(** A simple text based test runner. It prints out information
+ during the test.
+
+ @param verbose print verbose message
+ *)
+val run_test_tt : ?verbose:bool -> test -> test_result list
+
+(** Main version of the text based test runner. It reads the supplied command
+ line arguments to set the verbose level and limit the number of test to
+ run.
+
+ @param arg_specs add extra command line arguments
+ @param set_verbose call a function to set verbosity
+
+ @version 1.1.0
+ *)
+val run_test_tt_main :
+ ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list ->
+ ?set_verbose:(bool -> unit) ->
+ test -> test_result list

File Metadata

Mime Type
text/x-diff
Expires
Tue, Nov 19, 2:50 PM (1 d, 14 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
3804832
Default Alt Text
(54 KB)

Event Timeline