diff --git a/CHANGES.md b/CHANGES.md index 643c6ea4..8786f9b8 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,7 @@ - #540: Significantly increase the probability of context switching in `Lin_thread` and `STM_thread` by utilizing `Gc.Memprof` callbacks. Avoid on 5.0-5.2 without `Gc.Memprof` support. +- #546: Speed up `Lin`'s default `string` and `bytes` shrinkers. ## 0.7 diff --git a/lib/lin.ml b/lib/lin.ml index d80fce64..e70f81ff 100644 --- a/lib/lin.ml +++ b/lib/lin.ml @@ -159,7 +159,18 @@ let gen_deconstructible gen print eq = GenDeconstr (gen,print,eq) let qcheck_nat64_small = QCheck.(map Int64.of_int small_nat) -let bytes_small_printable = QCheck.bytes_small_of QCheck.Gen.printable +(* QCheck's string shrinker reduces each char repeatedly which is too excessive for Lin *) +let shrink_char c = QCheck.(if c = 'a' then Iter.empty else Iter.return 'a') +let shrink_string = QCheck.Shrink.string ~shrink:shrink_char +let shrink_bytes = QCheck.Shrink.bytes ~shrink:shrink_char + +let string = QCheck.(set_shrink shrink_string string) +let string_small = QCheck.(set_shrink shrink_string small_string) +let string_small_printable = QCheck.(set_shrink shrink_string small_printable_string) + +let bytes = QCheck.(set_shrink shrink_bytes bytes) +let bytes_small = QCheck.(set_shrink shrink_bytes bytes_small) +let bytes_small_printable = QCheck.(set_shrink shrink_bytes (bytes_small_of Gen.printable)) let unit = GenDeconstr (QCheck.unit, QCheck.Print.unit, (=)) let bool = GenDeconstr (QCheck.bool, QCheck.Print.bool, (=)) @@ -174,11 +185,11 @@ let int32 = GenDeconstr (QCheck.int32, Int32.to_string, Int3 let int64 = GenDeconstr (QCheck.int64, Int64.to_string, Int64.equal) let nat64_small = GenDeconstr (qcheck_nat64_small, Int64.to_string, Int64.equal) let float = GenDeconstr (QCheck.float, QCheck.Print.float, Float.equal) -let string = GenDeconstr (QCheck.string, QCheck.Print.string, String.equal) -let string_small = GenDeconstr (QCheck.small_string, QCheck.Print.string, String.equal) -let string_small_printable = GenDeconstr (QCheck.small_printable_string, QCheck.Print.string, String.equal) -let bytes = GenDeconstr (QCheck.bytes, QCheck.Print.bytes, Bytes.equal) -let bytes_small = GenDeconstr (QCheck.bytes_small, QCheck.Print.bytes, Bytes.equal) +let string = GenDeconstr (string, QCheck.Print.string, String.equal) +let string_small = GenDeconstr (string_small, QCheck.Print.string, String.equal) +let string_small_printable = GenDeconstr (string_small_printable, QCheck.Print.string, String.equal) +let bytes = GenDeconstr (bytes, QCheck.Print.bytes, Bytes.equal) +let bytes_small = GenDeconstr (bytes_small, QCheck.Print.bytes, Bytes.equal) let bytes_small_printable = GenDeconstr (bytes_small_printable, QCheck.Print.bytes, Bytes.equal) let option : type a c s. ?ratio:float -> (a, c, s, combinable) ty -> (a option, c, s, combinable) ty = diff --git a/src/bytes/lin_tests.ml b/src/bytes/lin_tests.ml index b56d107b..726c1a6e 100644 --- a/src/bytes/lin_tests.ml +++ b/src/bytes/lin_tests.ml @@ -6,6 +6,7 @@ module BConf = struct let init () = Stdlib.Bytes.make 42 '0' let cleanup _ = () + let bytes_to_seq b = List.to_seq (List.of_seq (Bytes.to_seq b)) (* eager version *) open Lin let int,string = nat_small, string_small_printable let api = [ @@ -29,6 +30,7 @@ module BConf = struct val_ "Bytes.contains" Bytes.contains (t @-> char @-> returning_or_exc bool); val_ "Bytes.contains_from" Bytes.contains_from (t @-> int @-> char @-> returning_or_exc bool); val_ "Bytes.rcontains_from" Bytes.rcontains_from (t @-> int @-> char @-> returning_or_exc bool); + val_ "Bytes.to_seq" bytes_to_seq (t @-> returning (seq char)); (* UTF codecs and validations *) val_ "Bytes.is_valid_utf_8" Bytes.is_valid_utf_8 (t @-> returning bool); val_ "Bytes.is_valid_utf_16be" Bytes.is_valid_utf_16be (t @-> returning bool); @@ -46,6 +48,6 @@ module BT_thread = Lin_thread.Make(BConf) ;; QCheck_base_runner.run_tests_main [ BT_domain.neg_lin_test ~count:5000 ~name:"Lin Bytes test with Domain"; - BT_thread.lin_test ~count:250 ~name:"Lin Bytes test with Thread"; + BT_thread.neg_lin_test ~count:5000 ~name:"Lin Bytes test with Thread"; BT_domain.stress_test ~count:1000 ~name:"Lin Bytes stress test with Domain"; ]