Merge pull request #436 from IntersectMBO/dcoutts/lockstep-io-sim-tweak-generation-2

QC Lockstep tests: tweak test case generation

Author: dcoutts

cabal.project

@@ -24,3 +24,8 @@ import: cabal.project.debug
 -- possible to have conditionals on package flags in a project file. Otherwise,
 -- we could add a conditional on (+serialblockio) to remove this import automatically.
 import: cabal.project.blockio-uring
+
+source-repository-package
+  type: git
+  location: https://github.com/well-typed/quickcheck-lockstep.git
+  tag: 8a724c0a7b2328a7444490f18dc7e401badcc8b8

lsm-tree.cabal

@@ -371,10 +371,10 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Model.Monoidal
     Test.Database.LSMTree.Model.Normal
     Test.Database.LSMTree.Monoidal
-    Test.Database.LSMTree.Normal.Examples
     Test.Database.LSMTree.Normal.StateMachine
     Test.Database.LSMTree.Normal.StateMachine.DL
     Test.Database.LSMTree.Normal.StateMachine.Op
+    Test.Database.LSMTree.Normal.UnitTests
     Test.System.Posix.Fcntl.NoCache
     Test.Util.FS
     Test.Util.Orphans

prototypes/ScheduledMergesTestQLS.hs

@@ -305,8 +305,8 @@ instance InLockstep Model where
 
   modelNextState = runModel
 
-  arbitraryWithVars findVars _model =
-    case findVars (Proxy :: Proxy (LSM RealWorld)) of
+  arbitraryWithVars ctx _model =
+    case findVars ctx (Proxy :: Proxy (LSM RealWorld)) of
       []   -> return (Some ANew)
       vars ->
         frequency $
@@ -321,7 +321,7 @@ instance InLockstep Model where
                   AInsert <$> elements vars
                           <*> fmap Left (elements kvars) -- key var
                           <*> arbitrarySizedNatural)    -- value
-          | let kvars = findVars (Proxy :: Proxy Key)
+          | let kvars = findVars ctx (Proxy :: Proxy Key)
           , not (null kvars)
           ]
           -- deletes of arbitrary keys:
@@ -333,7 +333,7 @@ instance InLockstep Model where
        ++ [ (1, fmap Some $
                   ADelete <$> elements vars
                           <*> fmap Left (elements kvars)) -- key var
-          | let kvars = findVars (Proxy :: Proxy Key)
+          | let kvars = findVars ctx (Proxy :: Proxy Key)
           , not (null kvars)
           ]
           -- lookup of arbitrary keys:
@@ -345,7 +345,7 @@ instance InLockstep Model where
        ++ [ (3, fmap Some $
                   ALookup <$> elements vars
                           <*> fmap Left (elements kvars)) -- key var
-          | let kvars = findVars (Proxy :: Proxy Key)
+          | let kvars = findVars ctx (Proxy :: Proxy Key)
           , not (null kvars)
           ]
        ++ [ (1, fmap Some $
@@ -355,19 +355,19 @@ instance InLockstep Model where
                   ADuplicate <$> elements vars)
           ]
 
