diff --git a/test/Test/FS.hs b/test/Test/FS.hs index cdbc72496..582f19a14 100644 --- a/test/Test/FS.hs +++ b/test/Test/FS.hs @@ -3,26 +3,102 @@ -- TODO: upstream to fs-sim module Test.FS (tests) where +import Control.Monad +import Control.Monad.IOSim (runSimOrThrow) +import Data.Char (isAsciiLower, isAsciiUpper) +import qualified Data.List as List +import qualified Data.Text as Text import GHC.Generics (Generic) import System.FS.API import System.FS.Sim.Error +import qualified System.FS.Sim.MockFS as MockFS import qualified System.FS.Sim.Stream as S import System.FS.Sim.Stream (InternalInfo (..), Stream (..)) import Test.QuickCheck import Test.QuickCheck.Classes (eqLaws) import Test.QuickCheck.Instances () import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) import Test.Util.FS import Test.Util.QC tests :: TestTree tests = testGroup "Test.FS" [ - testClassLaws "Stream" $ + -- * Simulated file system properties + testProperty "prop_propNumOpenHandles" prop_propNumOpenHandles + , testProperty "prop_propNoOpenHandles" prop_propNoOpenHandles + , testProperty "prop_propNumDirEntries" prop_propNumDirEntries + , testProperty "prop_propNoDirEntries" prop_propNoDirEntries + -- * Equality + , testClassLaws "Stream" $ eqLaws (Proxy @(Stream Int)) , testClassLaws "Errors" $ eqLaws (Proxy @Errors) ] +{------------------------------------------------------------------------------- + Simulated file system properties +-------------------------------------------------------------------------------} + +newtype Path = Path FsPath + deriving stock (Show, Eq) + +newtype UniqueList a = UniqueList [a] + deriving stock Show + +instance (Arbitrary a, Eq a) => Arbitrary (UniqueList a) where + arbitrary = do + xs <- arbitrary + pure (UniqueList (List.nub xs)) + shrink (UniqueList []) = [] + shrink (UniqueList xs) = UniqueList . List.nub <$> shrink xs + +instance Arbitrary Path where + arbitrary = Path . mkFsPath . (:[]) <$> ((:) <$> genChar <*> listOf genChar) + where + genChar = elements (['A'..'Z'] ++ ['a'..'z']) + shrink (Path p) = case fsPathToList p of + [] -> [] + t:_ -> [ + Path p' + | t' <- shrink t + , let t'' = Text.filter (\c -> isAsciiUpper c || isAsciiLower c) t' + , not (Text.null t'') + , let p' = fsPathFromList [t'] + ] + +prop_propNumOpenHandles :: UniqueList Path -> Property +prop_propNumOpenHandles (UniqueList paths) = runSimOrThrow $ + withSimHasFS prop MockFS.empty $ \hfs _ -> do + forM_ paths $ \(Path p) -> hOpen hfs p (WriteMode MustBeNew) + where + prop = propNumOpenHandles (length paths) + +prop_propNoOpenHandles :: Property +prop_propNoOpenHandles = once $ runSimOrThrow $ + withSimHasFS propNoOpenHandles MockFS.empty $ \_ _ -> pure () + +prop_propNumDirEntries :: Path -> InfiniteList Bool -> UniqueList Path -> Property +prop_propNumDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $ + withSimHasFS prop MockFS.empty $ \hfs _ -> do + createDirectoryIfMissing hfs False dir + forM_ (zip (getInfiniteList isFiles) paths) $ \(isFile, Path p) -> + if isFile then + void $ hOpen hfs (dir p) (WriteMode MustBeNew) + else + createDirectory hfs (dir p) + where + prop = propNumDirEntries dir (length paths) + +prop_propNoDirEntries :: Path -> Property +prop_propNoDirEntries (Path dir) = runSimOrThrow $ + withSimHasFS (propNoDirEntries dir) MockFS.empty $ \hfs _ -> do + createDirectoryIfMissing hfs False dir + +{------------------------------------------------------------------------------- + Equality +-------------------------------------------------------------------------------} + -- | This is not a fully lawful instance, because it uses 'approximateEqStream'. instance Eq a => Eq (Stream a) where (==) = approximateEqStream diff --git a/test/Test/Util/FS.hs b/test/Test/Util/FS.hs index 8342d9e68..9ad3e7a02 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -12,7 +12,10 @@ module Test.Util.FS ( , withSimErrorHasFS , withSimErrorHasBlockIO -- * Simulated file system properties + , propNumOpenHandles , propNoOpenHandles + , propNumDirEntries + , propNoDirEntries , assertNoOpenHandles , assertNumOpenHandles -- * Equality @@ -23,9 +26,11 @@ import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow) +import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Primitive (PrimMonad) +import qualified Data.Set as Set import GHC.Stack -import System.FS.API +import System.FS.API as FS import System.FS.BlockIO.API import System.FS.BlockIO.IO import System.FS.BlockIO.Sim (fromHasFS) @@ -137,13 +142,38 @@ withSimErrorHasBlockIO post fs errs k = Simulated file system properties -------------------------------------------------------------------------------} +{-# INLINABLE propNumOpenHandles #-} +propNumOpenHandles :: Int -> MockFS -> Property +propNumOpenHandles expected fs = + counterexample (printf "Expected %d open handles, but found %d" expected actual) $ + counterexample ("Open handles: " <> show (openHandles fs)) $ + printMockFSOnFailure fs $ + expected == actual + where actual = numOpenHandles fs + {-# INLINABLE propNoOpenHandles #-} propNoOpenHandles :: MockFS -> Property -propNoOpenHandles fs = - counterexample ("Expected 0 open handles, but found " <> show n) $ +propNoOpenHandles fs = propNumOpenHandles 0 fs + +{-# INLINABLE propNumDirEntries #-} +propNumDirEntries :: FsPath -> Int -> MockFS -> Property +propNumDirEntries path expected fs = + counterexample + (printf "Expected %d entries in the directory at %s, but found %d" + expected + (show path) actual) $ printMockFSOnFailure fs $ - n == 0 - where n = numOpenHandles fs + expected === actual + where + actual = + let (contents, _) = runSimOrThrow $ + runSimFS fs $ \hfs -> + FS.listDirectory hfs path + in Set.size contents + +{-# INLINABLE propNoDirEntries #-} +propNoDirEntries :: FsPath -> MockFS -> Property +propNoDirEntries path fs = propNumDirEntries path 0 fs printMockFSOnFailure :: Testable prop => MockFS -> prop -> Property printMockFSOnFailure fs = counterexample ("Mocked file system: " <> pretty fs)