Merge pull request #84 from input-output-hk/jdral/fix-errors-shrink

Fix the infinitely looping `Errors` shrinker
input-output-hk · Dec 10, 2024 · 8423cb3 · 8423cb3
2 parents 2d85d65 + 2c89665
commit 8423cb3
Show file tree

Hide file tree

Showing 6 changed files with 70 additions and 28 deletions.
diff --git a/cabal.project b/cabal.project
@@ -1,6 +1,6 @@
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2024-10-02T00:00:00Z
+  , hackage.haskell.org 2024-12-09T15:45:06Z
 
 packages:
   fs-api

diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md
@@ -1,11 +1,16 @@
 # Revision history for fs-sim
 
-## Next version -- ????-??-??
+## 0.3.1.0 -- 2024-12-10
 
 ### Non-breaking
 
 * Expose `openHandles` for testing.
 
+### Patch
+
+* Make `genInfinite` generate truly infinite streams.
+* The shrinker for `Errors` now truly shrinks towards empty errors.
+
 ## 0.3.0.1 -- 2024-10-02
 
 ### Patch

diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal
@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            fs-sim
-version:         0.3.0.1
+version:         0.3.1.0
 synopsis:        Simulated file systems
 description:     Simulated file systems.
 license:         Apache-2.0

diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs
@@ -452,30 +452,32 @@ genErrors genPartialWrites genSubstituteWithJunk = do
 instance Arbitrary Errors where
   arbitrary = genErrors True True
 
