Skip to content

Commit 8239796

Browse files
jorisdraljorisdral
committed
Use the unified LSM-Tree class in the state machine tests
1 parent 0f98d4b commit 8239796

File tree

5 files changed

+45
-29
lines changed

5 files changed

+45
-29
lines changed

‎test/Test/Database/LSMTree/Normal/StateMachine.hs‎

Lines changed: 41 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -84,19 +84,18 @@ import qualified Data.Set as Set
8484
import Data.Typeable (Proxy (..), Typeable, cast, eqT,
8585
type (:~:) (Refl))
8686
import qualified Data.Vector as V
87-
import Database.LSMTree.Class.Normal (LookupResult (..),
88-
QueryResult (..))
89-
import qualified Database.LSMTree.Class.Normal as Class
87+
import qualified Database.LSMTree as R
88+
import Database.LSMTree.Class (LookupResult (..), QueryResult (..))
89+
import qualified Database.LSMTree.Class as Class
9090
import Database.LSMTree.Extras (showPowersOf)
9191
import Database.LSMTree.Extras.Generators (KeyForIndexCompact)
9292
import Database.LSMTree.Extras.NoThunks (assertNoThunks)
9393
import Database.LSMTree.Internal (LSMTreeError (..))
9494
import qualified Database.LSMTree.Internal as R.Internal
9595
import Database.LSMTree.Internal.Serialise (SerialisedBlob,
9696
SerialisedValue)
97-
import qualified Database.LSMTree.Model.IO.Normal as ModelIO
97+
import qualified Database.LSMTree.Model.IO as ModelIO
9898
import qualified Database.LSMTree.Model.Session as Model
99-
import qualified Database.LSMTree.Normal as R
10099
import NoThunks.Class
101100
import Prelude hiding (init)
102101
import System.Directory (removeDirectoryRecursive)
@@ -323,7 +322,7 @@ getAllSessionTables ::
323322
getAllSessionTables (R.Internal.Session' s) = do
324323
R.Internal.withOpenSession s $ \seshEnv -> do
325324
ts <- readMVar (R.Internal.sessionOpenTables seshEnv)
326-
pure ((\x -> SomeTable (R.Internal.NormalTable x)) <$> Map.elems ts)
325+
pure ((\x -> SomeTable (R.Internal.Table' x)) <$> Map.elems ts)
327326

328327
getAllSessionCursors ::
329328
(MonadSTM m, MonadThrow m, MonadMVar m)
@@ -332,7 +331,7 @@ getAllSessionCursors ::
332331
getAllSessionCursors (R.Internal.Session' s) =
333332
R.Internal.withOpenSession s $ \seshEnv -> do
334333
cs <- readMVar (R.Internal.sessionOpenCursors seshEnv)
335-
pure ((\x -> SomeCursor (R.Internal.NormalCursor x)) <$> Map.elems cs)
334+
pure ((\x -> SomeCursor (R.Internal.Cursor' x)) <$> Map.elems cs)
336335

337336
realHandler :: Monad m => Handler m (Maybe Model.Err)
338337
realHandler = Handler $ pure . handler'
@@ -373,6 +372,9 @@ newtype Blob = Blob SerialisedBlob
373372
keyValueBlobLabel :: R.SnapshotLabel
374373
keyValueBlobLabel = R.SnapshotLabel "Key Value Blob"
375374

375+
instance R.ResolveValue Value where
376+
resolveValue _ = (<>)
377+
376378
{-------------------------------------------------------------------------------
377379
Model state
378380
-------------------------------------------------------------------------------}
@@ -402,11 +404,18 @@ type K a = (
402404
type V a = (
403405
Class.C_ a
404406
, R.SerialiseValue a
407+
, R.ResolveValue a
408+
, Arbitrary a
409+
)
410+
411+
type B a = (
412+
Class.C_ a
413+
, R.SerialiseValue a
405414
, Arbitrary a
406415
)
407416

408417
-- | Common constraints for keys, values and blobs
409-
type C k v blob = (K k, V v, V blob)
418+
type C k v blob = (K k, V v, B blob)
410419

411420
{-------------------------------------------------------------------------------
412421
StateModel
@@ -456,7 +465,7 @@ instance ( Show (Class.TableConfig h)
456465
=> V.Vector k -> Var h (WrapTable h IO k v blob)
457466
-> Act h ()
458467
-- Blobs
459-
RetrieveBlobs :: V blob
468+
RetrieveBlobs :: B blob
460469
=> Var h (V.Vector (WrapBlobRef h IO blob))
461470
-> Act h (V.Vector (WrapBlob blob))
462471
-- Snapshots
@@ -468,7 +477,7 @@ instance ( Show (Class.TableConfig h)
468477
-> Act h (WrapTable h IO k v blob)
469478
DeleteSnapshot :: R.SnapshotName -> Act h ()
470479
ListSnapshots :: Act h [R.SnapshotName]
471-
-- Multiple writable tables
480+
-- Duplicate tables
472481
Duplicate :: C k v blob
473482
=> Var h (WrapTable h IO k v blob)
474483
-> Act h (WrapTable h IO k v blob)
@@ -900,13 +909,13 @@ runModel lookUp = \case
900909
. Model.runModelM (Model.readCursor n (getCursor $ lookUp cursorVar))
901910
Updates kups tableVar ->
902911
wrap MUnit
903-
. Model.runModelM (Model.updates Model.noResolve (fmap ModelIO.convUpdate <$> kups) (getTable $ lookUp tableVar))
912+
. Model.runModelM (Model.updates Model.getResolve (fmap ModelIO.convUpdate <$> kups) (getTable $ lookUp tableVar))
904913
Inserts kins tableVar ->
905914
wrap MUnit
906-
. Model.runModelM (Model.inserts Model.noResolve kins (getTable $ lookUp tableVar))
915+
. Model.runModelM (Model.inserts Model.getResolve kins (getTable $ lookUp tableVar))
907916
Deletes kdels tableVar ->
908917
wrap MUnit
909-
. Model.runModelM (Model.deletes Model.noResolve kdels (getTable $ lookUp tableVar))
918+
. Model.runModelM (Model.deletes Model.getResolve kdels (getTable $ lookUp tableVar))
910919
RetrieveBlobs blobsVar ->
911920
wrap (MVector . fmap (MBlob . WrapBlob))
912921
. Model.runModelM (Model.retrieveBlobs (getBlobRefs . lookUp $ blobsVar))
@@ -1219,12 +1228,14 @@ arbitraryActionWithVars _ label ctx (ModelState st _stats) =
12191228
genUpdates :: Gen (V.Vector (k, R.Update v blob))
12201229
genUpdates = QC.liftArbitrary ((,) <$> QC.arbitrary <*> QC.oneof [
12211230
R.Insert <$> QC.arbitrary <*> genBlob
1231+
, R.Mupsert <$> QC.arbitrary
12221232
, pure R.Delete
12231233
])
12241234
where
12251235
_coveredAllCases :: R.Update v blob -> ()
12261236
_coveredAllCases = \case
12271237
R.Insert{} -> ()
1238+
R.Mupsert{} -> ()
12281239
R.Delete{} -> ()
12291240

12301241
genInserts :: Gen (V.Vector (k, v, Maybe blob))
@@ -1307,8 +1318,8 @@ data Stats = Stats {
13071318
, numLookupsResults :: {-# UNPACK #-} !(Int, Int, Int)
13081319
-- (NotFound, Found, FoundWithBlob)
13091320
-- | Number of succesful updates
1310-
, numUpdates :: {-# UNPACK #-} !(Int, Int, Int)
1311-
-- (Insert, InsertWithBlob, Delete)
1321+
, numUpdates :: {-# UNPACK #-} !(Int, Int, Int, Int)
1322+
-- (Insert, InsertWithBlob, Delete, Mupsert)
13121323
-- | Actions that succeeded
13131324
, successActions :: [String]
13141325
-- | Actions that failed with an error
@@ -1338,7 +1349,7 @@ initStats = Stats {
13381349
snapshotted = Set.empty
13391350
-- === Final tags
13401351
, numLookupsResults = (0, 0, 0)
1341-
, numUpdates = (0, 0, 0)
1352+
, numUpdates = (0, 0, 0, 0)
13421353
, successActions = []
13431354
, failActions = []
13441355
, numActionsPerTable = Map.empty
@@ -1412,15 +1423,16 @@ updateStats action lookUp modelBefore _modelAfter result =
14121423
}
14131424
_ -> stats
14141425
where
1415-
countAll :: forall k v blob. V.Vector (k, R.Update v blob) -> (Int, Int, Int)
1426+
countAll :: forall k v blob. V.Vector (k, R.Update v blob) -> (Int, Int, Int, Int)
14161427
countAll upds =
1417-
let count :: (Int, Int, Int)
1428+
let count :: (Int, Int, Int, Int)
14181429
-> (k, R.Update v blob)
1419-
-> (Int, Int, Int)
1420-
count (i, iwb, d) (_, upd) = case upd of
1421-
R.Insert _ Nothing -> (i+1, iwb , d )
1422-
R.Insert _ Just{} -> (i , iwb+1, d )
1423-
R.Delete{} -> (i , iwb , d+1)
1430+
-> (Int, Int, Int, Int)
1431+
count (i, iwb, d, m) (_, upd) = case upd of
1432+
R.Insert _ Nothing -> (i+1, iwb , d , m )
1433+
R.Insert _ Just{} -> (i , iwb+1, d , m )
1434+
R.Delete{} -> (i , iwb , d+1, m )
1435+
R.Mupsert{} -> (i , iwb , d , m + 1)
14241436
in V.foldl' count (numUpdates stats) upds
14251437

14261438
updSuccessActions stats = case result of
@@ -1662,6 +1674,10 @@ data FinalTag =
16621674
-- (this includes submissions through both 'Class.updates' and
16631675
-- 'Class.deletes')
16641676
| NumDeletes String
1677+
-- | Number of 'Class.Mupsert's succesfully submitted to a table
1678+
-- (this includes submissions through both 'Class.updates' and
1679+
-- 'Class.mupserts')
1680+
| NumMupserts String
16651681
-- | Total number of actions (failing, succeeding, either)
16661682
| NumActions String
16671683
-- | Which actions succeded
@@ -1705,8 +1721,9 @@ tagFinalState' (getModel -> ModelState finalState finalStats) = concat [
17051721
("Inserts" , [NumInserts $ showPowersOf 10 i])
17061722
, ("Inserts with blobs" , [NumInsertsWithBlobs $ showPowersOf 10 iwb])
17071723
, ("Deletes" , [NumDeletes $ showPowersOf 10 d])
1724+
, ("Mupserts" , [NumMupserts $ showPowersOf 10 m])
17081725
]
1709-
where (i, iwb, d) = numUpdates finalStats
1726+
where (i, iwb, d, m) = numUpdates finalStats
17101727

17111728
tagNumActions =
17121729
[ let n = length (successActions finalStats) in

‎test/Test/Database/LSMTree/Normal/StateMachine/DL.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,9 @@ module Test.Database.LSMTree.Normal.StateMachine.DL (
88
import Control.Tracer
99
import qualified Data.Map.Strict as Map
1010
import qualified Data.Vector as V
11+
import Database.LSMTree as R
1112
import qualified Database.LSMTree.Model.Session as Model (fromSomeTable, tables)
1213
import qualified Database.LSMTree.Model.Table as Model (values)
13-
import Database.LSMTree.Normal as R
1414
import Prelude
1515
import Test.Database.LSMTree.Normal.StateMachine hiding (tests)
1616
import Test.Database.LSMTree.Normal.StateMachine.Op

‎test/Test/Database/LSMTree/Normal/StateMachine/Op.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ import Control.Monad.IOSim (IOSim)
1919
import Control.Monad.Reader (ReaderT)
2020
import Control.Monad.State (StateT)
2121
import qualified Data.Vector as V
22-
import qualified Database.LSMTree.Class.Normal as Class
22+
import qualified Database.LSMTree.Class as Class
2323
import qualified Database.LSMTree.Model.Table as Model
2424
import GHC.Show (appPrec)
2525
import Test.QuickCheck.StateModel.Lockstep (InterpretOp, Operation)

‎test/Test/Util/Orphans.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,9 @@ import qualified Control.Concurrent.STM as Real
1919
import Control.Monad ((<=<))
2020
import Control.Monad.IOSim (IOSim)
2121
import Data.Kind (Type)
22+
import Database.LSMTree (Cursor, LookupResult, QueryResult, Table)
2223
import Database.LSMTree.Common (BlobRef, IOLike, SerialiseValue)
2324
import Database.LSMTree.Internal.Serialise (SerialiseKey)
24-
import Database.LSMTree.Normal (Cursor, LookupResult, QueryResult,
25-
Table)
2625
import Test.QuickCheck.Modifiers (Small (..))
2726
import Test.QuickCheck.StateModel (Realized)
2827
import Test.QuickCheck.StateModel.Lockstep (InterpretOp)

‎test/Test/Util/TypeFamilyWrappers.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ module Test.Util.TypeFamilyWrappers (
2121
) where
2222

2323
import Data.Kind (Type)
24-
import qualified Database.LSMTree.Class.Normal as SUT.Class
24+
import qualified Database.LSMTree.Class as SUT.Class
2525

2626
type WrapSession ::
2727
((Type -> Type) -> Type -> Type -> Type -> Type)

0 commit comments

Comments
 (0)