Skip to content

Commit

Permalink
update API for reporting messages in failures (see #39)
Browse files Browse the repository at this point in the history
  • Loading branch information
@c-cube
c-cube committed Jun 15, 2017
1 parent 73042bf commit 2133238
Show file tree
Hide file tree
Showing 4 changed files with 80 additions and 104 deletions.
15 changes: 11 additions & 4 deletions example/QCheck_runner_test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,15 @@ let prop_foldleft_foldright =
int_gen
(list int_gen)
(fun2 Observable.int Observable.int int_gen))
(fun (z,xs,f) -> List.fold_right (Fn.apply f) xs z = List.fold_left (Fn.apply f) z xs)
(fun (z,xs,f) ->
let l1 = List.fold_right (Fn.apply f) xs z in
let l2 = List.fold_left (Fn.apply f) z xs in
if l1=l2 then true
else QCheck.Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@."
(QCheck.Print.(list int) xs)
(QCheck.Print.int l1)
(QCheck.Print.int l2)
)

(* Another example (false) property *)
let prop_foldleft_foldright_uncurry =
Expand All @@ -85,13 +93,12 @@ let long_shrink =

let find_ex =
let open QCheck in
Test.make_full ~name:"find_example" (2--50)
(fun ctx n ->
Test.make ~name:"find_example" (2--50)
(fun n ->
let st = Random.State.make [| 0 |] in
let f m = n < m && m < 2 * n in
try
let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in
QCheck.Test.ctx_reportf ctx "example for %d is %d" n m;
f m
with No_example_found _ -> false)

Expand Down
116 changes: 57 additions & 59 deletions src/QCheck.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1042,6 +1042,7 @@ module TestResult = struct
type 'a counter_ex = {
instance: 'a; (** The counter-example(s) *)
shrink_steps: int; (** How many shrinking steps for this counterex *)
msg_l: string list; (** messages. @since NEXT_RELEASE *)
}

type 'a failed_state = 'a counter_ex list
Expand All @@ -1059,12 +1060,11 @@ module TestResult = struct
mutable count_gen: int; (* number of generated cases *)
collect_tbl: (string, int) Hashtbl.t lazy_t;
stats_tbl: ('a stat * (int, int) Hashtbl.t) list;
msg_l: string list;
}

(* indicate failure on the given [instance] *)
let fail ~small ~steps:shrink_steps res instance =
let c_ex = {instance; shrink_steps; } in
let fail ~msg_l ~small ~steps:shrink_steps res instance =
let c_ex = {instance; shrink_steps; msg_l; } in
match res.state with
| Success -> res.state <- Failed [ c_ex ]
| Error (x, e, bt) ->
Expand All @@ -1086,8 +1086,8 @@ module TestResult = struct
res.state <-
Failed (c_ex :: l)

let error ~steps res instance e bt =
res.state <- Error ({instance; shrink_steps=steps}, e, bt)
let error ~msg_l ~steps res instance e bt =
res.state <- Error ({instance; shrink_steps=steps; msg_l; }, e, bt)

let collect r =
if Lazy.is_val r.collect_tbl then Some (Lazy.force r.collect_tbl) else None
Expand All @@ -1096,27 +1096,12 @@ module TestResult = struct
end

module Test = struct
type test_context = {
ctx_rand: Random.State.t;
mutable ctx_msg: string list;
}

let ctx_rand c = c.ctx_rand
let ctx_messages c = c.ctx_msg
let ctx_report c s = c.ctx_msg <- s :: c.ctx_msg

let ctx_reportf c m =
let buf = Buffer.create 64 in
Format.kfprintf
(fun out -> Format.fprintf out "@?"; ctx_report c (Buffer.contents buf))
(Format.formatter_of_buffer buf) m

type 'a cell = {
count : int; (* number of tests to do *)
long_factor : int; (* multiplicative factor for long test count *)
max_gen : int; (* max number of instances to generate (>= count) *)
max_fail : int; (* max number of failures *)
law : test_context -> 'a -> bool; (* the law to check *)
law : 'a -> bool; (* the law to check *)
arb : 'a arbitrary; (* how to generate/print/shrink instances *)
mutable name : string; (* name of the law *)
}
Expand All @@ -1137,7 +1122,7 @@ module Test = struct
let r = ref 0 in
(fun () -> incr r; Printf.sprintf "anon_test_%d" !r)

let make_cell_full ?(count=default_count) ?(long_factor=1) ?max_gen
let make_cell ?(count=default_count) ?(long_factor=1) ?max_gen
?(max_fail=1) ?small ?(name=fresh_name()) arb law
=
let max_gen = match max_gen with None -> count + 200 | Some x->x in
Expand All @@ -1152,16 +1137,9 @@ module Test = struct
long_factor;
}

