From 570a8b80eeb93ed549b8b85719056c6ca4d23652 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Mon, 22 Jun 2015 19:29:03 +0200 Subject: [PATCH] Git rid of the OUnit dependency --- _oasis | 6 +- _tags | 10 +- examples/bad.ml | 8 +- examples/simple.ml | 4 +- lib/META | 4 +- lib/alcotest.ml | 351 +++++++++++++++++++++++++-------------------- lib/alcotest.mli | 33 ++++- setup.ml | 22 +-- 8 files changed, 251 insertions(+), 187 deletions(-) diff --git a/_oasis b/_oasis index 516f55f2..59dd9bec 100644 --- a/_oasis +++ b/_oasis @@ -11,7 +11,7 @@ Library alcotest Path: lib Findlibname: alcotest Modules: Alcotest_version, Alcotest - BuildDepends: oUnit, re.str, cmdliner, bytes + BuildDepends: re.str, cmdliner, bytes, unix Document alcotest Title: Alcotest docs @@ -25,12 +25,12 @@ Executable "simple" Path: examples MainIs: simple.ml Install: false - BuildDepends: alcotest, oUnit + BuildDepends: alcotest CompiledObject: best Executable "bad" Path: examples MainIs: bad.ml Install: false - BuildDepends: alcotest, oUnit + BuildDepends: alcotest CompiledObject: best \ No newline at end of file diff --git a/_tags b/_tags index 5f6c6366..c048cbdf 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 1fe08b99b371a3bf89836ea3eda0cc3d) +# DO NOT EDIT (digest: 65537aefedb61b4f9a674a6f0f0c3ced) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -18,23 +18,23 @@ true: annot, bin_annot "lib/alcotest.cmxs": use_alcotest : pkg_bytes : pkg_cmdliner -: pkg_oUnit : pkg_re.str +: pkg_unix # Executable simple : pkg_bytes : pkg_cmdliner -: pkg_oUnit : pkg_re.str +: pkg_unix : use_alcotest # Executable bad : pkg_bytes : pkg_cmdliner -: pkg_oUnit : pkg_re.str +: pkg_unix : use_alcotest : pkg_bytes : pkg_cmdliner -: pkg_oUnit : pkg_re.str +: pkg_unix : use_alcotest # OASIS_STOP diff --git a/examples/bad.ml b/examples/bad.ml index 0ef1918f..d70e3729 100644 --- a/examples/bad.ml +++ b/examples/bad.ml @@ -30,16 +30,16 @@ For more information, please refer to (* A module with functions to test *) module To_test = struct - let capit letter = Char.uppercase letter - let plus int_list = List.fold_left (fun a b -> a + b) 0 int_list + let capit letter = String.uppercase letter + let plus int_list = List.map (fun a -> a + a) int_list end (* The tests *) let capit () = - OUnit.assert_equal 'A' (To_test.capit 'b') + Alcotest.(check string) "strings" "A" (To_test.capit "b") let plus () = - OUnit.assert_equal 9 (To_test.plus [1;1;2;3]) + Alcotest.(check (list int)) "int lists" [1] (To_test.plus [1;1;2;3]) let test_one = [ "Capitalize" , `Quick, capit; diff --git a/examples/simple.ml b/examples/simple.ml index a02a9c3e..18878397 100644 --- a/examples/simple.ml +++ b/examples/simple.ml @@ -36,10 +36,10 @@ end (* The tests *) let capit () = - OUnit.assert_equal 'A' (To_test.capit 'a') + Alcotest.(check char) "Check A" 'A' (To_test.capit 'a') let plus () = - OUnit.assert_equal 7 (To_test.plus [1;1;2;3]) + Alcotest.(check int) "Sum equals to 7" 7 (To_test.plus [1;1;2;3]) let test_set = [ "Capitalize" , `Quick, capit; diff --git a/lib/META b/lib/META index bb2e37f9..7dd1c008 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: b7e3d72424d76281e480f10752a56913) +# DO NOT EDIT (digest: 6f16f1ec61baecfa38e183f8e682c502) version = "0.3.3" description = "A lightweight and colourful test framework" -requires = "oUnit re.str cmdliner bytes" +requires = "re.str cmdliner bytes unix" archive(byte) = "alcotest.cma" archive(byte, plugin) = "alcotest.cma" archive(native) = "alcotest.cmxa" diff --git a/lib/alcotest.ml b/lib/alcotest.ml index fcc4c0ad..18452f3a 100644 --- a/lib/alcotest.ml +++ b/lib/alcotest.ml @@ -14,32 +14,44 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +exception Check_error of string + let sp = Printf.sprintf (* Types *) type speed_level = [`Quick | `Slow] -type test_case = string * speed_level * (unit -> unit) +type run = unit -> unit -type test = string * test_case list +type path = Path of (string * int) + +type run_result = [ + | `Ok + | `Failure of path * string + | `Error of path * string + | `Skip + | `Todo of string +] + +type rrun = unit -> run_result + +type test_case = string * speed_level * run -(* FIXME: should remove dependency to OUnit *) -type node = OUnit.node +type test = string * test_case list -type single_test = OUnit.test -let single_test fn = OUnit.TestCase fn +let quiet = ref false (* global state *) type t = { (* library values. *) name : string; - tests: single_test list; + tests: (path * rrun) list; (* caches computed from the library values. *) - nodes: node list list; - doc : node list -> string option; - speed: node list -> speed_level option; + paths: path list; + doc : path -> string option; + speed: path -> speed_level option; (* runtime state. *) mutable errors: string list; @@ -58,7 +70,7 @@ type t = { let empty () = let name = Filename.basename Sys.argv.(0) in let errors = [] in - let nodes = [] in + let paths = [] in let doc _ = None in let speed _ = None in let tests = [] in @@ -69,7 +81,7 @@ let empty () = let show_errors = false in let json = false in let log_dir = Sys.getcwd () in - { name; errors; tests; nodes; doc; speed; + { name; errors; tests; paths; doc; speed; max_label; max_doc; speed_level; show_errors; json; verbose; log_dir } @@ -170,45 +182,26 @@ let string_of_channel ic = iter ic b s; Buffer.contents b -let file_of_path path ext = - let path = List.tl (List.rev path) in - sp "%s.%s" (String.concat "-" (List.map OUnit.string_of_node path)) ext - -let output_file t path = - Filename.concat t.log_dir (file_of_path path "output") +let short_string_of_path (Path (n, i)) = sp "%s.%3d" n i +let file_of_path path ext = sp "%s.%s" (short_string_of_path path) ext +let output_file t path = Filename.concat t.log_dir (file_of_path path "output") let prepare t = if not (Sys.file_exists t.log_dir) then Unix.mkdir t.log_dir 0o755 -let string_of_node t = function - | OUnit.ListItem i -> sp "%3d" i - | OUnit.Label l -> indent_left (sp "%s" (blue_s l)) (t.max_label+8) - -let string_of_path t path = - let rec aux = function - | [] -> "--" - | OUnit.ListItem _ :: t -> aux t - | h::r -> - string_of_node t h ^ String.concat " " (List.map (string_of_node t) r) - in - aux (List.rev path) +let string_of_path t (Path (n, i)) = + sp "%s%3d" (indent_left (sp "%s" (blue_s n)) (t.max_label+8)) i let doc_of_path t path = - let path = List.rev (List.tl (List.rev path)) in match t.doc path with - | None -> "" + | None -> "" | Some d -> d let speed_of_path t path = - let path = List.rev (List.tl (List.rev path)) in match t.speed path with | None -> `Slow | Some s -> s -let short_string_of_path path = - let path = List.rev (List.tl (List.rev path)) in - OUnit.string_of_path path - let eprintf t fmt = Printf.ksprintf (fun str -> if not t.json then Printf.eprintf "%s" str) fmt @@ -233,31 +226,54 @@ let error t path fmt = ) fmt let print_result t = function - | OUnit.RSuccess p -> right t (green "[OK]") - | OUnit.RFailure (p,s) -> error t p "Failure: %s" s - | OUnit.RError (p, s) -> error t p "%s" s - | OUnit.RSkip _ -> right t (yellow "[SKIP]") - | OUnit.RTodo _ -> right t (yellow "[TODO]") + | `Ok -> right t (green "[OK]") + | `Failure (p,s) -> error t p "Failure: %s" s + | `Error (p, s) -> error t p "%s" s + | `Skip -> right t (yellow "[SKIP]") + | `Todo _ -> right t (yellow "[TODO]") let print_event t = function - | OUnit.EStart p -> - left t (sp "%s %s" (string_of_path t p) (doc_of_path t p)) - | OUnit.EResult r -> print_result t r - | OUnit.EEnd p -> () - -let failure = function - | OUnit.RSuccess _ - | OUnit.RSkip _ -> false - | OUnit.RError _ - | OUnit.RFailure _ - | OUnit.RTodo _ -> true - -let has_run = function - | OUnit.RSuccess _ - | OUnit.RError _ - | OUnit.RFailure _ -> true - | OUnit.RSkip _ - | OUnit.RTodo _ -> false + | `Start p -> left t (sp "%s %s" (string_of_path t p) (doc_of_path t p)) + | `Result r -> print_result t r + | `End _ -> () + +let failure: run_result -> bool = function + | `Ok + | `Skip -> false + | `Error _ + | `Failure _ + | `Todo _ -> true + +let has_run: run_result -> bool = function + | `Ok + | `Error _ + | `Failure _ -> true + | `Skip + | `Todo _ -> false + +let protect_test path (f:run): rrun = + fun () -> + try f (); `Ok + with + | Check_error err -> + let err = sp "Test error: %s\n%s\n" err (Printexc.get_backtrace ()) + in + `Error (path, err) + | exn -> + let err = sp "Failure: %s\n%s\n" + (Printexc.to_string exn) + (Printexc.get_backtrace ()) + in + `Error (path, err) + +let perform_test t (path, test) = + print_event t (`Start path); + let result = test () in + print_event t (`Result result); + print_event t (`End path); + result + +let perform_tests t tests = List.map (perform_test t) tests let with_redirect oc file fn = flush oc; @@ -276,92 +292,39 @@ let with_redirect oc file fn = | `Ok x -> x | `Error e -> raise e -let map_test fn test = - let rec aux path = function - | OUnit.TestCase tf -> OUnit.TestCase (fn path tf) - | OUnit.TestList tl -> - let tl = List.mapi (fun i t -> aux (OUnit.ListItem i :: path) t) tl in - OUnit.TestList tl - | OUnit.TestLabel (l ,t) -> - let t = aux (OUnit.Label l :: path) t in - OUnit.TestLabel (l, t) in - aux [] test - -let same_label x y = - (String.lowercase x) = (String.lowercase y) - -let skip_fun () = - OUnit.skip_if true "Not selected" - -let skip = - OUnit.TestCase skip_fun - -let skip_label l = - OUnit.TestLabel (l, skip) - -let filter_test ~subst labels test = - let rec aux path suffix test = - match suffix, test with - | [] , _ - | _ , OUnit.TestCase _ -> Some test - | h::suffix, OUnit.TestLabel (l ,t) -> - if same_label h l then - match aux (OUnit.Label h :: path) suffix t with - | None -> if subst then Some (OUnit.TestLabel (l, skip)) else None - | Some t ->Some (OUnit.TestLabel (l, t)) - else None - | h::suffix, OUnit.TestList tl -> - let tl, _ = List.fold_left (fun (tl, i) t -> - if same_label (string_of_int i) h then - match aux (OUnit.ListItem i :: path) suffix t with - | None -> (if subst then skip :: tl else tl), i+1 - | Some t -> (t :: tl), i+1 - else (if subst then skip :: tl else tl), i+1 - ) ([], 0) tl in - match List.rev tl with - | [] -> None - | tl -> Some (OUnit.TestList tl) in - match test with - | OUnit.TestCase _ - | OUnit.TestLabel _ -> aux [] labels test - | OUnit.TestList tl -> - let tl = List.fold_left (fun acc test -> - match aux [] labels test with - | None -> if subst then skip :: acc else acc - | Some r -> r :: acc - ) [] tl in - if tl = [] then None else Some (OUnit.TestList tl) - -let filter_tests ~subst labels tests = +let same_label x y = (String.lowercase x) = (String.lowercase y) +let skip_fun () = `Skip + +let skip_label (path, _) = path, skip_fun + +let filter_test ~subst labels (test: path * rrun) = + let Path (n, i), _ = test in + match labels with + | [] -> Some test + | [m] -> if n=m then Some test else None + | [m;j] -> if n=m && int_of_string j = i then Some test else None + | _ -> failwith "filter_test" + +let map_test f l = List.map (fun (path, test) -> path, f path test) l + +let filter_tests ~subst path tests = let tests = List.fold_left (fun acc test -> - match test with - | OUnit.TestCase _ - | OUnit.TestList _ -> assert false - | OUnit.TestLabel (l, _) -> - match filter_test ~subst labels test with - | None -> if subst then skip_label l :: acc else acc - | Some r -> r :: acc + match filter_test ~subst path test with + | None -> if subst then skip_label test :: acc else acc + | Some r -> r :: acc ) [] tests in List.rev tests -let redirect_test_output t labels test_fun = - if t.verbose then test_fun +let redirect_test_output t path (f:rrun) = + if t.verbose then f else fun () -> - let output_file = output_file t labels in - with_redirect stdout output_file (fun () -> - with_redirect stderr output_file (fun () -> - try test_fun () - with exn -> begin - eprintf t "\nTest error: %s\n" (Printexc.to_string exn); - Printexc.print_backtrace stderr; - raise exn - end - ) - ) - -let select_speed t labels test_fun = - if compare_speed_level (speed_of_path t labels) t.speed_level >= 0 then - test_fun + let output_file = output_file t path in + with_redirect stdout output_file + (fun () -> with_redirect stderr output_file f) + +let select_speed t path (f:rrun): rrun = + if compare_speed_level (speed_of_path t path) t.speed_level >= 0 then + f else skip_fun @@ -401,20 +364,20 @@ let result t test = let start_time = Sys.time () in let test = map_test (redirect_test_output t) test in let test = map_test (select_speed t) test in - let results = OUnit.perform_test (print_event t) test in + let results = perform_tests t test in let time = Sys.time () -. start_time in let success = List.length (List.filter has_run results) in let failures = List.filter failure results in { time; success; failures = List.length failures } let list_tests t = - let nodes = List.sort (fun x y -> compare (List.rev x) (List.rev y)) t.nodes in + let paths = List.sort Pervasives.compare t.paths in List.iter (fun path -> Printf.printf "%s %s\n" (string_of_path t path) (doc_of_path t path) - ) nodes + ) paths let register t name (ts:test_case list) = - let nodes = Hashtbl.create 16 in + let paths = Hashtbl.create 16 in let docs = Hashtbl.create 16 in let speeds = Hashtbl.create 16 in let max_label = ref t.max_label in @@ -422,23 +385,23 @@ let register t name (ts:test_case list) = let ts = List.mapi (fun i (doc, speed, test) -> max_label := max !max_label (String.length name); max_doc := max !max_doc (String.length doc); - let path = [ OUnit.ListItem i; OUnit.Label name ] in + let path = Path (name, i) in let doc = if doc.[String.length doc - 1] = '.' then doc else doc ^ "." in - Hashtbl.add nodes path true; + Hashtbl.add paths path true; Hashtbl.add docs path doc; Hashtbl.add speeds path speed; - OUnit.TestCase test + path, protect_test path test ) ts in - let tests = t.tests @ [ OUnit.TestLabel (name, OUnit.TestList ts) ] in - let nodes = Hashtbl.fold (fun k _ acc -> k :: acc) nodes [] in - let nodes = t.nodes @ List.rev nodes in + let tests = t.tests @ ts in + let paths = Hashtbl.fold (fun k _ acc -> k :: acc) paths [] in + let paths = t.paths @ paths in let doc p = try Some (Hashtbl.find docs p) with Not_found -> t.doc p in let speed p = try Some (Hashtbl.find speeds p) with Not_found -> t.speed p in let max_label = !max_label in let max_doc = !max_doc in - { t with nodes; tests; doc; speed; max_label; max_doc } + { t with paths; tests; doc; speed; max_label; max_doc } exception Test_error @@ -451,12 +414,12 @@ let bool_of_env name = let apply fn t log_dir verbose show_errors quick json = let show_errors = show_errors || bool_of_env "ALCOTEST_SHOW_ERRORS" in let speed_level = if quick then `Quick else `Slow in + if json then quiet := false; let t = { t with verbose; log_dir; json; show_errors; speed_level } in fn t let run_registred_tests t = - let tests = OUnit.TestList t.tests in - let result = result t tests in + let result = result t t.tests in show_result t result; if result.failures > 0 then raise Test_error @@ -466,7 +429,6 @@ let run_subtest t labels = Printf.printf "%s\n" (red "Invalid request!"); exit 1 ) else let tests = filter_tests ~subst:true labels t.tests in - let tests = OUnit.TestList tests in let result = result t tests in show_result t result; if result.failures > 0 then raise Test_error @@ -524,3 +486,82 @@ let run ?(and_exit = true) name (tl:test list) = match Term.eval_choice ~err (default_cmd t) [list_cmd t; test_cmd t] with | `Error _ -> if and_exit then exit 1 else raise Test_error | _ -> if and_exit then exit 0 else () + +module type TESTABLE = sig + type t + val pp: Format.formatter -> t -> unit + val equal: t -> t -> bool +end + +type 'a testable = (module TESTABLE with type t = 'a) + +let int = + let module M = struct + type t = int + let pp = Format.pp_print_int + let equal = (=) + end in + (module M: TESTABLE with type t = M.t) + +let char = + let module M = struct + type t = char + let pp = Format.pp_print_char + let equal = (=) + end in + (module M: TESTABLE with type t = M.t) + +let string = + let module M = struct + type t = string + let pp = Format.pp_print_string + let equal = (=) + end in + (module M: TESTABLE with type t = M.t) + +let list (type a) elt = + let (module Elt: TESTABLE with type t = a) = elt in + let module M = struct + type t = a list + let rec pp_print_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function + | [] -> () + | [v] -> pp_v ppf v + | v :: vs -> + pp_v ppf v; + pp_sep ppf (); + pp_print_list ~pp_sep pp_v ppf vs + let pp = Format.pp_print_list Elt.pp + let equal = (=) + end in + (module M: TESTABLE with type t = M.t) + +let show_line msg = + if !quiet then () + else ( + line stderr ~color:`Yellow '-'; + Printf.eprintf "ASSERT %s" msg; + line stderr ~color:`Yellow '-'; + ) + +let check_err fmt = Format.ksprintf (fun err -> raise (Check_error err)) fmt + +let check (type a) (module T: TESTABLE with type t = a) msg x y = + show_line msg; + if not (T.equal x y) then ( + let err = + Format.asprintf "Error %s: expecting %a, got %a." msg T.pp x T.pp y + in + failwith err + ) + +let fail msg = + show_line msg; + check_err "Error %s." msg + +let check_raises msg exn f = + show_line msg; + try + f (); + check_err "Fail %s: expecting %s, got nothing." msg (Printexc.to_string exn) + with e -> + () diff --git a/lib/alcotest.mli b/lib/alcotest.mli index 248c185b..feae3895 100644 --- a/lib/alcotest.mli +++ b/lib/alcotest.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -(** A lightweight and colourful test framework, based on OUnit. *) +(** A lightweight and colourful test framework. *) type speed_level = [`Quick | `Slow] (** Speed level for a test. *) @@ -41,3 +41,34 @@ val run: ?and_exit:bool -> string -> test list -> unit val line: out_channel -> ?color:[`Blue|`Yellow] -> char -> unit (** Draw a line on the given channel *) + +(** {2 Assert functions} *) + +module type TESTABLE = sig + + type t + (** The type to test. *) + + val pp: Format.formatter -> t -> unit + (** A way to pretty-print the value. *) + + val equal: t -> t -> bool + (** Test for equality between two values. *) + +end + +type 'a testable = (module TESTABLE with type t = 'a) + +val int: int testable +val char: char testable +val string: string testable +val list: 'a testable -> 'a list testable + +val check: 'a testable -> string -> 'a -> 'a -> unit +(** Check that two values are equal. *) + +val fail: string -> 'a +(** Simply fail. *) + +val check_raises: string -> exn -> (unit -> unit) -> unit +(** Check that an exception is raised. *) diff --git a/setup.ml b/setup.ml index 9508c42e..3434243c 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 655854d1db615f07acb3215f52fbdcb5) *) +(* DO NOT EDIT (digest: ab34b1119a855878021b06bb5214eb8d) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6749,10 +6749,10 @@ let setup_t = bs_compiled_object = Best; bs_build_depends = [ - FindlibPackage ("oUnit", None); FindlibPackage ("re.str", None); FindlibPackage ("cmdliner", None); - FindlibPackage ("bytes", None) + FindlibPackage ("bytes", None); + FindlibPackage ("unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -6811,11 +6811,7 @@ let setup_t = bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "alcotest"; - FindlibPackage ("oUnit", None) - ]; + bs_build_depends = [InternalLibrary "alcotest"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6838,11 +6834,7 @@ let setup_t = bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples"; bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "alcotest"; - FindlibPackage ("oUnit", None) - ]; + bs_build_depends = [InternalLibrary "alcotest"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6863,7 +6855,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "Û\127r\137ßè¼Rc\t¬êÎ&ÿ\030"; + oasis_digest = Some "næ.º÷)\159\151è \159¼x[·\135"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -6871,6 +6863,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 6875 "setup.ml" +# 6867 "setup.ml" (* OASIS_STOP *) let () = setup ();;