-  shrinkWithVars _findVars _model (AInsert var (Right k) v) =
+  shrinkWithVars _ctx _model (AInsert var (Right k) v) =
     [ Some $ AInsert var (Right k') v' | (k', v') <- shrink (k, v) ]
 
-  shrinkWithVars _findVars _model (AInsert var (Left _kv) v) =
+  shrinkWithVars _ctx _model (AInsert var (Left _kv) v) =
     [ Some $ AInsert var (Right k) v | k <- shrink 100 ]
 
-  shrinkWithVars _findVars _model (ADelete var (Right k)) =
+  shrinkWithVars _ctx _model (ADelete var (Right k)) =
     [ Some $ ADelete var (Right k') | k' <- shrink k ]
 
-  shrinkWithVars _findVars _model (ADelete var (Left _kv)) =
+  shrinkWithVars _ctx _model (ADelete var (Left _kv)) =
     [ Some $ ADelete var (Right k) | k <- shrink 100 ]
 
-  shrinkWithVars _findVars _model _action = []
+  shrinkWithVars _ctx _model _action = []
 
 
 instance RunLockstep Model IO where
@@ -423,9 +423,10 @@ runActionIO action lookUp =
     tr = nullTracer
 
 runModel :: Action (Lockstep Model) a
-         -> ModelLookUp Model
-         -> Model -> (ModelValue Model a, Model)
-runModel action lookUp m =
+         -> ModelVarContext Model
+         -> Model
+         -> (ModelValue Model a, Model)
+runModel action ctx m =
   case action of
     ANew -> (MLSM mlsm, m')
       where (mlsm, m') = modelNew m
@@ -449,8 +450,8 @@ runModel action lookUp m =
       where (mapping, _) = modelDump (lookUpLsMVar var) m
   where
     lookUpLsMVar :: ModelVar Model (LSM RealWorld) -> ModelLSM
-    lookUpLsMVar var = case lookUp var of MLSM r -> r
+    lookUpLsMVar var = case lookupVar ctx var of MLSM r -> r
 
     lookUpKeyVar :: ModelVar Model Key -> Key
-    lookUpKeyVar var = case lookUp var of MInsert k -> k
+    lookUpKeyVar var = case lookupVar ctx var of MInsert k -> k
 

src-extras/Database/LSMTree/Extras/Generators.hs

@@ -492,7 +492,7 @@ instance Arbitrary LargeRawBytes where
 
 deriving newtype instance SerialiseValue LargeRawBytes
 
--- | Minimum length of 6 bytes.
+-- | Minimum length of 8 bytes.
 newtype KeyForIndexCompact =
     KeyForIndexCompact { getKeyForIndexCompact :: RawBytes }
   deriving stock (Eq, Ord, Show)

src/Database/LSMTree/Internal.hs

@@ -201,7 +201,7 @@ data LSMTreeError =
     -- The 'Int' index indicates which 'BlobRef' was invalid. Many may be
     -- invalid but only the first is reported.
   | ErrBlobRefInvalid Int
-  deriving stock (Show)
+  deriving stock (Show, Eq)
   deriving anyclass (Exception)
 
 {-------------------------------------------------------------------------------

src/Database/LSMTree/Internal/Lookup.hs

@@ -145,10 +145,10 @@ type ResolveSerialisedValue = SerialisedValue -> SerialisedValue -> SerialisedVa
 
 -- | An 'IOOp' read/wrote fewer or more bytes than expected
 data ByteCountDiscrepancy = ByteCountDiscrepancy {
-    expected :: ByteCount
-  , actual   :: ByteCount
+    expected :: !ByteCount
+  , actual   :: !ByteCount
   }
-  deriving stock (Show)
+  deriving stock (Show, Eq)
   deriving anyclass (Exception)
 
 {-# SPECIALIZE lookupsIO ::

src/Database/LSMTree/Internal/Paths.hs

@@ -31,6 +31,8 @@ import           Control.DeepSeq (NFData (..))
 import qualified Data.ByteString.Char8 as BS
 import           Data.Foldable (toList)
 import qualified Data.Map as Map
+import           Data.Maybe (fromMaybe)
+import           Data.String (IsString (..))
 import           Data.Traversable (for)
 import           Database.LSMTree.Internal.RunNumber
 import           Database.LSMTree.Internal.UniqCounter
@@ -70,6 +72,12 @@ newtype SnapshotName = MkSnapshotName FilePath
 instance Show SnapshotName where
   showsPrec d (MkSnapshotName p) = showsPrec d p
 
+-- | This instance uses 'mkSnapshotName', so all the restrictions on snap shot names apply here too. An invalid snapshot name will lead to an error.
+instance IsString SnapshotName where
+  fromString s = fromMaybe bad (mkSnapshotName s)
+    where
+      bad = error ("SnapshotName.fromString: invalid name " ++ show s)
+
 -- | Create snapshot name.
 --
 -- The name may consist of lowercase characters, digits, dashes @-@ and underscores @_@.

test/Database/LSMTree/Model/Normal/Session.hs

@@ -58,6 +58,8 @@ module Database.LSMTree.Model.Normal.Session (
   , rangeLookup
     -- ** Cursor
   , Cursor
+  , CursorID
+  , cursorID
   , newCursor
   , closeCursor
   , readCursor

test/Main.hs

@@ -31,9 +31,9 @@ import qualified Test.Database.LSMTree.Internal.Vector
 import qualified Test.Database.LSMTree.Model.Monoidal
 import qualified Test.Database.LSMTree.Model.Normal
 import qualified Test.Database.LSMTree.Monoidal
-import qualified Test.Database.LSMTree.Normal.Examples
 import qualified Test.Database.LSMTree.Normal.StateMachine
 import qualified Test.Database.LSMTree.Normal.StateMachine.DL
+import qualified Test.Database.LSMTree.Normal.UnitTests
 import qualified Test.System.Posix.Fcntl.NoCache
 import           Test.Tasty
 
@@ -67,7 +67,7 @@ main = defaultMain $ testGroup "lsm-tree"
     , Test.Database.LSMTree.Model.Normal.tests
     , Test.Database.LSMTree.Model.Monoidal.tests
     , Test.Database.LSMTree.Monoidal.tests
-    , Test.Database.LSMTree.Normal.Examples.tests
+    , Test.Database.LSMTree.Normal.UnitTests.tests
     , Test.Database.LSMTree.Normal.StateMachine.tests
     , Test.Database.LSMTree.Normal.StateMachine.DL.tests
     , Test.System.Posix.Fcntl.NoCache.tests

test/Test/Database/LSMTree/Internal/RunReaders.hs

@@ -184,20 +184,20 @@ instance InLockstep ReadersState where
 
   modelNextState :: forall a.
        LockstepAction ReadersState a
-    -> ModelLookUp ReadersState
+    -> ModelVarContext ReadersState
     -> ReadersState
     -> (ReadersVal a, ReadersState)
-  modelNextState action lookUp (ReadersState mock) =
-      ReadersState <$> runMock lookUp action mock
+  modelNextState action _ctx (ReadersState mock) =
+      ReadersState <$> runMock action mock
 
   usedVars :: LockstepAction ReadersState a -> [AnyGVar (ModelOp ReadersState)]
   usedVars = const []
 
   arbitraryWithVars ::
-       ModelFindVariables ReadersState
+       ModelVarContext ReadersState
     -> ReadersState
     -> Gen (Any (LockstepAction ReadersState))
-  arbitraryWithVars _ (ReadersState mock)
+  arbitraryWithVars _ctx (ReadersState mock)
     | isEmpty mock = do
         -- It's not allowed to keep using a drained RunReaders,
         -- we can only create a new one.
@@ -226,11 +226,11 @@ instance InLockstep ReadersState where
           ]
 
   shrinkWithVars ::
-       ModelFindVariables ReadersState
+       ModelVarContext ReadersState
     -> ReadersState
     -> LockstepAction ReadersState a
     -> [Any (LockstepAction ReadersState)]
-  shrinkWithVars _ _ = \case
+  shrinkWithVars _ctx _st = \case
       New k wb wbs      -> [ Some (New k' wb' wbs')
                            | (k', wb', wbs') <- shrink (k, wb, wbs)
                            ]
@@ -267,11 +267,10 @@ instance InLockstep ReadersState where
     ]
 
 runMock ::
-     lookUp
-  -> Action (Lockstep ReadersState) a
+     Action (Lockstep ReadersState) a
   -> MockReaders
   -> (ReadersVal a, MockReaders)
-runMock _ = \case
+runMock = \case
     New k wb wbs   -> const $ wrap MUnit (Right (), newMock (coerce k) (toList wb <> wbs))
     PeekKey        -> \m -> wrap MKey (peekKeyMock m, m)
     Pop n          -> wrap wrapPop . popMock n