Skip to content

Commit 3a8b68d

Browse files
jorisdraljorisdral
committed
Fewer fs-sim intialiser functions
Reduced duplication, only at the cost of being slightly more explicit at use sites.
1 parent 39343e5 commit 3a8b68d

File tree

4 files changed

+46
-71
lines changed

4 files changed

+46
-71
lines changed

‎test/Test/Database/LSMTree/Internal/Run.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ import qualified System.FS.API.Lazy as FSL
3737
import qualified System.FS.BlockIO.API as FS
3838
import qualified System.FS.BlockIO.IO as FS
3939
import qualified System.FS.IO as FsIO
40+
import qualified System.FS.Sim.MockFS as MockFS
4041
import qualified System.IO.Temp as Temp
4142
import Test.Database.LSMTree.Internal.RunReader (readKOps)
4243
import Test.Tasty (TestTree, testGroup)
@@ -67,16 +68,16 @@ tests = testGroup "Database.LSMTree.Internal.Run"
6768
(mkVal ("test-value-" <> BS.concat (replicate 500 "0123456789")))
6869
Nothing
6970
, testProperty "prop_WriteAndOpen" $ \wb ->
70-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
71+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7172
prop_WriteAndOpen hfs hbio wb
7273
, testProperty "prop_WriteNumEntries" $ \wb ->
73-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
74+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7475
prop_WriteNumEntries hfs hbio wb
7576
, testProperty "prop_WriteAndOpenWriteBuffer" $ \wb ->
76-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
77+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
7778
prop_WriteAndOpenWriteBuffer hfs hbio wb
7879
, testProperty "prop_WriteRunEqWriteWriteBuffer" $ \wb ->
79-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio ->
80+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
8081
prop_WriteRunEqWriteWriteBuffer hfs hbio wb
8182
]
8283
]

‎test/Test/Database/LSMTree/Internal/RunBuilder.hs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import Database.LSMTree.Internal.RunNumber
1212
import qualified System.FS.API as FS
1313
import System.FS.API (HasFS)
1414
import qualified System.FS.BlockIO.API as FS
15+
import qualified System.FS.Sim.MockFS as MockFS
1516
import Test.Tasty
1617
import Test.Tasty.QuickCheck
1718
import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO,
@@ -29,11 +30,14 @@ tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [
2930
]
3031
, testGroup "simHasFS" [
3132
testProperty "prop_newInExistingDir" $ ioProperty $
32-
withSimHasBlockIO propNoOpenHandles prop_newInExistingDir
33+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
34+
\hfs hbio _ -> prop_newInExistingDir hfs hbio
3335
, testProperty "prop_newInNonExistingDir" $ ioProperty $
34-
withSimHasBlockIO propNoOpenHandles prop_newInNonExistingDir
36+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
37+
\hfs hbio _ -> prop_newInNonExistingDir hfs hbio
3538
, testProperty "prop_newTwice" $ ioProperty $
36-
withSimHasBlockIO propNoOpenHandles prop_newTwice
39+
withSimHasBlockIO propNoOpenHandles MockFS.empty $
40+
\hfs hbio _ -> prop_newTwice hfs hbio
3741
]
3842
]
3943

