[Toss-devel-svn] SF.net SVN: toss:[1678] trunk/Toss
Status: Beta
Brought to you by:
lukaszkaiser
Menu
▾
▴
[Toss-devel-svn] SF.net SVN: toss:[1678] trunk/Toss
|
From: <luk...@us...> - 2012-02-18 17:53:19
|
Revision: 1678
http://toss.svn.sourceforge.net/toss/?rev=1678&view=rev
Author: lukaszkaiser
Date: 2012-02-18 17:53:06 +0000 (Sat, 18 Feb 2012)
Log Message:
-----------
Integrating oUnit with js_of_ocaml, test cleanups.
Modified Paths:
--------------
trunk/Toss/Arena/ArenaTest.ml
trunk/Toss/Arena/ContinuousRuleTest.ml
trunk/Toss/Arena/DiscreteRuleTest.ml
trunk/Toss/Arena/TermTest.ml
trunk/Toss/Client/JsHandler.ml
trunk/Toss/Client/Play.js
trunk/Toss/Client/clientTest.js
trunk/Toss/Formula/Aux.ml
trunk/Toss/Formula/Aux.mli
trunk/Toss/Formula/AuxIO.ml
trunk/Toss/Formula/AuxIO.mli
trunk/Toss/Formula/AuxTest.ml
trunk/Toss/Formula/BoolFormula.ml
trunk/Toss/Formula/BoolFormulaTest.ml
trunk/Toss/Formula/BoolFunctionTest.ml
trunk/Toss/Formula/FFTNFTest.ml
trunk/Toss/Formula/FormulaMapTest.ml
trunk/Toss/Formula/FormulaOpsTest.ml
trunk/Toss/Formula/FormulaSubstTest.ml
trunk/Toss/Formula/FormulaTest.ml
trunk/Toss/Formula/Sat/Sat.ml
trunk/Toss/Formula/Sat/SatTest.ml
trunk/Toss/GGP/GDLTest.ml
trunk/Toss/GGP/GameSimplTest.ml
trunk/Toss/GGP/TranslateFormulaTest.ml
trunk/Toss/GGP/TranslateGameTest.ml
trunk/Toss/Learn/LearnGameTest.ml
trunk/Toss/Makefile
trunk/Toss/Play/GameTreeTest.ml
trunk/Toss/Play/HeuristicTest.ml
trunk/Toss/Play/MoveTest.ml
trunk/Toss/Play/Play.ml
trunk/Toss/Play/PlayTest.ml
trunk/Toss/README
trunk/Toss/Server/ReqHandler.ml
trunk/Toss/Server/ReqHandler.mli
trunk/Toss/Server/ReqHandlerTest.ml
trunk/Toss/Server/Server.ml
trunk/Toss/Server/Tests.ml
trunk/Toss/Solver/AssignmentsTest.ml
trunk/Toss/Solver/ClassTest.ml
trunk/Toss/Solver/Num/Integers.ml
trunk/Toss/Solver/Num/IntegersTest.ml
trunk/Toss/Solver/Num/NaturalsTest.ml
trunk/Toss/Solver/Num/NumbersTest.ml
trunk/Toss/Solver/Num/RationalsTest.ml
trunk/Toss/Solver/RealQuantElim/Makefile
trunk/Toss/Solver/RealQuantElim/OrderedPolySetTest.ml
trunk/Toss/Solver/RealQuantElim/OrderedPolyTest.ml
trunk/Toss/Solver/RealQuantElim/PolyTest.ml
trunk/Toss/Solver/RealQuantElim/RealQuantElimTest.ml
trunk/Toss/Solver/RealQuantElim/SignTableTest.ml
trunk/Toss/Solver/SolverTest.ml
trunk/Toss/Solver/StructureTest.ml
trunk/Toss/www/contact.xml
trunk/Toss/www/develop.xml
Added Paths:
-----------
trunk/Toss/Formula/OUnit.ml
trunk/Toss/Formula/OUnit.mli
trunk/Toss/Formula/OUnitTest.ml
trunk/Toss/MenhirLib/LICENSE.txt
Modified: trunk/Toss/Arena/ArenaTest.ml
===================================================================
--- trunk/Toss/Arena/ArenaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/ArenaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -126,4 +126,3 @@
); *)
]
-let a = AuxIO.run_test_if_target "ArenaTest" tests
Modified: trunk/Toss/Arena/ContinuousRuleTest.ml
===================================================================
--- trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/ContinuousRuleTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -16,7 +16,7 @@
;;
let remove_insignificant_digits s =
- Str.global_replace (Str.regexp "\\.\\([0-9][0-9]\\)[0-9]+") ".\\1" s
+ Aux.replace_regexp ~regexp:"\\.\\([0-9][0-9]\\)[0-9]+" ~templ:".\\1" s
let tests = "ContinuousRule" >::: [
@@ -170,5 +170,3 @@
);
]
-
-let a = AuxIO.run_test_if_target "ContinuousRuleTest" tests
Modified: trunk/Toss/Arena/DiscreteRuleTest.ml
===================================================================
--- trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/DiscreteRuleTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -487,7 +487,7 @@
);
- "rewrite: compile_rule adding and deleting elements" >::
+ "rewrite: compile_rule adding and deleting els" >::
(fun () ->
(* adding *)
@@ -800,12 +800,3 @@
);
]
-
-let a = AuxIO.run_test_if_target "DiscreteRuleTest" tests
-
-let a () = DiscreteRule.debug_level := 7
-
-let a () =
- match (test_filter ["DiscreteRule:13:compile_rule: defined relations"] tests) with
- | Some tests -> ignore (run_test_tt ~verbose:true tests)
- | None -> ()
Modified: trunk/Toss/Arena/TermTest.ml
===================================================================
--- trunk/Toss/Arena/TermTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Arena/TermTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -5,12 +5,11 @@
let term_of_string s =
TermParser.parse_term Lexer.lex (Lexing.from_string s)
-;;
let eqs_of_string s =
TermParser.parse_eqs Lexer.lex (Lexing.from_string s)
-;;
+
let tests = "Term" >::: [
"parse" >::
(fun () ->
@@ -65,6 +64,4 @@
rk4_step "t" (Const 0.) (Const 0.1) eqs [Const 0.]))) 0 5);
);
-];;
-
-let a = AuxIO.run_test_if_target "TermTest" tests
+]
Modified: trunk/Toss/Client/JsHandler.ml
===================================================================
--- trunk/Toss/Client/JsHandler.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/JsHandler.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -205,7 +205,7 @@
Random.self_init ();
let time = Js.to_float time in
Play.set_timeout time;
- let comp_started = Aux.gettimeofday () in
+ let comp_started = AuxIO.gettimeofday () in
let game, _ = !cur_game.game_state in
let state = List.hd !play_states in
try
@@ -224,7 +224,7 @@
Js.Unsafe.set result (js"comp_started")
(Js.number_of_float comp_started);
Js.Unsafe.set result (js"comp_ended")
- (Js.number_of_float (Aux.gettimeofday ()));
+ (Js.number_of_float (AuxIO.gettimeofday ()));
Js.some result
with Not_found -> Js.null
@@ -245,3 +245,22 @@
js ("Game "^game_name^" ERROR: "^s)
let _ = set_handle "set_game" set_game
+
+let run_tests name full =
+ let len = String.length name in
+ let slash = try String.index name '/' with Not_found -> len in
+ let (dirs, files) =
+ if name = "" then ([], []) else if slash = len then ([name], []) else
+ if slash = len-1 then ([String.sub name 0 (len - 1)], []) else
+ let f = String.sub name (slash+1 ) (len-slash-1) in
+ let file =
+ if String.contains f '.' then
+ String.sub f 0 (String.index f '.')
+ else f in
+ ([String.sub name 0 slash], [file]) in
+ ignore (OUnit.run_test_tt ~verbose:true (Tests.tests ~full ~dirs ~files ()))
+
+let run_tests_small s = run_tests (of_js s) false
+let run_tests_big s = run_tests (of_js s) true
+
+let _ = set_handle "run_tests_small" run_tests_small
Modified: trunk/Toss/Client/Play.js
===================================================================
--- trunk/Toss/Client/Play.js 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/Play.js 2012-02-18 17:53:06 UTC (rev 1678)
@@ -182,7 +182,6 @@
that.redraw ();
}
if (typeof CONN == 'undefined') {
- // ASYNCH does not handle multiple plays
prev = ASYNCH ("prev_move", [this.move_nbr - 1], disp);
} else {
prev = CONN.prev_move (this.pid, this.move_nbr - 1);
@@ -208,8 +207,7 @@
that.redraw ();
}
if (typeof CONN == 'undefined') {
- // LOCAL does not handle multiple plays
- next = LOCAL.prev_move (this.move_nbr + 1);
+ next = ASYNCH ("prev_move", [this.move_nbr + 1], disp);
} else {
next = CONN.prev_move (this.pid, this.move_nbr + 1);
disp (next);
Modified: trunk/Toss/Client/clientTest.js
===================================================================
--- trunk/Toss/Client/clientTest.js 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Client/clientTest.js 2012-02-18 17:53:06 UTC (rev 1678)
@@ -74,7 +74,7 @@
function testIndex () {
function testTicTacToeClickB2 () {
- var page = pageOpen (fileUrl ("index.html"), "Client");
+ var page = pageOpen (fileUrl ("index.html"), "ClT");
doAtTime (page, 200, function () {
clickId ("btPlayTic-Tac-Toe");
});
@@ -87,7 +87,10 @@
assertAtTime (page, 4000, function () {
return (existsId ("pred_b2_P"));
});
- doAtTime (undefined, 4100, function () {
+ doAtTime (page, 4100, function () {
+ ASYNCH ("run_tests_small", ["Formula"], function () {});
+ });
+ doAtTime (undefined, 8000, function () {
console.log ("rendering");
page.render ("clientTestRender.png");
phantom.exit();
Modified: trunk/Toss/Formula/Aux.ml
===================================================================
--- trunk/Toss/Formula/Aux.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Aux.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,20 +1,10 @@
(* Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
-let gettimeofday () =
- IFDEF JAVASCRIPT THEN (
- let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
- t /. 1000. (* t is in milliseconds *)
- ) ELSE (
- Unix.gettimeofday ()
- ) ENDIF
-
-
exception Timeout of string
type ('a,'b) choice = Left of 'a | Right of 'b
-
module Strings = Set.Make
(struct type t = string let compare = String.compare end)
let add_strings nvs vs =
@@ -68,6 +58,19 @@
while !b <= !e && is_space (s.[!e]) do decr e done;
if !e < !b then "" else String.sub s !b (!e - !b + 1)
+let split_spaces s =
+ let l, i = String.length s, ref 0 in
+ let rec split_spaces_rec acc =
+ while !i < l && is_space s.[!i] do i := !i+1 done;
+ if !i = l then acc else (
+ let start = !i in
+ while !i < l && not (is_space s.[!i]) do i := !i+1 done;
+ split_spaces_rec ((String.sub s start (!i - start)) :: acc)
+ ) in
+ List.rev (split_spaces_rec [])
+
+let normalize_spaces s = String.concat " " (split_spaces s)
+
let fst3 (a,_,_) = a
let snd3 (_,a,_) = a
let trd3 (_,_,a) = a
@@ -659,12 +662,6 @@
let res = gen n in
if test res then n+1, res else first_i (n+1) gen test
-let new_filename basename suffix =
- if not (Sys.file_exists (basename^suffix))
- then basename^suffix else
- snd (first_i 1 (fun i->basename^(string_of_int i)^suffix)
- (fun fname->not (Sys.file_exists fname)))
-
let not_conflicting_name ?(truncate=false) names s =
let s =
if truncate then
@@ -736,11 +733,15 @@
let set_optimized_gc () =
- Gc.set { (Gc.get()) with
- Gc.space_overhead = 300; (* 300% instead of 80% std *)
- Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
- Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
- }
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
+ Gc.set { (Gc.get()) with
+ Gc.space_overhead = 300; (* 300% instead of 80% std *)
+ Gc.minor_heap_size = 160*1024; (* 4*std, opt ~= L2 cache/proc *)
+ Gc.major_heap_increment = 8*124*1024 (* 8*std ok *)
+ }
+ ) ENDIF
(* Replacements for basic Str functions. *)
@@ -767,7 +768,7 @@
IFDEF JAVASCRIPT THEN (
let js_s = Js.string s in
let js_regex = jsnew Js.regExp (Js.string regexp) in
- let res = js_s##replace (js_regex, Js.string templ) in
+ let res = js_s##replace (js_regex, Js.string templ) in
Js.to_string res
) ELSE (
Str.global_replace (Str.regexp regexp) templ s
Modified: trunk/Toss/Formula/Aux.mli
===================================================================
--- trunk/Toss/Formula/Aux.mli 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Aux.mli 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,10 +1,7 @@
(** Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
-(** Replacement for Unix.gettimeofday. *)
-val gettimeofday: unit -> float
-
exception Timeout of string
type ('a, 'b) choice = Left of 'a | Right of 'b
@@ -49,6 +46,12 @@
(** {2 Helper functions on lists and other functions lacking from the
standard library.} *)
+(** Split a string on spaces. *)
+val split_spaces : string -> string list
+
+(** Replace all white space sequences by a simple space, strip on both ends. *)
+val normalize_spaces : string -> string
+
(** Random element of a list. *)
val random_elem : 'a list -> 'a
@@ -315,9 +318,6 @@
(** Iterate a function [n] times: [f^n(x)]. *)
val fold_n : ('a -> 'a) -> 'a -> int -> 'a
-(** Generate a fresh filename of the form [base ^ n ^ suffix]. *)
-val new_filename : string -> string -> string
-
(** Returns a string proloning [s] and not appearing in [names]. If
[truncate] is true, remove numbers from the end of [s]. *)
val not_conflicting_name : ?truncate:bool -> Strings.t -> string -> string
Modified: trunk/Toss/Formula/AuxIO.ml
===================================================================
--- trunk/Toss/Formula/AuxIO.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxIO.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -2,8 +2,25 @@
structures and standard library-like definitions. *)
open Aux
+let gettimeofday () =
+ IFDEF JAVASCRIPT THEN (
+ let t = Js.to_float ((jsnew Js.date_now ())##getTime()) in
+ t /. 1000. (* t is in milliseconds *)
+ ) ELSE (
+ Unix.gettimeofday ()
+ ) ENDIF
+let backtrace () =
+ IFDEF JAVASCRIPT THEN ( "" ) ELSE (
+ (if Printexc.backtrace_status () then
+ "\n" ^ Printexc.get_backtrace ()
+ else "")
+ ) ENDIF
+
let run_if_target target_name f =
+ IFDEF JAVASCRIPT THEN (
+ ()
+ ) ELSE (
let file_from_path p =
String.sub p (String.rindex p '/'+1)
(String.length p - String.rindex p '/' - 1) in
@@ -12,14 +29,6 @@
String.length fname >= String.length target_name &&
String.sub fname 0 (String.length target_name) = target_name in
if test_fname then f ()
-
-let run_test_if_target target_name tests =
- IFDEF JAVASCRIPT THEN (
- failwith "JavaScript unit testing not implemented yet"
- ) ELSE (
- let f () = ignore (OUnit.run_test_tt ~verbose:true tests) in
- (* So that the tests are not run twice while building TossTest. *)
- run_if_target target_name f
) ENDIF
@@ -155,6 +164,13 @@
try Hashtbl.find debug_levels module_name
with Not_found -> !default_debug_level
+let print s =
+ IFDEF JAVASCRIPT THEN (
+ if is_worker then worker_log s else console_log s
+ ) ELSE (
+ print_string s; flush stdout
+ ) ENDIF
+
let log module_name debug_lev s =
let s = "["^string_of_int debug_lev^"@"^module_name^"] "^s in
IFDEF JAVASCRIPT THEN (
Modified: trunk/Toss/Formula/AuxIO.mli
===================================================================
--- trunk/Toss/Formula/AuxIO.mli 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxIO.mli 2012-02-18 17:53:06 UTC (rev 1678)
@@ -1,14 +1,16 @@
(** Auxiliary functions that operate on standard library data
structures and standard library-like definitions. *)
+(** Replacement for Unix.gettimeofday. *)
+val gettimeofday: unit -> float
+
(** Run a function if the executable name matches the given prefix. *)
val run_if_target : string -> (unit -> unit) -> unit
-(** Run a test suite if the executable name matches the given prefix. *)
-val run_test_if_target : string -> OUnit.test -> unit
+(** Get a backtrace as a string (native mode only). *)
+val backtrace : unit -> string
-
(** Input a file to a string. *)
val input_file : in_channel -> string
@@ -55,3 +57,6 @@
serves only informative purposes. Calling this function directly
outputs the message unconditionally. *)
val log : string -> int -> string -> unit
+
+(** Printing for JS and native. *)
+val print : string -> unit
Modified: trunk/Toss/Formula/AuxTest.ml
===================================================================
--- trunk/Toss/Formula/AuxTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/AuxTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -319,7 +319,7 @@
);
- "array_argfind, array_find_all, array_argfind_all, array_argfind_all_max" >::
+ "array_argfind, array_find_all" >::
(fun () ->
assert_equal ~printer:string_of_int
2
@@ -350,7 +350,10 @@
[]
(Aux.array_find_all (fun e->e.[0]='e')
[|"a";"c"; "b"|]);
+ );
+ "array_argfind_all, array_argfind_all_max" >::
+ (fun () ->
assert_equal
~printer:(fun l->String.concat "; " (List.map string_of_int l))
[2;4;6]
@@ -479,8 +482,8 @@
assert_equal ~printer:(fun x -> x)
"c43c43" (Aux.clean_name "++");
+
+ assert_equal ~printer:(fun x -> x) "ala ma kota i psa"
+ (String.concat " " (Aux.split_spaces " ala ma\nkota\t\n i psa\n"));
);
-
]
-
-let _ = AuxIO.run_test_if_target "AuxTest" tests
Modified: trunk/Toss/Formula/BoolFormula.ml
===================================================================
--- trunk/Toss/Formula/BoolFormula.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFormula.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -945,7 +945,7 @@
!clause in
let list_int line =
- let split = Aux.split_regexp ~regexp:"[ \t]+" line in
+ let split = Aux.split_spaces line in
List.rev (List.tl (List.rev_map
(fun s -> int_of_string s) (List.tl split))) in
Modified: trunk/Toss/Formula/BoolFormulaTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFormulaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -22,9 +22,8 @@
let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -410,9 +409,9 @@
);
]
-let exec () = AuxIO.run_test_if_target "BoolFormulaTest" tests
+let exec () = OUnit.run_test_if_target "BoolFormulaTest" tests
-let execbig ()= AuxIO.run_test_if_target "BoolFormulaTest" bigtests
+let execbig ()= OUnit.run_test_if_target "BoolFormulaTest" bigtests
let main () =
Modified: trunk/Toss/Formula/BoolFunctionTest.ml
===================================================================
--- trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/BoolFunctionTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -14,9 +14,8 @@
let assert_eq_string arg msg x_in y_in =
let full_msg = msg ^ " (argument: " ^ arg ^ ")" in
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg:full_msg
("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -129,12 +128,14 @@
let f = open_in !file in
let file_s = AuxIO.input_file f in
close_in f;
- let cleaned_s1 = Str.global_replace (Str.regexp "bool") "" file_s in
- let cleaned_s2 = Str.global_replace (Str.regexp "^.*<.*$") "" cleaned_s1 in
- let cleaned_s3 = Str.global_replace (Str.regexp "^.*~+.*$") "" cleaned_s2 in
- let cleaned_s4 = Str.global_replace (Str.regexp "^#.*$") "" cleaned_s3 in
- let cleaned_s5 = Str.global_replace (Str.regexp "^//.*$") "" cleaned_s4 in
- let res_s = Str.global_replace (Str.regexp "/\\*.*\\*/") "" cleaned_s5 in
+ let cleaned_s1 = Aux.replace_regexp ~regexp:"bool" ~templ:"" file_s in
+ let cleaned_s2 =
+ Aux.replace_regexp ~regexp:"^.*<.*$" ~templ:"" cleaned_s1 in
+ let cleaned_s3 =
+ Aux.replace_regexp ~regexp:"^.*~+.*$" ~templ:"" cleaned_s2 in
+ let cleaned_s4 = Aux.replace_regexp ~regexp:"^#.*$" ~templ:"" cleaned_s3 in
+ let cleaned_s5 = Aux.replace_regexp ~regexp:"^//.*$" ~templ:"" cleaned_s4 in
+ let res_s = Aux.replace_regexp ~regexp:"/\\*.*\\*/" ~templ:"" cleaned_s5 in
try
let (cl, dl, goal) = defs_goal_of_string res_s in
let new_defs =
@@ -152,7 +153,7 @@
with Lexer.Parsing_error err -> (
print_endline res_s;
let msg_raw = String.sub err 9 ((String.length err)-9) in
- let msg = Str.global_replace (Str.regexp "\n") "\n// " msg_raw in
+ let msg = Aux.replace_regexp ~regexp:"\n" ~templ:"\n// " msg_raw in
print_endline ("// ERROR: NOT PARSED\n//\n// " ^ msg ^ "\n");
)
Modified: trunk/Toss/Formula/FFTNFTest.ml
===================================================================
--- trunk/Toss/Formula/FFTNFTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FFTNFTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -45,9 +45,8 @@
let assert_eq_str ?(msg="") x_in y_in =
- let ws = Str.regexp "[ \n\t]+" in
- let x = Str.global_replace ws " " (" " ^ x_in ^ " ") in
- let y = Str.global_replace ws " " (" " ^ y_in ^ " ") in
+ let x = Aux.normalize_spaces (" " ^ x_in ^ " ") in
+ let y = Aux.normalize_spaces (" " ^ y_in ^ " ") in
assert_equal ~printer:(fun x -> x) ~msg ("\n" ^ x ^ "\n") ("\n" ^ y ^ "\n")
@@ -346,13 +345,3 @@
]
-let a = AuxIO.run_test_if_target "FFTNFTest" tests
-
-let a () = FFTNF.debug_level := 7
-
-let a () =
- match test_filter ["FFTNF:6:ff_tnf: breakthrough"]
- tests
- with
- | Some tests -> ignore (run_test_tt ~verbose:true tests)
- | None -> ()
Modified: trunk/Toss/Formula/FormulaMapTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaMapTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaMapTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -42,4 +42,3 @@
);
]
-let exec = AuxIO.run_test_if_target "FormulaMapTest" tests
Modified: trunk/Toss/Formula/FormulaOpsTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaOpsTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaOpsTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -312,7 +312,6 @@
]
-let exec = AuxIO.run_test_if_target "FormulaOpsTest" tests
(* --------------------------- Reals separation test ----------------------- *)
Modified: trunk/Toss/Formula/FormulaSubstTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaSubstTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaSubstTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -155,4 +155,3 @@
]
-let exec = AuxIO.run_test_if_target "FormulaSubstTest" tests
Modified: trunk/Toss/Formula/FormulaTest.ml
===================================================================
--- trunk/Toss/Formula/FormulaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/FormulaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -39,5 +39,3 @@
);
]
-
-let exec = AuxIO.run_test_if_target "FormulaTest" tests
Added: trunk/Toss/Formula/OUnit.ml
===================================================================
--- trunk/Toss/Formula/OUnit.ml (rev 0)
+++ trunk/Toss/Formula/OUnit.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -0,0 +1,653 @@
+(**************************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *)
+(* Copyright (C) 2010 OCamlCore SARL *)
+(* *)
+(* 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
+ ()
+
+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 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 = ref (AuxIO.backtrace)
+
+let set_backtrace b =
+ if b then mAYBE_BACKTRACE := AuxIO.backtrace else
+ mAYBE_BACKTRACE := (fun () -> "")
+
+(* 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 = AuxIO.gettimeofday () in
+ (AuxIO.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 sprintf, pr = Format.sprintf, AuxIO.print 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 pr (sprintf "%s... " (string_of_path p))
+ | EEnd _ ->
+ ()
+ | EResult result ->
+ pr (sprintf "%s@?" (string_of_result result))
+ in
+ let print_result_list results =
+ List.iter
+ (fun result ->
+ pr (sprintf "%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 pr (sprintf "\n");
+
+ (* Print test report *)
+ print_result_list errors;
+ print_result_list failures;
+ pr (sprintf "Ran: %d tests in: %.2f seconds.\n"
+ (List.length results) running_time);
+
+ (* Print final verdict *)
+ if was_successful results then
+ (
+ if skips = [] then
+ pr (sprintf "OK")
+ else
+ pr (sprintf "OK: Cases: %d Skip: %d\n"
+ (test_case_count test) (List.length skips))
+ )
+ else
+ pr (sprintf "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
+
+
+let run_test_if_target target_name tests =
+ let f () = ignore (run_test_tt ~verbose:true tests) in
+ (* So that the tests are not run twice while building TossTest. *)
+ AuxIO.run_if_target target_name f
Added: trunk/Toss/Formula/OUnit.mli
===================================================================
--- trunk/Toss/Formula/OUnit.mli (rev 0)
+++ trunk/Toss/Formula/OUnit.mli 2012-02-18 17:53:06 UTC (rev 1678)
@@ -0,0 +1,206 @@
+(** Unit test building blocks. See OUnit.ml *)
+
+
+(** Whether to show backtraces on failures or not. *)
+val set_backtrace : bool -> unit
+
+
+(** {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_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
+ *)
+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 in [msg].
+ For example [skip_if (Sys.os_type="Win32") "Test a doesn't run on windows"].
+ *)
+val skip_if : bool -> string -> unit
+
+(** The associated test is still to be done, for the reason given.
+ *)
+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
+
+
+(** {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. *)
+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.
+ *)
+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
+ *)
+val run_test_tt_main :
+ ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list ->
+ ?set_verbose:(bool -> unit) ->
+ test -> test_result list
+
+
+(** Run a test suite if the executable name matches the given prefix. *)
+val run_test_if_target : string -> test -> unit
Added: trunk/Toss/Formula/OUnitTest.ml
===================================================================
--- trunk/Toss/Formula/OUnitTest.ml (rev 0)
+++ trunk/Toss/Formula/OUnitTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -0,0 +1,179 @@
+(***********************************************************************)
+(* The OUnit library *)
+(* *)
+(* Copyright 2002, 2003, 2004, 2005, 2006, 2007, 2008 *)
+(* Maas-Maarten Zeeman. *)
+(* Copyright 2010 OCamlCore SARL *)
+(* All rights reserved. See LICENCE for details. *)
+(***********************************************************************)
+
+open OUnit
+
+let test_case = TestCase (fun () -> ())
+let labeled_test_case = "label" >: test_case
+let suite_a = "suite_a" >: TestList [test_case]
+let suite_b = "suite_b" >: TestList [labeled_test_case]
+let suite_c = "suite_c" >: TestList [test_case; labeled_test_case]
+let suite_d = "suite_d" >: TestList [suite_a; suite_c]
+
+let rec string_of_paths = function
+ [] -> ""
+ | h::t -> (string_of_path h) ^ "\n" ^ (string_of_paths t)
+
+(* Test which checks if the test case count function works correctly *)
+let test_case_count _ =
+ let assert_equal ?msg = assert_equal ?msg ~printer:string_of_int in
+ assert_equal 0 (test_case_count (TestList []));
+ assert_equal 0 (test_case_count (TestLabel("label", TestList [])));
+ assert_equal 0
+ (test_case_count
+ (TestList [TestList [];
+ TestList [TestList []]]));
+
+ assert_equal 1 (test_case_count test_case);
+ assert_equal 1 (test_case_count labeled_test_case);
+ assert_equal 1 (test_case_count suite_a);
+ assert_equal 1 (test_case_count suite_b);
+
+ assert_equal 1 (test_case_count (TestList [suite_a; TestList []]));
+ assert_equal 1
+ (test_case_count
+ (TestList [TestList [];
+ TestList [suite_b]]));
+ assert_equal 2 (test_case_count suite_c);
+ assert_equal 3 (test_case_count suite_d)
+
+(* Test which checks if the paths are correctly constructed *)
+let test_case_paths _ =
+ (* A single testcase results in a list countaining an empty list *)
+ let assert_equal ?msg = assert_equal ?msg ~printer:string_of_paths in
+ assert_equal [[]] (test_case_paths test_case);
+ assert_equal [[Label "label"]]
+ (test_case_paths labeled_test_case);
+ assert_equal [[ListItem 0; Label "suite_a"]]
+ (test_case_paths suite_a);
+ assert_equal [[Label "label"; ListItem 0; Label "suite_b"]]
+ (test_case_paths suite_b);
+ assert_equal [[ListItem 0; Label "suite_c"];
+ [Label "label"; ListItem 1; Label "suite_c"]]
+ (test_case_paths suite_c);
+ assert_equal [[ListItem 0; Label "suite_a"; ListItem 0; Label "suite_d"];
+ [ListItem 0; Label "suite_c"; ListItem 1; Label "suite_d"];
+ [Label "label"; ListItem 1; Label "suite_c"; ListItem 1;
+ Label "suite_d"]]
+ (test_case_paths suite_d)
+
+let test_assert_raises _ =
+ assert_raises
+ (Failure "OUnit: expected: Failure(\"Boo\") but got: Failure(\"Foo\")")
+ (fun _ -> (assert_raises (Failure "Boo")
+ (fun _ -> raise (Failure "Foo"))));
+ assert_raises
+ (Failure "OUnit: A label\nexpected: Failure(\"Boo\") but got: Failure(\"Foo\")")
+ (fun _ -> (assert_raises ~msg:"A label" (Failure "Boo")
+ (fun _ -> raise (Failure "Foo"))));
+ assert_raises
+ (Failure "OUnit: expected exception Failure(\"Boo\"), but no exception was raised.")
+ (fun _ -> (assert_raises (Failure "Boo") (fun _ -> ())));
+ assert_raises
+ (Failure "OUnit: A label\nexpected exception Failure(\"Boo\"), but no exception was raised.")
+ (fun _ -> (assert_raises ~msg:"A label" (Failure "Boo") (fun _ -> ())))
+
+(* Test the float compare, and use the cmp label *)
+let test_cmp_float _ =
+ assert_equal ~cmp: cmp_float 0.0001 0.0001;
+ assert_equal ~cmp: (cmp_float ~epsilon: 0.001) 1.0001 1.00001;
+ assert_raises (Failure "OUnit: not equal")
+ (fun _ -> assert_equal ~cmp: cmp_float 100.0001 101.001)
+
+let test_assert_string _ =
+ assert_string "";
+ assert_raises (Failure "OUnit: A string")
+ (fun _ -> assert_string "A string")
+
+let test_assert_bool _ =
+ assert_bool "true" true;
+ assert_raises (Failure "OUnit: false")
+ (fun _ -> assert_bool "false" false)
+
+let test_case_filter () =
+ let assert_test_case_count res tst_opt =
+ match tst_opt with
+ | Some tst ->
+ assert_equal res (OUnit.test_case_count tst)
+ | None ->
+ assert_failure "Unexpected empty filter result"
+ in
+ assert_equal None (test_filter [] suite_a);
+ assert_equal None (test_filter [] suite_b);
+ assert_equal None (test_filter [] suite_c);
+ assert_equal None (test_filter [] suite_d);
+ assert_test_case_count 1 (test_filter ["suite_a"] suite_a);
+ assert_test_case_count 1 (test_filter ["suite_a:0"] suite_a);
+ assert_test_case_count 1 (test_filter ["suite_b:0:label"] suite_b);
+ assert_test_case_count 1 (test_filter ["suite_c:0"] suite_c);
+ assert_test_case_count 2 (test_filter ["suite_c:0";"suite_c:1:label"] suite_c)
+
+let assert_equal_test_result =
+ assert_equal
+ ~printer:(fun tst_results ->
+ String.concat "; "
+ (List.map
+ (function
+ | RSuccess path ->
+ Printf.sprintf "RSuccess %S" (string_of_path path)
+ | RFailure (path, str) ->
+ Printf.sprintf "RFailure(%S, %S)"
+ (string_of_path path)
+ str
+ | RError (path, str) ->
+ Printf.sprintf "RError(%S, %S)"
+ (string_of_path path)
+ str
+ | RSkip (path, str) ->
+ Printf.sprintf "RSkip(%S, %S)"
+ (string_of_path path)
+ str
+ | RTodo (path, str) ->
+ Printf.sprintf "RTodo(%S, %S)"
+ (string_of_path path)
+ str
+ )
+ tst_results
+ ))
+
+let test_case_decorate () =
+ set_backtrace false;
+ assert_equal_test_result
+ [RSuccess [Label "label"; ListItem 1; Label "suite_c"];
+ RSuccess [ListItem 0; Label "suite_c"]]
+ (perform_test ignore suite_c);
+ assert_equal_test_result
+ [RFailure([Label "label"; ListItem 1; Label "suite_c"], "OUnit: fail");
+ RFailure([ListItem 0; Label "suite_c"], "OUnit: fail")]
+ (perform_test ignore
+ (test_decorate (fun _ -> (fun () -> assert_failure "fail")) suite_c))
+
+let test_case_skip () =
+ assert_equal_test_result
+ [RSkip ([Label "skip"], "test")]
+ (perform_test ignore ("skip" >:: (fun () -> skip_if true "test")))
+
+let test_case_todo () =
+ assert_equal_test_result
+ [RTodo ([Label "todo"], "test")]
+ (perform_test ignore ("todo" >:: (fun () -> todo "test")))
+
+(* Construct the test suite *)
+let tests = "OUnit" >:::
+ [ "test_case_count" >:: test_case_count;
+ "test_case_paths" >:: test_case_paths;
+ "test_assert_raises" >:: test_assert_raises;
+ "test_assert_string" >:: test_assert_string;
+ "test_assert_bool" >:: test_assert_bool;
+ "test_cmp_float" >:: test_cmp_float;
+ "test_case_filter" >:: test_case_filter;
+ "test_case_decorate" >:: test_case_decorate;
+ "test_case_skip" >:: test_case_skip;
+ "test_case_todo" >:: test_case_todo;
+ ]
Modified: trunk/Toss/Formula/Sat/Sat.ml
===================================================================
--- trunk/Toss/Formula/Sat/Sat.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Sat/Sat.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -6,12 +6,12 @@
let timeout = ref 0.
let minisat_timeout = ref 900.
let check_timeout msg =
- if !timeout > 0.5 && Aux.gettimeofday () > !timeout then
+ if !timeout > 0.5 && AuxIO.gettimeofday () > !timeout then
(timeout := 0.; raise (Aux.Timeout msg))
let set_timeout t =
minisat_timeout := 5. *. t; (* if MiniSat does it, it's important *)
- timeout := Aux.gettimeofday () +. t
+ timeout := AuxIO.gettimeofday () +. t
let clear_timeout () = (timeout := 0.; minisat_timeout := 900.)
Modified: trunk/Toss/Formula/Sat/SatTest.ml
===================================================================
--- trunk/Toss/Formula/Sat/SatTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/Formula/Sat/SatTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -213,8 +213,3 @@
);
]
-
-let exec = (
- AuxIO.run_test_if_target "SatTest" tests;
- AuxIO.run_test_if_target "SatTest" bigtests;
-)
Modified: trunk/Toss/GGP/GDLTest.ml
===================================================================
--- trunk/Toss/GGP/GDLTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/GGP/GDLTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -502,13 +502,3 @@
]
-let a () =
- GDL.debug_level := 5;
- (try
- ()
- with e -> print_endline (Printexc.to_string e);
- flush stdout; flush stderr; raise e);
- (* failwith "tested"; *)
- ()
-
-let exec = AuxIO.run_test_if_target "GDLTest" tests
Modified: trunk/Toss/GGP/GameSimplTest.ml
===================================================================
--- trunk/Toss/GGP/GameSimplTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/GGP/GameSimplTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -14,8 +14,6 @@
]
-let a () = AuxIO.run_test_if_target "GameSimplTest" tests
-
let a () =
match test_filter
[""]
Modified: trunk/Toss/GGP/TranslateFormulaTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/GGP/TranslateFormulaTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -100,12 +100,3 @@
]
-let a () =
- TranslateFormula.debug_level := 5;
- (* GDL.debug_level := 2; *)
- ()
-
-let a () =
- ()
-
-let exec = AuxIO.run_test_if_target "TranslateFormulaTest" tests
Modified: trunk/Toss/GGP/TranslateGameTest.ml
===================================================================
--- trunk/Toss/GGP/TranslateGameTest.ml 2012-02-18 02:07:02 UTC (rev 1677)
+++ trunk/Toss/GGP/TranslateGameTest.ml 2012-02-18 17:53:06 UTC (rev 1678)
@@ -444,12 +444,12 @@
let translate_file fname timeout =
try
- let start = Unix.gettimeofday () in
+ let start = AuxIO.gettimeofday () in
(match timeout with
| None -> ()
| Some tout ->
TranslateGame.set_timeout
- (fun () -> Unix.gettimeofday() -. start > float (tout)));
+ (fun () -> AuxIO.gettimeofday() -. start > float (tout)));
let descr = load_rules fname in
let gdl_data, game, (_, struc) =
TranslateGame.translate_game ~playing_as:(GDL.Const "") descr in
@@ -471,11 +471,11 @@
let mk_tst fname =
(fname ^ " (" ^ (string_of_int timeout) ^ "s)") >::
(fun () ->
- let start = Unix.gettimeofday () in
+ let start = AuxIO.gettimeofday () in
TranslateGame.set_timeout
- (fun () -> Unix.gettimeofday() -. start > float (timeout));
+ (fun () -> AuxIO.gettimeofday() -. start > float (timeout));
let res, msg = translate_file (dirname ^ fname) None in
- let t = Unix.gettimeofday() -. start in
+ let t = AuxIO.gettimeofday() -. start in
Gc.compact ();
let final = if res then Printf.sprintf "Suceeded (%f sec.)\n%!" t else
Printf.sprintf "%s (%f sec)\n%!" msg t in
@@ -484,7 +484,7 @@
("TranslateGame " ^ dirname) >::: (List.map mk_tst files)
let exec () =
- AuxIO.run_test_if_target "TranslateGameTest"
+ OUnit.run_test_if_target "TranslateGameTest"
("TranslateGame" >::: [tests; bigtests])
@@ -503,7 +503,7 @@
if !file <> "" && !testdir = "" then
print_endline (snd (translate_file !file (Some !timeout)))
else if !testdir <> "" then
- AuxIO.run_test_if_target "TranslateGameTest"
+ OUnit.run_test_if_target "TranslateG...
[truncated message content] |