Skip to content

Instantly share code, notes, and snippets.

@naokirin
Created August 3, 2012 10:31
Show Gist options
  • Save naokirin/3246539 to your computer and use it in GitHub Desktop.
Save naokirin/3246539 to your computer and use it in GitHub Desktop.
OCamlet (OCaml toy testing framework)
module Result = OCamlet_test_result
module Unit_test = OCamlet_test
include Unit_test.Test_poly
include Unit_test.Test_exn
let run_test_case c =
let open Result in
let result_unit x y =
match y.unittest_result with
| Pass -> ((fst x) && true, (snd x) ^ "")
| Failure_with_data z | Failure_exn z -> (false, (snd x) ^
(if y.unittest_name <> "" then " " ^ y.unittest_name ^ " : " ^ "\n" else "") ^
" actual:" ^ z.actual ^ " is not " ^ z.cmp_name ^ " expected:" ^ z.expected ^ "\n")
| Failure_raise s -> (false, (snd x ) ^
(if y.unittest_name <> "" then " " ^ y.unittest_name ^ " : " ^ "\n" else "") ^ " Raises " ^ s ^ "\n")
| Failure_without_data -> (false, (snd x) ^
(if y.unittest_name <> "" then " " ^ y.unittest_name ^ " : " else "") ^ " Failure" ^ "\n")
in
let result_case = List.fold_left result_unit (true, "") c.case_result in
"TestCase " ^ (
if fst result_case then c.case_name ^ " : Pass\n"
else c.case_name ^ " : Failure\n" ^ (snd result_case) ^ "\n")
let run_test_suite s =
let open Result in
let rec result_test_type x = function
| TestSuite ts -> (0,
(snd x) ^
(String.make (fst x) ' ') ^ "TestSuite " ^ ts.suite_name ^ "\n" ^
(String.make (fst x) ' ') ^ (String.make 30 '=') ^ "\n" ^
(String.make (fst x) ' ') ^ (snd (List.fold_left result_test_type ((fst x) + 1, "") ts.suite_result))
^"\n")
| TestCase c -> (fst x, (snd x) ^ run_test_case c)
in
(snd (List.fold_left result_test_type (0, "") s))
let test_suite name lst = Result.(TestSuite { suite_name = name; suite_result = lst })
let test_case name ?setup ?teardown lst =
let open Result in
let setup' = match setup with Some x -> x | None -> (fun () -> ()) in
let teardown' = match teardown with Some x -> x | None -> (fun () -> ()) in
TestCase { case_name = name;
case_result = List.map (fun f' -> f' setup' teardown') lst}
let test_case_param name ?setup ?teardown ?(test_f=test) f lst =
let open Result in
let setup' = match setup with Some x -> x | None -> (fun () -> ()) in
let teardown' = match teardown with Some x -> x | None -> (fun () -> ()) in
let unit_f x = (fun () -> x) in
let (>>) f g x = g (f x) in
TestCase { case_name = name;
case_result = List.(map (fun f' -> f' setup' teardown') (map (f >> unit_f >> test_f) lst))}
module T_int = Unit_test.Test_ord (struct
type t = int
let equal = (=)
let less = (<)
let printer = string_of_int
end)
module T_float = Unit_test.Test_ord (struct
type t = float
let equal = (=)
let less = (<)
let printer = string_of_float
end)
module T_bool = Unit_test.Test (struct
type t = bool
let equal = (=)
let printer = string_of_bool
end)
module T_string = Unit_test.Test (struct
type t = string
let equal = (=)
let printer = (fun a -> a)
end)
module T_char = Unit_test.Test (struct
type t = char
let equal = (=)
let printer = String.make 1
end)
module T_list = Unit_test.Test_with_subtype (struct
type 'a t = 'a list
let equal = fun _ -> (=)
let printer sub_printer lst =
"[" ^ List.(fold_left (fun x y -> x^";"^(sub_printer y)) (sub_printer (hd lst)) (tl lst)) ^ "]"
end)
module T_array = Unit_test.Test_with_subtype (struct
type 'a t = 'a array
let equal = fun _ -> (=)
let printer sub_printer arr = "[|" ^
List.(fold_left (fun x y -> x^";"^(sub_printer y)) (sub_printer (hd (Array.to_list arr))) (tl (Array.to_list arr)))
^ "|]"
end)
module T_option = Unit_test.Test_with_subtype (struct
type 'a t = 'a option
let equal = fun _ -> (=)
let printer sub_printer = function
| Some x -> "Some" ^ (sub_printer x)
| None -> "None"
end)
module T_ref = Unit_test.Test_with_subtype (struct
type 'a t = 'a ref
let equal = fun _ -> (=)
let printer sub_printer r =
"ref" ^ (sub_printer !r)
end)
open OCamlet_test_result
open OCamlet_test_core
module Test_exn = OCamlet_test_core.Test_exn_core
module Test_poly = OCamlet_test_core.Test_poly_core
module Test_without_printer = struct
module Test_without_printer (Test_nec : TEST_WITHOUT_PRINTER) = struct
module Test_necessary = Test_nec
type t = Test_necessary.t
let equal : t -> t -> bool = Test_necessary.equal
include Test_core_without_printer (Test_necessary)
end
module Test_ord_without_printer (Test_nec : TEST_ORD_WITHOUT_PRINTER) = struct
module Test_necessary = Test_nec
type t = Test_necessary.t
let equal = Test_necessary.equal
include Test_ord_core_without_printer(Test_nec)
end
module Test_with_subtype_without_printer (Test_nec : TEST_WITH_SUBTYPE_WITHOUT_PRINTER)
(Test_nec_subtype : TEST_WITHOUT_PRINTER) = struct
module Subtype = Test_nec_subtype
module Test_necessary = struct
type t = Subtype.t Test_nec.t
let equal = Test_nec.equal Subtype.equal
end
type t = Test_necessary.t
let equal = Test_necessary.equal
include Test_core_without_printer (Test_necessary)
end
module Test_ord_with_subtype_without_printer (Test_nec : TEST_ORD_WITH_SUBTYPE_WITHOUT_PRINTER)
(Test_nec_subtype : TEST_ORD_WITHOUT_PRINTER) = struct
module Subtype = Test_nec_subtype
module Test_necessary = struct
type t = Subtype.t Test_nec.t
let equal = Test_nec.equal Subtype.equal
let less = Test_nec.equal Subtype.less
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let less = Test_necessary.less
include Test_ord_core_without_printer (Test_necessary)
end
module Test_with_two_subtype_without_printer (Test_nec : TEST_WITH_TWO_SUBTYPE_WITHOUT_PRINTER)
(Test_nec_subtype1 : TEST_WITHOUT_PRINTER) (Test_nec_subtype2 : TEST_WITHOUT_PRINTER) = struct
module Subtype1 = Test_nec_subtype1
module Subtype2 = Test_nec_subtype2
module Test_necessary = struct
type t = (Subtype1.t, Subtype2.t) Test_nec.t
let equal = Test_nec.equal Subtype1.equal Subtype2.equal
end
type t = Test_necessary.t
let equal = Test_necessary.equal
include Test_core_without_printer (Test_necessary)
end
module Test_ord_with_two_subtype_without_printer (Test_nec : TEST_ORD_WITH_TWO_SUBTYPE_WITHOUT_PRINTER)
(Test_nec_subtype1 : TEST_ORD_WITHOUT_PRINTER) (Test_nec_subtype2 : TEST_ORD_WITHOUT_PRINTER) = struct
module Subtype1 = Test_nec_subtype1
module Subtype2 = Test_nec_subtype2
module Test_necessary = struct
type t = (Subtype1.t, Subtype2.t) Test_nec.t
let equal = Test_nec.equal Subtype1.equal Subtype2.equal
let less = Test_nec.less Subtype1.less Subtype2.less
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let less = Test_necessary.less
include Test_ord_core_without_printer (Test_necessary)
end
end
(* with printer*)
module Test (Test_nec : TEST) = struct
module Test_necessary = Test_nec
type t = Test_necessary.t
let equal = Test_necessary.equal
let printer = Test_necessary.printer
include Test_core (Test_necessary)
end
module Test_ord (Test_nec : TEST_ORD) = struct
module Test_necessary = Test_nec
type t = Test_necessary.t
let equal : t -> t -> bool = Test_necessary.equal
let printer : t -> string = Test_necessary.printer
include Test_ord_core (Test_nec)
end
module Test_with_subtype (Test_nec : TEST_WITH_SUBTYPE)
(Test_nec_subtype : TEST) = struct
module Subtype = Test_nec_subtype
module Test_necessary = struct
type t = Subtype.t Test_nec.t
let equal = Test_nec.equal Subtype.equal
let printer = Test_nec.printer Subtype.printer
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let printer = Test_necessary.printer
include Test_core (Test_necessary)
end
module Test_ord_with_subtype (Test_nec : TEST_ORD_WITH_SUBTYPE)
(Test_nec_subtype : TEST_ORD) = struct
module Subtype = Test_nec_subtype
module Test_necessary = struct
type t = Subtype.t Test_nec.t
let equal = Test_nec.equal Subtype.equal
let less = Test_nec.less Subtype.less
let printer = Test_nec.printer Subtype.printer
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let less = Test_necessary.less
let printer = Test_necessary.printer
include Test_ord_core (Test_necessary)
end
module Test_with_two_subtype (Test_nec : TEST_WITH_TWO_SUBTYPE)
(Test_nec_subtype1 : TEST) (Test_nec_subtype2 : TEST) = struct
module Subtype1 = Test_nec_subtype1
module Subtype2 = Test_nec_subtype2
module Test_necessary = struct
type t = (Subtype1.t, Subtype2.t) Test_nec.t
let equal = Test_nec.equal Subtype1.equal Subtype2.equal
let printer = Test_nec.printer Subtype1.printer Subtype2.printer
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let printer = Test_necessary.printer
include Test_core (Test_necessary)
end
module Test_ord_with_two_subtype (Test_nec : TEST_ORD_WITH_TWO_SUBTYPE)
(Test_nec_subtype1 : TEST_ORD) (Test_nec_subtype2 : TEST_ORD) = struct
module Subtype1 = Test_nec_subtype1
module Subtype2 = Test_nec_subtype2
module Test_necessary = struct
type t = (Subtype1.t, Subtype2.t) Test_nec.t
let equal = Test_nec.equal Subtype1.equal Subtype2.equal
let less = Test_nec.less Subtype1.less Subtype2.less
let printer = Test_nec.printer Subtype1.printer Subtype2.printer
end
type t = Test_necessary.t
let equal = Test_necessary.equal
let less = Test_necessary.less
let printer = Test_necessary.printer
include Test_ord_core (Test_necessary)
end
open OCamlet_test_result
(* This module is set of test with raising an exception *)
module Test_exn_core = struct
let ( @!= ) f expected =
let open OCamlet_test_result in
try f (); Failure_exn { cmp_name = "";
actual = "no raised exception"; expected = Printexc.to_string expected }
with
| e when e = expected -> Pass
| e -> Failure_exn { cmp_name = "";
actual = Printexc.to_string e; expected = Printexc.to_string expected }
end
module Test_poly_core = struct
let cmp_assertion cmp_name cmp actual expected =
let open OCamlet_test_result in
if cmp actual expected
then Pass
else Failure_with_data { cmp_name = cmp_name; actual; expected }
let ( @?= ) ?(cmp=(=)) actual expected =
cmp_assertion "equal to" cmp actual expected
let ( @?<> ) ?(cmp=(<>)) actual expected =
cmp_assertion "differnt from" cmp actual expected
let ( @?< ) ?(cmp=(<)) actual expected =
cmp_assertion "less than" cmp actual expected
let ( @?<= ) ?(cmp=(<)) actual expected =
cmp_assertion "less than or equal to" cmp actual expected
let ( @?> ) ?(cmp=(>)) actual expected =
cmp_assertion "greater than" cmp actual expected
let ( @?>= ) ?(cmp=(>=)) actual expected =
cmp_assertion "greater than or equal to" cmp actual expected
let test ?(name="") f setup teardown =
let open OCamlet_test_result in
let open Test_exn_core in
let result =
setup (); try f () with e -> Failure_raise (Printexc.to_string e) in
let str_result = match result with
| Failure_with_data _ | Failure_without_data -> Failure_without_data
| Pass -> Pass
| Failure_exn r -> Failure_exn r
| Failure_raise r -> Failure_raise r
in
teardown(); { unittest_name = name; unittest_result = str_result }
let ( @: ) name f setup teardown = test ~name:name f setup teardown
end
(* This module is set of test with equality. *)
module Test_equality (Test_nec : TEST_WITHOUT_PRINTER) = struct
let ( @?= ) actual expected =
Test_poly_core.( @?= ) ~cmp:Test_nec.equal actual expected
let ( @?<> ) actual expected =
Test_poly_core.( @?<> ) ~cmp:(fun x y -> not (Test_nec.equal x y)) actual expected
end
(* This module is set of test with ordered. *)
module Test_ordered (Test_nec : TEST_ORD_WITHOUT_PRINTER) = struct
include Test_equality (Test_nec)
let ( @?< ) actual expected =
Test_poly_core.( @?< ) ~cmp:Test_nec.less actual expected
let ( @?<= ) actual expected =
Test_poly_core.( @?<= ) ~cmp:Test_nec.(fun x y -> (less x y) && (equal x y)) actual expected
let ( @?> ) actual expected =
Test_poly_core.( @?> ) ~cmp:Test_nec.(fun x y -> not ((less x y) && (equal x y))) actual expected
let ( @?>= ) actual expected =
Test_poly_core.( @?>= ) ~cmp:Test_nec.(fun x y -> (not (less x y)) && (equal x y)) actual expected
end
module Test_core_without_printer (Test_nec : TEST_WITHOUT_PRINTER) = struct
include Test_equality (Test_nec)
let test = Test_poly_core.test
let ( @: ) = Test_poly_core.( @: )
end
module Test_ord_core_without_printer (Test_nec : TEST_ORD_WITHOUT_PRINTER) = struct
include Test_core_without_printer (Test_nec)
include Test_ordered (Test_nec)
end
module Test_core (Test_nec : TEST) = struct
include Test_equality (Test_nec)
let test ?(name="") f setup teardown =
let open OCamlet_test_result in
let open Test_exn_core in
let result =
setup (); try f () with e -> Failure_raise (Printexc.to_string e) in
let str_result = match result with
| Failure_with_data r ->
Failure_with_data { cmp_name = r.cmp_name; actual = Test_nec.printer r.actual; expected = Test_nec.printer r.expected }
| Pass -> Pass
| Failure_exn r -> Failure_exn r
| Failure_raise r -> Failure_raise r
| _ -> Failure_without_data
in
teardown(); { unittest_name = name; unittest_result = str_result }
let ( @: ) name f setup teardown = test ~name:name f setup teardown
end
module Test_ord_core (Test_nec : TEST_ORD) = struct
include Test_core (Test_nec)
include Test_ordered (Test_nec)
end
type 'a comparison = { cmp_name : string; expected : 'a; actual : 'a }
and 'a assertion_result =
| Pass
| Failure_with_data of 'a comparison
| Failure_exn of string comparison
| Failure_raise of string
| Failure_without_data
type unittest = { unittest_name : string; unittest_result : string assertion_result }
type case = { case_name : string; case_result : unittest list }
type suite = { suite_name : string; suite_result : test_type list }
and test_type = TestCase of case | TestSuite of suite
module type TEST_WITHOUT_PRINTER = sig
type t
val equal : t -> t -> bool
end
module type TEST_ORD_WITHOUT_PRINTER = sig
include TEST_WITHOUT_PRINTER
val less : t -> t -> bool
end
module type TEST_WITH_SUBTYPE_WITHOUT_PRINTER = sig
type 'a t
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
end
module type TEST_ORD_WITH_SUBTYPE_WITHOUT_PRINTER = sig
include TEST_WITH_SUBTYPE_WITHOUT_PRINTER
val less : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
end
module type TEST_WITH_TWO_SUBTYPE_WITHOUT_PRINTER = sig
type ('a, 'b) t
val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool
end
module type TEST_ORD_WITH_TWO_SUBTYPE_WITHOUT_PRINTER = sig
include TEST_WITH_TWO_SUBTYPE_WITHOUT_PRINTER
val less : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool
end
module type TEST = sig
include TEST_WITHOUT_PRINTER
val printer : t -> string
end
module type TEST_ORD = sig
include TEST_ORD_WITHOUT_PRINTER
val printer : t -> string
end
module type TEST_WITH_SUBTYPE = sig
include TEST_WITH_SUBTYPE_WITHOUT_PRINTER
val printer : ('a -> string) -> 'a t -> string
end
module type TEST_ORD_WITH_SUBTYPE = sig
include TEST_ORD_WITH_SUBTYPE_WITHOUT_PRINTER
val printer : ('a -> string) -> 'a t -> string
end
module type TEST_WITH_TWO_SUBTYPE = sig
include TEST_WITH_TWO_SUBTYPE_WITHOUT_PRINTER
val printer : ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string
end
module type TEST_ORD_WITH_TWO_SUBTYPE = sig
include TEST_ORD_WITH_TWO_SUBTYPE_WITHOUT_PRINTER
val printer : ('a -> string) -> ('b -> string) -> ('a, 'b) t -> string
end
let fizzbuzz x =
let div_3, div_5 = x mod 3 = 0, x mod 5 = 0 in
match div_3, div_5 with
| true, true -> "fizzbuzz"
| true, false -> "fizz"
| false, true -> "buzz"
| false, false -> string_of_int x
let fizzbuzz_test = let open T_string in
test_suite "fizzbuzz" [
test_case_param "divided 3" ~test_f:test
(fun x -> fizzbuzz x @?= "fizz")
[ 3; 6; 9; 12; 18 ];
test_case "divided 5" [
test (fun () -> fizzbuzz 5 @?= "buzz");
test (fun () -> fizzbuzz 10 @?= "buzz")
];
test_case "divided 3 and 5" [
test (fun () -> fizzbuzz 15 @?= "fizzbuzz");
test (fun () -> fizzbuzz 30 @?= "fizzbuzz")
];
test_case "not divided 3 and 5" [
test (fun () -> fizzbuzz 1 @?= "1");
test (fun () -> fizzbuzz 2 @?= "2")
]
]
module T_int_list = T_list(T_int)
let list_test =
test_suite "List" [
test_case "Test [1]" T_int.([
"length is 1" @: (fun () ->
List.length [1] @?= 1 );
"hd is 1" @: (fun () ->
List.hd [1] @?= 1 );
T_int_list.(
"tl is []" @: (fun () ->
List.tl [1] @?= [] ))
]);
test_case "Test []" T_int.([
"length is 0" @: (fun () -> List.length [] @?= 0);
"hd raises Failure" @: (fun () ->
(fun () -> List.hd [] ) @!= (Failure "hd"));
"tl raises Failure" @: (fun () ->
(fun () -> List.tl []) @!= (Failure "tl"))
])
]
let _ = print_endline (run_test_suite [fizzbuzz_test; list_test]);;
(*
TestSuite fizzbuzz
==============================
TestCase divided 3 : Pass
TestCase divided 5 : Pass
TestCase divided 3 and 5 : Pass
TestCase not divided 3 and 5 : Pass
TestSuite List
==============================
TestCase Test [1] : Pass
TestCase Test [] : Pass
*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment