diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,44 @@ # Revision history for fs-sim +## ?.?.?.? -- ????-??-?? + +## 0.4.0.0 -- 2025-05-30 + +### Breaking + +* Fix a bug where `withErrors` would not put back the previous `Errors` when an + exception is thrown during execution of the function. Though we fixed the bug, + it is also a breaking change: the type signature now has an additional + constraint. +* Change finiteness guarantees for `Stream`s. Where streams could previously be + *definitely* finite or *possibly* infinite, they should now be *definitely* + finite or *definitely* infinite. This is mostly a conceptual change: it was + already guaranteed by most if not all of the `Stream` functions. Still, the + conceptual change should make the use of `Streams` more ergonomic going + forward. + + As a result of and in addition to the conceptual change, the `Stream` + interface got an overhaul. The concrete changes are: + + * The internals of the `Stream` are now exposed, but with big warnings about + unsafe usage related to finiteness. + * Added new `runStreamN` and `runStreamIndefinitely` functions. + * Renamed `mkInfinite` to `unsafeMkInfinite`. + * Added new `isFinite` and `isInfinite` queries. + * Added a new `genFiniteN` function. + * Removed `genMaybe'`, as it was just a specific instantiation of `genMaybe` + that has no clear benefit being its own top-level function. + * Added a new `liftShrinkStream` function. + * Updated documentation. + +### Patch + +* Make it build with `ghc-9.12`. +* Drop support for `ghc-8.10`. +* Support `io-classes-1.8.0.1`. +* Support the new `MustExist` option for `AllowExisting` that was added in + `fs-api`. + ## 0.3.1.0 -- 2024-12-10 ### Non-breaking diff --git a/fs-sim.cabal b/fs-sim.cabal --- a/fs-sim.cabal +++ b/fs-sim.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: fs-sim -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Simulated file systems description: Simulated file systems. license: Apache-2.0 @@ -19,13 +19,19 @@ CHANGELOG.md README.md -tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 +tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12 source-repository head type: git location: https://github.com/input-output-hk/fs-sim subdir: fs-sim +source-repository this + type: git + location: https://github.com/input-output-hk/fs-sim + subdir: fs-sim + tag: fs-sim-0.4.0.0 + library hs-source-dirs: src exposed-modules: @@ -38,12 +44,12 @@ default-language: Haskell2010 build-depends: - , base >=4.14 && <4.21 + , base >=4.16 && <4.22 , base16-bytestring ^>=0.1 || ^>=1.0 , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12 , containers ^>=0.5 || ^>=0.6 || ^>=0.7 - , fs-api ^>=0.3 - , io-classes ^>=1.6 || ^>=1.7 + , fs-api ^>=0.4 + , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1 , io-classes:strict-stm , mtl ^>=2.2 || ^>=2.3 , primitive ^>=0.9 @@ -63,6 +69,7 @@ other-modules: Test.System.FS.Sim.Error Test.System.FS.Sim.FsTree + Test.System.FS.Sim.Stream Test.System.FS.StateMachine Test.Util Test.Util.RefEnv @@ -74,6 +81,7 @@ , bifunctors , bytestring , containers + , deepseq , fs-api , fs-sim , generics-sop diff --git a/src/System/FS/Sim/Error.hs b/src/System/FS/Sim/Error.hs --- a/src/System/FS/Sim/Error.hs +++ b/src/System/FS/Sim/Error.hs @@ -433,9 +433,11 @@ hPutBufSomeAtE <- commonPutErrors return Errors {..} where - streamGen l = Stream.genInfinite . Stream.genMaybe' l . QC.elements - streamGen' l = Stream.genInfinite . Stream.genMaybe' l . QC.frequency + genMaybe' = Stream.genMaybe 2 + streamGen l = Stream.genInfinite . genMaybe' l . QC.elements + streamGen' l = Stream.genInfinite . genMaybe' l . QC.frequency + commonGetErrors = streamGen' 20 [ (1, return $ Left FsReachedEOF) , (3, Right <$> arbitrary) ] @@ -572,15 +574,12 @@ -- | Execute the next action using the given 'Errors'. After the action is -- finished, the previous 'Errors' are restored. -withErrors :: MonadSTM m => StrictTVar m Errors -> Errors -> m a -> m a -withErrors errorsVar tempErrors action = do - originalErrors <- atomically $ do - originalErrors <- readTVar errorsVar - writeTVar errorsVar tempErrors - return originalErrors - res <- action - atomically $ writeTVar errorsVar originalErrors - return res +withErrors :: (MonadSTM m, MonadThrow m) => StrictTVar m Errors -> Errors -> m a -> m a +withErrors errorsVar tempErrors action = + bracket + (atomically $ swapTVar errorsVar tempErrors) + (\originalErrors -> atomically $ swapTVar errorsVar originalErrors) + $ \_ -> action {------------------------------------------------------------------------------- Utilities diff --git a/src/System/FS/Sim/FsTree.hs b/src/System/FS/Sim/FsTree.hs --- a/src/System/FS/Sim/FsTree.hs +++ b/src/System/FS/Sim/FsTree.hs @@ -231,14 +231,23 @@ Specific file system functions -------------------------------------------------------------------------------} --- | Open a file: create it if necessary or throw an error if it existed --- already wile we were supposed to create it from scratch (when passed --- 'MustBeNew'). +-- | Open a file: create it if necessary or throw an error if either: +-- 1. It existed already while we were supposed to create it from scratch +-- (when passed 'MustBeNew'). +-- 2. It did not already exists when we expected to (when passed 'MustExist'). openFile :: Monoid a => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a) -openFile fp ex = alterFile fp Left (Right mempty) $ \a -> case ex of - AllowExisting -> Right a - MustBeNew -> Left (FsExists fp) +openFile fp ex = alterFile fp Left caseDoesNotExist caseAlreadyExist + where + caseAlreadyExist a = case ex of + AllowExisting -> Right a + MustBeNew -> Left (FsExists fp) + MustExist -> Right a + + caseDoesNotExist = case ex of + AllowExisting -> Right mempty + MustBeNew -> Right mempty + MustExist -> Left (FsMissing fp (pathLast fp :| [])) -- | Replace the contents of the specified file (which must exist) replace :: FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a) diff --git a/src/System/FS/Sim/MockFS.hs b/src/System/FS/Sim/MockFS.hs --- a/src/System/FS/Sim/MockFS.hs +++ b/src/System/FS/Sim/MockFS.hs @@ -65,7 +65,7 @@ , hPutBufSomeAt ) where -import Control.Monad (forM, forM_, unless, void, when) +import Control.Monad (forM, forM_, unless, when) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.State.Strict (MonadState, get, gets, put) @@ -491,8 +491,6 @@ , fsErrorStack = prettyCallStack , fsLimitation = True } - when (openMode == ReadMode) $ void $ - checkFsTree $ FS.getFile fp (mockFiles fs) files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) return $ newHandle (fs { mockFiles = files' }) (OpenHandle fp (filePtr openMode)) diff --git a/src/System/FS/Sim/Stream.hs b/src/System/FS/Sim/Stream.hs --- a/src/System/FS/Sim/Stream.hs +++ b/src/System/FS/Sim/Stream.hs @@ -1,30 +1,39 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Possibly infinite streams of @'Maybe' a@s. +-- | Finite and infinite streams of @'Maybe' a@s. module System.FS.Sim.Stream ( -- * Streams - Stream + Stream (..) + , InternalInfo (..) -- * Running , runStream + , runStreamN + , runStreamIndefinitely -- * Construction , always , empty - , mkInfinite , repeating + , unsafeMkInfinite , unsafeMkFinite + -- * Modify + , filter -- * Query , null + , isFinite + , isInfinite -- * Generation and shrinking , genFinite + , genFiniteN , genInfinite , genMaybe - , genMaybe' , shrinkStream + , liftShrinkStream ) where import Control.Monad (replicateM) -import Prelude hiding (null) +import Prelude hiding (filter, isInfinite, null) +import qualified Prelude import qualified Test.QuickCheck as QC import Test.QuickCheck (Gen) @@ -32,29 +41,45 @@ Streams -------------------------------------------------------------------------------} --- | A 'Stream' is a stream of @'Maybe' a@s, which is /possibly/ infinite or --- /definitely/ finite. --- --- Finiteness is tracked internally and used for 'QC.shrink'ing and the 'Show' --- instance. -data Stream a = Stream { - -- | Info about the size of the stream. - _streamInternalInfo :: InternalInfo - , _getStream :: [Maybe a] +-- | A stream of @'Maybe' a@s that can be infinite. +data Stream a = + -- | UNSAFE: when constructing, modifying, or accessing the internals of a + -- 'Stream', it is the responsibility of the user to preserve the following + -- invariant: + -- + -- INVARIANT: if the stream is marked as 'Infinite', then the internal list + -- should be infinite. If the stream is marked as 'Finite', then the internal + -- list should finite. + -- + -- * If the internal list is infinite but marked as 'Finite', then 'QC.shrink' + -- or 'show' on the corresponding stream will diverge. + -- + -- * If the internal list is finite but marked as 'Infinite', then 'QC.shrink' + -- on the corresponding stream will degrade to an infinite list of empty + -- streams. + UnsafeStream { + -- | UNSAFE: see 'UnsafeStream' for more information. + -- + -- Info about the finiteness of the stream. It is used for 'QC.shrink'ing + -- and the 'Show' instance. + unsafeStreamInternalInfo :: InternalInfo + -- | UNSAFE: see 'UnsafeStream' for more information. + -- + -- The internal list underlying the stream. + , unsafeStreamList :: [Maybe a] } deriving Functor --- | Tag for 'Stream's that describes whether it is either /definitely/ a finite --- stream, or /possibly/ an infinite stream. +-- | Tag for 'Stream's that describes whether it is finite or infinite. -- --- Useful for the 'Show' instance of 'Stream': when a 'Stream' is /definitely/ --- finite, we can safely print the full stream. +-- Useful for the 'Show' instance of 'Stream': when a 'Stream' is finite, we can +-- safely print the full stream. data InternalInfo = Infinite | Finite --- | Fully shows a 'Stream' if it is /definitely/ finite, or prints a --- placeholder string if it is /possibly/ infinite. +-- | Fully shows a 'Stream' if it is finite, or prints a placeholder string if +-- it is infinite. instance Show a => Show (Stream a) where - showsPrec n (Stream info xs) = case info of + showsPrec n (UnsafeStream info xs) = case info of Infinite -> ("" ++) Finite -> (if n > 10 then ('(':) else id) . shows xs @@ -65,81 +90,127 @@ Running -------------------------------------------------------------------------------} --- | Advance the 'Stream'. Return the @'Maybe' a@ and the remaining 'Stream'. +-- | \( O(1) \): advance the 'Stream'. Return the @'Maybe' a@ and the remaining +-- 'Stream'. -- -- Returns 'Nothing' by default if the 'Stream' is empty. runStream :: Stream a -> (Maybe a, Stream a) -runStream s@(Stream _ [] ) = (Nothing, s) -runStream (Stream info (a:as)) = (a, Stream info as) +runStream s@(UnsafeStream _ [] ) = (Nothing, s) +runStream (UnsafeStream info (a:as)) = (a, UnsafeStream info as) +-- | \( O(n) \): like 'runStream', but advancing the stream @n@ times. +-- +-- If @n<=0@, then the stream is advanced @0@ times. +runStreamN :: Int -> Stream a -> ([Maybe a], Stream a) +runStreamN n s + | n <= 0 = ([], s) + | otherwise = + let (x, s') = runStream s + (xs, s'') = runStreamN (n-1) s' + in (x:xs, s'') + +-- | \( O(\infty) \): like 'runStream', but advancing the stream indefinitely. +-- +-- For infinite streams, this produces an infinite list. For finite streams, +-- this produces a finite list. +runStreamIndefinitely :: Stream a -> [Maybe a] +runStreamIndefinitely (UnsafeStream _ as) = as ++ repeat Nothing + {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} -- | Make an empty 'Stream'. empty :: Stream a -empty = Stream Finite [] +empty = UnsafeStream Finite [] -- | Make a 'Stream' that always generates the given @a@. always :: a -> Stream a -always x = Stream Infinite (repeat (Just x)) +always x = UnsafeStream Infinite (repeat (Just x)) -- | Make a 'Stream' that infinitely repeats the given list. repeating :: [Maybe a] -> Stream a -repeating xs = Stream Infinite $ concat (repeat xs) +repeating xs = UnsafeStream Infinite $ cycle xs --- | UNSAFE: Make a 'Stream' that is marked as definitely finite. --- --- This is unsafe since a user can pass in any list, and evaluating --- 'Test.QuickCheck.shrink' or 'show' on the resulting 'Stream' will diverge. It --- is the user's responsibility to only pass in a finite list. +-- | UNSAFE: Make a 'Stream' that is marked as finite. It is the user's +-- responsibility to only pass in finite lists. See 'UnsafeStream' for more +-- information. unsafeMkFinite :: [Maybe a] -> Stream a -unsafeMkFinite = Stream Finite +unsafeMkFinite = UnsafeStream Finite --- | Make a 'Stream' that is marked as possibly infinite. -mkInfinite :: [Maybe a] -> Stream a -mkInfinite = Stream Infinite +-- | UNSAFE: Make a 'Stream' that is marked as infinite. It is the user's +-- responsibility to only pass in infinite lists. See 'UnsafeStream' for more +-- information. +unsafeMkInfinite :: [Maybe a] -> Stream a +unsafeMkInfinite = UnsafeStream Infinite {------------------------------------------------------------------------------- + Modify +-------------------------------------------------------------------------------} + +-- | Filter a 'Stream', preserving finiteness. +filter :: (Maybe a -> Bool) -> Stream a -> Stream a +filter p (UnsafeStream info xs) = UnsafeStream info (Prelude.filter p xs) + +{------------------------------------------------------------------------------- Query -------------------------------------------------------------------------------} --- | Return 'True' if the stream is empty. +-- | Check that the stream is empty. -- --- A stream consisting of only 'Nothing's (even if it is only one) is not --- considered to be empty. +-- In general, a stream is only empty if the stream is equivalent to 'empty'. +-- +-- A finite\/infinite stream consisting of only 'Nothing's is not considered to +-- be empty. In particular, @'null' ('always' Nothing) /= True@. null :: Stream a -> Bool -null (Stream _ []) = True -null _ = False +null (UnsafeStream Finite []) = True +null _ = False +-- | Check that the stream is finite +isFinite :: Stream a -> Bool +isFinite (UnsafeStream Finite _) = True +isFinite (UnsafeStream Infinite _) = False + +-- | Check that the stream is infinite +isInfinite :: Stream a -> Bool +isInfinite (UnsafeStream Finite _) = False +isInfinite (UnsafeStream Infinite _) = True + {------------------------------------------------------------------------------- Generation and shrinking -------------------------------------------------------------------------------} --- | Shrink a stream like it is an 'Test.QuickCheck.InfiniteList'. +-- | Shrink a stream like it is an 'QC.InfiniteList'. -- --- Possibly infinite streams are shrunk differently than lists that are --- definitely finite, which is to ensure that shrinking terminates. --- * Possibly infinite streams are shrunk by taking finite prefixes of the --- argument stream. As such, shrinking a possibly infinite stream creates --- definitely finite streams. --- * Definitely finite streams are shrunk like lists are shrunk normally, --- preserving that the created streams are still definitely finite. +-- Infinite streams are shrunk differently than lists that are finite, which is +-- to ensure that we shrink infinite lists towards finite lists. +-- +-- * Infinite streams are shrunk by taking finite prefixes of the argument +-- stream. Note that there are an infinite number of finite prefixes, so even +-- though the *shrink list* is infinite, the individual *list elements* are +-- finite. +-- +-- * Finite streams are shrunk like lists are shrunk normally, preserving +-- finiteness. shrinkStream :: Stream a -> [Stream a] -shrinkStream (Stream info xs0) = case info of - Infinite -> Stream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]] - Finite -> Stream Finite <$> QC.shrinkList (const []) xs0 +shrinkStream (UnsafeStream info xs0) = case info of + Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]] + Finite -> UnsafeStream Finite <$> QC.shrinkList (const []) xs0 +-- | Like 'shrinkStream', but with a custom shrinker for elements of the stream. +liftShrinkStream :: (Maybe a -> [Maybe a]) -> Stream a -> [Stream a] +liftShrinkStream shrinkOne (UnsafeStream info xs0) = case info of + Infinite -> UnsafeStream Finite <$> [take n xs0 | n <- map (2^) [0 :: Int ..]] + Finite -> UnsafeStream Finite <$> QC.shrinkList shrinkOne xs0 + -- | Make a @'Maybe' a@ generator based on an @a@ generator. -- -- Each element has a chance of being either 'Nothing' or an element generated --- with the given @a@ generator (wrapped in a 'Just'). --- --- The first argument is the likelihood (as used by 'QC.frequency') of a --- 'Just' where 'Nothing' has likelihood 2. +-- with the given @a@ generator (wrapped in a 'Just'). These /likelihoods/ are +-- passed to 'QC.frequency'. genMaybe :: - Int -- ^ Likelihood of 'Nothing' - -> Int -- ^ Likelihood of @'Just' a@ + Int -- ^ Likelihood of 'Nothing' + -> Int -- ^ Likelihood of @'Just' a@ -> Gen a -> Gen (Maybe a) genMaybe nLi jLi genA = QC.frequency @@ -147,22 +218,21 @@ , (jLi, Just <$> genA) ] --- | Like 'genMaybe', but with the likelihood of 'Nothing' fixed to @2@. 'QC.frequency' -genMaybe' :: - Int -- ^ Likelihood of @'Just' a@ - -> Gen a +-- | Generate a finite 'Stream' of length @n@. +genFiniteN :: + Int -- ^ Requested size of finite stream. -> Gen (Maybe a) -genMaybe' = genMaybe 2 + -> Gen (Stream a) +genFiniteN n gen = UnsafeStream Finite <$> replicateM n gen --- | Generate a finite 'Stream' of length @n@. +-- | Generate a sized, finite 'Stream'. genFinite :: - Int -- ^ Requested size of finite stream. Tip: use 'genMaybe'. - -> Gen (Maybe a) + Gen (Maybe a) -> Gen (Stream a) -genFinite n gen = Stream Finite <$> replicateM n gen +genFinite gen = UnsafeStream Finite <$> QC.listOf gen -- | Generate an infinite 'Stream'. genInfinite :: - Gen (Maybe a) -- ^ Tip: use 'genMaybe'. + Gen (Maybe a) -> Gen (Stream a) -genInfinite gen = Stream Infinite <$> QC.infiniteListOf gen +genInfinite gen = UnsafeStream Infinite <$> QC.infiniteListOf gen diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,7 @@ import qualified Test.System.FS.Sim.Error import qualified Test.System.FS.Sim.FsTree +import qualified Test.System.FS.Sim.Stream import qualified Test.System.FS.StateMachine import Test.Tasty @@ -9,5 +10,6 @@ main = defaultMain $ testGroup "fs-sim-test" [ Test.System.FS.Sim.Error.tests , Test.System.FS.Sim.FsTree.tests + , Test.System.FS.Sim.Stream.tests , Test.System.FS.StateMachine.tests ] diff --git a/test/Test/System/FS/Sim/Stream.hs b/test/Test/System/FS/Sim/Stream.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/Sim/Stream.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- The @base@ library throws warnings on uses of @head@ on later GHC versions. +-- This is a just a test module, so we ignore the warning. +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + +module Test.System.FS.Sim.Stream (tests) where + +import Control.DeepSeq +import Data.Maybe (isJust, isNothing) +import Prelude hiding (filter, isInfinite, null) +import qualified Prelude +import System.FS.Sim.Stream +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util + +tests :: TestTree +tests = testGroup "Test.System.FS.Sim.Stream" [ + testProperty "prop_runStream" $ + prop_runStream @Int + , testProperty "prop_runStreamN" $ + prop_runStreamN @Int + , testProperty "prop_null" + prop_null + , testGroup "Shrinkers" [ + testProperty "prop_shrinkStreamFail" $ + prop_shrinkStreamFail @Int + , testProperty "prop_eventuallyJust @InfiniteStream" $ + \(InfiniteStream s) -> prop_eventuallyJust @Int s + , testProperty "prop_eventuallyNothing @InfiniteStream" $ + \(InfiniteStream s) -> prop_eventuallyNothing @Int s + , testProperty "prop_eventuallyNothing @FiniteStream" $ + \(FiniteStream s) -> prop_eventuallyNothing @Int s + ] + , testGroup "Generators and shrinkers" [ + testGroup "Stream" $ + prop_forAllArbitraryAndShrinkSatisfy + @(Stream Int) + arbitrary + (\s -> if isFinite s then shrink s else take 20 (shrink s)) + prop_stream + prop_finiteStream + , testGroup "FiniteSteam" $ + prop_arbitraryAndShrinkSatisfy + @(FiniteStream Int) + (\(FiniteStream s) -> prop_finiteStream s) + (\(FiniteStream s) -> prop_finiteStream s) + , testGroup "InfiniteStream" $ + prop_forAllArbitraryAndShrinkSatisfy + @(InfiniteStream Int) + arbitrary + (take 6 . shrink) + (\(InfiniteStream s) -> prop_infiniteStream s) + (\(InfiniteStream s) -> prop_finiteStream s) + , testGroup "NonEmptyStream" $ + prop_forAllArbitraryAndShrinkSatisfy + @(NonEmptyStream Int) + arbitrary + (\s@(NonEmptyStream s') -> if isFinite s' then shrink s else take 20 (shrink s)) + (\(NonEmptyStream s) -> prop_nonEmptyStream s) + (\(NonEmptyStream s) -> prop_nonEmptyStream s) + ] + ] + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +-- | Advancing a stream behaves like a head on an equivalent list. +prop_runStream :: (Eq a, Show a) => Stream a -> Property +prop_runStream s = + x === head ys + where + (x, _s') = runStream s + ys = runStreamIndefinitely s + +-- | Advancing a stream @n@ times behaves likes @take n@ on an equivalent list. +prop_runStreamN :: (Eq a, Show a) => Int -> Stream a -> Property +prop_runStreamN n s = + xs === take n ys + where + (xs, _s') = runStreamN n s + ys = runStreamIndefinitely s + +-- | Empty streams are null +prop_null :: Property +prop_null = once $ property $ null empty + +{------------------------------------------------------------------------------- + Shrinkers +-------------------------------------------------------------------------------} + +-- | A simple property that is expected to fail, but should exercise the +-- shrinker a little bit. +prop_shrinkStreamFail :: Stream a -> Property +prop_shrinkStreamFail s = expectFailure $ + let xs = fst (runStreamN 10 s) + in property $ length (Prelude.filter isJust xs) /= length (Prelude.filter isNothing xs) + +-- | A stream eventually produces a 'Just' +prop_eventuallyJust :: Stream a -> Property +prop_eventuallyJust = eventually isJust + +-- | A stream eventually produces a 'Nothing' +prop_eventuallyNothing :: Stream a -> Property +prop_eventuallyNothing = eventually isNothing + +eventually :: (Maybe a -> Bool) -> Stream a -> Property +eventually p = go 1 + where + go !n s = + let (x, s') = runStream s in + if p x + then tabulate "Number of elements inspected" [showPowersOf 2 n] $ property True + else go (n+1) s' + +{------------------------------------------------------------------------------- + Generators and shrinkers +-------------------------------------------------------------------------------} + +-- | A 'Stream' is either finite or infinite +prop_stream :: NFData a => Stream a -> Property +prop_stream s = + prop_finiteStream s + .||. prop_infiniteStream s + +-- | A stream is finite +prop_finiteStream :: NFData a => Stream a -> Property +prop_finiteStream s = + property (isFinite s) .&&. property (not (isInfinite s)) .&&. + prop_deepseqStream s + +-- | An stream is infinite +prop_infiniteStream :: Stream a -> Property +prop_infiniteStream s = + property (isInfinite s) .&&. property (not (isFinite s)) + +-- | A stream is non-empty, and finite or infinite +prop_nonEmptyStream :: NFData a => Stream a -> Property +prop_nonEmptyStream s = + property $ not (null s) + .&&. prop_stream s + +prop_deepseqStream :: NFData a => Stream a -> Property +prop_deepseqStream (UnsafeStream info xs) = property (rwhnf info `seq` rnf xs) + +{------------------------------------------------------------------------------- + Generators and shrinkers: utility properties +-------------------------------------------------------------------------------} + +prop_arbitraryAndShrinkSatisfy :: + forall a. (Arbitrary a, Show a) + => (a -> Property) -- ^ Generator property + -> (a -> Property) -- ^ Shrinker property + -> [TestTree] +prop_arbitraryAndShrinkSatisfy = + prop_forAllArbitraryAndShrinkSatisfy arbitrary shrink + +prop_forAllArbitraryAndShrinkSatisfy :: + forall a. Show a + => Gen a + -> (a -> [a]) + -> (a -> Property) -- ^ Generator property + -> (a -> Property) -- ^ Shrinker property + -> [TestTree] +prop_forAllArbitraryAndShrinkSatisfy gen shr pgen pshr = + [ prop_forAllArbitrarySatisfies gen shr pgen + , prop_forAllShrinkSatisfies gen shr pshr + ] + +prop_forAllArbitrarySatisfies :: + forall a. Show a + => Gen a + -> (a -> [a]) + -> (a -> Property) + -> TestTree +prop_forAllArbitrarySatisfies gen shr p = + testProperty "Arbitrary satisfies property" $ + forAllShrink gen shr p + +prop_forAllShrinkSatisfies :: + forall a. Show a + => Gen a + -> (a -> [a]) + -> (a -> Property) + -> TestTree +prop_forAllShrinkSatisfies gen shr p = + testProperty "Shrinking satisfies property" $ + forAll gen $ \x -> + case shr x of + [] -> label "no shrinks" $ property True + xs -> forAll (growingElements xs) p + +{------------------------------------------------------------------------------- + Arbitrary instances +-------------------------------------------------------------------------------} + +-- +-- Stream +-- + +instance Arbitrary a => Arbitrary (Stream a) where + arbitrary = oneof [ + genFinite arbitrary + , genInfinite arbitrary + ] + shrink = liftShrinkStream shrink + +-- +-- NonEmptyStream +-- + +newtype NonEmptyStream a = NonEmptyStream (Stream a) + deriving stock Show + +instance Arbitrary a => Arbitrary (NonEmptyStream a) where + arbitrary = NonEmptyStream <$> oneof [ + genFiniteNonEmpty + , genInfinite arbitrary + ] + where + genFiniteNonEmpty = do + x <- arbitrary + xs <- arbitrary + pure $ unsafeMkFinite (x : xs) + shrink (NonEmptyStream s) = + [ NonEmptyStream s' + | s' <- shrink s + , not (Prelude.null (unsafeStreamList s')) ] + +-- +-- FiniteStream +-- + +newtype FiniteStream a = FiniteStream { + getFiniteStream :: Stream a + } + deriving stock Show + +instance Arbitrary a => Arbitrary (FiniteStream a) where + arbitrary = FiniteStream <$> genFinite arbitrary + shrink (FiniteStream s) = FiniteStream <$> shrinkStream s + +-- +-- InfiniteStream +-- + +newtype InfiniteStream a = InfiniteStream { + getInfiniteStream :: Stream a + } + deriving stock Show + +instance Arbitrary a => Arbitrary (InfiniteStream a) where + arbitrary = InfiniteStream <$> genInfinite arbitrary + shrink (InfiniteStream s) = InfiniteStream <$> shrinkStream s + +-- +-- Tiny +-- + +newtype Tiny a = Tiny a + deriving stock Show + +instance Arbitrary (Tiny Int) where + arbitrary = Tiny <$> choose (0, 5) + shrink (Tiny x) = [ Tiny x' | x' <- shrink x, 0 <= x', x' <= 5] diff --git a/test/Test/System/FS/StateMachine.hs b/test/Test/System/FS/StateMachine.hs --- a/test/Test/System/FS/StateMachine.hs +++ b/test/Test/System/FS/StateMachine.hs @@ -676,7 +676,7 @@ (rf, wf) = if fileExists then (10,3) else (1,3) genAllowExisting :: Gen AllowExisting - genAllowExisting = elements [AllowExisting, MustBeNew] + genAllowExisting = elements [AllowExisting, MustBeNew, MustExist] genSeekMode :: Gen SeekMode genSeekMode = elements [ @@ -1004,84 +1004,107 @@ -- > Get .. | TagPutTruncateGet - -- Close a handle 2 times + -- | Close a handle 2 times -- -- > h <- Open .. -- > close h -- > close h | TagClosedTwice - -- Open an existing file with ReadMode and then with WriteMode + -- | Open an existing file with ReadMode and then with WriteMode -- -- > open fp ReadMode -- > open fp Write | TagOpenReadThenWrite - -- Open 2 Readers of a file. + -- | Open 2 Readers of a file. -- -- > open fp ReadMode -- > open fp ReadMode | TagOpenReadThenRead - -- ListDir on a non empty dirextory. + -- | ListDir on a non empty dirextory. -- -- > CreateDirIfMissing True a/b -- > ListDirectory a | TagCreateDirWithParentsThenListDirNotNull - -- Read from an AppendMode file + -- | Read from an AppendMode file -- -- > h <- Open fp AppendMode -- > Read h .. | TagReadInvalid - -- Write to a read only file + -- | Write to a read only file -- -- > h <- Open fp ReadMode -- > Put h .. | TagWriteInvalid - -- Put Seek and Get + -- | Put Seek and Get -- -- > Put .. -- > Seek .. -- > Get .. | TagPutSeekGet - -- Put Seek (negative) and Get + -- | Put Seek (negative) and Get -- -- > Put .. -- > Seek .. (negative) -- > Get .. | TagPutSeekNegGet - -- Open with MustBeNew (O_EXCL flag), but the file already existed. + -- | Open with MustBeNew (O_EXCL flag), but the file already existed. -- -- > h <- Open fp (AppendMode _) -- > Close h -- > Open fp (AppendMode MustBeNew) | TagExclusiveFail + -- | Open a file in read mode successfully + -- + -- > h <- Open fp (WriteMode _) + -- > Close h + -- > h <- Open fp ReadMode + | TagReadModeMustExist - -- Reading returns an empty bytestring when EOF + -- | Open a file in read mode, but it fails because the file does not exist. -- + -- > h <- Open fp ReadMode + | TagReadModeMustExistFail + + -- | Open a file in non-read mode with 'MustExist' successfully. + -- + -- > h <- Open fp (_ MustBeNew) + -- > Close h + -- > h <- Open fp (_ MustExist) + | TagFileMustExist + + -- | Open a file in non-read mode with 'MustExist', but it fails because the + -- files does not exist. + -- + -- > h <- Open fp (_ MustExist) + | TagFileMustExistFail + + -- | Reading returns an empty bytestring when EOF + -- -- > h <- open fp ReadMode -- > Get h 1 == "" | TagReadEOF - - -- GetAt + -- | GetAt -- -- > GetAt ... | TagPread - -- Roundtrip for I/O with user-supplied buffers + -- | Roundtrip for I/O with user-supplied buffers -- -- > PutBuf h bs c -- > GetBuf h c (==bs) | TagPutGetBuf - -- Roundtrip for I/O with user-supplied buffers + -- | Roundtrip for I/O with user-supplied buffers -- -- > PutBufAt h bs c o -- > GetBufAt h c o (==bs) @@ -1136,6 +1159,10 @@ , tagPutSeekGet Set.empty Set.empty , tagPutSeekNegGet Set.empty Set.empty , tagExclusiveFail + , tagReadModeMustExist + , tagReadModeMustExistFail + , tagFileMustExist + , tagFileMustExistFail , tagReadEOF , tagPread , tagPutGetBuf Set.empty @@ -1480,6 +1507,39 @@ , fsErrorType fsError == FsResourceAlreadyExist -> Left TagExclusiveFail _otherwise -> Right tagExclusiveFail + + tagReadModeMustExist :: EventPred + tagReadModeMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist + _otherwise -> Right tagReadModeMustExist + + tagReadModeMustExistFail :: EventPred + tagReadModeMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Left fsError)) + | fsErrorType fsError == FsResourceDoesNotExist -> + Left TagReadModeMustExistFail + _otherwise -> Right tagReadModeMustExistFail + + tagFileMustExist :: EventPred + tagFileMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Right (WHandle _ _))) + | MustExist <- allowExisting mode + , mode /= ReadMode + -> Left TagFileMustExist + _otherwise -> Right tagFileMustExist + + tagFileMustExistFail :: EventPred + tagFileMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Left fsError)) + | MustExist <- allowExisting mode + , mode /= ReadMode + , fsErrorType fsError == FsResourceDoesNotExist -> + Left TagFileMustExistFail + _otherwise -> Right tagFileMustExistFail tagReadEOF :: EventPred tagReadEOF = successful $ \ev suc ->