Skip to content

Commit

Permalink
Improve the Stream type.
Browse files Browse the repository at this point in the history 
* Improve shrinking, generation and showing by keeping track of whether
  a `Stream` is definitely finite or possibly infinite.
* Remove the `Semigroup` and `Monoid` instances for `Stream` (and
  subsequently, for `Errors` too).
* Clean up the interface.
  • Loading branch information
@jorisdral
jorisdral committed May 30, 2023
1 parent 328ebf8 commit 84aa0b0
Show file tree
Hide file tree
Showing 2 changed files with 211 additions and 120 deletions.
153 changes: 75 additions & 78 deletions fs-sim/src/System/FS/Sim/Error.hs
View file
@@ -1,5 +1,3 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
Expand All @@ -19,7 +17,7 @@ module System.FS.Sim.Error (
, ErrorStream
, ErrorStreamGetSome
, ErrorStreamPutSome
, Stream (..)
, Stream
, always
, mkStream
, mkStreamGen
Expand All @@ -39,6 +37,7 @@ module System.FS.Sim.Error (
-- * Error streams for 'HasFS'
, Errors (..)
, allNull
, emptyErrors
, genErrors
, simpleErrors
) where
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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'.
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down

0 comments on commit 84aa0b0

Please sign in to comment.