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 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/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 5964254..49e11f3 100644 --- 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