-  shrink err@($(fields 'Errors)) = concatMap (filter (not . allNull))
-      [ (\s' -> err { dumpStateE = s' })                <$> Stream.shrinkStream dumpStateE
-      , (\s' -> err { hOpenE = s' })                    <$> Stream.shrinkStream hOpenE
-      , (\s' -> err { hCloseE = s' })                   <$> Stream.shrinkStream hCloseE
-      , (\s' -> err { hSeekE = s' })                    <$> Stream.shrinkStream hSeekE
-      , (\s' -> err { hGetSomeE = s' })                 <$> Stream.shrinkStream hGetSomeE
-      , (\s' -> err { hGetSomeAtE = s' })               <$> Stream.shrinkStream hGetSomeAtE
-      , (\s' -> err { hPutSomeE = s' })                 <$> Stream.shrinkStream hPutSomeE
-      , (\s' -> err { hTruncateE = s' })                <$> Stream.shrinkStream hTruncateE
-      , (\s' -> err { hGetSizeE = s' })                 <$> Stream.shrinkStream hGetSizeE
-      , (\s' -> err { createDirectoryE = s' })          <$> Stream.shrinkStream createDirectoryE
-      , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.shrinkStream createDirectoryIfMissingE
-      , (\s' -> err { listDirectoryE = s' })            <$> Stream.shrinkStream listDirectoryE
-      , (\s' -> err { doesDirectoryExistE = s' })       <$> Stream.shrinkStream doesDirectoryExistE
-      , (\s' -> err { doesFileExistE = s' })            <$> Stream.shrinkStream doesFileExistE
-      , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE
-      , (\s' -> err { removeFileE = s' })               <$> Stream.shrinkStream removeFileE
-      , (\s' -> err { renameFileE = s' })               <$> Stream.shrinkStream renameFileE
-        -- File I\/O with user-supplied buffers
-      , (\s' -> err { hGetBufSomeE = s' })   <$> Stream.shrinkStream hGetBufSomeE
-      , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.shrinkStream hGetBufSomeAtE
-      , (\s' -> err { hPutBufSomeE = s' })   <$> Stream.shrinkStream hPutBufSomeE
-      , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.shrinkStream hPutBufSomeAtE
-      ]
+  shrink err@($(fields 'Errors))
+    | allNull err = []
+    | otherwise = emptyErrors : concatMap (filter (not . allNull))
+        [ (\s' -> err { dumpStateE = s' })                <$> Stream.shrinkStream dumpStateE
+        , (\s' -> err { hOpenE = s' })                    <$> Stream.shrinkStream hOpenE
+        , (\s' -> err { hCloseE = s' })                   <$> Stream.shrinkStream hCloseE
+        , (\s' -> err { hSeekE = s' })                    <$> Stream.shrinkStream hSeekE
+        , (\s' -> err { hGetSomeE = s' })                 <$> Stream.shrinkStream hGetSomeE
+        , (\s' -> err { hGetSomeAtE = s' })               <$> Stream.shrinkStream hGetSomeAtE
+        , (\s' -> err { hPutSomeE = s' })                 <$> Stream.shrinkStream hPutSomeE
+        , (\s' -> err { hTruncateE = s' })                <$> Stream.shrinkStream hTruncateE
+        , (\s' -> err { hGetSizeE = s' })                 <$> Stream.shrinkStream hGetSizeE
+        , (\s' -> err { createDirectoryE = s' })          <$> Stream.shrinkStream createDirectoryE
+        , (\s' -> err { createDirectoryIfMissingE = s' }) <$> Stream.shrinkStream createDirectoryIfMissingE
+        , (\s' -> err { listDirectoryE = s' })            <$> Stream.shrinkStream listDirectoryE
+        , (\s' -> err { doesDirectoryExistE = s' })       <$> Stream.shrinkStream doesDirectoryExistE
+        , (\s' -> err { doesFileExistE = s' })            <$> Stream.shrinkStream doesFileExistE
+        , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE
+        , (\s' -> err { removeFileE = s' })               <$> Stream.shrinkStream removeFileE
+        , (\s' -> err { renameFileE = s' })               <$> Stream.shrinkStream renameFileE
+          -- File I\/O with user-supplied buffers
+        , (\s' -> err { hGetBufSomeE = s' })   <$> Stream.shrinkStream hGetBufSomeE
+        , (\s' -> err { hGetBufSomeAtE = s' }) <$> Stream.shrinkStream hGetBufSomeAtE
+        , (\s' -> err { hPutBufSomeE = s' })   <$> Stream.shrinkStream hPutBufSomeE
+        , (\s' -> err { hPutBufSomeAtE = s' }) <$> Stream.shrinkStream hPutBufSomeAtE
+        ]
 
 {-------------------------------------------------------------------------------
   Simulate Errors monad

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
@@ -140,6 +140,15 @@ tests = testGroup "Test.System.FS.Sim.Error" [
                 MockFS.fromBuffer mba 0 (fromIntegral $ BS.length bs) >>=
                   maybe (error "fromOutput: should not fail") pure
         in  propGetterGetsAll hGetBufSomeAtC get fromOutput p bs
+
+    -- Generators and shrinkers
+
+    , testProperty "prop_regression_shrinkErrors"
+        prop_regression_shrinkErrors
+    , testProperty "prop_regression_shrinkNonEmptyErrors"
+        prop_regression_shrinkNonEmptyErrors
+    , testProperty "prop_regression_shrinkEmptyErrors"
+        prop_regression_shrinkEmptyErrors
     ]
 
 instance Arbitrary BS.ByteString where
@@ -242,3 +251,29 @@ propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs
       , hGetBufSomeE = errStream
       , hGetBufSomeAtE = errStream
       }
+
+{-------------------------------------------------------------------------------
+  Generators and shrinkers
+-------------------------------------------------------------------------------}
+
+-- | See fs-sim#84
+prop_regression_shrinkErrors :: Errors -> Property
+prop_regression_shrinkErrors _errs = expectFailure $
+    property False
+
+-- | See fs-sim#84
+prop_regression_shrinkNonEmptyErrors :: Errors -> Property
+prop_regression_shrinkNonEmptyErrors errs = expectFailure $
+    not (allNull errs) ==> property False
+
+newtype EmptyErrors = EmptyErrors Errors
+  deriving Show
+
+instance Arbitrary EmptyErrors where
+  arbitrary = EmptyErrors <$> oneof [ pure emptyErrors ]
+  shrink (EmptyErrors errs) = EmptyErrors <$> shrink errs
+
+-- | See fs-sim#84
+prop_regression_shrinkEmptyErrors :: EmptyErrors -> Property
+prop_regression_shrinkEmptyErrors (EmptyErrors errs) = expectFailure $
+    allNull errs ==> property False