OCamlet (OCaml toy testing framework)

oCamlet.ml

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)

oCamlet_test.ml

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

oCamlet_test_core.ml

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

oCamlet_test_result.ml

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

sample.ml

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
*)