Merge pull request #546 from ocaml-multicore/lin-bytes-fixes

Lin bytes test fixes

Author: jmid

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
 

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 =

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";
 ]