From db016b243af69d59d21928d7b96678b8261046c9 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 9 Dec 2024 22:20:23 +0100 Subject: [PATCH 1/4] Add regression tests for a looping shrinker of empty `Errors`. When `Errors` are empty (`allNull`) and we start shrinking, the shrinker will loop forever. The cause lies in the `genInfinite` function for `Stream`s, which generates a finite list even though it is marked as infinite. The next commit introduces a minimal bug fix. --- fs-sim/test/Test/System/FS/Sim/Error.hs | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/fs-sim/test/Test/System/FS/Sim/Error.hs b/fs-sim/test/Test/System/FS/Sim/Error.hs index 5964254..1641ff5 100644 --- a/fs-sim/test/Test/System/FS/Sim/Error.hs +++ b/fs-sim/test/Test/System/FS/Sim/Error.hs @@ -140,6 +140,13 @@ 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_shrinkNonEmptyErrors" + prop_regression_shrinkNonEmptyErrors + , testProperty "prop_regression_shrinkEmptyErrors" + prop_regression_shrinkEmptyErrors ] instance Arbitrary BS.ByteString where @@ -242,3 +249,17 @@ propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs , hGetBufSomeE = errStream , hGetBufSomeAtE = errStream } + +{------------------------------------------------------------------------------- + Generators and shrinkers +-------------------------------------------------------------------------------} + +-- | See fs-sim#84 +prop_regression_shrinkNonEmptyErrors :: Errors -> Property +prop_regression_shrinkNonEmptyErrors errs = expectFailure $ + not (allNull errs) ==> property False + +-- | See fs-sim#84 +prop_regression_shrinkEmptyErrors :: Errors -> Property +prop_regression_shrinkEmptyErrors errs = expectFailure $ + allNull errs ==> property False From d6c6fa7045146d406a584744aecf9d824dcc91b7 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 9 Dec 2024 22:46:22 +0100 Subject: [PATCH 2/4] Make `genInfinite` generate truly infinite streams. This makes the `prop_regression_shrinkEmptyErrors` property succeed, and not loop forever during shrinking. --- fs-sim/src/System/FS/Sim/Stream.hs | 2 +- fs-sim/test/Test/System/FS/Sim/Error.hs | 11 +++++++++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/fs-sim/src/System/FS/Sim/Stream.hs b/fs-sim/src/System/FS/Sim/Stream.hs index bf7ab9c..2c599c8 100644 --- 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 index 1641ff5..4fecad1 100644 --- a/fs-sim/test/Test/System/FS/Sim/Error.hs +++ b/fs-sim/test/Test/System/FS/Sim/Error.hs @@ -259,7 +259,14 @@ 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 :: Errors -> Property -prop_regression_shrinkEmptyErrors errs = expectFailure $ +prop_regression_shrinkEmptyErrors :: EmptyErrors -> Property +prop_regression_shrinkEmptyErrors (EmptyErrors errs) = expectFailure $ allNull errs ==> property False From 60a8ac3f48ee00488d090c2ad7fa477bfa580cbe Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 9 Dec 2024 22:58:32 +0100 Subject: [PATCH 3/4] Handle empty `Errors` explicitly in the shrinker --- fs-sim/src/System/FS/Sim/Error.hs | 50 +++++++++++++------------ fs-sim/test/Test/System/FS/Sim/Error.hs | 7 ++++ 2 files changed, 33 insertions(+), 24 deletions(-) diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index cbf8bff..f55b2e6 100644 --- 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/test/Test/System/FS/Sim/Error.hs b/fs-sim/test/Test/System/FS/Sim/Error.hs index 4fecad1..49e11f3 100644 --- a/fs-sim/test/Test/System/FS/Sim/Error.hs +++ b/fs-sim/test/Test/System/FS/Sim/Error.hs @@ -143,6 +143,8 @@ tests = testGroup "Test.System.FS.Sim.Error" [ -- Generators and shrinkers + , testProperty "prop_regression_shrinkErrors" + prop_regression_shrinkErrors , testProperty "prop_regression_shrinkNonEmptyErrors" prop_regression_shrinkNonEmptyErrors , testProperty "prop_regression_shrinkEmptyErrors" @@ -254,6 +256,11 @@ propGetterGetsAll getCounter get fromOutput (SometimesPartialReads errStream) bs 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 $ From 2c89665facbf34a0a85108c76bc05a3a6af0ae2d Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 9 Dec 2024 23:10:18 +0100 Subject: [PATCH 4/4] Release `fs-sim-0.3.1.0` --- cabal.project | 2 +- fs-sim/CHANGELOG.md | 7 ++++++- fs-sim/fs-sim.cabal | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index c68efc4..4e660a5 100644 --- 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 index c0d4697..6991adc 100644 --- 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 index aa8c36d..c17eca5 100644 --- 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