From dfeb776c3489ba1ed33a4c21a7439e9bcd9394c0 Mon Sep 17 00:00:00 2001 From: Julien Debon Date: Tue, 1 Jun 2021 14:55:37 +0200 Subject: [PATCH 1/6] TMP Migrate QCheck helpers and test_time --- src/lib_base/test/test_time.ml | 65 +++++++-------- src/lib_test/qcheck2_helpers.ml | 117 ++++++++++++++++++++++++++ src/lib_test/qcheck2_helpers.mli | 137 +++++++++++++++++++++++++++++++ src/lib_test/qcheck_helpers.mli | 2 +- 4 files changed, 285 insertions(+), 36 deletions(-) create mode 100644 src/lib_test/qcheck2_helpers.ml create mode 100644 src/lib_test/qcheck2_helpers.mli diff --git a/src/lib_base/test/test_time.ml b/src/lib_base/test/test_time.ml index 63ab4574ae93..0f6167a361ea 100644 --- a/src/lib_base/test/test_time.ml +++ b/src/lib_base/test/test_time.ml @@ -32,7 +32,7 @@ *) open Time -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module Protocol = struct include Protocol @@ -41,29 +41,28 @@ module Protocol = struct let min_rfc3339_seconds = to_seconds min_rfc3339 - let t_arb = QCheck.map ~rev:to_seconds of_seconds QCheck.int64 + let t_arb = QCheck2.map of_seconds QCheck2.int64 let rfc3339_compatible_t_arb = let within_rfc3339 = - QCheck.map - ~rev:to_seconds + QCheck2.map of_seconds (int64_range min_rfc3339_seconds max_rfc3339_seconds) in - QCheck.frequency + QCheck2.frequency [ (97, within_rfc3339); - (1, QCheck.always max_rfc3339); - (1, QCheck.always min_rfc3339); - (1, QCheck.always epoch); + (1, QCheck2.always max_rfc3339); + (1, QCheck2.always min_rfc3339); + (1, QCheck2.always epoch); ] let pp fmt t = Format.fprintf fmt "%Lx" (to_seconds t) let add_diff_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"Protocol.[add|diff] roundtrip" - (QCheck.pair t_arb QCheck.int64) + (QCheck2.pair t_arb QCheck2.int64) (fun (some_time, delta) -> let other_time = add some_time delta in let actual = diff other_time some_time in @@ -75,16 +74,16 @@ module Protocol = struct ()) let diff_add_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"Protocol.[diff|add] roundtrip" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (some_time, other_time) -> let delta = diff other_time some_time in let actual = add some_time delta in qcheck_eq' ~pp ~eq:equal ~expected:other_time ~actual ()) let encoding_binary_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"Protocol.encoding roundtrips in binary" t_arb (fun t -> @@ -93,7 +92,7 @@ module Protocol = struct qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) let encoding_json_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"Protocol.encoding roundtrips in JSON" t_arb (fun t -> @@ -102,12 +101,12 @@ module Protocol = struct qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) let encoding_to_notation_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"Protocol.[to|of]_notation roundtrip in RFC3339 range" rfc3339_compatible_t_arb (fun t -> to_notation t |> of_notation |> function - | None -> QCheck.Test.fail_report "Failed to roundtrip notation" + | None -> QCheck2.Test.fail_report "Failed to roundtrip notation" | Some actual -> qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) let tests = @@ -124,16 +123,13 @@ module System = struct open System (** Arbitrary of {!t} from usual time fragments year-month-day hour-minute-second, parsed through {!Ptime.of_date_time}. *) - let t_ymdhms_arb : t QCheck.arbitrary = - let open QCheck in - let rev t = - Option.get t |> Ptime.to_date_time |> fun (date, (time, _)) -> (date, time) - in + let t_ymdhms_arb : t QCheck2.arbitrary = + let open QCheck2 in of_option_arb (pair (triple (0 -- 9999) (1 -- 12) (1 -- 31)) (triple (0 -- 23) (0 -- 59) (0 -- 60)) - |> map ~rev (fun (date, time) -> Ptime.of_date_time (date, (time, 0)))) + |> map (fun (date, time) -> Ptime.of_date_time (date, (time, 0)))) |> set_print (Format.asprintf "%a" pp_hum) let (min_day, min_ps) = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps @@ -141,17 +137,16 @@ module System = struct let (max_day, max_ps) = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps (** Arbitrary of {!t} from days + picoseconds, parsed through {!Ptime.Span.of_d_ps}. *) - let t_dps_arb : t QCheck.arbitrary = - let open QCheck in - let rev t = Ptime.to_span t |> Ptime.Span.to_d_ps in + let t_dps_arb : t QCheck2.arbitrary = + let open QCheck2 in pair (min_day -- max_day) (int64_range min_ps max_ps) - |> map ~rev (fun (d, ps) -> + |> map (fun (d, ps) -> Ptime.Span.of_d_ps (d, ps) |> Option.get |> Ptime.of_span |> Option.get) (* But please keep using a nice pretty printer... We can probably write in the future a generic function that mixes features of [map ~rev] and [map_keep_input ~print] to only pass the monotonic transformation and the pretty printer, instead of manually writing [rev]. *) |> set_print (Format.asprintf "%a" pp_hum) - let t_arb = QCheck.choose [t_ymdhms_arb; t_dps_arb] + let t_arb = QCheck2.choose [t_ymdhms_arb; t_dps_arb] (** Check that the span is smaller than 1 second (useful for Protocol time roundtrips as Protocol time precision is the second). *) let is_small delta = @@ -160,12 +155,12 @@ module System = struct 0 let to_protocol_of_protocol_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"System.[to|of]_protocol roundtrip modulo option" t_arb (fun t -> match to_protocol t |> of_protocol_opt with - | None -> QCheck.Test.fail_report "Failed roundtrip" + | None -> QCheck2.Test.fail_report "Failed roundtrip" | Some actual -> let delta = Ptime.Span.abs @@ Ptime.diff t actual in is_small delta) @@ -178,11 +173,11 @@ module System = struct of the RFC3339 time range) *) let of_protocol_to_protocol_roundtrip_or_outside_rfc3339 = - QCheck.Test.make + QCheck2.Test.make ~name:"System.[of|to]_protocol roundtrip or outside RFC3339 range" (* Use both generators, otherwise statistically, we will almost never hit the RFC3339 time range. *) - (QCheck.choose [Protocol.t_arb; Protocol.rfc3339_compatible_t_arb]) + (QCheck2.choose [Protocol.t_arb; Protocol.rfc3339_compatible_t_arb]) (fun protocol_time -> match of_protocol_opt protocol_time with | None -> @@ -198,7 +193,7 @@ module System = struct ()) let rfc_encoding_binary_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"System.rfc_encoding roundtrips in binary modulo precision" t_arb (fun t -> @@ -208,7 +203,7 @@ module System = struct is_small delta) let rfc_encoding_json_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"System.rfc_encoding roundtrips in JSON modulo precision" t_arb (fun t -> @@ -218,7 +213,7 @@ module System = struct is_small delta) let encoding_binary_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"System.encoding roundtrips in binary modulo precision" t_arb (fun t -> @@ -228,7 +223,7 @@ module System = struct is_small delta) let encoding_json_roundtrip = - QCheck.Test.make + QCheck2.Test.make ~name:"System.encoding roundtrips in JSON modulo precision" t_arb (fun t -> diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml new file mode 100644 index 000000000000..fed19e79a46d --- /dev/null +++ b/src/lib_test/qcheck2_helpers.ml @@ -0,0 +1,117 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let qcheck_wrap ?verbose ?long ?rand = + List.map (QCheck_alcotest.to_alcotest ?verbose ?long ?rand) + +let qcheck_eq ?pp ?cmp ?eq expected actual = + let pass = + match (eq, cmp) with + | (Some eq, _) -> + eq expected actual + | (None, Some cmp) -> + cmp expected actual = 0 + | (None, None) -> + Stdlib.compare expected actual = 0 + in + if pass then true + else + match pp with + | None -> + QCheck2.Test.fail_reportf + "@[Values are not equal, but no pretty printer was provided.@]" + | Some pp -> + QCheck2.Test.fail_reportf + "@[Equality check failed!@,expected:@,%a@,actual:@,%a@]" + pp + expected + pp + actual + +let qcheck_eq' ?pp ?cmp ?eq ~expected ~actual () = + qcheck_eq ?pp ?cmp ?eq expected actual + +let int64_range a b = + let open QCheck2 in + let int64_range_gen st = + let range = Int64.sub b a in + let raw_val = Random.State.int64 st range in + let res = Int64.add a raw_val in + assert (a <= res && res <= b) ; + res + in + let gen = Gen.make_primitive + ~gen:int64_range_gen +(* TODO expose/reimplement QCheck2 logic of shrinking towards [0L] while respecting limits *) + ~shrink:(Shrink.int64_towards a) +in int64 |> set_gen gen + +let rec of_option_gen gen = + let open QCheck2.Gen in + gen >>= function + | None -> of_option_gen gen + | Some a -> pure a + +let of_option_arb arb = + let open QCheck2 in + let gen = of_option_gen (get_gen arb) in + let print = Option.map (fun print_opt a -> print_opt (Some a)) (get_print arb) in + let collect = + Option.map (fun collect_opt a -> collect_opt (Some a)) (get_collect arb) + in + let stats = + List.map (fun (s, f_opt) -> (s, fun a -> f_opt (Some a))) (get_stats arb) + in + QCheck2.make ?print ?collect ~stats gen + +let uint16 = QCheck2.(0 -- 65535) + +let int16 = QCheck2.(-32768 -- 32767) + +let bytes_arb = QCheck2.(map Bytes.of_string string) + +module MakeMapArb (Map : Stdlib.Map.S) = struct + open QCheck2 + + let arb_of_size (size_gen : int Gen.t) (key_arb : Map.key arbitrary) + (val_arb : 'v arbitrary) : 'v Map.t arbitrary = + map + (fun entries -> List.to_seq entries |> Map.of_seq) + (list_of_size size_gen @@ pair key_arb val_arb) + + let arb (key_arb : Map.key arbitrary) (val_arb : 'v arbitrary) : + 'v Map.t arbitrary = + arb_of_size Gen.small_nat key_arb val_arb + + let gen_of_size (size_gen : int Gen.t) (key_gen : Map.key Gen.t) + (val_gen : 'v Gen.t) : 'v Map.t Gen.t = + let open Gen in + map + (fun entries -> List.to_seq entries |> Map.of_seq) + (list_size size_gen @@ pair key_gen val_gen) + + let gen (key_gen : Map.key Gen.t) (val_gen : 'v Gen.t) : 'v Map.t Gen.t = + gen_of_size Gen.small_nat key_gen val_gen +end diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli new file mode 100644 index 000000000000..1de1012e29f4 --- /dev/null +++ b/src/lib_test/qcheck2_helpers.mli @@ -0,0 +1,137 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Nomadic Labs *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Wrap QCheck tests into Alcotests. *) +val qcheck_wrap : + ?verbose:bool -> + ?long:bool -> + ?rand:Random.State.t -> + QCheck2.Test.t list -> + unit Alcotest.test_case list + +(** [qcheck_eq pp cmp eq a b] evaluates whether [a] and [b] are equal, and if they + are not, raises a failure and prints an error message. + Equality is evaluated as follows: + - use a provided [eq] + - if no [eq] is provided, use a provided [cmp] + - if neither [eq] nor [cmp] is provided, use {!Stdlib.compare} + + If [pp] is provided, use this to print [x] and [y] if they are not equal. *) +val qcheck_eq : + ?pp:(Format.formatter -> 'a -> unit) -> + ?cmp:('a -> 'a -> int) -> + ?eq:('a -> 'a -> bool) -> + 'a -> + 'a -> + bool + +(** Labeled variant of {!qcheck_eq}. The [unit] argument is necessary as OCaml + requires at least one positional (non-labeled) argument in case of optional + arguments. *) +val qcheck_eq' : + ?pp:(Format.formatter -> 'a -> unit) -> + ?cmp:('a -> 'a -> int) -> + ?eq:('a -> 'a -> bool) -> + expected:'a -> + actual:'a -> + unit -> + bool + +(** [int64_range a b] generates an [int64] between [a] inclusive and [b] inclusive. + + Poorman's implementation until https://github.com/c-cube/qcheck/issues/105 is done. + + This probably spectacularly crashes if [(b - a) > Int64.max_int]. *) +val int64_range : int64 -> int64 -> int64 QCheck2.arbitrary + +(** [of_option_gen gen] converts a generator [gen] of optional values into a + generator of values by rerunning the generator if the generated value + was a [None] until a [Some] is generated. + + Be careful: if [None] is always returned, this hangs forever! *) +val of_option_gen : 'a option QCheck2.Gen.t -> 'a QCheck2.Gen.t + +(** [of_option_arb arb] converts an arbitrary [arb] of optional values into + an arbitrary of values. + + - Generation of values is delegated to {!of_option_gen} (retries on + [None] values until a [Some] is generated). + - Shrinking uses the input shrinker but ignores [None] values. + + Be careful: if [None] is always returned, this hangs forever! +*) +val of_option_arb : 'a option QCheck2.arbitrary -> 'a QCheck2.arbitrary + +(** [uint16] generates an unsigned int16 arbitrary + + - Generation of values is delegated to {!int_range} *) +val uint16 : int QCheck2.arbitrary + +(** [int16] generates a signed int16 arbitrary + + - Generation of values is delegated to {!int_range} *) +val int16 : int QCheck2.arbitrary + +(** [bytes_arb] is an arbitrary of bytes. *) +val bytes_arb : bytes QCheck2.arbitrary + +(** Map-related arbitraries/generators. *) +module MakeMapArb (Map : Stdlib.Map.S) : sig + (** [arb_of_size size_gen key_arb val_arb] is an arbitrary of Map + where the keys are generated with [key_arb] and the values with [val_arb]. + + The number of entries in the map is decided by [size_gen]. + + The arbitrary shrinks on the number of entries as well as on entries + if either the key or value arbitrary has a shrinker. *) + val arb_of_size : + int QCheck2.Gen.t -> + Map.key QCheck2.arbitrary -> + 'v QCheck2.arbitrary -> + 'v Map.t QCheck2.arbitrary + + (** [arb key_arb val_arb] is an arbitrary of Map where the keys are + generated with [key_arb] and the values with [val_arb]. + + The arbitrary shrinks on the number of entries as well as on entries + if either the key or value arbitrary has a shrinker. *) + val arb : + Map.key QCheck2.arbitrary -> + 'v QCheck2.arbitrary -> + 'v Map.t QCheck2.arbitrary + + (** [gen_of_size size_gen key_gen val_gen] is a generator of Map where the keys + are generated with [key_gen] and the values with [val_gen]. + The number of entries in the map is decided by [size_gen]. *) + val gen_of_size : + int QCheck2.Gen.t -> + Map.key QCheck2.Gen.t -> + 'v QCheck2.Gen.t -> + 'v Map.t QCheck2.Gen.t + + (** [gen key_gen arb_gen] is a generator of Map where the keys + are generated with [key_arb] and the values with [val_arb]. *) + val gen : Map.key QCheck2.Gen.t -> 'v QCheck2.Gen.t -> 'v Map.t QCheck2.Gen.t +end diff --git a/src/lib_test/qcheck_helpers.mli b/src/lib_test/qcheck_helpers.mli index b768aeb2c841..3ba9da1c29d0 100644 --- a/src/lib_test/qcheck_helpers.mli +++ b/src/lib_test/qcheck_helpers.mli @@ -28,7 +28,7 @@ val qcheck_wrap : ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> - QCheck.Test.t list -> + QCheck2.Test.t list -> unit Alcotest.test_case list (** [qcheck_eq pp cmp eq a b] evaluates whether [a] and [b] are equal, and if they -- GitLab From 6357a5839e06973f1dbf13a7896cb7a2718a163f Mon Sep 17 00:00:00 2001 From: Julien Debon Date: Tue, 1 Jun 2021 15:01:12 +0200 Subject: [PATCH 2/6] Migrate saturation_fuzzing.ml --- .../lib_protocol/test/saturation_fuzzing.ml | 46 +++++++++---------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml b/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml index 019a08f0926e..f020bd802615 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml @@ -31,23 +31,23 @@ *) open Protocol.Saturation_repr -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_arb = of_option_arb @@ QCheck.map of_int_opt QCheck.int +let unsatured_arb = of_option_arb @@ QCheck2.map of_int_opt QCheck2.int (** The general generator for [t]: generates both unsaturated values and [saturated]. *) -let t_arb : may_saturate t QCheck.arbitrary = - QCheck.frequency [(1, QCheck.always saturated); (4, unsatured_arb)] +let t_arb : may_saturate t QCheck2.arbitrary = + QCheck2.frequency [(1, QCheck2.always saturated); (4, unsatured_arb)] (* Test. * Tests that [add] commutes. *) let test_add_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 = t2 + t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in let t2_plus_t1 = add t2 t1 in @@ -57,9 +57,9 @@ let test_add_commutes = * Tests that [mul] commutes. *) let test_mul_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 * t2 = t2 * t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_times_t2 = mul t1 t2 in let t2_times_t1 = mul t2 t1 in @@ -69,7 +69,7 @@ let test_mul_commutes = * Tests that [zero] is neutral for [add]. *) let test_add_zero = - QCheck.Test.make ~name:"t + 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t + 0 = t" t_arb (fun t -> let t_plus_zero = add t zero in qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) @@ -77,9 +77,9 @@ let test_add_zero = * Tests that t1 + t2 >= t1 *) let test_add_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in t1_plus_t2 >= t1) @@ -89,7 +89,7 @@ let test_add_neq = *) let test_mul_one = let one = safe_int 1 in - QCheck.Test.make ~name:"t * 1 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 1 = t" t_arb (fun t -> let t_times_one = mul t one in qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) @@ -97,7 +97,7 @@ let test_mul_one = * Tests that [t] times [0] equals [0]. *) let test_mul_zero = - QCheck.Test.make ~name:"t * 0 = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 0 = 0" t_arb (fun t -> let t_times_zero = mul t zero in qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) @@ -105,7 +105,7 @@ let test_mul_zero = * Tests that [t] [sub] [zero] equals [t]. *) let test_sub_zero = - QCheck.Test.make ~name:"t - 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t - 0 = t" t_arb (fun t -> let t_sub_zero = sub t zero in qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) @@ -113,7 +113,7 @@ let test_sub_zero = * Tests that [t] [sub] [t] equals [zero]. *) let test_sub_itself = - QCheck.Test.make ~name:"t - t = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t - t = 0" t_arb (fun t -> let t_sub_t = sub t t in qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) @@ -121,9 +121,9 @@ let test_sub_itself = * Tests that t1 - t2 <= t1 *) let test_sub_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_minus_t2 = sub t1 t2 in t1_minus_t2 <= t1) @@ -132,9 +132,9 @@ let test_sub_neq = * Tests that (t1 + t2) - t2 <= t1 *) let test_add_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 + t2) - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let lhs = sub (add t1 t2) t2 in lhs <= t1) @@ -143,9 +143,9 @@ let test_add_sub = * Tests that (t1 - t2) + t2 >= t1 *) let test_sub_add = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 - t2) + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let lhs = add (sub t1 t2) t2 in lhs >= t1) @@ -154,12 +154,12 @@ let test_sub_add = * Tests that [saturated] >= t *) let test_leq_saturated = - QCheck.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) + QCheck2.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) (* Test. * Tests that [zero] <= t *) -let test_geq_zero = QCheck.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) +let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) let tests_add = [test_add_commutes; test_add_zero; test_add_neq] -- GitLab From 724d62d9ce5ff505bd18604c08887e55cd5153d9 Mon Sep 17 00:00:00 2001 From: Julien Debon Date: Tue, 1 Jun 2021 15:02:48 +0200 Subject: [PATCH 3/6] Migrate test_gas_properties.ml --- .../lib_protocol/test/test_gas_properties.ml | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml index 3906d946d3be..32eff94aaac5 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml @@ -31,7 +31,7 @@ *) open Protocol -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** Extract a Tezos result for compatibility with QCheck. *) let extract_qcheck_result = function @@ -87,8 +87,8 @@ let test_consume_commutes (start, cost1, cost2) = (Gas.consumed ~since:start ~until:branch2)) ) (** Arbitrary context with a gas limit of 100_000_000. *) -let context_arb : Alpha_context.t QCheck.arbitrary = - QCheck.always +let context_arb : Alpha_context.t QCheck2.arbitrary = + QCheck2.always (Lwt_main.run ( Context.init 1 >>=? fun (b, _contracts) -> Incremental.begin_construction b >|=? fun inc -> @@ -101,9 +101,9 @@ let context_arb : Alpha_context.t QCheck.arbitrary = | Error _ -> assert false) (** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = +let gas_cost_arb : Alpha_context.Gas.cost QCheck2.arbitrary = let open Alpha_context.Gas in - let open QCheck in + let open QCheck2 in let rand = 0 -- 1000 in let safe_rand = map Saturation_repr.safe_int rand in choose @@ -119,20 +119,20 @@ let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = let tests = [ - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming commutes" - QCheck.(triple context_arb gas_cost_arb gas_cost_arb) + QCheck2.(triple context_arb gas_cost_arb gas_cost_arb) test_consume_commutes; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming [free] consumes nothing" context_arb test_free_consumption; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"[free] is the neutral element of Gas addition" - QCheck.(pair context_arb gas_cost_arb) + QCheck2.(pair context_arb gas_cost_arb) test_free_neutral; ] -- GitLab From e7edbc97292baf6bead20ea000899abf0c0438c9 Mon Sep 17 00:00:00 2001 From: Julien Debon Date: Thu, 3 Jun 2021 11:27:38 +0200 Subject: [PATCH 4/6] TMP migrate all remaining tests to QCheck2 --- src/lib_base/test/test_p2p_addr.ml | 38 +++--- .../test/test_fuzzing_helpers.ml | 49 ++++---- .../test/test_fuzzing_list.ml | 4 +- .../test/test_fuzzing_option.ml | 16 +-- .../test/test_fuzzing_seq.ml | 4 +- .../test/test_fuzzing_seq_tiered.ml | 12 +- .../test/test_fuzzing_set.ml | 4 +- .../test/test_fuzzing_tests.ml | 38 +++--- .../test/test_mem_context_array_theory.ml | 39 +++---- src/lib_proxy/test/light_lib.ml | 2 +- src/lib_proxy/test/test_fuzzing_light.ml | 109 +++++++----------- src/lib_rpc_http/test/test_rpc_http.ml | 18 +-- .../test_synchronisation_heuristic_fuzzy.ml | 16 +-- src/lib_stdlib/test/test_bounded_heap.ml | 12 +- src/lib_stdlib/test/test_tzList.ml | 8 +- src/lib_test/qcheck2_helpers.ml | 23 ++-- .../lib_protocol/test/test_tez_repr.ml | 29 ++--- .../lib_protocol/test/saturation_fuzzing.ml | 46 ++++---- .../lib_protocol/test/test_gas_properties.ml | 20 ++-- .../lib_protocol/test/test_tez_repr.ml | 29 ++--- 20 files changed, 239 insertions(+), 277 deletions(-) diff --git a/src/lib_base/test/test_p2p_addr.ml b/src/lib_base/test/test_p2p_addr.ml index ed89fc1c8a35..d9a9686d7144 100644 --- a/src/lib_base/test/test_p2p_addr.ml +++ b/src/lib_base/test/test_p2p_addr.ml @@ -30,7 +30,7 @@ Subject: Check the parsing of addresses with domain names *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (* Note, this is a duplicate of some functions from Tezos_base_test_helpers.Tz_arbitrary. Unfortunately it's impossible to @@ -38,18 +38,18 @@ open Lib_test.Qcheck_helpers tezos-base-test-helpers and tezos-base packages, which opam would not allow. *) module Arbitrary = struct - open QCheck + open QCheck2 let port = uint16 - let port_opt = QCheck.option port + let port_opt = QCheck2.option port - (* could not craft a [p2p_identity QCheck.gen], we use instead a + (* could not craft a [p2p_identity QCheck2.gen], we use instead a constant [unit -> p2p_identity] which will be applied at each testing points. *) let peer_id = - QCheck.option QCheck.(map P2p_identity.generate_with_pow_target_0 unit) + QCheck2.option QCheck2.(map P2p_identity.generate_with_pow_target_0 unit) let ipv4 = map ~rev:Ipaddr.V4.to_int32 Ipaddr.V4.of_int32 int32 @@ -59,17 +59,17 @@ module Arbitrary = struct map ~rev:Ipaddr.V6.to_int64 Ipaddr.V6.of_int64 (pair int64 int64) |> set_print Ipaddr.V6.to_string - let ipv4t = QCheck.triple ipv4 port_opt peer_id + let ipv4t = QCheck2.triple ipv4 port_opt peer_id - let ipv6t = QCheck.triple ipv6 port_opt peer_id + let ipv6t = QCheck2.triple ipv6 port_opt peer_id let ipv4_as_v6 = - let open QCheck in + let open QCheck2 in map Ipaddr.v6_of_v4 ipv4 |> set_print Ipaddr.V6.to_string - let ip = QCheck.choose [ipv4_as_v6; ipv6] + let ip = QCheck2.choose [ipv4_as_v6; ipv6] - let p2p_point_id_t = QCheck.pair ip port + let p2p_point_id_t = QCheck2.pair ip port end (* To check the round trip property we change the printer for ipv4 and @@ -82,20 +82,20 @@ let pp_addr_port_id fmt {P2p_point.Id.addr; port; peer_id} = Option.iter (fprintf fmt "#%a" P2p_peer_id.pp) peer_id let addr_port_id_v4 = - QCheck.map + QCheck2.map (fun (ip, port, peer_id) -> let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = Ipaddr.V4.to_string ip; port; peer_id}) Arbitrary.ipv4t - |> QCheck.set_print (Format.asprintf "%a" pp_addr_port_id) + |> QCheck2.set_print (Format.asprintf "%a" pp_addr_port_id) let addr_port_id_v6 = - QCheck.map + QCheck2.map (fun (ip, port, peer_id) -> let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = P2p_addr.to_string ip; port; peer_id}) Arbitrary.ipv6t - |> QCheck.set_print (Format.asprintf "%a" pp_addr_port_id) + |> QCheck2.set_print (Format.asprintf "%a" pp_addr_port_id) let remove_brackets addr = let len = String.length addr in @@ -132,7 +132,7 @@ let ok_points = process_points "points.ok" let ko_points = process_points "points.ko" let ip_to_string_from_string = - let open QCheck in + let open QCheck2 in Test.make ~name:"Base.P2p_addr.ip.to-string-from-string" Arbitrary.ip @@ -144,7 +144,7 @@ let ip_to_string_from_string = | Some t' -> qcheck_eq' ~pp ~expected:t ~actual:t' ()) let ipv6_to_string_from_string = - let open QCheck in + let open QCheck2 in Test.make ~name:"Base.P2p_point.addr_port_id.ipv6.to-string-from-string-ok" addr_port_id_v6 @@ -161,7 +161,7 @@ let ipv6_to_string_from_string = | Ok res -> qcheck_eq' ~pp:pp_addr_port_id ~eq ~expected:t ~actual:res ()) let ipv4_to_string_from_string = - let open QCheck in + let open QCheck2 in Test.make ~name:"Base.P2p_point.addr_port_id.ipv4.to-string-from-string" addr_port_id_v4 @@ -209,7 +209,7 @@ let domain_to_string_from_string_ko () = ko_points f let encode_decode = - let open QCheck in + let open QCheck2 in Test.make ~name:"Base.P2p_point.id.encode-decode roundtrip" Arbitrary.p2p_point_id_t @@ -226,7 +226,7 @@ let encode_decode = (51) minus the 4 bytes used in the header to store the size, at the beginning (hence 47). This corresponds to an IPv6 with port and the optional enclosing brackets. *) let p2p_point_encoding_eager_fail = - let open QCheck in + let open QCheck2 in let max_binary_size_point = 47 in let max_possible_size_on_4_bytes = Int32.(to_int max_int) in Test.make diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index 0cde750f245e..ffb455f735fd 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -24,7 +24,7 @@ (*****************************************************************************) open Support.Lib.Monad -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers let rec log_pause n = if n <= 0 then Lwt.return_unit @@ -36,11 +36,11 @@ let rec log_pause n = module Fn = struct let lambda s l = - let open QCheck in + let open QCheck2 in make ~print:(fun _ -> s) (Gen.return l) let pred = - QCheck.oneof + QCheck2.oneof [ lambda "(fun x _ -> x > 0)" (fun x _ -> x > 0); lambda "(fun _ y -> y < 0)" (fun _ y -> y < 0); @@ -50,31 +50,33 @@ module Fn = struct ] let basic_int = - QCheck.(oneof [int; Gen.return 0 |> make; Gen.return 1 |> make]) + QCheck2.(oneof [int; Gen.return 0 |> make; Gen.return 1 |> make]) let arith = - let open QCheck in + let open QCheck2 in let module O = Observable in fun2 O.int O.int int (* combinators *) - let e (cond, QCheck.Fun (_, ok), QCheck.Fun (_, error)) x y = + let e (cond, QCheck2.Fun (_, ok), QCheck2.Fun (_, error)) x y = if cond x y then Ok (ok x y) else Error (error x y) - let arith_e = QCheck.(map e (triple pred arith arith)) + let arith_e = QCheck2.(map e (triple pred arith arith)) - let s (QCheck.Fun (_, pauses), QCheck.Fun (_, fn)) x y = + let s (QCheck2.Fun (_, pauses), QCheck2.Fun (_, fn)) x y = log_pause (pauses x y) >|= fun () -> fn x y - let arith_s = QCheck.(map s (pair arith arith)) + let arith_s = QCheck2.(map s (pair arith arith)) let es - (cond, QCheck.Fun (_, pauses), QCheck.Fun (_, ok), QCheck.Fun (_, error)) - x y = + ( cond, + QCheck2.Fun (_, pauses), + QCheck2.Fun (_, ok), + QCheck2.Fun (_, error) ) x y = log_pause (pauses x y) >|= fun () -> if cond x y then Ok (ok x y) else Error (error x y) - let arith_es = QCheck.(map es (quad pred arith arith arith)) + let arith_es = QCheck2.(map es (quad pred arith arith arith)) end (* Wrappers for generated functions *) @@ -402,19 +404,16 @@ end (* Data generators (we use lists of integers) *) -let one = QCheck.int +let one = QCheck2.int -let many = QCheck.(list int) +let many = QCheck2.(list int) -let maybe = QCheck.(option int) +let maybe = QCheck2.(option int) let manymany = - let open QCheck in + let open QCheck2 in oneof - [ - map ~rev:(fun (input, _) -> input) (fun input -> (input, input)) (list int); - pair (list int) (list int); - ] + [map (fun input -> (input, input)) (list int); pair (list int) (list int)] (* equality and lwt/error variants *) @@ -468,13 +467,13 @@ let eq_es_ep ?pp es ep = in if trace_ep_has_error_es then true else - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "%d not in %a" error_es (Support.Test_trace.pp Format.pp_print_int) trace_ep - | (Ok _, Error _) -> QCheck.Test.fail_report "Ok _ is not Error _" - | (Error _, Ok _) -> QCheck.Test.fail_report "Error _ is not Ok _" ) + | (Ok _, Error _) -> QCheck2.Test.fail_report "Ok _ is not Error _" + | (Error _, Ok _) -> QCheck2.Test.fail_report "Error _ is not Ok _" ) let eq_ep ?pp a b = Lwt_main.run @@ -484,8 +483,8 @@ let eq_ep ?pp a b = | (Ok ok_es, Ok ok_ep) -> eq ?pp ok_es ok_ep | (Error _, Error _) -> true (* Not as precise as we could be, but precise enough *) - | (Ok _, Error _) -> QCheck.Test.fail_report "Ok _ is not Error _" - | (Error _, Ok _) -> QCheck.Test.fail_report "Error _ is not Ok _" ) + | (Ok _, Error _) -> QCheck2.Test.fail_report "Ok _ is not Error _" + | (Error _, Ok _) -> QCheck2.Test.fail_report "Error _ is not Ok _" ) module PP = struct let int = Format.pp_print_int diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml index 6ec69ac136e2..74d159334cb0 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_list.ml @@ -24,7 +24,7 @@ (*****************************************************************************) open Test_fuzzing_tests -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module ListWithBase = struct type 'a elt = 'a @@ -41,7 +41,7 @@ module ListWithBase = struct end module type F = functor (S : module type of ListWithBase) -> sig - val tests : QCheck.Test.t list + val tests : QCheck2.Test.t list end let wrap (name, (module Test : F)) = diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml index 4809f4b0058b..1a31a080411c 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml @@ -30,7 +30,7 @@ open Test_fuzzing_helpers (* First-1: testing equivalence of iter* *) module TestIter = struct - open QCheck + open QCheck2 open Monad let iter = @@ -87,7 +87,7 @@ end (* First-2: testing equivalence of filter* *) module TestFilter = struct - open QCheck + open QCheck2 open Monad let filter = @@ -134,7 +134,7 @@ end (* First-3: testing equivalence of filter_map* *) module TestFilterMap = struct - open QCheck + open QCheck2 open Monad let filter_map = @@ -206,7 +206,7 @@ end (* First-4: testing equivalence of map* *) module TestMap = struct - open QCheck + open QCheck2 open Monad let map = @@ -251,10 +251,10 @@ end let () = let tests = [ - ("iter*", Lib_test.Qcheck_helpers.qcheck_wrap TestIter.tests); - ("filter*", Lib_test.Qcheck_helpers.qcheck_wrap TestFilter.tests); - ("filter_map*", Lib_test.Qcheck_helpers.qcheck_wrap TestFilterMap.tests); - ("map*", Lib_test.Qcheck_helpers.qcheck_wrap TestIter.tests); + ("iter*", Lib_test.Qcheck2_helpers.qcheck_wrap TestIter.tests); + ("filter*", Lib_test.Qcheck2_helpers.qcheck_wrap TestFilter.tests); + ("filter_map*", Lib_test.Qcheck2_helpers.qcheck_wrap TestFilterMap.tests); + ("map*", Lib_test.Qcheck2_helpers.qcheck_wrap TestIter.tests); ] in Alcotest.run "Option" tests diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml index 921ca0a6d026..f70ea09e6ce5 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq.ml @@ -24,7 +24,7 @@ (*****************************************************************************) open Test_fuzzing_tests -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module SeqWithBase = struct type 'a elt = 'a @@ -41,7 +41,7 @@ module SeqWithBase = struct end module type F = functor (S : module type of SeqWithBase) -> sig - val tests : QCheck.Test.t list + val tests : QCheck2.Test.t list end let wrap (name, (module Test : F)) = diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml index fe5409c0c794..3abd0e146e58 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml @@ -66,7 +66,7 @@ module TieredSeq : TIER with type t = int Seq.t = struct end module TestIter (Tier : TIER) = struct - open QCheck + open QCheck2 open Monad let test_iter = @@ -168,7 +168,7 @@ module TestedSeq_es = TestIter (TieredSeq_es) (* testing iter_ep is equivalent in two separate tiers NOTE: only for [Seq_s] *) let iter_ep = - let open QCheck in + let open QCheck2 in Test.make ~name:(Format.asprintf "Seq{,_s}.iter_ep") (quad Test_fuzzing_helpers.Fn.arith one one many) @@ -185,7 +185,7 @@ let iter_ep = >>=? fun () -> Monad.return !acc)) let iter_p = - let open QCheck in + let open QCheck2 in Test.make ~name:(Format.asprintf "Seq{,_s}.iter_p") (quad Test_fuzzing_helpers.Fn.arith one one many) @@ -203,7 +203,7 @@ let iter_p = let wrap (name, (module Tier : TIER)) = let module M = TestIter (Tier) in - (name, Lib_test.Qcheck_helpers.qcheck_wrap M.tests) + (name, Lib_test.Qcheck2_helpers.qcheck_wrap M.tests) let () = let name = "Test_fuzzing_seq_tiered" in @@ -218,8 +218,8 @@ let () = let tests = tests @ [ - ("iter_p", Lib_test.Qcheck_helpers.qcheck_wrap [iter_p]); - ("iter_ep", Lib_test.Qcheck_helpers.qcheck_wrap [iter_ep]); + ("iter_p", Lib_test.Qcheck2_helpers.qcheck_wrap [iter_p]); + ("iter_ep", Lib_test.Qcheck2_helpers.qcheck_wrap [iter_ep]); ] in Alcotest.run name tests diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml index 661877013e93..a51675b94cb6 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_set.ml @@ -24,7 +24,7 @@ (*****************************************************************************) open Test_fuzzing_tests -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module IntSet : Support.Lib.Set.S with type elt = int = struct include Support.Lib.Set.Make (Int) @@ -57,7 +57,7 @@ module SetWithBase = struct end module type F = functor (S : module type of SetWithBase) -> sig - val tests : QCheck.Test.t list + val tests : QCheck2.Test.t list end let wrap (name, (module Test : F)) = diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index 2c2b9ba6605d..b0d6ceec686b 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -43,7 +43,7 @@ open Support.Lib.Monad person debugging the code to write additional specialised tests. *) module type Test = sig - val tests : QCheck.Test.t list + val tests : QCheck2.Test.t list end module TestIterFold (M : sig @@ -53,7 +53,7 @@ module TestIterFold (M : sig include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let iter_fold_left = Test.make @@ -111,7 +111,7 @@ module TestRevMapRevMap (M : sig include Traits.REVMAP_PARALLEL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let rev_map = Test.make @@ -178,7 +178,7 @@ module TestIterAgainstStdlibList (M : sig include Traits.ITER_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_iter (fn, init, input) = let acc = ref init in @@ -234,7 +234,7 @@ module TestIteriAgainstStdlibList (M : sig include Traits.ITERI_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_iteri (fn, init, input) = let acc = ref init in @@ -295,7 +295,7 @@ end) : Test = struct we can only test iteration if the accumulator moves monotonically and the stepper doesn't depend on the accumulator. We do this here with a custom stepper. *) - open QCheck + open QCheck2 let with_stdlib_iter init (fn, const, input) = let acc = ref init in @@ -380,7 +380,7 @@ module TestMapAgainstStdlibList (M : sig include Traits.MAP_SEQUENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_map (fn, const, input) = Stdlib.List.map (MapOf.fn const fn) input @@ -429,7 +429,7 @@ module TestMappAgainstStdlibList (M : sig include Traits.MAP_PARALLEL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_map (fn, const, input) = Stdlib.List.map (MapOf.fn const fn) input @@ -460,7 +460,7 @@ module TestFoldAgainstStdlibList (M : sig include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_fold_left (fn, init, input) = Stdlib.List.fold_left (FoldOf.fn fn) init input @@ -509,7 +509,7 @@ module TestFoldMonotonicAgainstStdlibList (M : sig include FOLDOOO_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_fold_left const (fn, init, input) = Stdlib.List.fold_left (fun acc x -> acc + FoldOf.fn fn const x) init input @@ -570,7 +570,7 @@ module TestFoldRightAgainstStdlibList (M : sig include Traits.FOLDRIGHT_SEQUENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_fold_right (fn, init, input) = Stdlib.List.fold_right (FoldOf.fn fn) input init @@ -620,7 +620,7 @@ module TestExistForallAgainstStdlibList (M : sig include Traits.EXISTFORALL_PARALLEL with type 'a elt := int and type 'a t := int t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_exists (fn, const, input) = Stdlib.List.exists (CondOf.fn fn const) input @@ -750,7 +750,7 @@ module TestFilterAgainstStdlibList (M : sig include Traits.FILTER_SEQUENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_filter (fn, const, input) = Stdlib.List.filter (CondOf.fn fn const) input @@ -799,7 +799,7 @@ module TestFilterpAgainstStdlibList (M : sig include Traits.FILTER_PARALLEL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_filter (fn, const, input) = Stdlib.List.filter (CondOf.fn fn const) input @@ -830,7 +830,7 @@ module TestFiltermapAgainstStdlibList (M : sig include Traits.FILTERMAP_SEQUENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_filter_map (pred, arith, const, input) = Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input @@ -885,7 +885,7 @@ module TestFiltermappAgainstStdlibList (M : sig include Traits.FILTERMAP_PARALLEL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_filter_map (pred, arith, const, input) = Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input @@ -920,7 +920,7 @@ module TestFindStdlibList (M : sig include Traits.FIND_SEQUENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_find (pred, const, input) = Stdlib.List.find_opt (CondOf.fn pred const) input @@ -969,7 +969,7 @@ module TestPartitionStdlibList (M : sig include Traits.PARTITION_PARALLEL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let with_stdlib_partition (pred, const, input) = Stdlib.List.partition (CondOf.fn pred const) input @@ -1067,7 +1067,7 @@ module TestDoubleTraversorsStdlibList (M : sig include Traits.ALLDOUBLE_SEQENTIAL with type 'a t := 'a t end) : Test = struct - open QCheck + open QCheck2 let uncurry f (x, y) = f x y diff --git a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml index b529bb423e85..97c11ea4aff5 100644 --- a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml +++ b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml @@ -47,7 +47,7 @@ use automatically generated values; thanks to [QCheck]. *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers type key = Context.key @@ -58,18 +58,18 @@ type value = Context.value (** Using [QCheck.small_list] for performance reasons: using [QCheck.list] here makes the file 40 times slower, which is not acceptable. *) -let key_arb = QCheck.small_list QCheck.string +let key_arb = QCheck2.small_list QCheck2.string (* As bytes are mutable this is fine because the test doesn't do any mutation. Otherwise [rev] could be called on a value different than the value passed to the test. *) -let value_arb = QCheck.map ~rev:Bytes.to_string Bytes.of_string QCheck.string +let value_arb = QCheck2.map Bytes.of_string QCheck2.string -let key_value_arb = QCheck.pair key_arb value_arb +let key_value_arb = QCheck2.pair key_arb value_arb (* We generate contexts by starting from a fresh one and doing a sequence of calls to [Context.add]. *) -let context_arb : Context.t QCheck.arbitrary = +let context_arb : Context.t QCheck2.arbitrary = let set_all key_value_list = Lwt_main.run @@ Lwt_list.fold_left_s @@ -77,16 +77,7 @@ let context_arb : Context.t QCheck.arbitrary = Memory_context.empty key_value_list in - let rev ctxt = - let keys = Lwt_main.run @@ Test_mem_context.domain ctxt in - List.map - (fun key -> - ( key, - Lwt_main.run @@ Context.find ctxt key - |> WithExceptions.Option.get ~loc:__LOC__ )) - keys - in - QCheck.map ~rev set_all @@ QCheck.small_list key_value_arb + QCheck2.map set_all @@ QCheck2.small_list key_value_arb (** Some printers for passing to [check_eq*] functions *) @@ -107,7 +98,7 @@ let test_domain_spec (ctxt, k) = [Test_mem_contex.domain] appropriately returns an empty list. One could complexify this test to support this case, but I didn't want to spend too much time on this; we're testing a test after all here. *) - QCheck.assume_fail () + QCheck2.assume_fail () else let domain = Lwt_main.run @@ Test_mem_context.domain ctxt in qcheck_eq @@ -156,27 +147,27 @@ let test_set_domain (ctxt, (k, v)) = let () = let test_domain = - QCheck.Test.make + QCheck2.Test.make ~name:"Test_mem_context.domain's specification " - (QCheck.pair context_arb key_arb) + (QCheck2.pair context_arb key_arb) test_domain_spec in let test_set = - QCheck.Test.make + QCheck2.Test.make ~name:"get (set m k v) k = v " - (QCheck.pair context_arb key_value_arb) + (QCheck2.pair context_arb key_value_arb) test_get_set in let test_get_set_other = - QCheck.Test.make + QCheck2.Test.make ~name:"forall k1 <> k2, get (set m k1 v) k2 = get m k2 " - (QCheck.pair context_arb key_value_arb) + (QCheck2.pair context_arb key_value_arb) test_get_set_other in let test_get_set = - QCheck.Test.make + QCheck2.Test.make ~name:"forall k2 in domain (set m k1 v), k2 in domain m || k1 = k2 " - (QCheck.pair context_arb key_value_arb) + (QCheck2.pair context_arb key_value_arb) test_set_domain in Alcotest.run diff --git a/src/lib_proxy/test/light_lib.ml b/src/lib_proxy/test/light_lib.ml index 865f994855b8..510f2146df2b 100644 --- a/src/lib_proxy/test/light_lib.ml +++ b/src/lib_proxy/test/light_lib.ml @@ -26,7 +26,7 @@ (** Definitions used in files with actual tests *) module Store = Tezos_context_memory.Context -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** Taken from the output of: diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index 5a2c332b1e3b..3bffdb06c1fb 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -37,11 +37,11 @@ module Internal = Tezos_proxy.Light_internal module Merkle = Internal.Merkle module Store = Tezos_context_memory.Context -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** [list1_arb arb] generates non-empty lists using [arb]. *) let list1_arb arb = - QCheck.( + QCheck2.( list_of_size Gen.(1 -- 100) arb |> add_shrink_invariant (fun l -> List.length l > 0)) @@ -50,12 +50,10 @@ let irmin_hash_arb = QCheck.oneofl ~print:Fun.id Light_lib.irmin_hashes let merkle_node_arb = let open Tezos_shell_services.Block_services in let module MapArb = MakeMapArb (TzString.Map) in - let open QCheck in + let open QCheck2 in let open Gen in - let {gen = raw_context_gen; shrink = raw_context_shrink_opt; _} = - Light_lib.raw_context_arb - in - let {gen = irmin_hash_gen; _} = irmin_hash_arb in + let raw_context_gen = get_gen raw_context_arb in + let irmin_hash_gen = get_gen irmin_hash_arb in let gen = let max_depth_factor = 4 in fix @@ -73,36 +71,17 @@ let merkle_node_arb = (fun merkle_node_map -> Continue merkle_node_map) (MapArb.gen_of_size (0 -- 10) - string + (string ?gen:None) (self (current_depth_factor / 2))) ); ]) max_depth_factor in - let first_irmin_hash = - List.hd Light_lib.irmin_hashes |> function - | None -> assert false - | Some hash -> hash - in - let rec shrink = - let open Iter in - function - | Hash _ -> empty - | Data bigger_raw_context -> - shrink (Hash (Contents, first_irmin_hash)) - <+> ( of_option_shrink raw_context_shrink_opt bigger_raw_context - >|= fun smaller_raw_context -> Data smaller_raw_context ) - | Continue bigger_mnode -> - shrink (Hash (Contents, first_irmin_hash)) - <+> shrink (Data Cut) - <+> ( MapArb.shrink ~key:Shrink.string ~value:shrink bigger_mnode - >|= fun smaller_mnode -> Continue smaller_mnode ) - in let print = Format.asprintf "%a" pp_merkle_node in - make ~print ~shrink gen + make ~print gen let merkle_tree_arb = let open MakeMapArb (TzString.Map) in - arb_of_size QCheck.Gen.(0 -- 10) QCheck.string merkle_node_arb + arb_of_size QCheck2.Gen.(0 -- 10) QCheck2.string merkle_node_arb let irmin_tree_arb = let module StringList = struct @@ -112,14 +91,8 @@ let irmin_tree_arb = end in let module StringListMap = Stdlib.Map.Make (StringList) in let open MakeMapArb (StringListMap) in - let open QCheck in + let open QCheck2 in map - ~rev:(fun tree -> - Store.Tree.fold tree [] ~init:[] ~f:(fun path sub_tree acc -> - Store.Tree.to_value sub_tree >|= function - | None -> acc - | Some bytes -> (path, bytes) :: acc) - |> Lwt_main.run) (fun entries -> List.fold_left_s (fun built_tree (path, bytes) -> Store.Tree.add built_tree path bytes) @@ -128,14 +101,14 @@ let irmin_tree_arb = |> Lwt_main.run) (small_list (pair (small_list string) bytes_arb)) -let get_ok = function Ok x -> x | Error s -> QCheck.Test.fail_report s +let get_ok = function Ok x -> x | Error s -> QCheck2.Test.fail_report s (** Test that [merkle_tree_to_irmin_tree] preserves the tree's structure by checking that it yields the same [simple_tree] as when using [merkle_tree_to_simple_tree] *) let test_merkle_tree_to_irmin_tree_preserves_simple_tree = - QCheck.Test.make + QCheck2.Test.make ~name: "merkle_tree_to_irmin_tree mtree |> irmin_tree_to_simple_tree = \ merkle_tree_to_simple_tree mtree" @@ -181,7 +154,7 @@ and remove_data_in_tree mtree = an Irmin tree that is included in the original [merkle_tree]. This function specifically tests function [merkle_tree_to_irmin_tree]. *) let test_contains_merkle_tree = - QCheck.Test.make + QCheck2.Test.make ~name:"contains_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = true" merkle_tree_arb @@ fun mtree -> @@ -199,12 +172,12 @@ let test_contains_merkle_tree = in match contains_res with | Ok _ -> true - | Error msg -> QCheck.Test.fail_report msg + | Error msg -> QCheck2.Test.fail_report msg (** Test that unioning an empty irmin tree and a merkle tree should yield the same irmin tree as if it was built directly from the merkle tree *) let test_union_irmin_empty = - QCheck.Test.make + QCheck2.Test.make ~name: "union_irmin_tree_merkle_tree empty mtree = merkle_tree_to_irmin_tree \ mtree" @@ -229,7 +202,7 @@ let test_union_irmin_empty = Tests both [Merkle.merkle_tree_to_irmin_tree] and [Merkle.union_irmin_tree_merkle_tree] *) let test_union_translation = - QCheck.Test.make + QCheck2.Test.make ~name: "union_irmin_tree_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = \ merkle_tree_to_irmin_tree mtree" @@ -275,16 +248,16 @@ and union_merkle_tree t1 t2 = (** Test that unioning [Merkle.union_irmin_tree_merkle_tree] yields the same result as [union_merkle_tree] *) let test_union_direct = - QCheck.Test.make + QCheck2.Test.make ~name: "union_irmin_tree_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = \ merkle_tree_to_irmin_tree mtree" - (QCheck.pair merkle_tree_arb merkle_tree_arb) + (QCheck2.pair merkle_tree_arb merkle_tree_arb) @@ fun (mtree1, mtree2) -> match union_merkle_tree mtree1 mtree2 with | None -> (* trees are incompatible *) - QCheck.assume_fail () + QCheck2.assume_fail () | Some merkle_union -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let irmin_union1 = @@ -310,17 +283,17 @@ let test_union_direct = that [Merkle.union_irmin_tree_merkle_tree t1 t2] yields the same value as [Merkle.union_irmin_tree_merkle_tree t2 t1]. *) let test_union_commutation = - QCheck.Test.make + QCheck2.Test.make ~name: "union_irmin_tree_merkle_tree (union_irmin_tree_merkle_tree empty \ mtree1) mtree2 = union_irmin_tree_merkle_tree \ (union_irmin_tree_merkle_tree empty mtree2) mtree1" - (QCheck.pair merkle_tree_arb merkle_tree_arb) + (QCheck2.pair merkle_tree_arb merkle_tree_arb) @@ fun (mtree1, mtree2) -> match union_merkle_tree mtree1 mtree2 with | None -> (* rule out incompatible trees *) - QCheck.assume_fail () + QCheck2.assume_fail () | Some _ -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let union2 t1 t2 = @@ -342,7 +315,7 @@ let test_union_commutation = (** Test that unioning an irmin tree with an empty merkle tree yield the input irmin tree *) let test_union_merkle_empty = - QCheck.Test.make + QCheck2.Test.make ~name:"union_irmin_tree_merkle_tree tree empty = tree" irmin_tree_arb @@ fun tree -> @@ -356,15 +329,15 @@ let test_union_merkle_empty = (** Test that comparing the tree shape correctly ignores the key *) let test_shape_ignores_key = - QCheck.Test.make + QCheck2.Test.make ~name:"trees_shape_match ignores the key" - QCheck.(quad merkle_tree_arb (list string) merkle_node_arb merkle_node_arb) + QCheck2.(quad merkle_tree_arb (list string) merkle_node_arb merkle_node_arb) @@ fun (tree, key, node1, node2) -> let open Tezos_shell_services.Block_services in let is_continue = function Continue _ -> true | _ -> false in (* If both are [Continue] then they are trees with child nodes, hence shape comparison will fail. *) - QCheck.assume @@ not (is_continue node1 && is_continue node2) ; + QCheck2.assume @@ not (is_continue node1 && is_continue node2) ; let rec deep_add current_key value mtree = match current_key with | [last_fragment] -> TzString.Map.add last_fragment value mtree @@ -425,13 +398,19 @@ module HashStability = struct (** Provides a tree and a potentially shallowed (partially, totally or not at all) equivalent tree. Randomization of shallowing is sub-par (based on tree hash) because otherwise it would be very difficult to provide shrinking. Note that - this will no be a problem once QCheck provides integrated shrinking. *) + this will no be a problem once QCheck2 provides integrated shrinking. *) let tree_and_shallow_arb = - let open QCheck in - let repo = Lwt_main.run (Store.Tree.make_repo ()) in - map_keep_input - ~print:(Format.asprintf "%a" Store.Tree.pp) - (fun tree -> Lwt_main.run (make_partial_shallow_tree repo tree)) + let open QCheck2 in + let repo = Lwt_main.run Store.Tree.make_repo () in + map + ~print:(fun (tree, shallow_tree) -> + Format.asprintf + "(Tree:@.%a@.Shallow tree:@.%a" + Store.Tree.pp + tree + Store.Tree.pp + shallow_tree) + (fun tree -> (tree, Lwt_main.run (make_partial_shallow_tree repo tree))) irmin_tree_arb (** Test that replacing Irmin subtrees by their [Store.Tree.shallow] @@ -440,7 +419,7 @@ module HashStability = struct This test was also proposed to Irmin in https://github.com/mirage/irmin/pull/1291 *) let test_hash_stability = - QCheck.Test.make + QCheck2.Test.make ~name:"Shallowing trees does not change their top-level hash" tree_and_shallow_arb @@ fun (tree, shallow_tree) -> @@ -448,7 +427,7 @@ module HashStability = struct let shallow_hash = Store.Tree.hash shallow_tree in if Context_hash.equal hash shallow_hash then true else - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Equality check failed!@,\ expected:@,\ %a@,\ @@ -476,7 +455,7 @@ module AddTree = struct This test was also proposed to Irmin in https://github.com/mirage/irmin/pull/1291 *) let test_add_tree = - let open QCheck in + let open QCheck2 in Test.make ~name: "let tree' = Store.Tree.add_tree tree key at_key in \ @@ -636,7 +615,7 @@ module Consensus = struct let rand = Random.get_state () in let i = Random.State.int rand 11 in assert (0 <= i && i <= 10) ; - (* When QCheck lands (MR https://gitlab.com/tezos/tezos/-/merge_requests/2688), + (* When QCheck2 lands (MR https://gitlab.com/tezos/tezos/-/merge_requests/2688), this code should be generalized to also return a totally random merkle_tree (as long as it differs from [mtree]). Using Crowbar, this is impossible, because we cannot call a generator on our own, @@ -659,7 +638,7 @@ module Consensus = struct if is_rogue then match mk_rogue_tree mtree seed with | Ok rogue_mtree -> rogue_mtree - | _ -> QCheck.assume_fail () + | _ -> QCheck2.assume_fail () else mtree) |> return end : Tezos_proxy.Light_proto.PROTO_RPCS) @@ -731,7 +710,7 @@ module Consensus = struct end let add_test_consensus (min_agreement, honest, rogue, consensus_expected) = - let open QCheck in + let open QCheck2 in (* Because the node providing data always agrees, [honest] must be > 0 *) assert (honest > 0) ; (* Because we test consensus, to which the node providing data @@ -758,7 +737,7 @@ let add_test_consensus (min_agreement, honest, rogue, consensus_expected) = |> Lwt_main.run let test_consensus_spec = - let open QCheck in + let open QCheck2 in let min_agreement_arb = 0 -- 100 in let honest_arb = 1 -- 1000 in let rogue_arb = 0 -- 1000 in diff --git a/src/lib_rpc_http/test/test_rpc_http.ml b/src/lib_rpc_http/test/test_rpc_http.ml index 040776cddbcb..9ad80c277766 100644 --- a/src/lib_rpc_http/test/test_rpc_http.ml +++ b/src/lib_rpc_http/test/test_rpc_http.ml @@ -34,7 +34,7 @@ *) module Arbitrary = struct - open QCheck + open QCheck2 open RPC_server.Acl open Tz_arbitrary @@ -85,7 +85,7 @@ module Arbitrary = struct let open Gen in let rec add_to_policy policy n = if n > 0 then - let* acl = gen acl and* endpoint = gen addr_port_id in + let* acl = get_gen acl and* endpoint = get_gen addr_port_id in add_to_policy (put_policy (endpoint, acl) policy) (n - 1) else pure policy in @@ -108,15 +108,15 @@ module Arbitrary = struct } let find_policy_setup : find_policy_setup arbitrary = - let open QCheck in + let open QCheck2 in let generate_entry = let open Gen in - let* endpoint = gen addr_port_id and* acl = gen acl in + let* endpoint = get_gen addr_port_id and* acl = get_gen acl in pure (endpoint, acl) in let generate = let open Gen in - let* p = gen policy + let* p = get_gen policy and* (searched_for, searched_acl) = generate_entry and* added_entry = generate_entry in let* policy = @@ -183,7 +183,7 @@ let pp_policy ppf policy = Format.fprintf ppf "%s" (RPC_server.Acl.policy_to_string policy) let test_codec_identity = - let open QCheck in + let open QCheck2 in Test.make ~name:"Encoding and decoding an ACL is an identity function." Arbitrary.policy @@ -194,7 +194,7 @@ let test_codec_identity = let decoded = Data_encoding.Json.destruct RPC_server.Acl.policy_encoding json in - Qcheck_helpers.qcheck_eq ~pp:pp_policy policy decoded) + Qcheck2_helpers.qcheck_eq ~pp:pp_policy policy decoded) (* Assert that the result of searching [searched_for] in [policy] is never worse than the result of searching in @@ -206,7 +206,7 @@ let test_codec_identity = returns [true] if the comparison is satisfactory or [false] otherwise. *) let check_find_policy = - let open QCheck in + let open QCheck2 in let assert_results_satisfactory before_put after_put = match (before_put, after_put) with | (Some _, None) -> false @@ -317,7 +317,7 @@ let ensure_unsafe_rpcs_blocked = known_unsafe_rpcs) let () = - let open Qcheck_helpers in + let open Qcheck2_helpers in Alcotest.run "tezos-rpc-http" [ diff --git a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml index a79cf6cee5c8..74098574766f 100644 --- a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml +++ b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml @@ -30,7 +30,7 @@ Subject: Test the synchronisation heuristic with a reference implementation *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (* Interface implemented by the synchronisation heuristic. *) @@ -126,7 +126,7 @@ let forge_peer_id () = identity.peer_id let peer_id = - let open QCheck in + let open QCheck2 in let p1 = forge_peer_id () in let p2 = forge_peer_id () in let p3 = forge_peer_id () in @@ -163,7 +163,7 @@ let now = Time.System.to_protocol @@ Systime_os.now () let forge_timestamp ~delay = Time.Protocol.add now (Int64.of_int delay) let timestamp = - let open QCheck in + let open QCheck2 in let timestamp_pp n = let delay = Time.Protocol.diff n now in Format.asprintf "delay: %Ld" delay @@ -177,11 +177,11 @@ let timestamp = |> set_print timestamp_pp let value = - let open QCheck in + let open QCheck2 in pair timestamp peer_id let values = - let open QCheck in + let open QCheck2 in list value let pp fmt = @@ -195,14 +195,14 @@ let pp fmt = let make_tests check_update lcreate rcreate threshold latency = let threshold_1 = - QCheck.Test.make + QCheck2.Test.make ~name: (Format.asprintf "Shell.synchronisation_heuristic.equivalence-with-reference-implementation \ (threshold %d) (latency %d)" 1 latency) - QCheck.(pair value value) + QCheck2.(pair value value) (fun (v1, v2) -> let state_left = lcreate ~threshold:1 ~latency in let state_right = rcreate ~threshold:1 ~latency in @@ -212,7 +212,7 @@ let make_tests check_update lcreate rcreate threshold latency = let threshold_n = List.map (fun threshold -> - QCheck.Test.make + QCheck2.Test.make ~name: (Format.asprintf "Shell.synchronisation_heuristic.equivalence-with-reference-implementation \ diff --git a/src/lib_stdlib/test/test_bounded_heap.ml b/src/lib_stdlib/test/test_bounded_heap.ml index 1ab67e3f7089..d00c8d769955 100644 --- a/src/lib_stdlib/test/test_bounded_heap.ml +++ b/src/lib_stdlib/test/test_bounded_heap.ml @@ -40,19 +40,19 @@ let take_nth_biggest n l = (* At least 2 elements, since we'll create a bounded set of size #elements / 2 *) -let list_size = QCheck.Gen.int_range 2 1000 +let list_size = QCheck2.Gen.int_range 2 1000 (* Checks whether using inserting the elementes of list [l] of size [2 * n] inside a bounded heap of size [n], and getting its list view gives the same result as sorting list [l] and taking the first [n] elements *) let test_bounded_heap = - QCheck.Test.make + QCheck2.Test.make ~name:"bounded_heap (qcheck)" ~count:1000 - QCheck.(list_of_size list_size int) + QCheck2.(list_of_size list_size int) (fun l -> let sz = List.length l / 2 in - QCheck.assume (sz > 0) ; + QCheck2.assume (sz > 0) ; let t = B.create sz in List.iter (fun x -> B.insert x t) l ; let contents = B.get t in @@ -63,13 +63,13 @@ let test_bounded_heap = ~pp_sep:(fun ppf () -> Format.fprintf ppf "; ") Format.pp_print_int in - Lib_test.Qcheck_helpers.qcheck_eq' + Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:Format.pp_print_int ~eq:( = ) ~actual:ln ~expected:sz () - && Lib_test.Qcheck_helpers.qcheck_eq' + && Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:pp_list ~eq:( = ) ~actual:contents diff --git a/src/lib_stdlib/test/test_tzList.ml b/src/lib_stdlib/test/test_tzList.ml index db33a45b4434..45efa136515c 100644 --- a/src/lib_stdlib/test/test_tzList.ml +++ b/src/lib_stdlib/test/test_tzList.ml @@ -77,7 +77,7 @@ let test_take_n _ = ~f:(fun xs -> Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 5 xs) [4; 5; 5; 5; 6]) -let list_size = QCheck.Gen.int_range 2 1000 +let list_size = QCheck2.Gen.int_range 2 1000 let pp_int_list = Format.pp_print_list @@ -85,14 +85,14 @@ let pp_int_list = Format.pp_print_int let test_shuffle_preserves_values = - QCheck.Test.make + QCheck2.Test.make ~name:"shuffle preserves value sets" ~count:1000 - QCheck.(list_of_size list_size int) + QCheck2.(list_of_size list_size int) (fun l -> let l1 = List.sort Int.compare l in let l2 = List.sort Int.compare (TzList.shuffle l) in - Lib_test.Qcheck_helpers.qcheck_eq' + Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:pp_int_list ~eq:( = ) ~actual:l2 diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index fed19e79a46d..aeb8cfc88df7 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -62,22 +62,25 @@ let int64_range a b = assert (a <= res && res <= b) ; res in - let gen = Gen.make_primitive - ~gen:int64_range_gen -(* TODO expose/reimplement QCheck2 logic of shrinking towards [0L] while respecting limits *) - ~shrink:(Shrink.int64_towards a) -in int64 |> set_gen gen + let gen = + Gen.make_primitive + ~gen: + int64_range_gen + (* TODO expose/reimplement QCheck2 logic of shrinking towards [0L] while respecting limits *) + ~shrink:(Shrink.int64_towards a) + in + int64 |> set_gen gen let rec of_option_gen gen = let open QCheck2.Gen in - gen >>= function - | None -> of_option_gen gen - | Some a -> pure a + gen >>= function None -> of_option_gen gen | Some a -> pure a let of_option_arb arb = let open QCheck2 in let gen = of_option_gen (get_gen arb) in - let print = Option.map (fun print_opt a -> print_opt (Some a)) (get_print arb) in + let print = + Option.map (fun print_opt a -> print_opt (Some a)) (get_print arb) + in let collect = Option.map (fun collect_opt a -> collect_opt (Some a)) (get_collect arb) in @@ -90,7 +93,7 @@ let uint16 = QCheck2.(0 -- 65535) let int16 = QCheck2.(-32768 -- 32767) -let bytes_arb = QCheck2.(map Bytes.of_string string) +let bytes_arb = QCheck2.(map Bytes.of_string string) module MakeMapArb (Map : Stdlib.Map.S) = struct open QCheck2 diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml index b7eef52ed651..01faf284c025 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml @@ -44,16 +44,16 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with | (true, Ok c) -> - Lib_test.Qcheck_helpers.qcheck_eq' + Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () | (true, Error _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are in Z bounds, but tez operation fails.@]" | (false, Ok _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are not in Z bounds, but tez operation did not fail.@]" | (false, Error _) -> true @@ -74,24 +74,19 @@ let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) (** Arbitrary int64 by conversion from int32 *) -let arb_int64_of32 : int64 QCheck.arbitrary = - QCheck.(map ~rev:Int64.to_int32 Int64.of_int32 int32) +let arb_int64_of32 : int64 QCheck2.arbitrary = + QCheck2.(map Int64.of_int32 int32) (** Arbitrary int64 mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_int64_sizes : int64 QCheck.arbitrary = - let open QCheck in - oneof - [ - QCheck.map ~rev:Int64.to_int Int64.of_int (int_range (-10) 10); - arb_int64_of32; - int64; - ] +let arb_int64_sizes : int64 QCheck2.arbitrary = + let open QCheck2 in + oneof [QCheck2.map Int64.of_int (int_range (-10) 10); arb_int64_of32; int64] (** Arbitrary positive int64, mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_ui64_sizes : int64 QCheck.arbitrary = - let open QCheck in +let arb_ui64_sizes : int64 QCheck2.arbitrary = + let open QCheck2 in map_same_type (fun i -> let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in @@ -101,8 +96,8 @@ let arb_ui64_sizes : int64 QCheck.arbitrary = (** Arbitrary tez based on [arb_tez_sizes] *) let arb_tez_sizes = - let open QCheck in - map ~rev:Tez.to_mutez Tez.of_mutez_exn arb_ui64_sizes + let open QCheck2 in + map Tez.of_mutez_exn arb_ui64_sizes let test_coherent_mul = QCheck.Test.make diff --git a/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml b/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml index 88672c7527c3..5e2d809a0bc7 100644 --- a/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml +++ b/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml @@ -31,23 +31,23 @@ *) open Protocol.Saturation_repr -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_arb = of_option_arb @@ QCheck.map of_int_opt QCheck.int +let unsatured_arb = of_option_arb @@ QCheck2.map of_int_opt QCheck2.int (** The general generator for [t]: generates both unsaturated values and [saturated]. *) -let t_arb : may_saturate t QCheck.arbitrary = - QCheck.frequency [(1, QCheck.always saturated); (4, unsatured_arb)] +let t_arb : may_saturate t QCheck2.arbitrary = + QCheck2.frequency [(1, QCheck2.always saturated); (4, unsatured_arb)] (* Test. * Tests that [add] commutes. *) let test_add_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 = t2 + t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in let t2_plus_t1 = add t2 t1 in @@ -57,9 +57,9 @@ let test_add_commutes = * Tests that [mul] commutes. *) let test_mul_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 * t2 = t2 * t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_times_t2 = mul t1 t2 in let t2_times_t1 = mul t2 t1 in @@ -69,7 +69,7 @@ let test_mul_commutes = * Tests that [zero] is neutral for [add]. *) let test_add_zero = - QCheck.Test.make ~name:"t + 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t + 0 = t" t_arb (fun t -> let t_plus_zero = add t zero in qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) @@ -77,9 +77,9 @@ let test_add_zero = * Tests that t1 + t2 >= t1 *) let test_add_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in t1_plus_t2 >= t1) @@ -89,7 +89,7 @@ let test_add_neq = *) let test_mul_one = let one = safe_int 1 in - QCheck.Test.make ~name:"t * 1 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 1 = t" t_arb (fun t -> let t_times_one = mul t one in qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) @@ -97,7 +97,7 @@ let test_mul_one = * Tests that [t] times [0] equals [0]. *) let test_mul_zero = - QCheck.Test.make ~name:"t * 0 = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 0 = 0" t_arb (fun t -> let t_times_zero = mul t zero in qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) @@ -105,7 +105,7 @@ let test_mul_zero = * Tests that [t] [sub] [zero] equals [t]. *) let test_sub_zero = - QCheck.Test.make ~name:"t - 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t - 0 = t" t_arb (fun t -> let t_sub_zero = sub t zero in qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) @@ -113,7 +113,7 @@ let test_sub_zero = * Tests that [t] [sub] [t] equals [zero]. *) let test_sub_itself = - QCheck.Test.make ~name:"t - t = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t - t = 0" t_arb (fun t -> let t_sub_t = sub t t in qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) @@ -121,9 +121,9 @@ let test_sub_itself = * Tests that t1 - t2 <= t1 *) let test_sub_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let t1_minus_t2 = sub t1 t2 in t1_minus_t2 <= t1) @@ -132,9 +132,9 @@ let test_sub_neq = * Tests that (t1 + t2) - t2 <= t1 *) let test_add_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 + t2) - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let lhs = sub (add t1 t2) t2 in lhs <= t1) @@ -143,9 +143,9 @@ let test_add_sub = * Tests that (t1 - t2) + t2 >= t1 *) let test_sub_add = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 - t2) + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.pair t_arb t_arb) (fun (t1, t2) -> let lhs = add (sub t1 t2) t2 in lhs >= t1) @@ -154,12 +154,12 @@ let test_sub_add = * Tests that [saturated] >= t *) let test_leq_saturated = - QCheck.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) + QCheck2.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) (* Test. * Tests that [zero] <= t *) -let test_geq_zero = QCheck.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) +let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) let tests_add = [test_add_commutes; test_add_zero; test_add_neq] diff --git a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml index 9e0c1a32c05d..484d672b0696 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml @@ -31,7 +31,7 @@ *) open Protocol -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** Extract a Tezos result for compatibility with QCheck. *) let extract_qcheck_result = function @@ -87,8 +87,8 @@ let test_consume_commutes (start, cost1, cost2) = (Gas.consumed ~since:start ~until:branch2)) ) (** Arbitrary context with a gas limit of 100_000_000. *) -let context_arb : Alpha_context.t QCheck.arbitrary = - QCheck.always +let context_arb : Alpha_context.t QCheck2.arbitrary = + QCheck2.always (Lwt_main.run ( Context.init 1 >>=? fun (b, _contracts) -> Incremental.begin_construction b >|=? fun inc -> @@ -101,9 +101,9 @@ let context_arb : Alpha_context.t QCheck.arbitrary = | Error _ -> assert false) (** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = +let gas_cost_arb : Alpha_context.Gas.cost QCheck2.arbitrary = let open Alpha_context.Gas in - let open QCheck in + let open QCheck2 in let rand = 0 -- 1000 in let safe_rand = map Saturation_repr.safe_int rand in choose @@ -119,20 +119,20 @@ let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = let tests = [ - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming commutes" - QCheck.(triple context_arb gas_cost_arb gas_cost_arb) + QCheck2.(triple context_arb gas_cost_arb gas_cost_arb) test_consume_commutes; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming [free] consumes nothing" context_arb test_free_consumption; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"[free] is the neutral element of Gas addition" - QCheck.(pair context_arb gas_cost_arb) + QCheck2.(pair context_arb gas_cost_arb) test_free_neutral; ] diff --git a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml index 37990a26145b..9bb60e4b4a72 100644 --- a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml @@ -44,16 +44,16 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with | (true, Ok c) -> - Lib_test.Qcheck_helpers.qcheck_eq' + Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () | (true, Error _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are in Z bounds, but tez operation fails.@]" | (false, Ok _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are not in Z bounds, but tez operation did not fail.@]" | (false, Error _) -> true @@ -74,24 +74,19 @@ let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) (** Arbitrary int64 by conversion from int32 *) -let arb_int64_of32 : int64 QCheck.arbitrary = - QCheck.(map ~rev:Int64.to_int32 Int64.of_int32 int32) +let arb_int64_of32 : int64 QCheck2.arbitrary = + QCheck2.(map Int64.of_int32 int32) (** Arbitrary int64 mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_int64_sizes : int64 QCheck.arbitrary = - let open QCheck in - oneof - [ - QCheck.map ~rev:Int64.to_int Int64.of_int (int_range (-10) 10); - arb_int64_of32; - int64; - ] +let arb_int64_sizes : int64 QCheck2.arbitrary = + let open QCheck2 in + oneof [QCheck2.map Int64.of_int (int_range (-10) 10); arb_int64_of32; int64] (** Arbitrary positive int64, mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_ui64_sizes : int64 QCheck.arbitrary = - let open QCheck in +let arb_ui64_sizes : int64 QCheck2.arbitrary = + let open QCheck2 in map_same_type (fun i -> let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in @@ -101,8 +96,8 @@ let arb_ui64_sizes : int64 QCheck.arbitrary = (** Arbitrary tez based on [arb_tez_sizes] *) let arb_tez_sizes = - let open QCheck in - map ~rev:Tez.to_mutez Tez.of_mutez_exn arb_ui64_sizes + let open QCheck2 in + map Tez.of_mutez_exn arb_ui64_sizes let test_coherent_mul = QCheck.Test.make -- GitLab From f8dadb140a90129b2eed735430931d707c7bf6d2 Mon Sep 17 00:00:00 2001 From: Valentin Chaboche Date: Tue, 22 Jun 2021 17:11:26 +0200 Subject: [PATCH 5/6] Remove QCheck2.arbitrary for QCheck2.Gen.t --- src/lib_base/test/test_p2p_addr.ml | 10 +- src/lib_base/test/test_time.ml | 79 +++-- .../test/test_fuzzing_helpers.ml | 78 +++-- .../test/test_fuzzing_option.ml | 72 ++-- .../test/test_fuzzing_seq_tiered.ml | 24 +- .../test/test_fuzzing_tests.ml | 329 ++++++++++++------ .../test/test_mem_context_array_theory.ml | 49 +-- src/lib_proxy/test/test_fuzzing_light.ml | 114 +++--- src/lib_rpc_http/test/test_rpc_http.ml | 110 +++--- .../test_synchronisation_heuristic_fuzzy.ml | 68 ++-- src/lib_stdlib/test/test_bounded_heap.ml | 3 +- src/lib_stdlib/test/test_tzList.ml | 2 +- src/lib_test/qcheck2_helpers.ml | 45 +-- src/lib_test/qcheck2_helpers.mli | 56 +-- .../lib_protocol/test/saturation_fuzzing.ml | 39 ++- .../lib_protocol/test/test_gas_properties.ml | 15 +- .../lib_protocol/test/test_tez_repr.ml | 31 +- .../lib_protocol/test/saturation_fuzzing.ml | 41 ++- .../lib_protocol/test/test_gas_properties.ml | 22 +- .../lib_protocol/test/test_tez_repr.ml | 32 +- 20 files changed, 717 insertions(+), 502 deletions(-) diff --git a/src/lib_base/test/test_p2p_addr.ml b/src/lib_base/test/test_p2p_addr.ml index d9a9686d7144..58cfc01ee6a1 100644 --- a/src/lib_base/test/test_p2p_addr.ml +++ b/src/lib_base/test/test_p2p_addr.ml @@ -81,8 +81,10 @@ let pp_addr_port_id fmt {P2p_point.Id.addr; port; peer_id} = Option.iter (fprintf fmt ":%d") port ; Option.iter (fprintf fmt "#%a" P2p_peer_id.pp) peer_id +let addr_port_id_to_string = Format.asprintf "%a" pp_addr_port_id + let addr_port_id_v4 = - QCheck2.map + QCheck2.Gen.map (fun (ip, port, peer_id) -> let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = Ipaddr.V4.to_string ip; port; peer_id}) @@ -90,7 +92,7 @@ let addr_port_id_v4 = |> QCheck2.set_print (Format.asprintf "%a" pp_addr_port_id) let addr_port_id_v6 = - QCheck2.map + QCheck2.Gen.map (fun (ip, port, peer_id) -> let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = P2p_addr.to_string ip; port; peer_id}) @@ -164,6 +166,7 @@ let ipv4_to_string_from_string = let open QCheck2 in Test.make ~name:"Base.P2p_point.addr_port_id.ipv4.to-string-from-string" + ~print:addr_port_id_to_string addr_port_id_v4 (fun t -> let open P2p_point.Id in @@ -231,7 +234,8 @@ let p2p_point_encoding_eager_fail = let max_possible_size_on_4_bytes = Int32.(to_int max_int) in Test.make ~name:"Base.P2p_point.Id.encoding eagerly fails on too big input" - (max_binary_size_point + 1 -- max_possible_size_on_4_bytes) + ~print:Print.int + Gen.(max_binary_size_point + 1 -- max_possible_size_on_4_bytes) (fun excessive_size -> (* The size header is stored on 4 bytes (the 4 bytes we remove from the total size of [max_binary_size_point] compared to the max size coded diff --git a/src/lib_base/test/test_time.ml b/src/lib_base/test/test_time.ml index 0f6167a361ea..2e217827f401 100644 --- a/src/lib_base/test/test_time.ml +++ b/src/lib_base/test/test_time.ml @@ -41,28 +41,28 @@ module Protocol = struct let min_rfc3339_seconds = to_seconds min_rfc3339 - let t_arb = QCheck2.map of_seconds QCheck2.int64 + let gen : t QCheck2.Gen.t = QCheck2.Gen.(map of_seconds int64) - let rfc3339_compatible_t_arb = + let rfc3339_compatible_gen = let within_rfc3339 = - QCheck2.map - of_seconds - (int64_range min_rfc3339_seconds max_rfc3339_seconds) + QCheck2.Gen.( + map of_seconds (int64_range min_rfc3339_seconds max_rfc3339_seconds)) in - QCheck2.frequency - [ - (97, within_rfc3339); - (1, QCheck2.always max_rfc3339); - (1, QCheck2.always min_rfc3339); - (1, QCheck2.always epoch); - ] + QCheck2.Gen.( + frequency + [ + (97, within_rfc3339); + (1, pure max_rfc3339); + (1, pure min_rfc3339); + (1, pure epoch); + ]) let pp fmt t = Format.fprintf fmt "%Lx" (to_seconds t) let add_diff_roundtrip = QCheck2.Test.make ~name:"Protocol.[add|diff] roundtrip" - (QCheck2.pair t_arb QCheck2.int64) + QCheck2.Gen.(pair gen int64) (fun (some_time, delta) -> let other_time = add some_time delta in let actual = diff other_time some_time in @@ -76,7 +76,7 @@ module Protocol = struct let diff_add_roundtrip = QCheck2.Test.make ~name:"Protocol.[diff|add] roundtrip" - (QCheck2.pair t_arb t_arb) + (QCheck2.Gen.pair gen gen) (fun (some_time, other_time) -> let delta = diff other_time some_time in let actual = add some_time delta in @@ -85,17 +85,14 @@ module Protocol = struct let encoding_binary_roundtrip = QCheck2.Test.make ~name:"Protocol.encoding roundtrips in binary" - t_arb + gen (fun t -> let b = Data_encoding.Binary.to_bytes_exn encoding t in let actual = Data_encoding.Binary.of_bytes_exn encoding b in qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) let encoding_json_roundtrip = - QCheck2.Test.make - ~name:"Protocol.encoding roundtrips in JSON" - t_arb - (fun t -> + QCheck2.Test.make ~name:"Protocol.encoding roundtrips in JSON" gen (fun t -> let j = Data_encoding.Json.construct encoding t in let actual = Data_encoding.Json.destruct encoding j in qcheck_eq' ~pp ~eq:equal ~expected:t ~actual ()) @@ -103,7 +100,8 @@ module Protocol = struct let encoding_to_notation_roundtrip = QCheck2.Test.make ~name:"Protocol.[to|of]_notation roundtrip in RFC3339 range" - rfc3339_compatible_t_arb + ~print:(Format.asprintf "%a" pp) + rfc3339_compatible_gen (fun t -> to_notation t |> of_notation |> function | None -> QCheck2.Test.fail_report "Failed to roundtrip notation" @@ -122,33 +120,36 @@ end module System = struct open System - (** Arbitrary of {!t} from usual time fragments year-month-day hour-minute-second, parsed through {!Ptime.of_date_time}. *) - let t_ymdhms_arb : t QCheck2.arbitrary = + (** Generator of {!t} from usual time fragments year-month-day hour-minute-second, + parsed through {!Ptime.of_date_time}. *) + let ymdhms_gen : t QCheck2.Gen.t = let open QCheck2 in - of_option_arb + let open Gen in + of_option_gen (pair (triple (0 -- 9999) (1 -- 12) (1 -- 31)) (triple (0 -- 23) (0 -- 59) (0 -- 60)) |> map (fun (date, time) -> Ptime.of_date_time (date, (time, 0)))) - |> set_print (Format.asprintf "%a" pp_hum) let (min_day, min_ps) = Ptime.min |> Ptime.to_span |> Ptime.Span.to_d_ps let (max_day, max_ps) = Ptime.max |> Ptime.to_span |> Ptime.Span.to_d_ps - (** Arbitrary of {!t} from days + picoseconds, parsed through {!Ptime.Span.of_d_ps}. *) - let t_dps_arb : t QCheck2.arbitrary = + (** Generator of {!t} from days + picoseconds, parsed through {!Ptime.Span.of_d_ps}. *) + let dps_gen : t QCheck2.Gen.t = let open QCheck2 in + let open Gen in pair (min_day -- max_day) (int64_range min_ps max_ps) |> map (fun (d, ps) -> Ptime.Span.of_d_ps (d, ps) |> Option.get |> Ptime.of_span |> Option.get) - (* But please keep using a nice pretty printer... We can probably write in the future a generic function that mixes features of [map ~rev] and [map_keep_input ~print] to only pass the monotonic transformation and the pretty printer, instead of manually writing [rev]. *) - |> set_print (Format.asprintf "%a" pp_hum) - let t_arb = QCheck2.choose [t_ymdhms_arb; t_dps_arb] + let gen : t QCheck2.Gen.t = QCheck2.Gen.oneof [ymdhms_gen; dps_gen] + + let pp = pp_hum - (** Check that the span is smaller than 1 second (useful for Protocol time roundtrips as Protocol time precision is the second). *) + (** Check that the span is smaller than 1 second (useful for Protocol time + roundtrips as Protocol time precision is the second). *) let is_small delta = Stdlib.( < ) (Ptime.Span.compare delta (Ptime.Span.v (0, 1_000_000_000_000L))) @@ -157,7 +158,8 @@ module System = struct let to_protocol_of_protocol_roundtrip = QCheck2.Test.make ~name:"System.[to|of]_protocol roundtrip modulo option" - t_arb + ~print:(Format.asprintf "%a" pp) + gen (fun t -> match to_protocol t |> of_protocol_opt with | None -> QCheck2.Test.fail_report "Failed roundtrip" @@ -175,9 +177,10 @@ module System = struct let of_protocol_to_protocol_roundtrip_or_outside_rfc3339 = QCheck2.Test.make ~name:"System.[of|to]_protocol roundtrip or outside RFC3339 range" + ~print:(Format.asprintf "%a" Protocol.pp) (* Use both generators, otherwise statistically, we will almost never hit the RFC3339 time range. *) - (QCheck2.choose [Protocol.t_arb; Protocol.rfc3339_compatible_t_arb]) + (QCheck2.Gen.oneof [Protocol.gen; Protocol.rfc3339_compatible_gen]) (fun protocol_time -> match of_protocol_opt protocol_time with | None -> @@ -195,7 +198,8 @@ module System = struct let rfc_encoding_binary_roundtrip = QCheck2.Test.make ~name:"System.rfc_encoding roundtrips in binary modulo precision" - t_arb + ~print:(Format.asprintf "%a" pp) + gen (fun t -> let b = Data_encoding.Binary.to_bytes_exn rfc_encoding t in let tt = Data_encoding.Binary.of_bytes_exn rfc_encoding b in @@ -205,7 +209,8 @@ module System = struct let rfc_encoding_json_roundtrip = QCheck2.Test.make ~name:"System.rfc_encoding roundtrips in JSON modulo precision" - t_arb + ~print:(Format.asprintf "%a" pp) + gen (fun t -> let j = Data_encoding.Json.construct rfc_encoding t in let tt = Data_encoding.Json.destruct rfc_encoding j in @@ -215,7 +220,8 @@ module System = struct let encoding_binary_roundtrip = QCheck2.Test.make ~name:"System.encoding roundtrips in binary modulo precision" - t_arb + ~print:(Format.asprintf "%a" pp) + gen (fun t -> let b = Data_encoding.Binary.to_bytes_exn encoding t in let tt = Data_encoding.Binary.of_bytes_exn encoding b in @@ -225,7 +231,8 @@ module System = struct let encoding_json_roundtrip = QCheck2.Test.make ~name:"System.encoding roundtrips in JSON modulo precision" - t_arb + ~print:(Format.asprintf "%a" pp) + gen (fun t -> let j = Data_encoding.Json.construct encoding t in let tt = Data_encoding.Json.destruct encoding j in diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml index ffb455f735fd..4d5dac8c78bd 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_helpers.ml @@ -35,38 +35,50 @@ let rec log_pause n = (* Function generators *) module Fn = struct - let lambda s l = - let open QCheck2 in - make ~print:(fun _ -> s) (Gen.return l) + (* let lambda s l = + * let open QCheck2 in + * make ~print:(fun _ -> s) (Gen.return l) *) let pred = - QCheck2.oneof - [ - lambda "(fun x _ -> x > 0)" (fun x _ -> x > 0); - lambda "(fun _ y -> y < 0)" (fun _ y -> y < 0); - lambda "(fun _ _ -> false)" (fun _ _ -> false); - lambda "(fun _ _ -> true)" (fun _ _ -> true); - lambda "(fun x y -> x < y)" (fun x y -> x < y); - ] + (* If the string is really important, a work-around could be + done, otherwise we only keep the generator *) + QCheck2.Gen.( + oneof + [ + pure (fun x _ -> x > 0); + pure (fun _ y -> y < 0); + pure (fun _ _ -> false); + pure (fun _ _ -> true); + pure (fun x y -> x < y); + ]) + + (* QCheck2.Gen.oneof + * [ lambda "(fun x _ -> x > 0)" (fun x _ -> x > 0); + * lambda "(fun _ y -> y < 0)" (fun _ y -> y < 0); + * lambda "(fun _ _ -> false)" (fun _ _ -> false); + * lambda "(fun _ _ -> true)" (fun _ _ -> true); + * lambda "(fun x y -> x < y)" (fun x y -> x < y) ] *) let basic_int = - QCheck2.(oneof [int; Gen.return 0 |> make; Gen.return 1 |> make]) + (* small_int_corners is a generator with 0; 1; 2; max_int and then classic + int generator *) + QCheck2.Gen.small_int_corners () let arith = let open QCheck2 in let module O = Observable in - fun2 O.int O.int int + fun2 O.int O.int Gen.int (* combinators *) let e (cond, QCheck2.Fun (_, ok), QCheck2.Fun (_, error)) x y = if cond x y then Ok (ok x y) else Error (error x y) - let arith_e = QCheck2.(map e (triple pred arith arith)) + let arith_e = QCheck2.Gen.(map e (triple pred arith arith)) let s (QCheck2.Fun (_, pauses), QCheck2.Fun (_, fn)) x y = log_pause (pauses x y) >|= fun () -> fn x y - let arith_s = QCheck2.(map s (pair arith arith)) + let arith_s = QCheck2.Gen.(map s (pair arith arith)) let es ( cond, @@ -76,7 +88,7 @@ module Fn = struct log_pause (pauses x y) >|= fun () -> if cond x y then Ok (ok x y) else Error (error x y) - let arith_es = QCheck2.(map es (quad pred arith arith arith)) + let arith_es = QCheck2.Gen.(map es (quad pred arith arith arith)) end (* Wrappers for generated functions *) @@ -404,16 +416,17 @@ end (* Data generators (we use lists of integers) *) -let one = QCheck2.int +let one = QCheck2.Gen.int -let many = QCheck2.(list int) +let many = QCheck2.Gen.(list int) -let maybe = QCheck2.(option int) +let maybe = QCheck2.Gen.(opt ~ratio:0.5 int) let manymany = let open QCheck2 in - oneof - [map (fun input -> (input, input)) (list int); pair (list int) (list int)] + Gen.( + oneof + [map (fun input -> (input, input)) (list int); pair (list int) (list int)]) (* equality and lwt/error variants *) @@ -499,3 +512,26 @@ module PP = struct let trace = Support.Test_trace.pp end + +module Misc = struct + include PP + + let print_int : int -> string = Format.asprintf "%a" int + + let print_fn : 'f QCheck2.fun_ -> string = QCheck2.Fn.print + + let print_pred (_ : int -> int -> bool) : string = "" + + let print_manymany : int list * int list -> string = + QCheck2.Print.(pair (list print_int) (list print_int)) + + let arith = Fn.arith + + let arith_e = Fn.arith_e + + let arith_s = Fn.arith_s + + let arith_es = Fn.arith_es + + let pred = Fn.pred +end diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml index 1a31a080411c..dd5a9d577af3 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_option.ml @@ -32,11 +32,15 @@ open Test_fuzzing_helpers module TestIter = struct open QCheck2 open Monad + open Misc + + let print = Print.(triple print_fn print_int @@ option print_int) let iter = Test.make ~name:"{Option,List([01])}.iter" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + Gen.(triple arith one maybe) (fun (Fun (_, fn), init, input) -> eq (let acc = ref init in @@ -49,7 +53,8 @@ module TestIter = struct let iter_e = Test.make ~name:"{Option,List([01])}.iter_e" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), init, input) -> eq_e (let acc = ref init in @@ -61,7 +66,8 @@ module TestIter = struct let iter_s = Test.make ~name:"{Option,List([01])}.iter_s" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), init, input) -> eq_s (let acc = ref init in @@ -73,7 +79,8 @@ module TestIter = struct let iter_es = Test.make ~name:"{Option,List([01])}.iter_es" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -89,11 +96,15 @@ end module TestFilter = struct open QCheck2 open Monad + open Misc + + let print = Print.(triple print_pred print_int @@ option print_int) let filter = Test.make ~name:"{Option,List([01])}.filter" - (triple Test_fuzzing_helpers.Fn.pred one maybe) + ~print + Gen.(triple pred one maybe) (fun (fn, const, input) -> eq (Option.filter (CondOf.fn fn const) input) @@ -102,7 +113,8 @@ module TestFilter = struct let filter_e = Test.make ~name:"{Option,List([01])}.filter_e" - (triple Test_fuzzing_helpers.Fn.pred one maybe) + ~print + Gen.(triple pred one maybe) (fun (fn, const, input) -> eq_e (Option.filter_e (CondEOf.fn fn const) input) @@ -112,7 +124,8 @@ module TestFilter = struct let filter_s = Test.make ~name:"{Option,List([01])}.filter_s" - (triple Test_fuzzing_helpers.Fn.pred one maybe) + ~print + Gen.(triple pred one maybe) (fun (fn, const, input) -> eq_s (Option.filter_s (CondSOf.fn fn const) input) @@ -122,7 +135,8 @@ module TestFilter = struct let filter_es = Test.make ~name:"{Option,List([01])}.filter_es" - (triple Test_fuzzing_helpers.Fn.pred one maybe) + ~print + Gen.(triple pred one maybe) (fun (fn, const, input) -> eq_es (Option.filter_es (CondESOf.fn fn const) input) @@ -136,15 +150,15 @@ end module TestFilterMap = struct open QCheck2 open Monad + open Misc + + let print = Print.(quad print_pred print_fn print_int @@ option print_int) let filter_map = Test.make ~name:"{Option,List([01])}.filter_map" - (quad - Test_fuzzing_helpers.Fn.pred - Test_fuzzing_helpers.Fn.arith - one - maybe) + ~print + (Gen.quad pred arith one maybe) (fun (pred, Fun (_, arith), const, input) -> eq (Option.filter_map (FilterMapOf.fns pred arith const) input) @@ -156,11 +170,8 @@ module TestFilterMap = struct let filter_map_e = Test.make ~name:"{Option,List([01])}.filter_map_e" - (quad - Test_fuzzing_helpers.Fn.pred - Test_fuzzing_helpers.Fn.arith - one - maybe) + ~print + (Gen.quad pred arith one maybe) (fun (pred, Fun (_, arith), const, input) -> eq_e (Option.filter_map_e (FilterMapEOf.fns pred arith const) input) @@ -172,7 +183,8 @@ module TestFilterMap = struct let filter_map_s = Test.make ~name:"{Option,List([01])}.filter_map_s" - (quad + ~print + (Gen.quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one @@ -188,11 +200,8 @@ module TestFilterMap = struct let filter_map_es = Test.make ~name:"{Option,List([01])}.filter_map_es" - (quad - Test_fuzzing_helpers.Fn.pred - Test_fuzzing_helpers.Fn.arith - one - maybe) + ~print + (Gen.quad pred arith one maybe) (fun (pred, Fun (_, arith), const, input) -> eq_es (Option.filter_map_es (FilterMapESOf.fns pred arith const) input) @@ -208,11 +217,15 @@ end module TestMap = struct open QCheck2 open Monad + open Misc + + let print = Print.(triple print_fn print_int @@ option print_int) let map = Test.make ~name:"{Option,List([01])}.map" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), const, input) -> eq (Option.map (MapOf.fn const fn) input) @@ -221,7 +234,8 @@ module TestMap = struct let map_e = Test.make ~name:"{Option,List([01])}.map_e" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), const, input) -> eq (Option.map_e (MapEOf.fn const fn) input) @@ -230,7 +244,8 @@ module TestMap = struct let map_s = Test.make ~name:"{Option,List([01])}.map_s" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), const, input) -> eq (Option.map_s (MapSOf.fn const fn) input) @@ -239,7 +254,8 @@ module TestMap = struct let map_es = Test.make ~name:"{Option,List([01])}.map_es" - (triple Test_fuzzing_helpers.Fn.arith one maybe) + ~print + (Gen.triple arith one maybe) (fun (Fun (_, fn), const, input) -> eq (Option.map_es (MapESOf.fn const fn) input) diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml index 3abd0e146e58..850310c1ce32 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_seq_tiered.ml @@ -68,11 +68,15 @@ end module TestIter (Tier : TIER) = struct open QCheck2 open Monad + open Misc + + let print = Print.(triple print_fn print_int @@ list print_int) let test_iter = Test.make ~name:(Format.asprintf "Seq{,_%s}.iter" Tier.suffix) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print + (Gen.triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -85,7 +89,8 @@ module TestIter (Tier : TIER) = struct let test_iter_e = Test.make ~name:(Format.asprintf "Seq{,%s}.iter_e" Tier.suffix) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print + (Gen.triple arith one many) (fun (Fun (_, fn), init, input) -> let open Monad in eq_es @@ -99,7 +104,8 @@ module TestIter (Tier : TIER) = struct let test_iter_s = Test.make ~name:(Format.asprintf "Seq{,%s}.iter_s" Tier.suffix) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print + (Gen.triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -112,7 +118,8 @@ module TestIter (Tier : TIER) = struct let test_iter_es = Test.make ~name:(Format.asprintf "Seq{,%s}.iter_es" Tier.suffix) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print + (Gen.triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -164,6 +171,9 @@ module TieredSeq_es : TIER with type t = (int, int) Seq_es.t = struct end module TestedSeq_es = TestIter (TieredSeq_es) +open Misc + +let print = QCheck2.Print.(quad print_fn print_int print_int @@ list print_int) (* testing iter_ep is equivalent in two separate tiers NOTE: only for [Seq_s] *) @@ -171,7 +181,8 @@ let iter_ep = let open QCheck2 in Test.make ~name:(Format.asprintf "Seq{,_s}.iter_ep") - (quad Test_fuzzing_helpers.Fn.arith one one many) + ~print + (Gen.quad arith one one many) (fun (Fun (_, fn), const, init, input) -> let open Monad in eq_es @@ -188,7 +199,8 @@ let iter_p = let open QCheck2 in Test.make ~name:(Format.asprintf "Seq{,_s}.iter_p") - (quad Test_fuzzing_helpers.Fn.arith one one many) + ~print + (Gen.quad arith one one many) (fun (Fun (_, fn), const, init, input) -> let open Monad in eq_es diff --git a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml index b0d6ceec686b..cc658352d4ee 100644 --- a/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml +++ b/src/lib_lwt_result_stdlib/test/test_fuzzing_tests.ml @@ -54,11 +54,13 @@ module TestIterFold (M : sig include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let iter_fold_left = Test.make ~name:(Format.asprintf "%s.{iter,fold_left}" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> let input = M.of_list input in eq @@ -70,7 +72,7 @@ end) : Test = struct let iter_fold_left_e = Test.make ~name:(Format.asprintf "%s.{iter,fold_left}_e" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one many) + (Gen.triple arith_e one many) (fun (fn, init, input) -> let input = M.of_list input in eq_e @@ -81,7 +83,7 @@ end) : Test = struct let iter_fold_left_s = Test.make ~name:(Format.asprintf "%s.{iter,fold_left}_s" M.name) - (triple Test_fuzzing_helpers.Fn.arith_s one many) + (Gen.triple arith_s one many) (fun (fn, init, input) -> let input = M.of_list input in eq_s @@ -92,7 +94,7 @@ end) : Test = struct let iter_fold_left_es = Test.make ~name:(Format.asprintf "%s.{iter,fold_left}_es" M.name) - (triple Test_fuzzing_helpers.Fn.arith_es one many) + (Gen.triple arith_es one many) (fun (fn, init, input) -> let input = M.of_list input in eq_es @@ -112,11 +114,13 @@ module TestRevMapRevMap (M : sig include Traits.REVMAP_PARALLEL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let rev_map = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> let input = M.of_list input in let fn = MapOf.fn const fn in @@ -125,7 +129,7 @@ end) : Test = struct let rev_map_e = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}_e" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one many) + (Gen.triple arith_e one many) (fun (fn, const, input) -> let input = M.of_list input in let fn = MapEOf.fn_e const fn in @@ -134,7 +138,7 @@ end) : Test = struct let rev_map_s = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}_s" M.name) - (triple Test_fuzzing_helpers.Fn.arith_s one many) + (Gen.triple arith_s one many) (fun (fn, const, input) -> let input = M.of_list input in let fn = MapSOf.fn_s const fn in @@ -143,7 +147,7 @@ end) : Test = struct let rev_map_es = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}_es" M.name) - (triple Test_fuzzing_helpers.Fn.arith_es one many) + (Gen.triple arith_es one many) (fun (fn, const, input) -> let input = M.of_list input in let fn = MapESOf.fn_es const fn in @@ -152,7 +156,7 @@ end) : Test = struct let rev_map_p = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}_p" M.name) - (triple Test_fuzzing_helpers.Fn.arith_s one many) + (Gen.triple arith_s one many) (fun (fn, const, input) -> let input = M.of_list input in let fn = MapSOf.fn_s const fn in @@ -161,7 +165,7 @@ end) : Test = struct let rev_map_ep = Test.make ~name:(Format.asprintf "%s.{rev map,rev_map}_ep" M.name) - (triple Test_fuzzing_helpers.Fn.arith_es one many) + (Gen.triple arith_es one many) (fun (fn, const, input) -> let input = M.of_list input in let fn_ep = MapEPOf.fn_ep const fn in @@ -179,6 +183,7 @@ module TestIterAgainstStdlibList (M : sig include Traits.ITER_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let with_stdlib_iter (fn, init, input) = let acc = ref init in @@ -188,7 +193,8 @@ end) : Test = struct let iter = Test.make ~name:(Format.asprintf "%s.iter, Stdlib.List.iter" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq (let acc = ref init in @@ -199,7 +205,8 @@ end) : Test = struct let iter_e = Test.make ~name:(Format.asprintf "%s.iter_e, Stdlib.List.iter" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_e (let acc = ref init in @@ -209,7 +216,8 @@ end) : Test = struct let iter_s = Test.make ~name:(Format.asprintf "%s.iter_s, Stdlib.List.iter" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_s (let acc = ref init in @@ -219,7 +227,8 @@ end) : Test = struct let iter_es = Test.make ~name:(Format.asprintf "%s.iter_es, Stdlib.List.iter" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -235,6 +244,7 @@ module TestIteriAgainstStdlibList (M : sig include Traits.ITERI_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let with_stdlib_iteri (fn, init, input) = let acc = ref init in @@ -244,7 +254,8 @@ end) : Test = struct let iteri = Test.make ~name:(Format.asprintf "%s.iteri, Stdlib.List.iteri" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq (let acc = ref init in @@ -255,7 +266,8 @@ end) : Test = struct let iteri_e = Test.make ~name:(Format.asprintf "%s.iteri_e, Stdlib.List.iteri" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_e (let acc = ref init in @@ -265,7 +277,8 @@ end) : Test = struct let iteri_s = Test.make ~name:(Format.asprintf "%s.iteri_s, Stdlib.List.iteri" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_s (let acc = ref init in @@ -275,7 +288,8 @@ end) : Test = struct let iteri_es = Test.make ~name:(Format.asprintf "%s.iteri_es, Stdlib.List.iteri" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (let acc = ref init in @@ -296,16 +310,20 @@ end) : Test = struct stepper doesn't depend on the accumulator. We do this here with a custom stepper. *) open QCheck2 + open Misc let with_stdlib_iter init (fn, const, input) = let acc = ref init in Stdlib.List.iter (fun elt -> acc := !acc + MapOf.fn const fn elt) input ; !acc + let print = Print.(quad print_int print_fn print_int @@ list print_int) + let iter = Test.make ~name:(Format.asprintf "%s.iter, Stdlib.List.iter" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (init, Fun (_, fn), const, input) -> eq (let acc = ref init in @@ -319,7 +337,8 @@ end) : Test = struct let iter_s = Test.make ~name:(Format.asprintf "%s.iter_s, Stdlib.List.iter" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (init, Fun (_, fn), const, input) -> eq_s (let acc = ref init in @@ -333,7 +352,8 @@ end) : Test = struct let iter_es = Test.make ~name:(Format.asprintf "%s.iter_es, Stdlib.List.iter" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (init, Fun (_, fn), const, input) -> eq_es (let acc = ref init in @@ -347,7 +367,8 @@ end) : Test = struct let iter_p = Test.make ~name:(Format.asprintf "%s.iter_p, Stdlib.List.iter" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (init, Fun (_, fn), const, input) -> eq_s (let acc = ref init in @@ -361,7 +382,8 @@ end) : Test = struct let iter_ep = Test.make ~name:(Format.asprintf "%s.iter_ep, Stdlib.List.iter" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (init, Fun (_, fn), const, input) -> eq_es (let acc = ref init in @@ -381,6 +403,7 @@ module TestMapAgainstStdlibList (M : sig include Traits.MAP_SEQUENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_map (fn, const, input) = Stdlib.List.map (MapOf.fn const fn) input @@ -388,7 +411,8 @@ end) : Test = struct let map = Test.make ~name:(Format.asprintf "%s.map, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq (M.to_list @@ M.map (MapOf.fn const fn) (M.of_list input)) @@ -397,7 +421,8 @@ end) : Test = struct let map_e = Test.make ~name:(Format.asprintf "%s.map_e, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq_e (M.map_e (MapEOf.fn const fn) (M.of_list input) >|? M.to_list) @@ -406,7 +431,8 @@ end) : Test = struct let map_s = Test.make ~name:(Format.asprintf "%s.map_s, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq_s (M.map_s (MapSOf.fn const fn) (M.of_list input) >|= M.to_list) @@ -415,7 +441,8 @@ end) : Test = struct let map_es = Test.make ~name:(Format.asprintf "%s.map_es, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq_es (M.map_es (MapESOf.fn const fn) (M.of_list input) >|=? M.to_list) @@ -430,6 +457,7 @@ module TestMappAgainstStdlibList (M : sig include Traits.MAP_PARALLEL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_map (fn, const, input) = Stdlib.List.map (MapOf.fn const fn) input @@ -437,7 +465,8 @@ end) : Test = struct let map_p = Test.make ~name:(Format.asprintf "%s.map_p, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq_s (M.map_p (MapSOf.fn const fn) (M.of_list input) >|= M.to_list) @@ -446,7 +475,8 @@ end) : Test = struct let map_ep = Test.make ~name:(Format.asprintf "%s.map_ep, Stdlib.List.map" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), const, input) -> eq_es (M.map_ep (MapESOf.fn const fn) (M.of_list input) >|=? M.to_list) @@ -461,6 +491,7 @@ module TestFoldAgainstStdlibList (M : sig include FOLDLEFT_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let with_stdlib_fold_left (fn, init, input) = Stdlib.List.fold_left (FoldOf.fn fn) init input @@ -468,7 +499,8 @@ end) : Test = struct let fold_left = Test.make ~name:(Format.asprintf "%s.fold_left, Stdlib.List.fold_left" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq (M.fold_left (FoldOf.fn fn) init (M.of_list input)) @@ -477,7 +509,8 @@ end) : Test = struct let fold_left_e = Test.make ~name:(Format.asprintf "%s.fold_left_e, Stdlib.List.fold_left" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_e (M.fold_left_e (FoldEOf.fn fn) init (M.of_list input)) @@ -486,7 +519,8 @@ end) : Test = struct let fold_left_s = Test.make ~name:(Format.asprintf "%s.fold_left_s, Stdlib.List.fold_left" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_s (M.fold_left_s (FoldSOf.fn fn) init (M.of_list input)) @@ -495,7 +529,8 @@ end) : Test = struct let fold_left_es = Test.make ~name:(Format.asprintf "%s.fold_left_es, Stdlib.List.fold_left" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (M.fold_left_es (FoldESOf.fn fn) init (M.of_list input)) @@ -510,14 +545,18 @@ module TestFoldMonotonicAgainstStdlibList (M : sig include FOLDOOO_SEQUENTIAL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let with_stdlib_fold_left const (fn, init, input) = Stdlib.List.fold_left (fun acc x -> acc + FoldOf.fn fn const x) init input + let print = Print.(quad print_int print_fn print_int @@ list print_int) + let fold = Test.make ~name:(Format.asprintf "%s.fold, Stdlib.List.fold_left" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (const, Fun (_, fn), init, input) -> eq (M.fold @@ -529,7 +568,8 @@ end) : Test = struct let fold_e = Test.make ~name:(Format.asprintf "%s.fold_e, Stdlib.List.fold_left" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (const, Fun (_, fn), init, input) -> eq_e (M.fold_e @@ -541,7 +581,8 @@ end) : Test = struct let fold_s = Test.make ~name:(Format.asprintf "%s.fold_s, Stdlib.List.fold_left" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (const, Fun (_, fn), init, input) -> eq_s (M.fold_s @@ -553,7 +594,8 @@ end) : Test = struct let fold_es = Test.make ~name:(Format.asprintf "%s.fold_es, Stdlib.List.fold_left" M.name) - (quad one Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad one arith one many) (fun (const, Fun (_, fn), init, input) -> eq_es (M.fold_es @@ -571,6 +613,7 @@ module TestFoldRightAgainstStdlibList (M : sig include Traits.FOLDRIGHT_SEQUENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_fold_right (fn, init, input) = Stdlib.List.fold_right (FoldOf.fn fn) input init @@ -578,7 +621,8 @@ end) : Test = struct let fold_right = Test.make ~name:(Format.asprintf "%s.fold_right, Stdlib.List.fold_right" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq (M.fold_right (FoldOf.fn fn) (M.of_list input) init) @@ -587,7 +631,8 @@ end) : Test = struct let fold_right_e = Test.make ~name:(Format.asprintf "%s.fold_right_e, Stdlib.List.fold_right" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_e (M.fold_right_e (FoldEOf.fn fn) (M.of_list input) init) @@ -596,7 +641,8 @@ end) : Test = struct let fold_right_s = Test.make ~name:(Format.asprintf "%s.fold_right_s, Stdlib.List.fold_right" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_s (M.fold_right_s (FoldSOf.fn fn) (M.of_list input) init) @@ -605,7 +651,8 @@ end) : Test = struct let fold_right_es = Test.make ~name:(Format.asprintf "%s.fold_right_es, Stdlib.List.fold_right" M.name) - (triple Test_fuzzing_helpers.Fn.arith one many) + ~print:Print.(triple print_fn print_int @@ list print_int) + Gen.(triple arith one many) (fun (Fun (_, fn), init, input) -> eq_es (M.fold_right_es (FoldESOf.fn fn) (M.of_list input) init) @@ -621,14 +668,18 @@ module TestExistForallAgainstStdlibList (M : sig Traits.EXISTFORALL_PARALLEL with type 'a elt := int and type 'a t := int t end) : Test = struct open QCheck2 + open Misc let with_stdlib_exists (fn, const, input) = Stdlib.List.exists (CondOf.fn fn const) input + let print = Print.(triple print_pred print_int @@ list print_int) + let exists = Test.make ~name:(Format.asprintf "%s.exists, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq (M.exists (CondOf.fn fn const) (M.of_list input)) @@ -637,7 +688,8 @@ end) : Test = struct let exists_e = Test.make ~name:(Format.asprintf "%s.exists_e, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_e (M.exists_e (CondEOf.fn fn const) (M.of_list input)) @@ -646,7 +698,8 @@ end) : Test = struct let exists_s = Test.make ~name:(Format.asprintf "%s.exists_s, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.exists_s (CondSOf.fn fn const) (M.of_list input)) @@ -655,7 +708,8 @@ end) : Test = struct let exists_es = Test.make ~name:(Format.asprintf "%s.exists_es, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.exists_es (CondESOf.fn fn const) (M.of_list input)) @@ -664,7 +718,8 @@ end) : Test = struct let exists_p = Test.make ~name:(Format.asprintf "%s.exists_p, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.exists_p (CondSOf.fn fn const) (M.of_list input)) @@ -673,7 +728,8 @@ end) : Test = struct let exists_ep = Test.make ~name:(Format.asprintf "%s.exists_ep, Stdlib.List.exists" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.exists_ep (CondESOf.fn fn const) (M.of_list input)) @@ -688,7 +744,8 @@ end) : Test = struct let for_all = Test.make ~name:(Format.asprintf "%s.for_all, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq (M.for_all (CondOf.fn fn const) (M.of_list input)) @@ -697,7 +754,8 @@ end) : Test = struct let for_all_e = Test.make ~name:(Format.asprintf "%s.for_all_e, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_e (M.for_all_e (CondEOf.fn fn const) (M.of_list input)) @@ -706,7 +764,8 @@ end) : Test = struct let for_all_s = Test.make ~name:(Format.asprintf "%s.for_all_s, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.for_all_s (CondSOf.fn fn const) (M.of_list input)) @@ -715,7 +774,8 @@ end) : Test = struct let for_all_es = Test.make ~name:(Format.asprintf "%s.for_all_es, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.for_all_es (CondESOf.fn fn const) (M.of_list input)) @@ -724,7 +784,8 @@ end) : Test = struct let for_all_p = Test.make ~name:(Format.asprintf "%s.for_all_p, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.for_all_p (CondSOf.fn fn const) (M.of_list input)) @@ -733,7 +794,8 @@ end) : Test = struct let for_all_ep = Test.make ~name:(Format.asprintf "%s.for_all_ep, Stdlib.List.for_all" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.for_all_ep (CondESOf.fn fn const) (M.of_list input)) @@ -751,14 +813,18 @@ module TestFilterAgainstStdlibList (M : sig include Traits.FILTER_SEQUENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_filter (fn, const, input) = Stdlib.List.filter (CondOf.fn fn const) input + let print = Print.(triple print_pred print_int @@ list print_int) + let filter = Test.make ~name:(Format.asprintf "%s.filter, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq (M.filter (CondOf.fn fn const) (M.of_list input) |> M.to_list) @@ -767,7 +833,8 @@ end) : Test = struct let filter_e = Test.make ~name:(Format.asprintf "%s.filter_e, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_e (M.filter_e (CondEOf.fn fn const) (M.of_list input) >|? M.to_list) @@ -776,7 +843,8 @@ end) : Test = struct let filter_s = Test.make ~name:(Format.asprintf "%s.filter_s, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.filter_s (CondSOf.fn fn const) (M.of_list input) >|= M.to_list) @@ -785,7 +853,8 @@ end) : Test = struct let filter_es = Test.make ~name:(Format.asprintf "%s.filter_es, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.filter_es (CondESOf.fn fn const) (M.of_list input) >|=? M.to_list) @@ -800,14 +869,18 @@ module TestFilterpAgainstStdlibList (M : sig include Traits.FILTER_PARALLEL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_filter (fn, const, input) = Stdlib.List.filter (CondOf.fn fn const) input + let print = Print.(triple print_pred print_int @@ list print_int) + let filter_p = Test.make ~name:(Format.asprintf "%s.filter_p, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_s (M.filter_p (CondSOf.fn fn const) (M.of_list input) >|= M.to_list) @@ -816,7 +889,8 @@ end) : Test = struct let filter_ep = Test.make ~name:(Format.asprintf "%s.filter_ep, Stdlib.List.filter" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (fn, const, input) -> eq_es (M.filter_ep (CondESOf.fn fn const) (M.of_list input) >|=? M.to_list) @@ -831,14 +905,18 @@ module TestFiltermapAgainstStdlibList (M : sig include Traits.FILTERMAP_SEQUENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_filter_map (pred, arith, const, input) = Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input + let print = Print.(quad print_pred print_fn print_int @@ list print_int) + let filter_map = Test.make ~name:(Format.asprintf "%s.filter_map, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq (M.filter_map (FilterMapOf.fns pred arith const) (M.of_list input) @@ -848,7 +926,8 @@ end) : Test = struct let filter_map_e = Test.make ~name:(Format.asprintf "%s.filter_map_e, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq_e (M.filter_map_e (FilterMapEOf.fns pred arith const) (M.of_list input) @@ -858,7 +937,8 @@ end) : Test = struct let filter_map_s = Test.make ~name:(Format.asprintf "%s.filter_map_s, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq_s (M.filter_map_s (FilterMapSOf.fns pred arith const) (M.of_list input) @@ -868,7 +948,8 @@ end) : Test = struct let filter_map_es = Test.make ~name:(Format.asprintf "%s.filter_map_es, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq_es (M.filter_map_es @@ -886,14 +967,18 @@ module TestFiltermappAgainstStdlibList (M : sig include Traits.FILTERMAP_PARALLEL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_filter_map (pred, arith, const, input) = Stdlib.List.filter_map (FilterMapOf.fns pred arith const) input + let print = Print.(quad print_pred print_fn print_int @@ list print_int) + let filter_map_p = Test.make ~name:(Format.asprintf "%s.filter_map_p, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq_s (M.filter_map_p (FilterMapSOf.fns pred arith const) (M.of_list input) @@ -903,7 +988,8 @@ end) : Test = struct let filter_map_ep = Test.make ~name:(Format.asprintf "%s.filter_map_ep, Stdlib.List.filter_map" M.name) - (quad Test_fuzzing_helpers.Fn.pred Test_fuzzing_helpers.Fn.arith one many) + ~print + Gen.(quad pred arith one many) (fun (pred, Fun (_, arith), const, input) -> eq_es (M.filter_map_ep @@ -921,14 +1007,18 @@ module TestFindStdlibList (M : sig include Traits.FIND_SEQUENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_find (pred, const, input) = Stdlib.List.find_opt (CondOf.fn pred const) input + let print = Print.(triple print_pred print_int @@ list print_int) + let find = Test.make ~name:(Format.asprintf "%s.find, Stdlib.List.find_opt" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq (M.find (CondOf.fn pred const) (M.of_list input)) @@ -937,7 +1027,8 @@ end) : Test = struct let find_e = Test.make ~name:(Format.asprintf "%s.find_e, Stdlib.List.find_opt" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq (M.find_e (CondEOf.fn pred const) (M.of_list input)) @@ -946,7 +1037,8 @@ end) : Test = struct let find_s = Test.make ~name:(Format.asprintf "%s.find_s, Stdlib.List.find_opt" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.find_s (CondSOf.fn pred const) (M.of_list input)) @@ -955,7 +1047,8 @@ end) : Test = struct let find_es = Test.make ~name:(Format.asprintf "%s.find_es, Stdlib.List.find_opt" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.find_es (CondESOf.fn pred const) (M.of_list input)) @@ -970,16 +1063,20 @@ module TestPartitionStdlibList (M : sig include Traits.PARTITION_PARALLEL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let with_stdlib_partition (pred, const, input) = Stdlib.List.partition (CondOf.fn pred const) input let to_list_pair (a, b) = (M.to_list a, M.to_list b) + let print = Print.(triple print_pred print_int @@ list print_int) + let partition = Test.make ~name:(Format.asprintf "%s.partition, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq (M.partition (CondOf.fn pred const) (M.of_list input) |> to_list_pair) @@ -988,7 +1085,8 @@ end) : Test = struct let partition_e = Test.make ~name:(Format.asprintf "%s.partition_e, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq (M.partition_e (CondEOf.fn pred const) (M.of_list input) @@ -998,7 +1096,8 @@ end) : Test = struct let partition_s = Test.make ~name:(Format.asprintf "%s.partition_s, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.partition_s (CondSOf.fn pred const) (M.of_list input) @@ -1008,7 +1107,8 @@ end) : Test = struct let partition_es = Test.make ~name:(Format.asprintf "%s.partition_es, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.partition_es (CondESOf.fn pred const) (M.of_list input) @@ -1018,7 +1118,8 @@ end) : Test = struct let partition_p = Test.make ~name:(Format.asprintf "%s.partition_p, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.partition_p (CondSOf.fn pred const) (M.of_list input) @@ -1028,7 +1129,8 @@ end) : Test = struct let partition_ep = Test.make ~name:(Format.asprintf "%s.partition_ep, Stdlib.List.partition" M.name) - (triple Test_fuzzing_helpers.Fn.pred one many) + ~print + Gen.(triple pred one many) (fun (pred, const, input) -> eq_s (M.partition_ep (CondESOf.fn pred const) (M.of_list input) @@ -1068,6 +1170,7 @@ module TestDoubleTraversorsStdlibList (M : sig include Traits.ALLDOUBLE_SEQENTIAL with type 'a t := 'a t end) : Test = struct open QCheck2 + open Misc let uncurry f (x, y) = f x y @@ -1075,10 +1178,13 @@ end) : Test = struct let uncurry_r f (x, y) acc = f x y acc + let print = Print.(triple print_fn print_int print_manymany) + let iter = Test.make ~name:(Format.asprintf "%s.iter{2,}" M.name) - (triple Test_fuzzing_helpers.Fn.arith one manymany) + ~print + Gen.(triple arith one manymany) (fun (Fun (_, fn), init, (left, right)) -> eq_e (let acc = ref init in @@ -1098,7 +1204,7 @@ end) : Test = struct let iter_e = Test.make ~name:(Format.asprintf "%s.iter{2,}_e" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one manymany) + Gen.(triple arith_e one manymany) (fun (fn, init, (left, right)) -> eq_e (let acc = ref init in @@ -1118,7 +1224,7 @@ end) : Test = struct let iter_s = Test.make ~name:(Format.asprintf "%s.iter{2,}_s" M.name) - (triple Test_fuzzing_helpers.Fn.arith_s one manymany) + (Gen.triple arith_s one manymany) (fun (fn, init, (left, right)) -> eq_s (let acc = ref init in @@ -1140,7 +1246,7 @@ end) : Test = struct let iter_es = Test.make ~name:(Format.asprintf "%s.iter{2,}_es" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one manymany) + Gen.(triple arith_e one manymany) (fun (fn, init, (left, right)) -> eq_es (let acc = ref init in @@ -1164,7 +1270,8 @@ end) : Test = struct let map = Test.make ~name:(Format.asprintf "%s.map{2,}" M.name) - (pair Test_fuzzing_helpers.Fn.arith manymany) + ~print:Print.(pair print_fn print_manymany) + Gen.(pair arith manymany) (fun (Fun (_, fn), (left, right)) -> eq_e (M.map2 @@ -1181,7 +1288,7 @@ end) : Test = struct let map_e = Test.make ~name:(Format.asprintf "%s.map{2,}_e" M.name) - (pair Test_fuzzing_helpers.Fn.arith_e manymany) + Gen.(pair arith_e manymany) (fun (fn, (left, right)) -> eq_e (M.map2_e @@ -1198,7 +1305,7 @@ end) : Test = struct let map_s = Test.make ~name:(Format.asprintf "%s.map{2,}_s" M.name) - (pair Test_fuzzing_helpers.Fn.arith manymany) + Gen.(pair arith manymany) (fun (Fun (_, fn), (left, right)) -> eq_s (M.map2_s @@ -1215,7 +1322,7 @@ end) : Test = struct let map_es = Test.make ~name:(Format.asprintf "%s.map{2,}_es" M.name) - (pair Test_fuzzing_helpers.Fn.arith_e manymany) + Gen.(pair arith_e manymany) (fun (fn, (left, right)) -> eq_es (M.map2_es @@ -1236,7 +1343,8 @@ end) : Test = struct let rev_map = Test.make ~name:(Format.asprintf "%s.rev_map{2,}" M.name) - (pair Test_fuzzing_helpers.Fn.arith manymany) + ~print:Print.(pair print_fn print_manymany) + Gen.(pair arith manymany) (fun (Fun (_, fn), (left, right)) -> eq_e (M.rev_map2 @@ -1253,7 +1361,7 @@ end) : Test = struct let rev_map_e = Test.make ~name:(Format.asprintf "%s.rev_map{2,}_e" M.name) - (pair Test_fuzzing_helpers.Fn.arith_e manymany) + Gen.(pair Test_fuzzing_helpers.Fn.arith_e manymany) (fun (fn, (left, right)) -> eq_e (M.rev_map2_e @@ -1270,7 +1378,8 @@ end) : Test = struct let rev_map_s = Test.make ~name:(Format.asprintf "%s.rev_map{2,}_s" M.name) - (pair Test_fuzzing_helpers.Fn.arith manymany) + ~print:Print.(pair print_fn print_manymany) + Gen.(pair arith manymany) (fun (Fun (_, fn), (left, right)) -> eq_s (M.rev_map2_s @@ -1287,7 +1396,7 @@ end) : Test = struct let rev_map_es = Test.make ~name:(Format.asprintf "%s.rev_map{2,}_es" M.name) - (pair Test_fuzzing_helpers.Fn.arith_e manymany) + Gen.(pair arith_e manymany) (fun (fn, (left, right)) -> eq_es (M.rev_map2_es @@ -1308,7 +1417,8 @@ end) : Test = struct let fold_left = Test.make ~name:(Format.asprintf "%s.fold_left{2,}" M.name) - (triple Test_fuzzing_helpers.Fn.arith one manymany) + ~print + Gen.(triple arith one manymany) (fun (Fun (_, fn), init, (left, right)) -> eq_e (M.fold_left2 @@ -1326,7 +1436,7 @@ end) : Test = struct let fold_left_e = Test.make ~name:(Format.asprintf "%s.fold_left{2,}_e" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one manymany) + Gen.(triple arith_e one manymany) (fun (fn, init, (left, right)) -> eq_e (M.fold_left2_e @@ -1345,7 +1455,8 @@ end) : Test = struct let fold_left_s = Test.make ~name:(Format.asprintf "%s.fold_left{2,}_s" M.name) - (triple Test_fuzzing_helpers.Fn.arith one manymany) + ~print + Gen.(triple arith one manymany) (fun (Fun (_, fn), init, (left, right)) -> eq_s (M.fold_left2_s @@ -1364,7 +1475,7 @@ end) : Test = struct let fold_left_es = Test.make ~name:(Format.asprintf "%s.fold_left{2,}_es" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one manymany) + Gen.(triple arith_e one manymany) (fun (fn, init, (left, right)) -> eq_es (M.fold_left2_es @@ -1387,7 +1498,8 @@ end) : Test = struct let fold_right = Test.make ~name:(Format.asprintf "%s.fold_right{2,}" M.name) - (triple Test_fuzzing_helpers.Fn.arith one manymany) + ~print + Gen.(triple arith one manymany) (fun (Fun (_, fn), init, (left, right)) -> eq_e (M.fold_right2 @@ -1406,7 +1518,7 @@ end) : Test = struct let fold_right_e = Test.make ~name:(Format.asprintf "%s.fold_right{2,}_e" M.name) - (triple Test_fuzzing_helpers.Fn.arith_e one manymany) + Gen.(triple arith_e one manymany) (fun (fn, init, (left, right)) -> eq_e (M.fold_right2_e @@ -1425,7 +1537,8 @@ end) : Test = struct let fold_right_s = Test.make ~name:(Format.asprintf "%s.fold_right{2,}_s" M.name) - (triple Test_fuzzing_helpers.Fn.arith one manymany) + ~print + Gen.(triple arith one manymany) (fun (Fun (_, fn), init, (left, right)) -> eq_s (M.fold_right2_s @@ -1448,7 +1561,7 @@ end) : Test = struct let fold_right_es = Test.make ~name:(Format.asprintf "%s.fold_right{2,}_es" M.name) - (triple Test_fuzzing_helpers.Fn.arith_es one manymany) + Gen.(triple arith_es one manymany) (fun (fn, init, (left, right)) -> eq_es (M.fold_right2_es @@ -1467,10 +1580,13 @@ end) : Test = struct let tests_fold_right = [fold_right; fold_right_e; fold_right_s; fold_right_es] + let print = Print.(pair print_pred print_manymany) + let for_all = Test.make ~name:(Format.asprintf "%s.for_all{2,}" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_e ~pp:PP.(res bool int) @@ -1491,7 +1607,8 @@ end) : Test = struct let for_all_e = Test.make ~name:(Format.asprintf "%s.for_all{2,}_e" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_e ~pp:PP.(res bool int) @@ -1512,7 +1629,8 @@ end) : Test = struct let for_all_s = Test.make ~name:(Format.asprintf "%s.for_all{2,}_s" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_s ~pp:PP.(res bool int) @@ -1533,7 +1651,8 @@ end) : Test = struct let for_all_es = Test.make ~name:(Format.asprintf "%s.for_all{2,}_es" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_es (M.for_all2_es @@ -1555,7 +1674,8 @@ end) : Test = struct let exists = Test.make ~name:(Format.asprintf "%s.exists{2,}" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_e ~pp:PP.(res bool int) @@ -1576,7 +1696,8 @@ end) : Test = struct let exists_e = Test.make ~name:(Format.asprintf "%s.exists{2,}_e" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_e ~pp:PP.(res bool int) @@ -1597,7 +1718,8 @@ end) : Test = struct let exists_s = Test.make ~name:(Format.asprintf "%s.exists{2,}_s" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_s ~pp:PP.(res bool int) @@ -1618,7 +1740,8 @@ end) : Test = struct let exists_es = Test.make ~name:(Format.asprintf "%s.exists{2,}_es" M.name) - (pair Test_fuzzing_helpers.Fn.pred manymany) + ~print + Gen.(pair pred manymany) (fun (pred, (left, right)) -> eq_es (M.exists2_es diff --git a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml index 97c11ea4aff5..31b0e01e409e 100644 --- a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml +++ b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml @@ -58,18 +58,15 @@ type value = Context.value (** Using [QCheck.small_list] for performance reasons: using [QCheck.list] here makes the file 40 times slower, which is not acceptable. *) -let key_arb = QCheck2.small_list QCheck2.string +let key_gen = QCheck2.Gen.(small_list @@ string ?gen:None) -(* As bytes are mutable this is fine because the test doesn't do any - mutation. Otherwise [rev] could be called on a value different than - the value passed to the test. *) -let value_arb = QCheck2.map Bytes.of_string QCheck2.string +let value_gen = QCheck2.Gen.(map Bytes.of_string @@ string ?gen:None) -let key_value_arb = QCheck2.pair key_arb value_arb +let key_value_gen = QCheck2.Gen.(pair key_gen value_gen) (* We generate contexts by starting from a fresh one and doing a sequence of calls to [Context.add]. *) -let context_arb : Context.t QCheck2.arbitrary = +let context_gen : Context.t QCheck2.Gen.t = let set_all key_value_list = Lwt_main.run @@ Lwt_list.fold_left_s @@ -77,7 +74,7 @@ let context_arb : Context.t QCheck2.arbitrary = Memory_context.empty key_value_list in - QCheck2.map set_all @@ QCheck2.small_list key_value_arb + QCheck2.Gen.(map set_all @@ small_list key_value_gen) (** Some printers for passing to [check_eq*] functions *) @@ -147,28 +144,32 @@ let test_set_domain (ctxt, (k, v)) = let () = let test_domain = - QCheck2.Test.make - ~name:"Test_mem_context.domain's specification " - (QCheck2.pair context_arb key_arb) - test_domain_spec + QCheck2.( + Test.make + ~name:"Test_mem_context.domain's specification " + Gen.(pair context_gen key_gen) + test_domain_spec) in let test_set = - QCheck2.Test.make - ~name:"get (set m k v) k = v " - (QCheck2.pair context_arb key_value_arb) - test_get_set + QCheck2.( + Test.make + ~name:"get (set m k v) k = v " + Gen.(pair context_gen key_value_gen) + test_get_set) in let test_get_set_other = - QCheck2.Test.make - ~name:"forall k1 <> k2, get (set m k1 v) k2 = get m k2 " - (QCheck2.pair context_arb key_value_arb) - test_get_set_other + QCheck2.( + Test.make + ~name:"forall k1 <> k2, get (set m k1 v) k2 = get m k2 " + Gen.(pair context_gen key_value_gen) + test_get_set_other) in let test_get_set = - QCheck2.Test.make - ~name:"forall k2 in domain (set m k1 v), k2 in domain m || k1 = k2 " - (QCheck2.pair context_arb key_value_arb) - test_set_domain + QCheck2.( + Test.make + ~name:"forall k2 in domain (set m k1 v), k2 in domain m || k1 = k2 " + Gen.(pair context_gen key_value_gen) + test_set_domain) in Alcotest.run "Memory context array theory" diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index 3bffdb06c1fb..13f410981932 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -39,17 +39,17 @@ module Merkle = Internal.Merkle module Store = Tezos_context_memory.Context open Lib_test.Qcheck2_helpers -(** [list1_arb arb] generates non-empty lists using [arb]. *) -let list1_arb arb = - QCheck2.( - list_of_size Gen.(1 -- 100) arb +(** [list1_gen gen] generates non-empty lists using [gen]. *) +let list1_gen gen = + QCheck2.Gen.( + list_size (1 -- 100) gen |> add_shrink_invariant (fun l -> List.length l > 0)) let irmin_hash_arb = QCheck.oneofl ~print:Fun.id Light_lib.irmin_hashes -let merkle_node_arb = +let merkle_node_gen = let open Tezos_shell_services.Block_services in - let module MapArb = MakeMapArb (TzString.Map) in + let module MapArb = MakeMapGen (TzString.Map) in let open QCheck2 in let open Gen in let raw_context_gen = get_gen raw_context_arb in @@ -83,15 +83,16 @@ let merkle_tree_arb = let open MakeMapArb (TzString.Map) in arb_of_size QCheck2.Gen.(0 -- 10) QCheck2.string merkle_node_arb -let irmin_tree_arb = +let irmin_tree_gen = let module StringList = struct type t = string list let compare = Stdlib.compare end in let module StringListMap = Stdlib.Map.Make (StringList) in - let open MakeMapArb (StringListMap) in + let open MakeMapGen (StringListMap) in let open QCheck2 in + let open Gen in map (fun entries -> List.fold_left_s @@ -99,7 +100,7 @@ let irmin_tree_arb = (Store.Tree.empty Store.empty) entries |> Lwt_main.run) - (small_list (pair (small_list string) bytes_arb)) + (small_list (pair (small_list (string ?gen:None)) bytes_gen)) let get_ok = function Ok x -> x | Error s -> QCheck2.Test.fail_report s @@ -112,7 +113,8 @@ let test_merkle_tree_to_irmin_tree_preserves_simple_tree = ~name: "merkle_tree_to_irmin_tree mtree |> irmin_tree_to_simple_tree = \ merkle_tree_to_simple_tree mtree" - merkle_tree_arb + ~print:print_merkle_tree + merkle_tree_gen @@ fun mtree -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let merkle_irmin_tree = @@ -156,7 +158,8 @@ and remove_data_in_tree mtree = let test_contains_merkle_tree = QCheck2.Test.make ~name:"contains_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = true" - merkle_tree_arb + ~print:print_merkle_tree + merkle_tree_gen @@ fun mtree -> (* Because contains_merkle_tree doesn't support Data nodes, we need to remove them. That's because contains_merkle_tree is only called @@ -181,7 +184,8 @@ let test_union_irmin_empty = ~name: "union_irmin_tree_merkle_tree empty mtree = merkle_tree_to_irmin_tree \ mtree" - merkle_tree_arb + ~print:print_merkle_tree + merkle_tree_gen @@ fun mtree -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let direct_tree = @@ -206,7 +210,8 @@ let test_union_translation = ~name: "union_irmin_tree_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = \ merkle_tree_to_irmin_tree mtree" - merkle_tree_arb + ~print:print_merkle_tree + merkle_tree_gen @@ fun mtree -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let direct_tree = @@ -252,7 +257,8 @@ let test_union_direct = ~name: "union_irmin_tree_merkle_tree (merkle_tree_to_irmin_tree mtree) mtree = \ merkle_tree_to_irmin_tree mtree" - (QCheck2.pair merkle_tree_arb merkle_tree_arb) + ~print:(QCheck2.Print.pair print_merkle_tree print_merkle_tree) + (QCheck2.Gen.pair merkle_tree_gen merkle_tree_gen) @@ fun (mtree1, mtree2) -> match union_merkle_tree mtree1 mtree2 with | None -> @@ -288,7 +294,8 @@ let test_union_commutation = "union_irmin_tree_merkle_tree (union_irmin_tree_merkle_tree empty \ mtree1) mtree2 = union_irmin_tree_merkle_tree \ (union_irmin_tree_merkle_tree empty mtree2) mtree1" - (QCheck2.pair merkle_tree_arb merkle_tree_arb) + ~print:(QCheck2.Print.pair print_merkle_tree print_merkle_tree) + (QCheck2.Gen.pair merkle_tree_gen merkle_tree_gen) @@ fun (mtree1, mtree2) -> match union_merkle_tree mtree1 mtree2 with | None -> @@ -317,7 +324,8 @@ let test_union_commutation = let test_union_merkle_empty = QCheck2.Test.make ~name:"union_irmin_tree_merkle_tree tree empty = tree" - irmin_tree_arb + ~print:print_irmin_tree + irmin_tree_gen @@ fun tree -> let repo = Lwt_main.run (Store.Tree.make_repo ()) in let res = @@ -331,7 +339,19 @@ let test_union_merkle_empty = let test_shape_ignores_key = QCheck2.Test.make ~name:"trees_shape_match ignores the key" - QCheck2.(quad merkle_tree_arb (list string) merkle_node_arb merkle_node_arb) + ~print: + QCheck2.Print.( + quad + print_merkle_tree + (list @@ string) + print_merkle_node + print_merkle_node) + QCheck2.Gen.( + quad + merkle_tree_gen + (list (string ?gen:None)) + merkle_node_gen + merkle_node_gen) @@ fun (tree, key, node1, node2) -> let open Tezos_shell_services.Block_services in let is_continue = function Continue _ -> true | _ -> false in @@ -399,19 +419,20 @@ module HashStability = struct Randomization of shallowing is sub-par (based on tree hash) because otherwise it would be very difficult to provide shrinking. Note that this will no be a problem once QCheck2 provides integrated shrinking. *) - let tree_and_shallow_arb = + let tree_and_shallow_gen = let open QCheck2 in - let repo = Lwt_main.run Store.Tree.make_repo () in - map - ~print:(fun (tree, shallow_tree) -> - Format.asprintf - "(Tree:@.%a@.Shallow tree:@.%a" - Store.Tree.pp - tree - Store.Tree.pp - shallow_tree) + let repo = Lwt_main.run Store.Tree.make_repo in + Gen.map (fun tree -> (tree, Lwt_main.run (make_partial_shallow_tree repo tree))) - irmin_tree_arb + irmin_tree_gen + + let print_tree_and_shallow (tree, shallow_tree) = + Format.asprintf + "(Tree:@.%a@.Shallow tree:@.%a" + Store.Tree.pp + tree + Store.Tree.pp + shallow_tree (** Test that replacing Irmin subtrees by their [Store.Tree.shallow] value leaves the top-level [Store.Tree.hash] unchanged. @@ -421,7 +442,8 @@ module HashStability = struct let test_hash_stability = QCheck2.Test.make ~name:"Shallowing trees does not change their top-level hash" - tree_and_shallow_arb + ~print:print_tree_and_shallow + tree_and_shallow_gen @@ fun (tree, shallow_tree) -> let hash = Store.Tree.hash tree in let shallow_hash = Store.Tree.hash shallow_tree in @@ -460,10 +482,17 @@ module AddTree = struct ~name: "let tree' = Store.Tree.add_tree tree key at_key in \ Store.Tree.find_tree tree' key = at_key" - (triple - HashStability.tree_and_shallow_arb - (list1_arb string) - irmin_tree_arb) + ~print: + Print.( + triple + HashStability.print_tree_and_shallow + (list string) + print_irmin_tree) + Gen.( + triple + HashStability.tree_and_shallow_gen + (list1_gen @@ string ?gen:None) + irmin_tree_gen) (fun ( ((_, tree) : _ * Store.tree), (key : Store.key), (added : Store.tree) ) -> @@ -724,7 +753,8 @@ let add_test_consensus (min_agreement, honest, rogue, consensus_expected) = honest rogue consensus_expected) - (triple merkle_tree_arb (list string) int) + ~print:Print.(triple print_merkle_tree (list string) int) + Gen.(triple merkle_tree_gen (list @@ string ?gen:None) int) @@ fun (mtree, key, randoms) -> Consensus.test_consensus min_agreement @@ -738,17 +768,21 @@ let add_test_consensus (min_agreement, honest, rogue, consensus_expected) = let test_consensus_spec = let open QCheck2 in - let min_agreement_arb = 0 -- 100 in - let honest_arb = 1 -- 1000 in - let rogue_arb = 0 -- 1000 in - let key_arb = list string in + let open Gen in + let min_agreement_gen = 0 -- 100 in + let honest_gen = 1 -- 1000 in + let rogue_gen = 0 -- 1000 in + let key_gen = list @@ string ?gen:None in Test.make ~name: "test_consensus min_agreement honest rogue ... = min_agreeing_endpoints \ min_agreement (honest + rogue + 1) <= honest" + ~print: + Print.( + pair (quad int int int @@ list string) (pair print_merkle_tree int)) (pair - (quad min_agreement_arb honest_arb rogue_arb key_arb) - (pair merkle_tree_arb int)) + (quad min_agreement_gen honest_gen rogue_gen key_gen) + (pair merkle_tree_gen int)) @@ fun ((min_agreement_int, honest, rogue, key), (mtree, seed)) -> assert (0 <= min_agreement_int && min_agreement_int <= 100) ; let min_agreement = Float.of_int min_agreement_int /. 100. in diff --git a/src/lib_rpc_http/test/test_rpc_http.ml b/src/lib_rpc_http/test/test_rpc_http.ml index 9ad80c277766..b73cb9702780 100644 --- a/src/lib_rpc_http/test/test_rpc_http.ml +++ b/src/lib_rpc_http/test/test_rpc_http.ml @@ -33,67 +33,64 @@ RPC HTTP server. *) -module Arbitrary = struct +module Generator = struct open QCheck2 open RPC_server.Acl open Tz_arbitrary - let meth_matcher : meth_matcher arbitrary = - oneofl + let meth_matcher : meth_matcher Gen.t = + Gen.oneofl [Any; Exact `GET; Exact `PUT; Exact `POST; Exact `PATCH; Exact `DELETE] - let chunk_matcher : chunk_matcher arbitrary = + let chunk_matcher : chunk_matcher Gen.t = let of_string s = Literal s in let gen = let open Gen in oneof [char_range '0' '9'; char_range 'A' 'Z'; char_range 'a' 'z'] in - let chunk = make Gen.(string_size ~gen (1 -- 32)) in - choose [always Wildcard; map of_string chunk] + let chunk = Gen.(string_size ~gen (1 -- 32)) in + Gen.(oneof [pure Wildcard; map of_string chunk]) - let path_matcher : path_matcher arbitrary = - let cm = list_of_size Gen.(1 -- 5) chunk_matcher in - choose - [ - map (fun l -> FollowedByAnySuffix l) cm; - map (fun l : path_matcher -> Exact l) cm; - ] + let path_matcher : path_matcher Gen.t = + let cm = Gen.(list_size (1 -- 5) chunk_matcher) in + Gen.( + oneof + [ + map (fun l -> FollowedByAnySuffix l) cm; + map (fun l : path_matcher -> Exact l) cm; + ]) - let matcher : matcher arbitrary = - pair meth_matcher path_matcher - |> map (fun (meth, path) -> {meth; path}) - |> set_print matcher_to_string + let matcher : matcher Gen.t = + Gen.( + pair meth_matcher path_matcher |> map (fun (meth, path) -> {meth; path})) let pp_matchers = let open Format in pp_print_list (fun ppf m -> Format.fprintf ppf "%s" (matcher_to_string m)) - let acl : t arbitrary = - let m = list_of_size Gen.(1 -- 10) matcher in - choose - [ - map (fun m -> Deny_all {except = m}) m; - map (fun m -> Allow_all {except = m}) m; - ] - |> set_print (function - | Allow_all {except} -> - Format.asprintf "Blacklist: [%a]" pp_matchers except - | Deny_all {except} -> - Format.asprintf "Whitelist: [%a]" pp_matchers except) + let acl : t Gen.t = + let m = Gen.(list_size (1 -- 10) matcher) in + Gen.( + oneof + [ + map (fun m -> Deny_all {except = m}) m; + map (fun m -> Allow_all {except = m}) m; + ]) + + let print_acl = function + | Allow_all {except} -> Format.asprintf "Blacklist: [%a]" pp_matchers except + | Deny_all {except} -> Format.asprintf "Whitelist: [%a]" pp_matchers except - let policy : policy arbitrary = + let policy : policy Gen.t = let open Gen in let rec add_to_policy policy n = if n > 0 then - let* acl = get_gen acl and* endpoint = get_gen addr_port_id in + let* acl = acl and* endpoint = addr_port_id in add_to_policy (put_policy (endpoint, acl) policy) (n - 1) else pure policy in - let gen_policy = - let* n = 1 -- 5 in - add_to_policy empty_policy n - in - make gen_policy ~print:policy_to_string + let* n = 1 -- 5 in + add_to_policy empty_policy n (* We test the property that if [searched_for] was found in some [policy], then it also must be found in [put_policy added_one @@ -107,24 +104,35 @@ module Arbitrary = struct added_entry : P2p_point.Id.addr_port_id * t; } - let find_policy_setup : find_policy_setup arbitrary = + let print_find_policy_setup {policy; searched_for; added_entry = (x, y)} = + Format.asprintf + {| +{ + policy: %s; + searched_for: %s; + added_entry: (%s, %s); +} +|} + (RPC_server.Acl.policy_to_string policy) + (P2p_point.Id.addr_port_id_to_string searched_for) + (P2p_point.Id.addr_port_id_to_string x) + (print_acl y) + + let find_policy_setup : find_policy_setup Gen.t = let open QCheck2 in let generate_entry = let open Gen in - let* endpoint = get_gen addr_port_id and* acl = get_gen acl in + let* endpoint = addr_port_id and* acl = acl in pure (endpoint, acl) in - let generate = - let open Gen in - let* p = get_gen policy - and* (searched_for, searched_acl) = generate_entry - and* added_entry = generate_entry in - let* policy = - oneofl [p; RPC_server.Acl.put_policy (searched_for, searched_acl) p] - in - pure {policy; searched_for; added_entry} + let open Gen in + let* p = policy + and* (searched_for, searched_acl) = generate_entry + and* added_entry = generate_entry in + let* policy = + oneofl [p; RPC_server.Acl.put_policy (searched_for, searched_acl) p] in - make generate + pure {policy; searched_for; added_entry} end let example_policy = @@ -186,7 +194,8 @@ let test_codec_identity = let open QCheck2 in Test.make ~name:"Encoding and decoding an ACL is an identity function." - Arbitrary.policy + ~print:RPC_server.Acl.policy_to_string + Generator.policy (fun policy -> let json = Data_encoding.Json.construct RPC_server.Acl.policy_encoding policy @@ -214,7 +223,8 @@ let check_find_policy = in Test.make ~name:"put_policy preserves existing entries." - Arbitrary.find_policy_setup + ~print:Generator.print_find_policy_setup + Generator.find_policy_setup (fun {policy; searched_for; added_entry} -> let open RPC_server.Acl in let search_str = P2p_point.Id.addr_port_id_to_string searched_for in diff --git a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml index 74098574766f..b0f6c4f82544 100644 --- a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml +++ b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml @@ -127,6 +127,7 @@ let forge_peer_id () = let peer_id = let open QCheck2 in + let open Gen in let p1 = forge_peer_id () in let p2 = forge_peer_id () in let p3 = forge_peer_id () in @@ -136,27 +137,24 @@ let peer_id = let p7 = forge_peer_id () in let p8 = forge_peer_id () in let p9 = forge_peer_id () in - let pp_peer_id pid = - let id = - if pid == p1 then "P1" - else if pid == p2 then "P2" - else if pid == p3 then "P3" - else if pid == p4 then "P4" - else if pid == p5 then "P5" - else if pid == p6 then "P6" - else if pid == p7 then "P7" - else if pid == p8 then "P8" - else if pid == p9 then "P9" - else "fresh" - in - Format.asprintf "peer: %s" id - in - (map (fun () -> forge_peer_id ()) unit |> set_print pp_peer_id) - :: - List.map - (fun p -> make ~print:pp_peer_id (Gen.return p)) - [p1; p2; p3; p4; p5; p6; p7; p8; p9] - |> choose + (* let pp_peer_id pid = + let id = + if pid == p1 then "P1" + else if pid == p2 then "P2" + else if pid == p3 then "P3" + else if pid == p4 then "P4" + else if pid == p5 then "P5" + else if pid == p6 then "P6" + else if pid == p7 then "P7" + else if pid == p8 then "P8" + else if pid == p9 then "P9" + else "fresh" + in + Format.asprintf "peer: %s" id + in *) + map (fun () -> forge_peer_id ()) unit + :: List.map pure [p1; p2; p3; p4; p5; p6; p7; p8; p9] + |> oneof let now = Time.System.to_protocol @@ Systime_os.now () @@ -164,26 +162,34 @@ let forge_timestamp ~delay = Time.Protocol.add now (Int64.of_int delay) let timestamp = let open QCheck2 in - let timestamp_pp n = - let delay = Time.Protocol.diff n now in - Format.asprintf "delay: %Ld" delay - in + let open Gen in map (fun pre_delay -> let delay = (pre_delay * 20) - 300 in (* ~ [ -300; 100] with a step of 20 *) forge_timestamp ~delay) - (make (Gen.oneof [Gen.return 5; Gen.int_range 0 20])) - |> set_print timestamp_pp + (oneof [pure 5; 0 -- 20]) + +let timestamp_pp n = + let delay = Time.Protocol.diff n now in + Format.asprintf "delay: %Ld" delay let value = - let open QCheck2 in + let open QCheck2.Gen in pair timestamp peer_id +let value_pp = + let open QCheck2.Print in + pair timestamp_pp (fun _ -> "") + let values = - let open QCheck2 in + let open QCheck2.Gen in list value +let values_pp = + let open QCheck2.Print in + list value_pp + let pp fmt = let open Reference in function @@ -202,7 +208,8 @@ let make_tests check_update lcreate rcreate threshold latency = (threshold %d) (latency %d)" 1 latency) - QCheck2.(pair value value) + ~print:QCheck2.Print.(pair value_pp value_pp) + QCheck2.Gen.(pair value value) (fun (v1, v2) -> let state_left = lcreate ~threshold:1 ~latency in let state_right = rcreate ~threshold:1 ~latency in @@ -219,6 +226,7 @@ let make_tests check_update lcreate rcreate threshold latency = (threshold %d) (latency %d)" threshold latency) + ~print:values_pp values (fun values -> let state_left = lcreate ~threshold ~latency in diff --git a/src/lib_stdlib/test/test_bounded_heap.ml b/src/lib_stdlib/test/test_bounded_heap.ml index d00c8d769955..0d4beb9b2aa5 100644 --- a/src/lib_stdlib/test/test_bounded_heap.ml +++ b/src/lib_stdlib/test/test_bounded_heap.ml @@ -49,7 +49,8 @@ let test_bounded_heap = QCheck2.Test.make ~name:"bounded_heap (qcheck)" ~count:1000 - QCheck2.(list_of_size list_size int) + ~print:QCheck2.Print.(list int) + (QCheck2.Gen.list_size list_size QCheck2.Gen.int) (fun l -> let sz = List.length l / 2 in QCheck2.assume (sz > 0) ; diff --git a/src/lib_stdlib/test/test_tzList.ml b/src/lib_stdlib/test/test_tzList.ml index 45efa136515c..6327cc711971 100644 --- a/src/lib_stdlib/test/test_tzList.ml +++ b/src/lib_stdlib/test/test_tzList.ml @@ -88,7 +88,7 @@ let test_shuffle_preserves_values = QCheck2.Test.make ~name:"shuffle preserves value sets" ~count:1000 - QCheck2.(list_of_size list_size int) + QCheck2.(Gen.list_size list_size Gen.int) (fun l -> let l1 = List.sort Int.compare l in let l2 = List.sort Int.compare (TzList.shuffle l) in diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index aeb8cfc88df7..c8e6cad220b4 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -62,52 +62,25 @@ let int64_range a b = assert (a <= res && res <= b) ; res in - let gen = - Gen.make_primitive - ~gen: - int64_range_gen - (* TODO expose/reimplement QCheck2 logic of shrinking towards [0L] while respecting limits *) - ~shrink:(Shrink.int64_towards a) - in - int64 |> set_gen gen + Gen.make_primitive + ~gen: + int64_range_gen + (* TODO expose/reimplement QCheck2 logic of shrinking towards [0L] while respecting limits *) + ~shrink:(Shrink.int64_towards a) let rec of_option_gen gen = let open QCheck2.Gen in gen >>= function None -> of_option_gen gen | Some a -> pure a -let of_option_arb arb = - let open QCheck2 in - let gen = of_option_gen (get_gen arb) in - let print = - Option.map (fun print_opt a -> print_opt (Some a)) (get_print arb) - in - let collect = - Option.map (fun collect_opt a -> collect_opt (Some a)) (get_collect arb) - in - let stats = - List.map (fun (s, f_opt) -> (s, fun a -> f_opt (Some a))) (get_stats arb) - in - QCheck2.make ?print ?collect ~stats gen - -let uint16 = QCheck2.(0 -- 65535) +let uint16 = QCheck2.Gen.(0 -- 65535) -let int16 = QCheck2.(-32768 -- 32767) +let int16 = QCheck2.Gen.(-32768 -- 32767) -let bytes_arb = QCheck2.(map Bytes.of_string string) +let bytes_gen = QCheck2.Gen.(map Bytes.of_string @@ string ?gen:None) -module MakeMapArb (Map : Stdlib.Map.S) = struct +module MakeMapGen (Map : Stdlib.Map.S) = struct open QCheck2 - let arb_of_size (size_gen : int Gen.t) (key_arb : Map.key arbitrary) - (val_arb : 'v arbitrary) : 'v Map.t arbitrary = - map - (fun entries -> List.to_seq entries |> Map.of_seq) - (list_of_size size_gen @@ pair key_arb val_arb) - - let arb (key_arb : Map.key arbitrary) (val_arb : 'v arbitrary) : - 'v Map.t arbitrary = - arb_of_size Gen.small_nat key_arb val_arb - let gen_of_size (size_gen : int Gen.t) (key_gen : Map.key Gen.t) (val_gen : 'v Gen.t) : 'v Map.t Gen.t = let open Gen in diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli index 1de1012e29f4..eb1c8e815976 100644 --- a/src/lib_test/qcheck2_helpers.mli +++ b/src/lib_test/qcheck2_helpers.mli @@ -64,7 +64,7 @@ val qcheck_eq' : Poorman's implementation until https://github.com/c-cube/qcheck/issues/105 is done. This probably spectacularly crashes if [(b - a) > Int64.max_int]. *) -val int64_range : int64 -> int64 -> int64 QCheck2.arbitrary +val int64_range : int64 -> int64 -> int64 QCheck2.Gen.t (** [of_option_gen gen] converts a generator [gen] of optional values into a generator of values by rerunning the generator if the generated value @@ -73,55 +73,21 @@ val int64_range : int64 -> int64 -> int64 QCheck2.arbitrary Be careful: if [None] is always returned, this hangs forever! *) val of_option_gen : 'a option QCheck2.Gen.t -> 'a QCheck2.Gen.t -(** [of_option_arb arb] converts an arbitrary [arb] of optional values into - an arbitrary of values. - - - Generation of values is delegated to {!of_option_gen} (retries on - [None] values until a [Some] is generated). - - Shrinking uses the input shrinker but ignores [None] values. - - Be careful: if [None] is always returned, this hangs forever! -*) -val of_option_arb : 'a option QCheck2.arbitrary -> 'a QCheck2.arbitrary - -(** [uint16] generates an unsigned int16 arbitrary +(** [uint16] generates an unsigned int16 generator - Generation of values is delegated to {!int_range} *) -val uint16 : int QCheck2.arbitrary +val uint16 : int QCheck2.Gen.t -(** [int16] generates a signed int16 arbitrary +(** [int16] generates a signed int16 generator - Generation of values is delegated to {!int_range} *) -val int16 : int QCheck2.arbitrary - -(** [bytes_arb] is an arbitrary of bytes. *) -val bytes_arb : bytes QCheck2.arbitrary - -(** Map-related arbitraries/generators. *) -module MakeMapArb (Map : Stdlib.Map.S) : sig - (** [arb_of_size size_gen key_arb val_arb] is an arbitrary of Map - where the keys are generated with [key_arb] and the values with [val_arb]. - - The number of entries in the map is decided by [size_gen]. - - The arbitrary shrinks on the number of entries as well as on entries - if either the key or value arbitrary has a shrinker. *) - val arb_of_size : - int QCheck2.Gen.t -> - Map.key QCheck2.arbitrary -> - 'v QCheck2.arbitrary -> - 'v Map.t QCheck2.arbitrary - - (** [arb key_arb val_arb] is an arbitrary of Map where the keys are - generated with [key_arb] and the values with [val_arb]. +val int16 : int QCheck2.Gen.t - The arbitrary shrinks on the number of entries as well as on entries - if either the key or value arbitrary has a shrinker. *) - val arb : - Map.key QCheck2.arbitrary -> - 'v QCheck2.arbitrary -> - 'v Map.t QCheck2.arbitrary +(** [bytes_gen] is a generator of bytes. *) +val bytes_gen : bytes QCheck2.Gen.t +(** Map-related generators. *) +module MakeMapGen (Map : Stdlib.Map.S) : sig (** [gen_of_size size_gen key_gen val_gen] is a generator of Map where the keys are generated with [key_gen] and the values with [val_gen]. The number of entries in the map is decided by [size_gen]. *) @@ -131,7 +97,7 @@ module MakeMapArb (Map : Stdlib.Map.S) : sig 'v QCheck2.Gen.t -> 'v Map.t QCheck2.Gen.t - (** [gen key_gen arb_gen] is a generator of Map where the keys - are generated with [key_arb] and the values with [val_arb]. *) + (** [gen key_gen val_gen] is a generator of Map where the keys + are generated with [key_gen] and the values with [val_gen]. *) val gen : Map.key QCheck2.Gen.t -> 'v QCheck2.Gen.t -> 'v Map.t QCheck2.Gen.t end diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml b/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml index f020bd802615..34d3b00a1689 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/saturation_fuzzing.ml @@ -34,12 +34,14 @@ open Protocol.Saturation_repr open Lib_test.Qcheck2_helpers (** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_arb = of_option_arb @@ QCheck2.map of_int_opt QCheck2.int +let unsatured_gen = of_option_gen @@ QCheck2.Gen.(map of_int_opt int) (** The general generator for [t]: generates both unsaturated values and [saturated]. *) -let t_arb : may_saturate t QCheck2.arbitrary = - QCheck2.frequency [(1, QCheck2.always saturated); (4, unsatured_arb)] +let gen : may_saturate t QCheck2.Gen.t = + QCheck2.Gen.(frequency [(1, pure saturated); (4, unsatured_gen)]) + +let print : may_saturate t -> string = Format.asprintf "%a" pp (* Test. * Tests that [add] commutes. @@ -47,7 +49,7 @@ let t_arb : may_saturate t QCheck2.arbitrary = let test_add_commutes = QCheck2.Test.make ~name:"t1 + t2 = t2 + t1" - (QCheck2.pair t_arb t_arb) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in let t2_plus_t1 = add t2 t1 in @@ -59,7 +61,7 @@ let test_add_commutes = let test_mul_commutes = QCheck2.Test.make ~name:"t1 * t2 = t2 * t1" - (QCheck2.pair t_arb t_arb) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_times_t2 = mul t1 t2 in let t2_times_t1 = mul t2 t1 in @@ -69,7 +71,7 @@ let test_mul_commutes = * Tests that [zero] is neutral for [add]. *) let test_add_zero = - QCheck2.Test.make ~name:"t + 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t + 0 = t" gen (fun t -> let t_plus_zero = add t zero in qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) @@ -79,7 +81,8 @@ let test_add_zero = let test_add_neq = QCheck2.Test.make ~name:"t1 + t2 >= t1" - (QCheck2.pair t_arb t_arb) + ~print:(QCheck2.Print.pair print print) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in t1_plus_t2 >= t1) @@ -89,7 +92,7 @@ let test_add_neq = *) let test_mul_one = let one = safe_int 1 in - QCheck2.Test.make ~name:"t * 1 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 1 = t" gen (fun t -> let t_times_one = mul t one in qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) @@ -97,7 +100,7 @@ let test_mul_one = * Tests that [t] times [0] equals [0]. *) let test_mul_zero = - QCheck2.Test.make ~name:"t * 0 = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 0 = 0" gen (fun t -> let t_times_zero = mul t zero in qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) @@ -105,7 +108,7 @@ let test_mul_zero = * Tests that [t] [sub] [zero] equals [t]. *) let test_sub_zero = - QCheck2.Test.make ~name:"t - 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t - 0 = t" gen (fun t -> let t_sub_zero = sub t zero in qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) @@ -113,7 +116,7 @@ let test_sub_zero = * Tests that [t] [sub] [t] equals [zero]. *) let test_sub_itself = - QCheck2.Test.make ~name:"t - t = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t - t = 0" gen (fun t -> let t_sub_t = sub t t in qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) @@ -123,7 +126,8 @@ let test_sub_itself = let test_sub_neq = QCheck2.Test.make ~name:"t1 - t2 <= t1" - (QCheck2.pair t_arb t_arb) + ~print:QCheck2.Print.(pair print print) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_minus_t2 = sub t1 t2 in t1_minus_t2 <= t1) @@ -134,7 +138,8 @@ let test_sub_neq = let test_add_sub = QCheck2.Test.make ~name:"(t1 + t2) - t2 <= t1" - (QCheck2.pair t_arb t_arb) + ~print:QCheck2.Print.(pair print print) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let lhs = sub (add t1 t2) t2 in lhs <= t1) @@ -145,7 +150,8 @@ let test_add_sub = let test_sub_add = QCheck2.Test.make ~name:"(t1 - t2) + t2 >= t1" - (QCheck2.pair t_arb t_arb) + ~print:QCheck2.Print.(pair print print) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let lhs = add (sub t1 t2) t2 in lhs >= t1) @@ -154,12 +160,13 @@ let test_sub_add = * Tests that [saturated] >= t *) let test_leq_saturated = - QCheck2.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) + QCheck2.Test.make ~name:"t <= saturated" ~print gen (fun t -> saturated >= t) (* Test. * Tests that [zero] <= t *) -let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) +let test_geq_zero = + QCheck2.Test.make ~name:"t >= 0" ~print gen (fun t -> zero <= t) let tests_add = [test_add_commutes; test_add_zero; test_add_neq] diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml index 32eff94aaac5..9b7b2e263507 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_gas_properties.ml @@ -87,8 +87,8 @@ let test_consume_commutes (start, cost1, cost2) = (Gas.consumed ~since:start ~until:branch2)) ) (** Arbitrary context with a gas limit of 100_000_000. *) -let context_arb : Alpha_context.t QCheck2.arbitrary = - QCheck2.always +let context_gen : Alpha_context.t QCheck2.Gen.t = + QCheck2.Gen.pure (Lwt_main.run ( Context.init 1 >>=? fun (b, _contracts) -> Incremental.begin_construction b >|=? fun inc -> @@ -101,12 +101,13 @@ let context_arb : Alpha_context.t QCheck2.arbitrary = | Error _ -> assert false) (** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_arb : Alpha_context.Gas.cost QCheck2.arbitrary = +let gas_cost_gen : Alpha_context.Gas.cost QCheck2.Gen.t = let open Alpha_context.Gas in let open QCheck2 in + let open Gen in let rand = 0 -- 1000 in let safe_rand = map Saturation_repr.safe_int rand in - choose + oneof [ map atomic_step_cost safe_rand; map step_cost safe_rand; @@ -122,17 +123,17 @@ let tests = QCheck2.Test.make ~count:1000 ~name:"Consuming commutes" - QCheck2.(triple context_arb gas_cost_arb gas_cost_arb) + QCheck2.Gen.(triple context_gen gas_cost_gen gas_cost_gen) test_consume_commutes; QCheck2.Test.make ~count:1000 ~name:"Consuming [free] consumes nothing" - context_arb + context_gen test_free_consumption; QCheck2.Test.make ~count:1000 ~name:"[free] is the neutral element of Gas addition" - QCheck2.(pair context_arb gas_cost_arb) + QCheck2.Gen.(pair context_gen gas_cost_gen) test_free_neutral; ] diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml index 01faf284c025..e5e74bb7f663 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml @@ -73,31 +73,32 @@ let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) ((a, b) : Tez.t * int64) : bool = compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) -(** Arbitrary int64 by conversion from int32 *) -let arb_int64_of32 : int64 QCheck2.arbitrary = - QCheck2.(map Int64.of_int32 int32) +(** Generator int64 by conversion from int32 *) +let gen_int64_of32 : int64 QCheck2.Gen.t = + QCheck2.Gen.(map Int64.of_int32 int32) -(** Arbitrary int64 mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let arb_int64_sizes : int64 QCheck2.arbitrary = +(** Generator int64 mixing small positive integers, + int64s from int32 and generator int64 with equal frequency *) +let gen_int64_sizes : int64 QCheck2.Gen.t = let open QCheck2 in - oneof [QCheck2.map Int64.of_int (int_range (-10) 10); arb_int64_of32; int64] + let open Gen in + oneof [map Int64.of_int (int_range (-10) 10); gen_int64_of32; int64] -(** Arbitrary positive int64, mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let arb_ui64_sizes : int64 QCheck2.arbitrary = +(** Generator positive int64, mixing small positive integers, + int64s from int32 and generator int64 with equal frequency *) +let gen_ui64_sizes : int64 QCheck2.Gen.t = let open QCheck2 in - map_same_type + Gen.map (fun i -> let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in assert (v >= 0L) ; v) - arb_int64_sizes + gen_int64_sizes -(** Arbitrary tez based on [arb_tez_sizes] *) -let arb_tez_sizes = +(** Generator tez based on [gen_tez_sizes] *) +let gen_tez_sizes = let open QCheck2 in - map Tez.of_mutez_exn arb_ui64_sizes + Gen.map Tez.of_mutez_exn gen_ui64_sizes let test_coherent_mul = QCheck.Test.make diff --git a/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml b/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml index 5e2d809a0bc7..817e94c07257 100644 --- a/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml +++ b/src/proto_alpha/lib_protocol/test/saturation_fuzzing.ml @@ -34,12 +34,16 @@ open Protocol.Saturation_repr open Lib_test.Qcheck2_helpers (** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_arb = of_option_arb @@ QCheck2.map of_int_opt QCheck2.int +let unsatured_gen = of_option_gen @@ QCheck2.Gen.(map of_int_opt int) (** The general generator for [t]: generates both unsaturated values and [saturated]. *) -let t_arb : may_saturate t QCheck2.arbitrary = - QCheck2.frequency [(1, QCheck2.always saturated); (4, unsatured_arb)] +let gen : may_saturate t QCheck2.Gen.t = + QCheck2.Gen.(frequency [(1, pure saturated); (4, unsatured_gen)]) + +let print = Format.asprintf "%a" pp + +let print_double = QCheck2.Print.(pair print print) (* Test. * Tests that [add] commutes. @@ -47,7 +51,7 @@ let t_arb : may_saturate t QCheck2.arbitrary = let test_add_commutes = QCheck2.Test.make ~name:"t1 + t2 = t2 + t1" - (QCheck2.pair t_arb t_arb) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in let t2_plus_t1 = add t2 t1 in @@ -59,7 +63,7 @@ let test_add_commutes = let test_mul_commutes = QCheck2.Test.make ~name:"t1 * t2 = t2 * t1" - (QCheck2.pair t_arb t_arb) + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_times_t2 = mul t1 t2 in let t2_times_t1 = mul t2 t1 in @@ -69,7 +73,7 @@ let test_mul_commutes = * Tests that [zero] is neutral for [add]. *) let test_add_zero = - QCheck2.Test.make ~name:"t + 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t + 0 = t" gen (fun t -> let t_plus_zero = add t zero in qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) @@ -79,7 +83,8 @@ let test_add_zero = let test_add_neq = QCheck2.Test.make ~name:"t1 + t2 >= t1" - (QCheck2.pair t_arb t_arb) + ~print:print_double + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in t1_plus_t2 >= t1) @@ -89,7 +94,7 @@ let test_add_neq = *) let test_mul_one = let one = safe_int 1 in - QCheck2.Test.make ~name:"t * 1 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 1 = t" gen (fun t -> let t_times_one = mul t one in qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) @@ -97,7 +102,7 @@ let test_mul_one = * Tests that [t] times [0] equals [0]. *) let test_mul_zero = - QCheck2.Test.make ~name:"t * 0 = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 0 = 0" gen (fun t -> let t_times_zero = mul t zero in qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) @@ -105,7 +110,7 @@ let test_mul_zero = * Tests that [t] [sub] [zero] equals [t]. *) let test_sub_zero = - QCheck2.Test.make ~name:"t - 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t - 0 = t" gen (fun t -> let t_sub_zero = sub t zero in qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) @@ -113,7 +118,7 @@ let test_sub_zero = * Tests that [t] [sub] [t] equals [zero]. *) let test_sub_itself = - QCheck2.Test.make ~name:"t - t = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t - t = 0" gen (fun t -> let t_sub_t = sub t t in qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) @@ -123,7 +128,8 @@ let test_sub_itself = let test_sub_neq = QCheck2.Test.make ~name:"t1 - t2 <= t1" - (QCheck2.pair t_arb t_arb) + ~print:print_double + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let t1_minus_t2 = sub t1 t2 in t1_minus_t2 <= t1) @@ -134,7 +140,8 @@ let test_sub_neq = let test_add_sub = QCheck2.Test.make ~name:"(t1 + t2) - t2 <= t1" - (QCheck2.pair t_arb t_arb) + ~print:print_double + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let lhs = sub (add t1 t2) t2 in lhs <= t1) @@ -145,7 +152,8 @@ let test_add_sub = let test_sub_add = QCheck2.Test.make ~name:"(t1 - t2) + t2 >= t1" - (QCheck2.pair t_arb t_arb) + ~print:print_double + (QCheck2.Gen.pair gen gen) (fun (t1, t2) -> let lhs = add (sub t1 t2) t2 in lhs >= t1) @@ -154,12 +162,13 @@ let test_sub_add = * Tests that [saturated] >= t *) let test_leq_saturated = - QCheck2.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) + QCheck2.Test.make ~name:"t <= saturated" ~print gen (fun t -> saturated >= t) (* Test. * Tests that [zero] <= t *) -let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) +let test_geq_zero = + QCheck2.Test.make ~name:"t >= 0" ~print gen (fun t -> zero <= t) let tests_add = [test_add_commutes; test_add_zero; test_add_neq] diff --git a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml index 484d672b0696..aa7ece77975b 100644 --- a/src/proto_alpha/lib_protocol/test/test_gas_properties.ml +++ b/src/proto_alpha/lib_protocol/test/test_gas_properties.ml @@ -86,9 +86,9 @@ let test_consume_commutes (start, cost1, cost2) = (Gas.consumed ~since:start ~until:branch1) (Gas.consumed ~since:start ~until:branch2)) ) -(** Arbitrary context with a gas limit of 100_000_000. *) -let context_arb : Alpha_context.t QCheck2.arbitrary = - QCheck2.always +(** Generator context with a gas limit of 100_000_000. *) +let context_gen : Alpha_context.t QCheck2.Gen.t = + QCheck2.Gen.pure (Lwt_main.run ( Context.init 1 >>=? fun (b, _contracts) -> Incremental.begin_construction b >|=? fun inc -> @@ -100,13 +100,17 @@ let context_arb : Alpha_context.t QCheck2.arbitrary = | Ok a -> a | Error _ -> assert false) -(** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_arb : Alpha_context.Gas.cost QCheck2.arbitrary = +(** This generator could be improved (pretty printer and shrinker) if there was + a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom + [generator] instance, but I wanted to stick to the former design of this test for + the time being. *) +let gas_cost_gen : Alpha_context.Gas.cost QCheck2.Gen.t = let open Alpha_context.Gas in let open QCheck2 in + let open Gen in let rand = 0 -- 1000 in let safe_rand = map Saturation_repr.safe_int rand in - choose + oneof [ map atomic_step_cost safe_rand; map step_cost safe_rand; @@ -122,17 +126,17 @@ let tests = QCheck2.Test.make ~count:1000 ~name:"Consuming commutes" - QCheck2.(triple context_arb gas_cost_arb gas_cost_arb) + QCheck2.(Gen.triple context_gen gas_cost_gen gas_cost_gen) test_consume_commutes; QCheck2.Test.make ~count:1000 ~name:"Consuming [free] consumes nothing" - context_arb + context_gen test_free_consumption; QCheck2.Test.make ~count:1000 ~name:"[free] is the neutral element of Gas addition" - QCheck2.(pair context_arb gas_cost_arb) + QCheck2.(Gen.pair context_gen gas_cost_gen) test_free_neutral; ] diff --git a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml index 9bb60e4b4a72..5f1eeb8e14b3 100644 --- a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml @@ -73,31 +73,33 @@ let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) ((a, b) : Tez.t * int64) : bool = compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) -(** Arbitrary int64 by conversion from int32 *) -let arb_int64_of32 : int64 QCheck2.arbitrary = - QCheck2.(map Int64.of_int32 int32) +(** Generator int64 by conversion from int32 *) +let gen_int64_of32 : int64 QCheck2.Gen.t = + QCheck2.Gen.(map Int64.of_int32 int32) -(** Arbitrary int64 mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let arb_int64_sizes : int64 QCheck2.arbitrary = +(** Generator int64 mixing small positive integers, + int64s from int32 and genitrary int64 with equal frequency *) +let gen_int64_sizes : int64 QCheck2.Gen.t = let open QCheck2 in - oneof [QCheck2.map Int64.of_int (int_range (-10) 10); arb_int64_of32; int64] + let open Gen in + oneof [map Int64.of_int (int_range (-10) 10); gen_int64_of32; int64] -(** Arbitrary positive int64, mixing small positive integers, - int64s from int32 and arbitrary int64 with equal frequency *) -let arb_ui64_sizes : int64 QCheck2.arbitrary = +(** Generator positive int64, mixing small positive integers, + int64s from int32 and genitrary int64 with equal frequency *) +let gen_ui64_sizes : int64 QCheck2.Gen.t = let open QCheck2 in - map_same_type + let open Gen in + map (fun i -> let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in assert (v >= 0L) ; v) - arb_int64_sizes + gen_int64_sizes -(** Arbitrary tez based on [arb_tez_sizes] *) -let arb_tez_sizes = +(** Generator tez based on [gen_tez_sizes] *) +let gen_tez_sizes = let open QCheck2 in - map Tez.of_mutez_exn arb_ui64_sizes + Gen.map Tez.of_mutez_exn gen_ui64_sizes let test_coherent_mul = QCheck.Test.make -- GitLab From e1cd9a6b6e49a4b3726927bf6436398092f384ff Mon Sep 17 00:00:00 2001 From: Julien Debon Date: Mon, 26 Jul 2021 11:31:15 +0200 Subject: [PATCH 6/6] Some more migration --- src/lib_base/test/test_p2p_addr.ml | 29 +++---- src/lib_base/test_helpers/tz_arbitrary.ml | 45 ++++------ .../test/test_mem_context_array_theory.ml | 4 +- src/lib_proxy/test/light_lib.ml | 63 +++++--------- src/lib_proxy/test/test_fuzzing_light.ml | 84 ++++++++++--------- .../test/test_fuzzing_proxy_getter.ml | 16 ++-- src/lib_rpc_http/test/test_rpc_http.ml | 2 +- src/lib_test/qcheck2_helpers.ml | 11 +-- .../lib_protocol/test/test_tez_repr.ml | 20 ++--- .../lib_protocol/test/test_tez_repr.ml | 20 ++--- 10 files changed, 126 insertions(+), 168 deletions(-) diff --git a/src/lib_base/test/test_p2p_addr.ml b/src/lib_base/test/test_p2p_addr.ml index 58cfc01ee6a1..2260edc41164 100644 --- a/src/lib_base/test/test_p2p_addr.ml +++ b/src/lib_base/test/test_p2p_addr.ml @@ -38,38 +38,31 @@ open Lib_test.Qcheck2_helpers tezos-base-test-helpers and tezos-base packages, which opam would not allow. *) module Arbitrary = struct - open QCheck2 + open QCheck2.Gen let port = uint16 - let port_opt = QCheck2.option port + let port_opt = opt port (* could not craft a [p2p_identity QCheck2.gen], we use instead a constant [unit -> p2p_identity] which will be applied at each testing points. *) - let peer_id = - QCheck2.option QCheck2.(map P2p_identity.generate_with_pow_target_0 unit) + let peer_id = opt (map P2p_identity.generate_with_pow_target_0 unit) - let ipv4 = - map ~rev:Ipaddr.V4.to_int32 Ipaddr.V4.of_int32 int32 - |> set_print Ipaddr.V4.to_string + let ipv4 = map Ipaddr.V4.of_int32 int32 - let ipv6 = - map ~rev:Ipaddr.V6.to_int64 Ipaddr.V6.of_int64 (pair int64 int64) - |> set_print Ipaddr.V6.to_string + let ipv6 = map Ipaddr.V6.of_int64 (pair int64 int64) - let ipv4t = QCheck2.triple ipv4 port_opt peer_id + let ipv4t = triple ipv4 port_opt peer_id - let ipv6t = QCheck2.triple ipv6 port_opt peer_id + let ipv6t = triple ipv6 port_opt peer_id - let ipv4_as_v6 = - let open QCheck2 in - map Ipaddr.v6_of_v4 ipv4 |> set_print Ipaddr.V6.to_string + let ipv4_as_v6 = map Ipaddr.v6_of_v4 ipv4 - let ip = QCheck2.choose [ipv4_as_v6; ipv6] + let ip = oneof [ipv4_as_v6; ipv6] - let p2p_point_id_t = QCheck2.pair ip port + let p2p_point_id_t = pair ip port end (* To check the round trip property we change the printer for ipv4 and @@ -89,7 +82,6 @@ let addr_port_id_v4 = let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = Ipaddr.V4.to_string ip; port; peer_id}) Arbitrary.ipv4t - |> QCheck2.set_print (Format.asprintf "%a" pp_addr_port_id) let addr_port_id_v6 = QCheck2.Gen.map @@ -97,7 +89,6 @@ let addr_port_id_v6 = let peer_id = Option.map (fun gen -> gen.P2p_identity.peer_id) peer_id in P2p_point.Id.{addr = P2p_addr.to_string ip; port; peer_id}) Arbitrary.ipv6t - |> QCheck2.set_print (Format.asprintf "%a" pp_addr_port_id) let remove_brackets addr = let len = String.length addr in diff --git a/src/lib_base/test_helpers/tz_arbitrary.ml b/src/lib_base/test_helpers/tz_arbitrary.ml index daad950ef7a6..1b5b89533c72 100644 --- a/src/lib_base/test_helpers/tz_arbitrary.ml +++ b/src/lib_base/test_helpers/tz_arbitrary.ml @@ -23,48 +23,37 @@ (* *) (*****************************************************************************) -open Lib_test.Qcheck_helpers -open QCheck +open Lib_test.Qcheck2_helpers +open QCheck2.Gen -let ipv4 = - map ~rev:Ipaddr.V4.to_int32 Ipaddr.V4.of_int32 int32 - |> set_print Ipaddr.V4.to_string +let ipv4 = map Ipaddr.V4.of_int32 int32 -let ipv6 = - map ~rev:Ipaddr.V6.to_int64 Ipaddr.V6.of_int64 (pair int64 int64) - |> set_print Ipaddr.V6.to_string +let ipv6 = map Ipaddr.V6.of_int64 (pair int64 int64) -let ipv4_as_v6 = - let open QCheck in - map Ipaddr.v6_of_v4 ipv4 |> set_print Ipaddr.V6.to_string +let ipv4_as_v6 = map Ipaddr.v6_of_v4 ipv4 let addr_port_id = - let gen = - let open Gen in - let open P2p_point.Id in - let* addr = map Ipaddr.V4.to_string @@ gen ipv4 - and* port = opt @@ gen Lib_test.Qcheck_helpers.uint16 in - pure {addr; port; peer_id = None} - in - make gen ~print:P2p_point.Id.addr_port_id_to_string + let open P2p_point.Id in + let+ addr = map Ipaddr.V4.to_string ipv4 + and+ port = opt Lib_test.Qcheck2_helpers.uint16 in + {addr; port; peer_id = None} let port = uint16 -let port_opt = QCheck.option port +let port_opt = opt port -(* could not craft a [p2p_identity QCheck.gen], we use instead a +(* could not craft a [p2p_identity QCheck2.gen], we use instead a constant [unit -> p2p_identity] which will be applied at each testing points. *) -let peer_id = - QCheck.option QCheck.(map P2p_identity.generate_with_pow_target_0 unit) +let peer_id = opt (map P2p_identity.generate_with_pow_target_0 unit) -let ip = QCheck.choose [ipv4_as_v6; ipv6] +let ip = oneof [ipv4_as_v6; ipv6] -let ipv4_as_v6_or_v6 = QCheck.choose [ipv4_as_v6; ipv6] +let ipv4_as_v6_or_v6 = oneof [ipv4_as_v6; ipv6] -let ipv4t = QCheck.triple ipv4 port_opt peer_id +let ipv4t = triple ipv4 port_opt peer_id -let ipv6t = QCheck.triple ipv6 port_opt peer_id +let ipv6t = triple ipv6 port_opt peer_id -let p2p_point_id_t = QCheck.pair ip port +let p2p_point_id_t = pair ip port diff --git a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml index 31b0e01e409e..2fdec11d446d 100644 --- a/src/lib_protocol_environment/test/test_mem_context_array_theory.ml +++ b/src/lib_protocol_environment/test/test_mem_context_array_theory.ml @@ -58,9 +58,9 @@ type value = Context.value (** Using [QCheck.small_list] for performance reasons: using [QCheck.list] here makes the file 40 times slower, which is not acceptable. *) -let key_gen = QCheck2.Gen.(small_list @@ string ?gen:None) +let key_gen = QCheck2.Gen.(small_list string) -let value_gen = QCheck2.Gen.(map Bytes.of_string @@ string ?gen:None) +let value_gen = QCheck2.Gen.(map Bytes.of_string string) let key_value_gen = QCheck2.Gen.(pair key_gen value_gen) diff --git a/src/lib_proxy/test/light_lib.ml b/src/lib_proxy/test/light_lib.ml index 510f2146df2b..b049a8e853e9 100644 --- a/src/lib_proxy/test/light_lib.ml +++ b/src/lib_proxy/test/light_lib.ml @@ -162,46 +162,25 @@ and merkle_tree_to_simple_tree tree = let check_simple_tree_eq t1 t2 = qcheck_eq ~pp:pp_simple_tree ~eq:simple_tree_eq t1 t2 -let raw_context_arb = +let raw_context_gen = let open Tezos_shell_services.Block_services in - let module MapArb = MakeMapArb (TzString.Map) in - let open QCheck in - let {gen = bytes_gen; shrink = bytes_shrink_opt; _} = bytes_arb in - let gen = - let open Gen in - (* Factor used to limit the depth of the tree. *) - let max_depth_factor = 10 in - fix - (fun self current_depth_factor -> - frequency - [ - (max_depth_factor, map (fun b -> Key b) bytes_gen); - (max_depth_factor, pure Cut); - ( current_depth_factor, - map - (fun d -> Dir d) - (MapArb.gen_of_size - (0 -- 10) - string - (self (current_depth_factor / 2))) ); - ]) - max_depth_factor - in - let rec shrink = - let open Iter in - function - | Cut -> empty - | Key bigger_bytes -> - shrink Cut - <+> ( of_option_shrink bytes_shrink_opt bigger_bytes - >|= fun smaller_bytes -> Key smaller_bytes ) - | Dir bigger_raw_context_map -> - shrink Cut <+> shrink (Key Bytes.empty) - <+> ( MapArb.shrink - ~key:Shrink.string - ~value:shrink - bigger_raw_context_map - >|= fun smaller_dir -> Dir smaller_dir ) - in - let print = Format.asprintf "%a" pp_raw_context in - make ~print ~shrink gen + let module MapGen = MakeMapGen (TzString.Map) in + let open QCheck2 in + let open Gen in + (* Factor used to limit the depth of the tree. *) + let max_depth_factor = 10 in + fix + (fun self current_depth_factor -> + frequency + [ + (max_depth_factor, map (fun b -> Key b) bytes_gen); + (max_depth_factor, pure Cut); + ( current_depth_factor, + map + (fun d -> Dir d) + (MapGen.gen_of_size + (0 -- 10) + string + (self (current_depth_factor / 2))) ); + ]) + max_depth_factor diff --git a/src/lib_proxy/test/test_fuzzing_light.ml b/src/lib_proxy/test/test_fuzzing_light.ml index 13f410981932..12fe1a5a2af9 100644 --- a/src/lib_proxy/test/test_fuzzing_light.ml +++ b/src/lib_proxy/test/test_fuzzing_light.ml @@ -40,48 +40,50 @@ module Store = Tezos_context_memory.Context open Lib_test.Qcheck2_helpers (** [list1_gen gen] generates non-empty lists using [gen]. *) -let list1_gen gen = - QCheck2.Gen.( - list_size (1 -- 100) gen - |> add_shrink_invariant (fun l -> List.length l > 0)) +let list1_gen gen = QCheck2.Gen.(list_size (1 -- 100) gen) -let irmin_hash_arb = QCheck.oneofl ~print:Fun.id Light_lib.irmin_hashes +let small_string_gen = QCheck2.Gen.small_string ?gen:None + +let irmin_hash_gen = QCheck2.Gen.oneofl Light_lib.irmin_hashes let merkle_node_gen = let open Tezos_shell_services.Block_services in let module MapArb = MakeMapGen (TzString.Map) in let open QCheck2 in let open Gen in - let raw_context_gen = get_gen raw_context_arb in - let irmin_hash_gen = get_gen irmin_hash_arb in - let gen = - let max_depth_factor = 4 in - fix - (fun self current_depth_factor -> - frequency - [ - ( max_depth_factor, - map - (fun (kind, hash) -> Hash (kind, hash)) - (pair (oneofl [Contents; Node]) irmin_hash_gen) ); - ( max_depth_factor, - map (fun raw_context -> Data raw_context) raw_context_gen ); - ( current_depth_factor, - map - (fun merkle_node_map -> Continue merkle_node_map) - (MapArb.gen_of_size - (0 -- 10) - (string ?gen:None) - (self (current_depth_factor / 2))) ); - ]) - max_depth_factor - in - let print = Format.asprintf "%a" pp_merkle_node in - make ~print gen - -let merkle_tree_arb = - let open MakeMapArb (TzString.Map) in - arb_of_size QCheck2.Gen.(0 -- 10) QCheck2.string merkle_node_arb + let max_depth_factor = 4 in + fix + (fun self current_depth_factor -> + frequency + [ + ( max_depth_factor, + map + (fun (kind, hash) -> Hash (kind, hash)) + (pair (oneofl [Contents; Node]) irmin_hash_gen) ); + ( max_depth_factor, + map (fun raw_context -> Data raw_context) Light_lib.raw_context_gen + ); + ( current_depth_factor, + map + (fun merkle_node_map -> Continue merkle_node_map) + (MapArb.gen_of_size + (0 -- 10) + small_string_gen + (self (current_depth_factor / 2))) ); + ]) + max_depth_factor + +let merkle_tree_gen = + let open MakeMapGen (TzString.Map) in + gen_of_size QCheck2.Gen.(0 -- 10) small_string_gen merkle_node_gen + +let print_merkle_tree = + Format.asprintf "%a" Tezos_shell_services.Block_services.pp_merkle_tree + +let print_merkle_node = + Format.asprintf "%a" Tezos_shell_services.Block_services.pp_merkle_node + +let print_irmin_tree = Format.asprintf "%a" Store.Tree.pp let irmin_tree_gen = let module StringList = struct @@ -100,7 +102,7 @@ let irmin_tree_gen = (Store.Tree.empty Store.empty) entries |> Lwt_main.run) - (small_list (pair (small_list (string ?gen:None)) bytes_gen)) + (small_list (pair (small_list small_string_gen) bytes_gen)) let get_ok = function Ok x -> x | Error s -> QCheck2.Test.fail_report s @@ -349,7 +351,7 @@ let test_shape_ignores_key = QCheck2.Gen.( quad merkle_tree_gen - (list (string ?gen:None)) + (small_list small_string_gen) merkle_node_gen merkle_node_gen) @@ fun (tree, key, node1, node2) -> @@ -421,7 +423,7 @@ module HashStability = struct this will no be a problem once QCheck2 provides integrated shrinking. *) let tree_and_shallow_gen = let open QCheck2 in - let repo = Lwt_main.run Store.Tree.make_repo in + let repo = Lwt_main.run (Store.Tree.make_repo ()) in Gen.map (fun tree -> (tree, Lwt_main.run (make_partial_shallow_tree repo tree))) irmin_tree_gen @@ -491,7 +493,7 @@ module AddTree = struct Gen.( triple HashStability.tree_and_shallow_gen - (list1_gen @@ string ?gen:None) + (list1_gen small_string_gen) irmin_tree_gen) (fun ( ((_, tree) : _ * Store.tree), (key : Store.key), @@ -754,7 +756,7 @@ let add_test_consensus (min_agreement, honest, rogue, consensus_expected) = rogue consensus_expected) ~print:Print.(triple print_merkle_tree (list string) int) - Gen.(triple merkle_tree_gen (list @@ string ?gen:None) int) + Gen.(triple merkle_tree_gen (small_list small_string_gen) int) @@ fun (mtree, key, randoms) -> Consensus.test_consensus min_agreement @@ -772,7 +774,7 @@ let test_consensus_spec = let min_agreement_gen = 0 -- 100 in let honest_gen = 1 -- 1000 in let rogue_gen = 0 -- 1000 in - let key_gen = list @@ string ?gen:None in + let key_gen = small_list small_string_gen in Test.make ~name: "test_consensus min_agreement honest rogue ... = min_agreeing_endpoints \ diff --git a/src/lib_proxy/test/test_fuzzing_proxy_getter.ml b/src/lib_proxy/test/test_fuzzing_proxy_getter.ml index c5d56cc3f9c6..3e753a558d54 100644 --- a/src/lib_proxy/test/test_fuzzing_proxy_getter.ml +++ b/src/lib_proxy/test/test_fuzzing_proxy_getter.ml @@ -33,12 +33,12 @@ module Local = Tezos_context_memory.Context module Proxy_getter = Tezos_proxy.Proxy_getter module Tree = Proxy_getter.Internal.Tree -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers -let key_arb = +let key_gen = (* Using small_list, otherwise the test takes considerably longer. This test is quite slow already *) - QCheck.(small_list string) + QCheck2.Gen.(small_list string) let tree_arb = let rec mk_tree acc sets = @@ -50,20 +50,20 @@ let tree_arb = | Tezos_proxy.Proxy.Value acc' -> (mk_tree [@ocaml.tailcall]) acc' tl) in let mk_tree acc sets = Lwt_main.run @@ mk_tree acc sets in - QCheck.( - map (mk_tree Tree.empty) (list (pair key_arb Light_lib.raw_context_arb))) + QCheck2.Gen.( + map (mk_tree Tree.empty) (list (pair key_gen Light_lib.raw_context_gen))) (** [Tree.set_leaf] then [Tree.get] should return the inserted data *) let test_set_leaf_get = - QCheck.Test.make + QCheck2.Test.make ~name:"Tree.get (Tree.set_leaf t k v) k = v" - QCheck.(triple tree_arb key_arb Light_lib.raw_context_arb) + QCheck2.Gen.(triple tree_arb key_gen Light_lib.raw_context_gen) @@ fun (tree, key, value) -> let expected = Lwt_main.run @@ Proxy_getter.Internal.raw_context_to_tree value in (* We need to make sure that we are actually setting something: *) - QCheck.assume @@ Option.is_some expected ; + QCheck2.assume @@ Option.is_some expected ; let tree' = Lwt_main.run @@ Tree.set_leaf tree key value in let tree' = match tree' with diff --git a/src/lib_rpc_http/test/test_rpc_http.ml b/src/lib_rpc_http/test/test_rpc_http.ml index b73cb9702780..6569fcf34346 100644 --- a/src/lib_rpc_http/test/test_rpc_http.ml +++ b/src/lib_rpc_http/test/test_rpc_http.ml @@ -275,7 +275,7 @@ let test_finding_policy = "localhost:8732") let ensure_default_policy_parses = - let open QCheck in + let open QCheck2 in Test.make ~name:"default policy parses and is of correct type" Tz_arbitrary.ipv6 diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index c8e6cad220b4..371ef358cacb 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -29,12 +29,9 @@ let qcheck_wrap ?verbose ?long ?rand = let qcheck_eq ?pp ?cmp ?eq expected actual = let pass = match (eq, cmp) with - | (Some eq, _) -> - eq expected actual - | (None, Some cmp) -> - cmp expected actual = 0 - | (None, None) -> - Stdlib.compare expected actual = 0 + | (Some eq, _) -> eq expected actual + | (None, Some cmp) -> cmp expected actual = 0 + | (None, None) -> Stdlib.compare expected actual = 0 in if pass then true else @@ -76,7 +73,7 @@ let uint16 = QCheck2.Gen.(0 -- 65535) let int16 = QCheck2.Gen.(-32768 -- 32767) -let bytes_gen = QCheck2.Gen.(map Bytes.of_string @@ string ?gen:None) +let bytes_gen = QCheck2.Gen.(map Bytes.of_string string) module MakeMapGen (Map : Stdlib.Map.S) = struct open QCheck2 diff --git a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml index e5e74bb7f663..ba45062ca9b1 100644 --- a/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_010_PtGRANAD/lib_protocol/test/test_tez_repr.ml @@ -101,29 +101,29 @@ let gen_tez_sizes = Gen.map Tez.of_mutez_exn gen_ui64_sizes let test_coherent_mul = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(*?) is coherent w.r.t. Z.(*)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (prop_binop64 Tez.( *? ) Z.( * )) let test_coherent_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(-?) is coherent w.r.t. Z.(-)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop Tez.( -? ) Z.( - )) let test_coherent_add = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(+?) is coherent w.r.t. Z.(+)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop Tez.( +? ) Z.( + )) let test_coherent_div = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(/?) is coherent w.r.t. Z.(/)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (fun (a, b) -> - QCheck.assume (b > 0L) ; + QCheck2.assume (b > 0L) ; prop_binop64 Tez.( /? ) Z.( / ) (a, b)) let tests = @@ -132,4 +132,4 @@ let tests = let () = Alcotest.run "Tez_repr" - [("Tez_repr", Lib_test.Qcheck_helpers.qcheck_wrap tests)] + [("Tez_repr", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml index 5f1eeb8e14b3..7f5abfd3cfc0 100644 --- a/src/proto_alpha/lib_protocol/test/test_tez_repr.ml +++ b/src/proto_alpha/lib_protocol/test/test_tez_repr.ml @@ -102,29 +102,29 @@ let gen_tez_sizes = Gen.map Tez.of_mutez_exn gen_ui64_sizes let test_coherent_mul = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(*?) is coherent w.r.t. Z.(*)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (prop_binop64 Tez.( *? ) Z.( * )) let test_coherent_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(-?) is coherent w.r.t. Z.(-)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop Tez.( -? ) Z.( - )) let test_coherent_add = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(+?) is coherent w.r.t. Z.(+)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop Tez.( +? ) Z.( + )) let test_coherent_div = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(/?) is coherent w.r.t. Z.(/)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (fun (a, b) -> - QCheck.assume (b > 0L) ; + QCheck2.assume (b > 0L) ; prop_binop64 Tez.( /? ) Z.( / ) (a, b)) let tests = @@ -133,4 +133,4 @@ let tests = let () = Alcotest.run "Tez_repr" - [("Tez_repr", Lib_test.Qcheck_helpers.qcheck_wrap tests)] + [("Tez_repr", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] -- GitLab