‎test/Test/Database/LSMTree/Internal/RunReader.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ import qualified Database.LSMTree.Internal.RunReader as Reader
1717
import Database.LSMTree.Internal.Serialise
1818
import qualified System.FS.API as FS
1919
import qualified System.FS.BlockIO.API as FS
20+
import qualified System.FS.Sim.MockFS as MockFS
2021
import Test.Tasty (TestTree, testGroup)
2122
import Test.Tasty.QuickCheck
2223
import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO,
@@ -27,19 +28,19 @@ tests :: TestTree
2728
tests = testGroup "Database.LSMTree.Internal.RunReader"
2829
[ testGroup "MockFS"
2930
[ testProperty "prop_read" $ \wb ->
30-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
31+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3132
prop_readAtOffset hfs hbio wb Nothing
3233
, testProperty "prop_readAtOffset" $ \wb offset ->
33-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
34+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3435
prop_readAtOffset hfs hbio wb (Just offset)
3536
, testProperty "prop_readAtOffsetExisting" $ \wb i ->
36-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
37+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
3738
prop_readAtOffsetExisting hfs hbio wb i
3839
, testProperty "prop_readAtOffsetIdempotence" $ \wb i ->
39-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
40+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
4041
prop_readAtOffsetIdempotence hfs hbio wb i
4142
, testProperty "prop_readAtOffsetReadHead" $ \wb ->
42-
ioProperty $ withSimHasBlockIO propNoOpenHandles $ \hfs hbio -> do
43+
ioProperty $ withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ -> do
4344
prop_readAtOffsetReadHead hfs hbio wb
4445
]
4546
, testGroup "RealFS"

‎test/Test/Util/FS.hs‎

Lines changed: 28 additions & 59 deletions
Original file line numberDiff line numberDiff line change
@@ -10,9 +10,7 @@ module Test.Util.FS (
1010
, withSimHasBlockIO
1111
-- * Simulated file system with errors
1212
, withSimErrorHasFS
13-
, withSimErrorHasFS'
1413
, withSimErrorHasBlockIO
15-
, withSimErrorHasBlockIO'
1614
-- * Simulated file system properties
1715
, propNoOpenHandles
1816
, assertNoOpenHandles
@@ -33,7 +31,6 @@ import System.FS.BlockIO.IO
3331
import System.FS.BlockIO.Sim (fromHasFS)
3432
import System.FS.IO
3533
import System.FS.Sim.Error
36-
import qualified System.FS.Sim.MockFS as MockFS
3734
import System.FS.Sim.MockFS
3835
import System.FS.Sim.STM
3936
import System.FS.Sim.Stream (InternalInfo (..), Stream (..))
@@ -61,27 +58,36 @@ withTempIOHasBlockIO path action =
6158

6259
{-# INLINABLE withSimHasFS #-}
6360
withSimHasFS ::
64-
(MonadSTM m, MonadThrow m, PrimMonad m)
65-
=> (MockFS -> Property)
66-
-> (HasFS m HandleMock -> m Property)
61+
(MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2)
62+
=> (MockFS -> prop1)
63+
-> MockFS
64+
-> ( HasFS m HandleMock
65+
-> StrictTMVar m MockFS
66+
-> m prop2
67+
)
6768
-> m Property
68-
withSimHasFS post k = do
69-
var <- newTMVarIO MockFS.empty
69+
withSimHasFS post fs k = do
70+
var <- newTMVarIO fs
7071
let hfs = simHasFS var
71-
x <- k hfs
72-
fs <- atomically $ readTMVar var
73-
pure (x .&&. post fs)
72+
x <- k hfs var
73+
fs' <- atomically $ readTMVar var
74+
pure (x .&&. post fs')
7475

7576
{-# INLINABLE withSimHasBlockIO #-}
7677
withSimHasBlockIO ::
77-
(MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m)
78-
=> (MockFS -> Property)
79-
-> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m Property)
78+
(MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m, Testable prop1, Testable prop2)
79+
=> (MockFS -> prop1)
80+
-> MockFS
81+
-> ( HasFS m HandleMock
82+
-> HasBlockIO m HandleMock
83+
-> StrictTMVar m MockFS
84+
-> m prop2
85+
)
8086
-> m Property
81-
withSimHasBlockIO post k = do
82-
withSimHasFS post $ \hfs -> do
87+
withSimHasBlockIO post fs k = do
88+
withSimHasFS post fs $ \hfs fsVar -> do
8389
hbio <- fromHasFS hfs
84-
k hfs hbio
90+
k hfs hbio fsVar
8591

8692
{-------------------------------------------------------------------------------
8793
Simulated file system with errors
@@ -107,28 +113,13 @@ withSimErrorHasFS post fs errs k = do
107113
fs' <- atomically $ readTMVar fsVar
108114
pure (x .&&. post fs')
109115

110-
{-# INLINABLE withSimErrorHasFS' #-}
111-
withSimErrorHasFS' ::
112-
(MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2)
113-
=> (MockFS -> prop1)
114-
-> MockFS
115-
-> Errors
116-
-> (HasFS m HandleMock -> m prop2)
117-
-> m Property
118-
withSimErrorHasFS' post fs errs k = do
119-
fsVar <- newTMVarIO fs
120-
errVar <- newTVarIO errs
121-
let hfs = simErrorHasFS fsVar errVar
122-
x <- k hfs
123-
fs' <- atomically $ readTMVar fsVar
124-
pure (x .&&. post fs')
125-
126116
{-# INLINABLE withSimErrorHasBlockIO #-}
127117
withSimErrorHasBlockIO ::
128118
( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m
129119
, Testable prop1, Testable prop2
130120
)
131121
=> (MockFS -> prop1)
122+
-> MockFS
132123
-> Errors
133124
-> ( HasFS m HandleMock
134125
-> HasBlockIO m HandleMock
@@ -137,32 +128,10 @@ withSimErrorHasBlockIO ::
137128
-> m prop2
138129
)
139130
-> m Property
140-
withSimErrorHasBlockIO post errs k = do
141-
fsVar <- newTMVarIO MockFS.empty
142-
errVar <- newTVarIO errs
143-
let hfs = simErrorHasFS fsVar errVar
144-
hbio <- fromHasFS hfs
145-
x <- k hfs hbio fsVar errVar
146-
fs <- atomically $ readTMVar fsVar
147-
pure (x .&&. post fs)
148-
149-
{-# INLINABLE withSimErrorHasBlockIO' #-}
150-
withSimErrorHasBlockIO' ::
151-
( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m
152-
, Testable prop1, Testable prop2
153-
)
154-
=> (MockFS -> prop1)
155-
-> Errors
156-
-> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m prop2)
157-
-> m Property
158-
withSimErrorHasBlockIO' post errs k = do
159-
fsVar <- newTMVarIO MockFS.empty
160-
errVar <- newTVarIO errs
161-
let hfs = simErrorHasFS fsVar errVar
162-
hbio <- fromHasFS hfs
163-
x <- k hfs hbio
164-
fs <- atomically $ readTMVar fsVar
165-
pure (x .&&. post fs)
131+
withSimErrorHasBlockIO post fs errs k =
132+
withSimErrorHasFS post fs errs $ \hfs fsVar errsVar -> do
133+
hbio <- fromHasFS hfs
134+
k hfs hbio fsVar errsVar
166135

167136
{-------------------------------------------------------------------------------
168137
Simulated file system properties

0 commit comments

Comments
 (0)