let make_cell ?count ?long_factor ?max_gen ?max_fail ?small ?name arb f =
make_cell_full ?count ?long_factor ?max_gen ?max_fail ?small ?name
arb (fun _ctx x -> f x)

let make ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law =
Test (make_cell ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law)

let make_full ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law =
Test (make_cell_full ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law)

(** {6 Running the test} *)

module R = TestResult
Expand Down Expand Up @@ -1195,7 +1173,7 @@ module Test = struct
test: 'a cell;
step: 'a step;
handler : 'a handler;
ctx: test_context;
rand: Random.State.t;
mutable res: 'a TestResult.t;
mutable cur_count: int; (** number of iterations to do *)
mutable cur_max_gen: int; (** maximum number of generations allowed *)
Expand All @@ -1211,7 +1189,7 @@ module Test = struct
let new_input state =
state.res.R.count_gen <- state.res.R.count_gen + 1;
state.cur_max_gen <- state.cur_max_gen - 1;
state.test.arb.gen state.ctx.ctx_rand
state.test.arb.gen state.rand

(* statistics on inputs *)
let collect st i = match st.test.arb.collect with
Expand All @@ -1235,35 +1213,57 @@ module Test = struct
| Shrink_fail
| Shrink_exn of exn

(* triggered by user to fail with a message *)
exception User_fail of string

let fail_report m = raise (User_fail m)

let fail_reportf m =
let buf = Buffer.create 64 in
Format.kfprintf
(fun out -> Format.fprintf out "@?"; fail_report (Buffer.contents buf))
(Format.formatter_of_buffer buf) m

type 'a run_res =
| Run_ok
| Run_fail of string list

let run_law law x =
try
if law x then Run_ok else Run_fail []
with User_fail msg -> Run_fail [msg]

