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

@@ -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
       ]
     ]

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
         ]
     ]
 

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"

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