Make 'genInfinite' generate truly infinite streams

This makes the `prop_regression_shrinkAllNullErrors` property succeed, and not loop forever during shrinking.
input-output-hk · Dec 9, 2024 · dbc9f07 · dbc9f07
1 parent 4b8b851
commit dbc9f07
Show file tree

Hide file tree

Showing 2 changed files with 10 additions and 3 deletions.
diff --git a/fs-sim/src/System/FS/Sim/Stream.hs b/fs-sim/src/System/FS/Sim/Stream.hs
@@ -165,4 +165,4 @@ genFinite n gen = Stream Finite <$> replicateM n gen
 genInfinite ::
      Gen (Maybe a)  -- ^ Tip: use 'genMaybe'.
   -> Gen (Stream a)
-genInfinite gen = Stream Infinite <$> QC.listOf gen
+genInfinite gen = Stream Infinite <$> QC.infiniteListOf gen
diff --git a/fs-sim/test/Test/System/FS/Sim/Error.hs b/fs-sim/test/Test/System/FS/Sim/Error.hs
@@ -258,6 +258,13 @@ prop_regression_shrinkNotAllNullErrors :: Errors -> Property
 prop_regression_shrinkNotAllNullErrors errs = expectFailure $
     not (allNull errs) ==> property False
 
-prop_regression_shrinkAllNullErrors :: Errors -> Property
-prop_regression_shrinkAllNullErrors errs = expectFailure $
+newtype AllNullErrors = AllNullErrors Errors
+  deriving Show
+
+instance Arbitrary AllNullErrors where
+  arbitrary = AllNullErrors <$> oneof [ pure emptyErrors ]
+  shrink (AllNullErrors errs) = AllNullErrors <$> shrink errs
+
+prop_regression_shrinkAllNullErrors :: AllNullErrors -> Property
+prop_regression_shrinkAllNullErrors (AllNullErrors errs) = expectFailure $
     allNull errs ==> property False