diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index c17eca5..a7e404f 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -63,6 +63,7 @@ test-suite fs-sim-test 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 +75,7 @@ test-suite fs-sim-test , bifunctors , bytestring , containers + , deepseq , fs-api , fs-sim , generics-sop diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index f55b2e6..4be80dd 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -433,8 +433,10 @@ genErrors genPartialWrites genSubstituteWithJunk = do 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) diff --git a/fs-sim/src/System/FS/Sim/Stream.hs b/fs-sim/src/System/FS/Sim/Stream.hs index 2c599c8..cee523c 100644 --- a/fs-sim/src/System/FS/Sim/Stream.hs +++ b/fs-sim/src/System/FS/Sim/Stream.hs @@ -1,30 +1,35 @@ {-# 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 (..) -- * Running , runStream + , runStreamN + , runStreamIndefinitely -- * Construction , always , empty - , mkInfinite + , unsafeMkInfinite , repeating , unsafeMkFinite -- * 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 (isInfinite, null) import qualified Test.QuickCheck as QC import Test.QuickCheck (Gen) @@ -32,29 +37,31 @@ import Test.QuickCheck (Gen) 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: accessing, modifying, or manually constructing the internals of a + -- 'Stream' might break invariants. + UnsafeStream { + -- | UNSAFE: see 'UnsafeStream'. + -- + -- Info about the size of the stream. It is used for 'QC.shrink'ing and + -- the 'Show' instance. + unsafeStreamInternalInfo :: InternalInfo + -- | UNSAFE: see 'UnsafeStream'. + , 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,12 +72,31 @@ instance Show a => Show (Stream a) where 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 @@ -78,68 +104,91 @@ runStream (Stream info (a:as)) = (a, Stream info as) -- | 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. +-- | UNSAFE: Make a 'Stream' that is marked as 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. +-- This is unsafe since a user can pass in any list, and if the list is infinite +-- then evaluating 'QC.shrink' or 'show' on the resulting 'Stream' will diverge. +-- It is the user's responsibility to only pass in finite lists. 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. +-- +-- This is unsafe since a user can pass in any list, and if the list is finite +-- then the result of 'QC.shrink' will degrade to an infinite list of empty +-- streams. It is the user's responsibility to only pass in infinite lists. +unsafeMkInfinite :: [Maybe a] -> Stream a +unsafeMkInfinite = UnsafeStream Infinite {------------------------------------------------------------------------------- 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'. +-- +-- Infinite streams are shrunk differently than lists that are finite, which is +-- to ensure that we shrink infinite lists towards finite lists. -- --- 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 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 + +-- | TODO +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 +196,21 @@ genMaybe nLi jLi genA = QC.frequency , (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/fs-sim/test/Main.hs b/fs-sim/test/Main.hs index 6ece07d..3156005 100644 --- a/fs-sim/test/Main.hs +++ b/fs-sim/test/Main.hs @@ -2,6 +2,7 @@ module Main (main) where 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 :: IO () 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/fs-sim/test/Test/System/FS/Sim/Stream.hs b/fs-sim/test/Test/System/FS/Sim/Stream.hs new file mode 100644 index 0000000..a7f0823 --- /dev/null +++ b/fs-sim/test/Test/System/FS/Sim/Stream.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# LANGUAGE FlexibleInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.System.FS.Sim.Stream (tests) where + +import Control.DeepSeq +import Data.Maybe (isJust, isNothing) +import Prelude hiding (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 (filter isJust xs) /= length (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]