diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index 8deb54a..fa79c7b 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} @@ -19,7 +17,7 @@ module System.FS.Sim.Error ( , ErrorStream , ErrorStreamGetSome , ErrorStreamPutSome - , Stream (..) + , Stream , always , mkStream , mkStreamGen @@ -39,6 +37,7 @@ module System.FS.Sim.Error ( -- * Error streams for 'HasFS' , Errors (..) , allNull + , emptyErrors , genErrors , simpleErrors ) where @@ -72,7 +71,35 @@ import System.FS.API.Types import System.FS.Sim.MockFS (HandleMock, MockFS) import qualified System.FS.Sim.STM as Sim -import System.FS.Sim.Stream +import qualified System.FS.Sim.Stream as Stream + +{------------------------------------------------------------------------------- + Deprecations +-------------------------------------------------------------------------------} + +{-# DEPRECATED Stream "Use Stream from System.FS.Sim.Stream instead" #-} +type Stream = Stream.Stream + +{-# DEPRECATED always "Use always from System.FS.Sim.Stream instead" #-} +always :: a -> Stream a +always = Stream.always + +{-# DEPRECATED mkStream "Use mkInfinite or unsafeMkFinite from System.FS.Sim.Stream instead" #-} +mkStream :: [Maybe a] -> Stream a +mkStream = Stream.mkInfinite + +{-# DEPRECATED mkStreamGen "Use genFinite, genInfinite, genMaybe and genMaybe' from System.FS.Sim.Stream instead" #-} +mkStreamGen :: Int -> Gen a -> Gen (Stream a) +mkStreamGen justLikelihood genA = + Stream.genFinite 10 (Stream.genMaybe 2 justLikelihood genA) + +{-# DEPRECATED null "Use null from System.FS.Sim.Stream instead" #-} +null :: Stream a -> Bool +null = Stream.null + +{-# DEPRECATED runStream "Use runStream from System.FS.Sim.Stream instead" #-} +runStream :: Stream a -> (Maybe a, Stream a) +runStream = Stream.runStream {------------------------------------------------------------------------------- Streams of errors @@ -237,22 +264,22 @@ data Errors = Errors -- | Return 'True' if all streams are empty ('null'). allNull :: Errors -> Bool -allNull Errors {..} = null dumpStateE - && null hOpenE - && null hCloseE - && null hSeekE - && null hGetSomeE - && null hGetSomeAtE - && null hPutSomeE - && null hTruncateE - && null hGetSizeE - && null createDirectoryE - && null createDirectoryIfMissingE - && null listDirectoryE - && null doesDirectoryExistE - && null doesFileExistE - && null removeFileE - && null renameFileE +allNull Errors {..} = Stream.null dumpStateE + && Stream.null hOpenE + && Stream.null hCloseE + && Stream.null hSeekE + && Stream.null hGetSomeE + && Stream.null hGetSomeAtE + && Stream.null hPutSomeE + && Stream.null hTruncateE + && Stream.null hGetSizeE + && Stream.null createDirectoryE + && Stream.null createDirectoryIfMissingE + && Stream.null listDirectoryE + && Stream.null doesDirectoryExistE + && Stream.null doesFileExistE + && Stream.null removeFileE + && Stream.null renameFileE instance Show Errors where @@ -261,10 +288,8 @@ instance Show Errors where where -- | Show a stream unless it is empty s :: Show a => String -> Stream a -> Maybe String - s _ (Stream []) = Nothing - -- While the testsuite currently never prints an infinite streams, it's - -- better to protect us against it when it were to happen accidentally. - s fld (Stream xs) = Just $ fld <> " = " <> show (take 50 xs) + s fld str | Stream.null str = Nothing + | otherwise = Just $ fld <> " = " <> show str streams :: [String] streams = catMaybes @@ -286,33 +311,8 @@ instance Show Errors where , s "renameFileE" renameFileE ] -instance Semigroup Errors where - egs1 <> egs2 = Errors - { dumpStateE = combine dumpStateE - , hOpenE = combine hOpenE - , hCloseE = combine hCloseE - , hSeekE = combine hSeekE - , hGetSomeE = combine hGetSomeE - , hGetSomeAtE = combine hGetSomeAtE - , hPutSomeE = combine hPutSomeE - , hTruncateE = combine hTruncateE - , hGetSizeE = combine hGetSizeE - , createDirectoryE = combine createDirectoryE - , createDirectoryIfMissingE = combine createDirectoryIfMissingE - , listDirectoryE = combine listDirectoryE - , doesDirectoryExistE = combine doesDirectoryExistE - , doesFileExistE = combine doesFileExistE - , removeDirectoryRecursiveE = combine removeDirectoryRecursiveE - , removeFileE = combine removeFileE - , renameFileE = combine renameFileE - } - where - combine :: (Errors -> Stream a) -> Stream a - combine f = f egs1 <> f egs2 - -instance Monoid Errors where - mappend = (<>) - mempty = simpleErrors mempty +emptyErrors :: Errors +emptyErrors = simpleErrors Stream.empty -- | Use the given 'ErrorStream' for each field/method. No corruption of -- 'hPutSome'. @@ -345,13 +345,14 @@ genErrors :: Bool -- ^ 'True' -> generate partial writes -> Bool -- ^ 'True' -> generate 'SubstituteWithJunk' corruptions -> Gen Errors genErrors genPartialWrites genSubstituteWithJunk = do - let streamGen l = mkStreamGen l . QC.elements + let streamGen l = Stream.genInfinite . Stream.genMaybe' l . QC.elements + streamGen' l = Stream.genInfinite . Stream.genMaybe' l . QC.frequency -- TODO which errors are possible for these operations below (that -- have dummy for now)? dummy = streamGen 2 [ FsInsufficientPermissions ] dumpStateE <- dummy -- TODO let this one fail: - let hCloseE = mkStream [] + let hCloseE = Stream.empty hTruncateE <- dummy doesDirectoryExistE <- dummy doesFileExistE <- dummy @@ -360,13 +361,13 @@ genErrors genPartialWrites genSubstituteWithJunk = do , FsResourceAlreadyInUse, FsResourceAlreadyExist , FsInsufficientPermissions, FsTooManyOpenFiles ] hSeekE <- streamGen 3 [ FsReachedEOF ] - hGetSomeE <- mkStreamGen 20 $ QC.frequency + hGetSomeE <- streamGen' 20 [ (1, return $ Left FsReachedEOF) , (3, Right <$> arbitrary) ] - hGetSomeAtE <- mkStreamGen 20 $ QC.frequency + hGetSomeAtE <- streamGen' 20 [ (1, return $ Left FsReachedEOF) , (3, Right <$> arbitrary) ] - hPutSomeE <- mkStreamGen 5 $ QC.frequency + hPutSomeE <- streamGen' 5 [ (1, Left . (FsDeviceFull, ) <$> QC.frequency [ (2, return Nothing) , (1, Just . PartialWrite <$> arbitrary) @@ -398,28 +399,24 @@ genErrors genPartialWrites genSubstituteWithJunk = do instance Arbitrary Errors where arbitrary = genErrors True True - shrink err@Errors {..} = filter (not . allNull) $ catMaybes - [ (\s' -> err { dumpStateE = s' }) <$> dropLast dumpStateE - , (\s' -> err { hOpenE = s' }) <$> dropLast hOpenE - , (\s' -> err { hCloseE = s' }) <$> dropLast hCloseE - , (\s' -> err { hSeekE = s' }) <$> dropLast hSeekE - , (\s' -> err { hGetSomeE = s' }) <$> dropLast hGetSomeE - , (\s' -> err { hGetSomeAtE = s' }) <$> dropLast hGetSomeAtE - , (\s' -> err { hPutSomeE = s' }) <$> dropLast hPutSomeE - , (\s' -> err { hTruncateE = s' }) <$> dropLast hTruncateE - , (\s' -> err { hGetSizeE = s' }) <$> dropLast hGetSizeE - , (\s' -> err { createDirectoryE = s' }) <$> dropLast createDirectoryE - , (\s' -> err { createDirectoryIfMissingE = s' }) <$> dropLast createDirectoryIfMissingE - , (\s' -> err { listDirectoryE = s' }) <$> dropLast listDirectoryE - , (\s' -> err { doesDirectoryExistE = s' }) <$> dropLast doesDirectoryExistE - , (\s' -> err { doesFileExistE = s' }) <$> dropLast doesFileExistE - , (\s' -> err { removeFileE = s' }) <$> dropLast removeFileE - , (\s' -> err { renameFileE = s' }) <$> dropLast renameFileE + shrink err@Errors {..} = filter (not . allNull) $ concat + [ (\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 { removeFileE = s' }) <$> Stream.shrinkStream removeFileE + , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE ] - where - dropLast :: Stream a -> Maybe (Stream a) - dropLast (Stream []) = Nothing - dropLast (Stream xs) = Just $ Stream $ zipWith const xs (drop 1 xs) {------------------------------------------------------------------------------- Simulate Errors monad @@ -536,7 +533,7 @@ next :: MonadSTM m next errorsVar getter setter = do atomically $ do errors <- readTVar errorsVar - let (mb, s') = runStream (getter errors) + let (mb, s') = Stream.runStream (getter errors) writeTVar errorsVar (setter s' errors) return mb diff --git a/fs-sim/src/System/FS/Sim/Stream.hs b/fs-sim/src/System/FS/Sim/Stream.hs index 479c2ab..24900ba 100644 --- a/fs-sim/src/System/FS/Sim/Stream.hs +++ b/fs-sim/src/System/FS/Sim/Stream.hs @@ -1,17 +1,29 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Possibly infinite streams of @'Maybe' a@s. module System.FS.Sim.Stream ( - Stream (..) + -- * Streams + Stream + -- * Running + , runStream + -- * Construction , always - , mkStream - , mkStreamGen + , empty + , unsafeMkFinite + , mkInfinite + , repeating + -- * Query , null - , runStream + -- * Generation and shrinking + , genFinite + , genInfinite + , genMaybe + , genMaybe' + , shrinkStream ) where import Control.Monad (replicateM) -import Data.List (dropWhileEnd) -import Data.Maybe (isNothing) import Prelude hiding (null) import qualified Test.QuickCheck as QC import Test.QuickCheck (Gen) @@ -20,55 +32,137 @@ import Test.QuickCheck (Gen) Streams -------------------------------------------------------------------------------} --- | A 'Stream' is a possibly infinite stream of @'Maybe' a@s. -newtype Stream a = Stream { getStream :: [Maybe a] } - deriving (Show, Functor) +-- | 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] + } + deriving Functor -instance Semigroup (Stream a) where - Stream s1 <> Stream s2 = Stream (zipWith pickLast s1 s2) - where - pickLast (Just x) Nothing = Just x - pickLast _ mbY = mbY +-- | Tag for 'Stream's that describes whether it is either /definitely/ a finite +-- stream, or /possibly/ an infinite stream. +-- +-- Useful for the 'Show' instance of 'Stream': when a 'Stream' is /definitely/ +-- finite, we can safely print the full stream. +data InternalInfo = Infinite | Finite -instance Monoid (Stream a) where - mempty = Stream (repeat Nothing) - mappend = (<>) +-- | Fully shows a 'Stream' if it is /definitely/ finite, or prints a +-- placeholder string if it is /possibly/ infinite. +instance Show a => Show (Stream a) where + showsPrec n (Stream info xs) = case info of + Infinite -> ("" ++) + Finite -> (if n > 10 then ('(':) else id) + . shows xs + . (" ++ ..." ++) + . (if n > 10 then (')':) else id) --- | Create a 'Stream' based on the given possibly infinite list of @'Maybe' --- a@s. -mkStream :: [Maybe a] -> Stream a -mkStream = Stream +{------------------------------------------------------------------------------- + Running +-------------------------------------------------------------------------------} -- | 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 (a:as)) = (a, Stream as) +runStream s@(Stream _ [] ) = (Nothing, s) +runStream (Stream info (a:as)) = (a, Stream info as) + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Make an empty 'Stream'. +empty :: Stream a +empty = Stream Finite [] -- | Make a 'Stream' that always generates the given @a@. always :: a -> Stream a -always a = Stream (repeat (Just a)) +always x = Stream Infinite (repeat (Just x)) --- | Make a 'Stream' generator based on a @a@ generator. --- --- The generator generates a finite stream of 10 elements, where each element --- has a chance of being either 'Nothing' or an element generated with the --- given @a@ generator (wrapped in a 'Just'). +-- | Make a 'Stream' that infinitely repeats the given list. +repeating :: [Maybe a] -> Stream a +repeating xs = Stream Infinite $ concat (repeat xs) + +-- | UNSAFE: Make a 'Stream' that is marked as definitely finite. -- --- The first argument is the likelihood (as used by 'QC.frequency') of a --- 'Just' where 'Nothing' has likelihood 2. -mkStreamGen :: Int -> Gen a -> Gen (Stream a) -mkStreamGen justLikelihood genA = - mkStream . dropWhileEnd isNothing <$> replicateM 10 mbGenA - where - mbGenA = QC.frequency - [ (2, return Nothing) - , (justLikelihood, Just <$> genA) - ] +-- 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. +unsafeMkFinite :: [Maybe a] -> Stream a +unsafeMkFinite = Stream Finite + +-- | Make a 'Stream' that is marked as possibly infinite. +mkInfinite :: [Maybe a] -> Stream a +mkInfinite = Stream Infinite + +{------------------------------------------------------------------------------- + Query +-------------------------------------------------------------------------------} -- | Return 'True' if the stream is empty. -- -- A stream consisting of only 'Nothing's (even if it is only one) is not -- considered to be empty. null :: Stream a -> Bool -null (Stream []) = True -null _ = False +null (Stream _ []) = True +null _ = False + +{------------------------------------------------------------------------------- + Generation and shrinking +-------------------------------------------------------------------------------} + +-- | Shrink a stream like it is an 'Test.QuickCheck.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. +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 + +-- | 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. +genMaybe :: + Int -- ^ Likelihood of 'Nothing' + -> Int -- ^ Likelihood of @'Just' a@ + -> Gen a + -> Gen (Maybe a) +genMaybe nLi jLi genA = QC.frequency + [ (nLi, return Nothing) + , (jLi, Just <$> genA) + ] + +-- | Like 'genMaybe', but with the likelihood of 'Nothing' fixed to @2@. 'QC.frequency' +genMaybe' :: + Int -- ^ Likelihood of @'Just' a@ + -> Gen a + -> Gen (Maybe a) +genMaybe' = genMaybe 2 + +-- | Generate a finite 'Stream' of length @n@. +genFinite :: + Int -- ^ Requested size of finite stream. Tip: use 'genMaybe'. + -> Gen (Maybe a) + -> Gen (Stream a) +genFinite n gen = Stream Finite <$> replicateM n gen + +-- | Generate an infinite 'Stream'. +genInfinite :: + Gen (Maybe a) -- ^ Tip: use 'genMaybe'. + -> Gen (Stream a) +genInfinite gen = Stream Infinite <$> QC.listOf gen