(* try to shrink counter-ex [i] into a smaller one. Returns
shrinked value and number of steps *)
let shrink st (i:'a) (r:res_or_exn) : 'a * res_or_exn * int =
let shrink st (i:'a) (r:res_or_exn) m : 'a * res_or_exn * string list * int =
let is_err = match r with
| Shrink_exn _ -> true | _ -> false
in
let rec shrink_ st i r ~steps =
let rec shrink_ st i r m ~steps =
st.handler st.test.name st.test (Shrunk (steps, i));
match st.test.arb.shrink with
| None -> i, r, steps
| None -> i, r, m, steps
| Some f ->
let count = ref 0 in
let i' = Iter.find_map
(fun x ->
try
incr count;
st.handler st.test.name st.test (Shrinking (steps, !count, x));
if not (st.test.law st.ctx x) && not is_err
then Some (x, Shrink_fail)
else None
with FailedPrecondition | No_example_found _ -> None
| e when is_err -> Some (x, Shrink_exn e) (* fail test (by error) *)
begin match run_law st.test.law x with
| Run_fail m when not is_err -> Some (x, Shrink_fail, m)
| _ -> None
end
with
| FailedPrecondition | No_example_found _ -> None
| e when is_err -> Some (x, Shrink_exn e, []) (* fail test (by error) *)
) (f i)
in
match i' with
| None -> i, r, steps
| Some (i',r') -> shrink_ st i' r' ~steps:(steps+1) (* shrink further *)
| None -> i, r, m, steps
| Some (i',r',m') -> shrink_ st i' r' m' ~steps:(steps+1) (* shrink further *)
in
shrink_ ~steps:0 st i r
shrink_ ~steps:0 st i r m

type 'a check_result =
| CR_continue
Expand All @@ -1273,26 +1273,26 @@ module Test = struct
let handle_exn state input e bt : _ check_result =
(* first, shrink
TODO: shall we shrink differently (i.e. expected only an error)? *)
let input, r, steps = shrink state input (Shrink_exn e) in
let input, r, msg_l, steps = shrink state input (Shrink_exn e) [] in
(* recover exception of shrunk input *)
let e = match r with
| Shrink_fail -> e
| Shrink_exn e' -> e'
in
state.step state.test.name state.test input (Error (e, bt));
R.error state.res ~steps input e bt;
R.error state.res ~steps ~msg_l input e bt;
CR_yield state.res

(* test failed on [input], which means the law is wrong. Continue if
we should. *)
let handle_fail state input : _ check_result =
let handle_fail state input msg_l : _ check_result =
(* first, shrink *)
let input, _, steps = shrink state input Shrink_fail in
let input, _, msg_l, steps = shrink state input Shrink_fail msg_l in
(* fail *)
decr_count state;
state.step state.test.name state.test input Failure;
state.cur_max_fail <- state.cur_max_fail - 1;
R.fail ~small:state.test.arb.small state.res ~steps input;
R.fail ~small:state.test.arb.small state.res ~steps ~msg_l input;
if _is_some state.test.arb.small && state.cur_max_fail > 0
then CR_continue
else CR_yield state.res
Expand All @@ -1313,13 +1313,15 @@ module Test = struct
let res =
try
state.handler state.test.name state.test (Testing input);
if state.test.law state.ctx input
then (
(* one test ok *)
decr_count state;
state.step state.test.name state.test input Success;
CR_continue
) else handle_fail state input
begin match run_law state.test.law input with
| Run_ok ->
(* one test ok *)
decr_count state;
state.step state.test.name state.test input Success;
CR_continue
| Run_fail msg_l ->
handle_fail state input msg_l
end
with
| FailedPrecondition | No_example_found _ ->
state.step state.test.name state.test input FalseAssumption;
Expand All @@ -1343,8 +1345,7 @@ module Test = struct
?(rand=Random.State.make [| 0 |]) cell =
let factor = if long then cell.long_factor else 1 in
let state = {
test=cell;
ctx={ctx_rand=rand; ctx_msg=[]; };
test=cell; rand;
step; handler;
cur_count=factor*cell.count;
cur_max_gen=factor*cell.max_gen;
Expand All @@ -1353,12 +1354,9 @@ module Test = struct
state=R.Success; count=0; count_gen=0;
collect_tbl=lazy (Hashtbl.create 10);
stats_tbl= List.map (fun stat -> stat, Hashtbl.create 10) cell.arb.stats;
msg_l=[];
};
} in
let res = check_state state in
(* update list of messages *)
let res = {res with R.msg_l=List.rev state.ctx.ctx_msg; } in
call cell.name cell res;
res

Expand Down
43 changes: 7 additions & 36 deletions src/QCheck.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -570,6 +570,7 @@ module TestResult : sig
type 'a counter_ex = {
instance: 'a; (** The counter-example(s) *)
shrink_steps: int; (** How many shrinking steps for this counterex *)
msg_l: string list; (** messages. @since NEXT_RELEASE *)
}

type 'a failed_state = 'a counter_ex list
Expand All @@ -587,7 +588,6 @@ module TestResult : sig
mutable count_gen: int; (* Number of generated cases *)
collect_tbl: (string, int) Hashtbl.t lazy_t;
stats_tbl: ('a stat * (int, int) Hashtbl.t) list; (** @since 0.6 *)
msg_l: string list; (** messages. @since NEXT_RELEASE *)
}

val collect : _ t -> (string,int) Hashtbl.t option
Expand All @@ -603,26 +603,15 @@ module Test : sig
type 'a cell
(** A single property test *)

type test_context
(** Context for a single test run, with some internal state
@since NEXT_RELEASE *)

val ctx_rand : test_context -> Random.State.t
(** Current random generator, useful in combination with {!find_example_gen}.
val fail_report : string -> 'a
(** Fail the test with some additional message that will
be reported.
@since NEXT_RELEASE *)

val ctx_report : test_context -> string -> unit
(** Report some message for the current test (typically, pretty-print
some value if the test fails).
val fail_reportf : ('a, Format.formatter, unit, 'b) format4 -> 'a
(** Format version of {!fail_report}
@since NEXT_RELEASE *)

val ctx_reportf : test_context -> ('a, Format.formatter, unit, unit) format4 -> 'a
(** Format version of {!ctx_report}
@since NEXT_RELEASE *)

val ctx_messages : test_context -> string list
(** All reported messages *)

val make_cell :
?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) ->
Expand All @@ -645,16 +634,8 @@ module Test : sig
function, only the smallest failures will be printed.
*)

val make_cell_full :
?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
?small:('a -> int) -> ?name:string -> 'a arbitrary -> (test_context -> 'a -> bool) ->
'a cell
(** More general version of {!make_cell}, with a context given to the
property to check.
@since NEXT_RELEASE *)

val get_arbitrary : 'a cell -> 'a arbitrary
val get_law : 'a cell -> (test_context -> 'a -> bool)
val get_law : 'a cell -> ('a -> bool)
val get_name : _ cell -> string
val set_name : _ cell -> string -> unit

Expand All @@ -678,16 +659,6 @@ module Test : sig
See {!make_cell} for a description of the parameters.
*)

val make_full :
?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
?small:('a -> int) -> ?name:string ->
'a arbitrary ->
(test_context -> 'a -> bool) -> t
(** [make arb prop] builds a test that checks property [prop] on instances
of the generator [arb]. Here [prop] takes an explicit context.
@since NEXT_RELEASE
*)

(** {6 Running the test} *)

exception Test_fail of string * string list
Expand Down
Loading

0 comments on commit 2133238

Please sign in to comment.