258 lines
8 KiB
OCaml
258 lines
8 KiB
OCaml
(*---------------------------------------------------------------------------
|
|
Copyright (c) 2015 The fpath programmers. All rights reserved.
|
|
Distributed under the ISC license, see terms at the end of the file.
|
|
%%NAME%% %%VERSION%%
|
|
---------------------------------------------------------------------------*)
|
|
|
|
(* Value equality and pretty printing *)
|
|
|
|
type 'a eq = 'a -> 'a -> bool
|
|
type 'a pp = Format.formatter -> 'a -> unit
|
|
|
|
(* Pretty printers *)
|
|
|
|
let pp = Format.fprintf
|
|
let pp_exn ppf v = pp ppf "%s" (Printexc.to_string v)
|
|
let pp_bool ppf v = pp ppf "%b" v
|
|
let pp_char ppf v = pp ppf "%C" v
|
|
let pp_str ppf v = pp ppf "%S" v
|
|
let pp_int = Format.pp_print_int
|
|
let pp_float ppf v = pp ppf "%.10f" (* bof... *) v
|
|
let pp_int32 ppf v = pp ppf "%ld" v
|
|
let pp_int64 ppf v = pp ppf "%Ld" v
|
|
let pp_text = Format.pp_print_text
|
|
let pp_list pp_v ppf l =
|
|
let pp_sep ppf () = pp ppf ";@," in
|
|
pp ppf "@[<1>[%a]@]" (Format.pp_print_list ~pp_sep pp_v) l
|
|
|
|
let pp_option pp_v ppf = function
|
|
| None -> Format.fprintf ppf "None"
|
|
| Some v -> Format.fprintf ppf "Some %a" pp_v v
|
|
|
|
let pp_slot_loc ppf l =
|
|
pp ppf "%s:%d.%d-%d:"
|
|
l.Printexc.filename l.Printexc.line_number
|
|
l.Printexc.start_char l.Printexc.end_char
|
|
|
|
let pp_bt ppf bt = match Printexc.backtrace_slots bt with
|
|
| None -> pp ppf "@,@[%a@]" pp_text "No backtrace. Did you compile with -g ?"
|
|
| Some slots ->
|
|
let rec loop = function
|
|
| [] -> assert false
|
|
| s :: ss ->
|
|
begin match Printexc.Slot.location s with
|
|
| None -> ()
|
|
| Some l when l.Printexc.filename = "test/testing.ml" ||
|
|
l.Printexc.filename = "test/test.ml" -> ()
|
|
| Some l -> pp ppf "@,%a" pp_slot_loc l
|
|
end;
|
|
if ss <> [] then (loop ss) else ()
|
|
in
|
|
loop (Array.to_list slots)
|
|
|
|
(* Assertion counters *)
|
|
|
|
let fail_count = ref 0
|
|
let pass_count = ref 0
|
|
|
|
(* Logging *)
|
|
|
|
let log_part fmt = Format.printf fmt
|
|
let log ?header fmt = match header with
|
|
| Some h -> Format.printf ("[%s] " ^^ fmt ^^ "@.") h
|
|
| None -> Format.printf (fmt ^^ "@.")
|
|
|
|
let log_results () =
|
|
let total = !pass_count + !fail_count in
|
|
match !fail_count with
|
|
| 0 -> log ~header:"OK" "All %d assertions succeeded !@." total; true
|
|
| 1 -> log ~header:"FAIL" "1 failure out of %d assertions" total; false
|
|
| n -> log ~header:"FAIL" "%d failures out of %d assertions"
|
|
!fail_count total; false
|
|
|
|
let log_fail msg bt =
|
|
log ~header:"FAIL" "@[<v>@[%a@]%a@]" pp_text msg pp_bt bt
|
|
|
|
let log_unexpected_exn ~header exn bt =
|
|
log ~header:"SUITE" "@[<v>@[ABORTED: unexpected exception:@]@,%a%a@]"
|
|
pp_exn exn pp_bt bt
|
|
|
|
(* Testing scopes *)
|
|
|
|
exception Fail
|
|
exception Fail_handled
|
|
|
|
let block f = try f () with
|
|
| Fail | Fail_handled -> ()
|
|
| exn ->
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
incr fail_count;
|
|
log_unexpected_exn ~header:"BLOCK" exn bt
|
|
|
|
type test = string * (unit -> unit)
|
|
|
|
let test n f = n, f
|
|
let run_test (n, f) =
|
|
log "* %s" n;
|
|
try f () with
|
|
| Fail | Fail_handled ->
|
|
log ~header:"TEST" "ABORTED: a test failure blew the test scope"
|
|
| exn ->
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
incr fail_count;
|
|
log_unexpected_exn ~header:"TEST" exn bt
|
|
|
|
type suite = string * test list
|
|
let suite n ts = n, ts
|
|
let run_suite (n, ts) = try log "%s" n; List.iter run_test ts with
|
|
| exn ->
|
|
let bt = Printexc.get_raw_backtrace () in
|
|
incr fail_count;
|
|
log_unexpected_exn ~header:"SUITE" exn bt
|
|
|
|
let run suites = List.iter run_suite suites
|
|
|
|
(* Passing and failing tests *)
|
|
|
|
let pass () = incr pass_count
|
|
let fail fmt =
|
|
let bt = Printexc.get_callstack 10 in
|
|
let fail _ = log_fail (Format.flush_str_formatter ()) bt in
|
|
(incr fail_count; Format.kfprintf fail Format.str_formatter fmt)
|
|
|
|
(* Checking values *)
|
|
|
|
let pp_neq pp_v ppf (v, v') = pp ppf "@[%a@]@ <>@ @[%a@]@]" pp_v v pp_v v'
|
|
|
|
let fail_eq pp v v' = fail "%a" (pp_neq pp) (v, v')
|
|
|
|
let eq ~eq ~pp v v' = if eq v v' then pass () else fail_eq pp v v'
|
|
let eq_char = eq ~eq:(=) ~pp:pp_char
|
|
let eq_str = eq ~eq:(=) ~pp:pp_str
|
|
let eq_bool = eq ~eq:(=) ~pp:Format.pp_print_bool
|
|
let eq_int = eq ~eq:(=) ~pp:Format.pp_print_int
|
|
let eq_int32 = eq ~eq:(=) ~pp:pp_int32
|
|
let eq_int64 = eq ~eq:(=) ~pp:pp_int64
|
|
let eq_float = eq ~eq:(=) ~pp:pp_float
|
|
let eq_nan f =
|
|
if f <> f then pass () else fail "@[%a@]@ is@ not a NaN" pp_float f
|
|
|
|
let eq_option ~eq:eq_v ~pp =
|
|
let eq_opt v v' = match v, v' with
|
|
| Some v, Some v' -> eq_v v v'
|
|
| None, None -> true
|
|
| _ -> false
|
|
in
|
|
let pp = pp_option pp in
|
|
fun v v' -> eq ~eq:eq_opt ~pp v v'
|
|
|
|
let eq_some = function
|
|
| Some _ -> pass ()
|
|
| None -> fail "None <> Some _"
|
|
|
|
let eq_none ~pp = function
|
|
| None -> pass ()
|
|
| Some v -> fail "@[%a <>@ None@]" pp v
|
|
|
|
let eq_list ~eq:eq_v ~pp:pp_v =
|
|
let eql l l' = try List.for_all2 eq_v l l' with Invalid_argument _ -> false in
|
|
fun l l' -> eq ~eq:eql ~pp:(pp_list pp_v) l l'
|
|
|
|
(* Tracing and checking function applications. *)
|
|
|
|
type app = (* Gathers information about the application *)
|
|
{ fail_count : int; (* fail_count checkpoint when the app starts *)
|
|
pp_args : Format.formatter -> unit -> unit; }
|
|
|
|
let ctx () = { fail_count = -1; pp_args = fun ppf () -> (); }
|
|
|
|
let log_app_raised app exn =
|
|
log "@[<2>@[%a@]==> raised %a" app.pp_args () pp_exn exn
|
|
|
|
let pp_app app pp_v ppf v =
|
|
pp ppf "@[<2>@[%a@]==>@ @[%a@]@]" app.pp_args () pp_v v
|
|
|
|
let log_app app pp_v v = log "%a" (pp_app app pp_v) v
|
|
|
|
let ( $ ) f k = k (ctx ()) f
|
|
|
|
let ( @-> ) (pp_v : 'a pp) k app f v =
|
|
let pp_args ppf () = app.pp_args ppf (); pp ppf "%a@ " pp_v v in
|
|
let fc = if app.fail_count = -1 then !fail_count else app.fail_count in
|
|
let app = { fail_count = fc; pp_args } in
|
|
try k app (f v) with
|
|
| Fail ->
|
|
log_app app pp_v v;
|
|
raise Fail_handled
|
|
| Fail_handled as e -> raise e
|
|
| exn ->
|
|
log_app_raised app exn;
|
|
fail "unexpected exception %a raised" pp_exn exn;
|
|
raise Fail_handled
|
|
|
|
let ret pp app v =
|
|
if !fail_count <> app.fail_count then log_app app pp v;
|
|
v
|
|
|
|
let ret_eq ~eq pp r app v =
|
|
if eq r v then (pass (); ret pp app v) else
|
|
(fail "@[<v>%a@,%a@]" (pp_neq pp) (r, v) (pp_app app pp) v;
|
|
raise Fail_handled)
|
|
|
|
let ret_none pp app v = match v with
|
|
| None -> pass (); ret (pp_option pp) app v
|
|
| Some _ -> ret_eq ~eq:(=) (pp_option pp) None app v
|
|
|
|
let ret_some pp app v = match v with
|
|
| Some _ as v -> pass (); ret (pp_option pp) app v
|
|
| None as v ->
|
|
fail "@[<v>Some _ <> None@,%a@]" (pp_app app (pp_option pp)) v;
|
|
raise Fail_handled
|
|
|
|
let ret_get_option pp app v = match ret_some pp app v with
|
|
| Some v -> v
|
|
| None -> assert false
|
|
|
|
(* I think we could handle the following functions on app traced ones
|
|
by enriching the app type and have alternate functions to $ for
|
|
handling these cases. Note that the only place were we can check
|
|
for these things are in the @-> combinator *)
|
|
|
|
let app_invalid ~pp f v =
|
|
try
|
|
let r = f v in
|
|
fail "%a <> exception Invalid_arg _" pp r
|
|
with
|
|
| Invalid_argument _ -> pass ()
|
|
| exn -> fail "exception %a <> exception Invalid_arg _" pp_exn exn
|
|
|
|
let app_exn ~pp e f v =
|
|
try
|
|
let r = f v in
|
|
fail "%a <> exception %a" pp r pp_exn e
|
|
with
|
|
| exn when exn = e -> pass ()
|
|
| exn -> fail "exception %a <> exception %a_" pp_exn exn pp_exn e
|
|
|
|
let app_raises ~pp f v =
|
|
try
|
|
let r = f v in
|
|
fail "%a <> exception _ " pp r
|
|
with
|
|
| exn -> pass ()
|
|
|
|
(*---------------------------------------------------------------------------
|
|
Copyright (c) 2015 The fpath programmers
|
|
|
|
Permission to use, copy, modify, and/or distribute this software for any
|
|
purpose with or without fee is hereby granted, provided that the above
|
|
copyright notice and this permission notice appear in all copies.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
---------------------------------------------------------------------------*)
|