From 3a8b68d3f8651396668775ac366eda041627dc37 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 7 Jan 2025 14:50:08 +0100 Subject: [PATCH] Fewer `fs-sim` intialiser functions Reduced duplication, only at the cost of being slightly more explicit at use sites. --- test/Test/Database/LSMTree/Internal/Run.hs | 9 +- .../Database/LSMTree/Internal/RunBuilder.hs | 10 ++- .../Database/LSMTree/Internal/RunReader.hs | 11 +-- test/Test/Util/FS.hs | 87 ++++++------------- 4 files changed, 46 insertions(+), 71 deletions(-) diff --git a/test/Test/Database/LSMTree/Internal/Run.hs b/test/Test/Database/LSMTree/Internal/Run.hs index e991e37e8..393bf5f51 100644 --- a/test/Test/Database/LSMTree/Internal/Run.hs +++ b/test/Test/Database/LSMTree/Internal/Run.hs @@ -37,6 +37,7 @@ import qualified System.FS.API.Lazy as FSL import qualified System.FS.BlockIO.API as FS import qualified System.FS.BlockIO.IO as FS import qualified System.FS.IO as FsIO +import qualified System.FS.Sim.MockFS as MockFS import qualified System.IO.Temp as Temp import Test.Database.LSMTree.Internal.RunReader (readKOps) import Test.Tasty (TestTree, testGroup) @@ -67,16 +68,16 @@ tests = testGroup "Database.LSMTree.Internal.Run" (mkVal ("test-value-" <> BS.concat (replicate 500 "0123456789"))) Nothing , testProperty "prop_WriteAndOpen" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteAndOpen hfs hbio wb , testProperty "prop_WriteNumEntries" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteNumEntries hfs hbio wb , testProperty "prop_WriteAndOpenWriteBuffer" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteAndOpenWriteBuffer hfs hbio wb , testProperty "prop_WriteRunEqWriteWriteBuffer" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> prop_WriteRunEqWriteWriteBuffer hfs hbio wb ] ] diff --git a/test/Test/Database/LSMTree/Internal/RunBuilder.hs b/test/Test/Database/LSMTree/Internal/RunBuilder.hs index e7178fd62..ce6a2693e 100644 --- a/test/Test/Database/LSMTree/Internal/RunBuilder.hs +++ b/test/Test/Database/LSMTree/Internal/RunBuilder.hs @@ -12,6 +12,7 @@ import Database.LSMTree.Internal.RunNumber import qualified System.FS.API as FS import System.FS.API (HasFS) import qualified System.FS.BlockIO.API as FS +import qualified System.FS.Sim.MockFS as MockFS import Test.Tasty import Test.Tasty.QuickCheck import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO, @@ -29,11 +30,14 @@ tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [ ] , testGroup "simHasFS" [ testProperty "prop_newInExistingDir" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newInExistingDir + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newInExistingDir hfs hbio , testProperty "prop_newInNonExistingDir" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newInNonExistingDir + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newInNonExistingDir hfs hbio , testProperty "prop_newTwice" $ ioProperty $ - withSimHasBlockIO propNoOpenHandles prop_newTwice + withSimHasBlockIO propNoOpenHandles MockFS.empty $ + \hfs hbio _ -> prop_newTwice hfs hbio ] ] diff --git a/test/Test/Database/LSMTree/Internal/RunReader.hs b/test/Test/Database/LSMTree/Internal/RunReader.hs index 651d07d79..89aa419ab 100644 --- a/test/Test/Database/LSMTree/Internal/RunReader.hs +++ b/test/Test/Database/LSMTree/Internal/RunReader.hs @@ -17,6 +17,7 @@ import qualified Database.LSMTree.Internal.RunReader as Reader import Database.LSMTree.Internal.Serialise import qualified System.FS.API as FS import qualified System.FS.BlockIO.API as FS +import qualified System.FS.Sim.MockFS as MockFS import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO, @@ -27,19 +28,19 @@ tests :: TestTree tests = testGroup "Database.LSMTree.Internal.RunReader" [ testGroup "MockFS" [ testProperty "prop_read" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffset hfs hbio wb Nothing , testProperty "prop_readAtOffset" $ \wb offset -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffset hfs hbio wb (Just offset) , testProperty "prop_readAtOffsetExisting" $ \wb i -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetExisting hfs hbio wb i , testProperty "prop_readAtOffsetIdempotence" $ \wb i -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetIdempotence hfs hbio wb i , testProperty "prop_readAtOffsetReadHead" $ \wb -> - ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do + ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do prop_readAtOffsetReadHead hfs hbio wb ] , testGroup "RealFS" diff --git a/test/Test/Util/FS.hs b/test/Test/Util/FS.hs index c0ddea0ec..8342d9e68 100644 --- a/test/Test/Util/FS.hs +++ b/test/Test/Util/FS.hs @@ -10,9 +10,7 @@ module Test.Util.FS ( , withSimHasBlockIO -- * Simulated file system with errors , withSimErrorHasFS - , withSimErrorHasFS' , withSimErrorHasBlockIO - , withSimErrorHasBlockIO' -- * Simulated file system properties , propNoOpenHandles , assertNoOpenHandles @@ -33,7 +31,6 @@ import System.FS.BlockIO.IO import System.FS.BlockIO.Sim (fromHasFS) import System.FS.IO import System.FS.Sim.Error -import qualified System.FS.Sim.MockFS as MockFS import System.FS.Sim.MockFS import System.FS.Sim.STM import System.FS.Sim.Stream (InternalInfo (..), Stream (..)) @@ -61,27 +58,36 @@ withTempIOHasBlockIO path action = {-# INLINABLE withSimHasFS #-} withSimHasFS :: - (MonadSTM m, MonadThrow m, PrimMonad m) - => (MockFS -> Property) - -> (HasFS m HandleMock -> m Property) + (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2) + => (MockFS -> prop1) + -> MockFS + -> ( HasFS m HandleMock + -> StrictTMVar m MockFS + -> m prop2 + ) -> m Property -withSimHasFS post k = do - var <- newTMVarIO MockFS.empty +withSimHasFS post fs k = do + var <- newTMVarIO fs let hfs = simHasFS var - x <- k hfs - fs <- atomically $ readTMVar var - pure (x .&&. post fs) + x <- k hfs var + fs' <- atomically $ readTMVar var + pure (x .&&. post fs') {-# INLINABLE withSimHasBlockIO #-} withSimHasBlockIO :: - (MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m) - => (MockFS -> Property) - -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m Property) + (MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m, Testable prop1, Testable prop2) + => (MockFS -> prop1) + -> MockFS + -> ( HasFS m HandleMock + -> HasBlockIO m HandleMock + -> StrictTMVar m MockFS + -> m prop2 + ) -> m Property -withSimHasBlockIO post k = do - withSimHasFS post $ \hfs -> do +withSimHasBlockIO post fs k = do + withSimHasFS post fs $ \hfs fsVar -> do hbio <- fromHasFS hfs - k hfs hbio + k hfs hbio fsVar {------------------------------------------------------------------------------- Simulated file system with errors @@ -107,28 +113,13 @@ withSimErrorHasFS post fs errs k = do fs' <- atomically $ readTMVar fsVar pure (x .&&. post fs') -{-# INLINABLE withSimErrorHasFS' #-} -withSimErrorHasFS' :: - (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2) - => (MockFS -> prop1) - -> MockFS - -> Errors - -> (HasFS m HandleMock -> m prop2) - -> m Property -withSimErrorHasFS' post fs errs k = do - fsVar <- newTMVarIO fs - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - x <- k hfs - fs' <- atomically $ readTMVar fsVar - pure (x .&&. post fs') - {-# INLINABLE withSimErrorHasBlockIO #-} withSimErrorHasBlockIO :: ( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m , Testable prop1, Testable prop2 ) => (MockFS -> prop1) + -> MockFS -> Errors -> ( HasFS m HandleMock -> HasBlockIO m HandleMock @@ -137,32 +128,10 @@ withSimErrorHasBlockIO :: -> m prop2 ) -> m Property -withSimErrorHasBlockIO post errs k = do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - hbio <- fromHasFS hfs - x <- k hfs hbio fsVar errVar - fs <- atomically $ readTMVar fsVar - pure (x .&&. post fs) - -{-# INLINABLE withSimErrorHasBlockIO' #-} -withSimErrorHasBlockIO' :: - ( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m - , Testable prop1, Testable prop2 - ) - => (MockFS -> prop1) - -> Errors - -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m prop2) - -> m Property -withSimErrorHasBlockIO' post errs k = do - fsVar <- newTMVarIO MockFS.empty - errVar <- newTVarIO errs - let hfs = simErrorHasFS fsVar errVar - hbio <- fromHasFS hfs - x <- k hfs hbio - fs <- atomically $ readTMVar fsVar - pure (x .&&. post fs) +withSimErrorHasBlockIO post fs errs k = + withSimErrorHasFS post fs errs $ \hfs fsVar errsVar -> do + hbio <- fromHasFS hfs + k hfs hbio fsVar errsVar {------------------------------------------------------------------------------- Simulated file system properties