From 0009925c2e118bf59d5193c58ac4d92fa7b31154 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 26 Nov 2024 15:20:14 +0100 Subject: [PATCH] Rename `blob` and `blobref` type variables to `b` It makes the code more succinct. --- bench/macro/lsm-tree-bench-wp8.hs | 2 +- .../Database/LSMTree/Extras/Generators.hs | 4 +- .../Database/LSMTree/Extras/NoThunks.hs | 4 +- src-extras/Database/LSMTree/Extras/RunData.hs | 12 +- src/Database/LSMTree.hs | 200 +++++++++--------- src/Database/LSMTree/Common.hs | 6 +- src/Database/LSMTree/Internal.hs | 2 +- src/Database/LSMTree/Internal/Entry.hs | 18 +- src/Database/LSMTree/Internal/PageAcc.hs | 4 +- src/Database/LSMTree/Monoidal.hs | 2 +- src/Database/LSMTree/Normal.hs | 178 ++++++++-------- test/Database/LSMTree/Class/Monoidal.hs | 2 +- test/Database/LSMTree/Class/Normal.hs | 130 ++++++------ test/Database/LSMTree/Model/IO/Normal.hs | 12 +- test/Database/LSMTree/Model/Session.hs | 158 +++++++------- test/Database/LSMTree/Model/Table.hs | 18 +- test/Test/Database/LSMTree/Class/Normal.hs | 48 ++--- test/Test/Database/LSMTree/Internal/Entry.hs | 20 +- .../Database/LSMTree/Normal/StateMachine.hs | 184 ++++++++-------- .../LSMTree/Normal/StateMachine/Op.hs | 6 +- test/Test/Util/Orphans.hs | 18 +- test/Test/Util/TypeFamilyWrappers.hs | 20 +- 22 files changed, 524 insertions(+), 524 deletions(-) diff --git a/bench/macro/lsm-tree-bench-wp8.hs b/bench/macro/lsm-tree-bench-wp8.hs index 062b52f4e..fda31bca8 100644 --- a/bench/macro/lsm-tree-bench-wp8.hs +++ b/bench/macro/lsm-tree-bench-wp8.hs @@ -857,7 +857,7 @@ pureReference !initialSize !batchSize !batchCount !seed = Nothing -> (,) k LSM.NotFound Just u -> (,) k $! updateToLookupResult u -updateToLookupResult :: LSM.Update v blob -> LSM.LookupResult v () +updateToLookupResult :: LSM.Update v b -> LSM.LookupResult v () updateToLookupResult (LSM.Insert v Nothing) = LSM.Found v updateToLookupResult (LSM.Insert v (Just _)) = LSM.FoundWithBlob v () updateToLookupResult LSM.Delete = LSM.NotFound diff --git a/src-extras/Database/LSMTree/Extras/Generators.hs b/src-extras/Database/LSMTree/Extras/Generators.hs index 2a7009181..368182737 100644 --- a/src-extras/Database/LSMTree/Extras/Generators.hs +++ b/src-extras/Database/LSMTree/Extras/Generators.hs @@ -75,7 +75,7 @@ import Test.QuickCheck.Instances () Common LSMTree types -------------------------------------------------------------------------------} -instance (Arbitrary v, Arbitrary blob) => Arbitrary (Normal.Update v blob) where +instance (Arbitrary v, Arbitrary b) => Arbitrary (Normal.Update v b) where arbitrary = QC.arbitrary2 shrink = QC.shrink2 @@ -132,7 +132,7 @@ instance (Arbitrary k, Ord k) => Arbitrary (Range k) where Entry -------------------------------------------------------------------------------} -instance (Arbitrary v, Arbitrary blob) => Arbitrary (Entry v blob) where +instance (Arbitrary v, Arbitrary b) => Arbitrary (Entry v b) where arbitrary = QC.arbitrary2 shrink = QC.shrink2 diff --git a/src-extras/Database/LSMTree/Extras/NoThunks.hs b/src-extras/Database/LSMTree/Extras/NoThunks.hs index b7b5e70bc..639cd3a0d 100644 --- a/src-extras/Database/LSMTree/Extras/NoThunks.hs +++ b/src-extras/Database/LSMTree/Extras/NoThunks.hs @@ -97,8 +97,8 @@ instance (NoThunksIOLike m, Typeable m, Typeable (PrimState m)) -- | Does not check 'NoThunks' for the 'Common.Session' that this -- 'Normal.Table' belongs to. instance (NoThunksIOLike m, Typeable m, Typeable (PrimState m)) - => NoThunks (NormalTable m k v blob) where - showTypeOf (_ :: Proxy (NormalTable m k v blob)) = "NormalTable" + => NoThunks (NormalTable m k v b) where + showTypeOf (_ :: Proxy (NormalTable m k v b)) = "NormalTable" wNoThunks ctx (NormalTable t) = wNoThunks ctx t {------------------------------------------------------------------------------- diff --git a/src-extras/Database/LSMTree/Extras/RunData.hs b/src-extras/Database/LSMTree/Extras/RunData.hs index db4ae4f42..2c2e1e09a 100644 --- a/src-extras/Database/LSMTree/Extras/RunData.hs +++ b/src-extras/Database/LSMTree/Extras/RunData.hs @@ -148,11 +148,11 @@ instance ( Ord k, Arbitrary k, Arbitrary v, Arbitrary b shrink = shrinkRunData shrink shrink shrink genRunData :: - forall k v blob. Ord k + forall k v b. Ord k => Gen k -> Gen v - -> Gen blob - -> Gen (RunData k v blob) + -> Gen b + -> Gen (RunData k v b) genRunData genKey genVal genBlob = RunData <$> liftArbitrary2Map genKey (liftArbitrary2 genVal genBlob) @@ -160,9 +160,9 @@ shrinkRunData :: Ord k => (k -> [k]) -> (v -> [v]) - -> (blob -> [blob]) - -> RunData k v blob - -> [RunData k v blob] + -> (b -> [b]) + -> RunData k v b + -> [RunData k v b] shrinkRunData shrinkKey shrinkVal shrinkBlob = fmap RunData . liftShrink2Map shrinkKey (liftShrink2 shrinkVal shrinkBlob) diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 5dc27fd14..1972681a6 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -131,13 +131,13 @@ type Table = Internal.Table' {-# SPECIALISE withTable :: Session IO -> Common.TableConfig - -> (Table IO k v blob -> IO a) + -> (Table IO k v b -> IO a) -> IO a #-} withTable :: IOLike m => Session m -> Common.TableConfig - -> (Table m k v blob -> m a) + -> (Table m k v b -> m a) -> m a withTable (Internal.Session' sesh) conf action = Internal.withTable sesh conf (action . Internal.Table') @@ -145,20 +145,20 @@ withTable (Internal.Session' sesh) conf action = {-# SPECIALISE new :: Session IO -> Common.TableConfig - -> IO (Table IO k v blob) #-} + -> IO (Table IO k v b) #-} new :: IOLike m => Session m -> Common.TableConfig - -> m (Table m k v blob) + -> m (Table m k v b) new (Internal.Session' sesh) conf = Internal.Table' <$> Internal.new sesh conf {-# SPECIALISE close :: - Table IO k v blob + Table IO k v b -> IO () #-} close :: IOLike m - => Table m k v blob + => Table m k v b -> m () close (Internal.Table' t) = Internal.close t @@ -167,10 +167,10 @@ close (Internal.Table' t) = Internal.close t -------------------------------------------------------------------------------} -- | Result of a single point lookup. -data LookupResult v blobref = +data LookupResult v b = NotFound | Found !v - | FoundWithBlob !v !blobref + | FoundWithBlob !v !b deriving stock (Eq, Show, Functor, Foldable, Traversable) instance Bifunctor LookupResult where @@ -186,20 +186,20 @@ instance Bifunctor LookupResult where {-# SPECIALISE lookups :: (SerialiseKey k, SerialiseValue v, ResolveValue v) - => Table IO k v blob + => Table IO k v b -> V.Vector k - -> IO (V.Vector (LookupResult v (BlobRef IO blob))) #-} + -> IO (V.Vector (LookupResult v (BlobRef IO b))) #-} {-# INLINEABLE lookups #-} lookups :: - forall m k v blob. ( + forall m k v b. ( IOLike m , SerialiseKey k , SerialiseValue v , ResolveValue v ) - => Table m k v blob + => Table m k v b -> V.Vector k - -> m (V.Vector (LookupResult v (BlobRef m blob))) + -> m (V.Vector (LookupResult v (BlobRef m b))) lookups (Internal.Table' t) ks = V.map toLookupResult <$> Internal.lookups (resolve @v Proxy) (V.map Internal.serialiseKey ks) t @@ -212,9 +212,9 @@ lookups (Internal.Table' t) ks = Entry.Delete -> NotFound toLookupResult Nothing = NotFound -data QueryResult k v blobref = +data QueryResult k v b = FoundInQuery !k !v - | FoundInQueryWithBlob !k !v !blobref + | FoundInQueryWithBlob !k !v !b deriving stock (Eq, Show, Functor, Foldable, Traversable) instance Bifunctor (QueryResult k) where @@ -224,19 +224,19 @@ instance Bifunctor (QueryResult k) where {-# SPECIALISE rangeLookup :: (SerialiseKey k, SerialiseValue v, ResolveValue v) - => Table IO k v blob + => Table IO k v b -> Range k - -> IO (V.Vector (QueryResult k v (BlobRef IO blob))) #-} + -> IO (V.Vector (QueryResult k v (BlobRef IO b))) #-} rangeLookup :: - forall m k v blob. ( + forall m k v b. ( IOLike m , SerialiseKey k , SerialiseValue v , ResolveValue v ) - => Table m k v blob + => Table m k v b -> Range k - -> m (V.Vector (QueryResult k v (BlobRef m blob))) + -> m (V.Vector (QueryResult k v (BlobRef m b))) rangeLookup (Internal.Table' t) range = Internal.rangeLookup (resolve @v Proxy) (Internal.serialiseKey <$> range) t $ \k v mblob -> toQueryResult @@ -252,13 +252,13 @@ type Cursor :: (Type -> Type) -> Type -> Type -> Type -> Type type Cursor = Internal.Cursor' {-# SPECIALISE withCursor :: - Table IO k v blob - -> (Cursor IO k v blob -> IO a) + Table IO k v b + -> (Cursor IO k v b -> IO a) -> IO a #-} withCursor :: IOLike m - => Table m k v blob - -> (Cursor m k v blob -> m a) + => Table m k v b + -> (Cursor m k v b -> m a) -> m a withCursor (Internal.Table' t) action = Internal.withCursor Internal.NoOffsetKey t (action . Internal.Cursor') @@ -266,71 +266,71 @@ withCursor (Internal.Table' t) action = {-# SPECIALISE withCursorAtOffset :: SerialiseKey k => k - -> Table IO k v blob - -> (Cursor IO k v blob -> IO a) + -> Table IO k v b + -> (Cursor IO k v b -> IO a) -> IO a #-} withCursorAtOffset :: ( IOLike m , SerialiseKey k ) => k - -> Table m k v blob - -> (Cursor m k v blob -> m a) + -> Table m k v b + -> (Cursor m k v b -> m a) -> m a withCursorAtOffset offset (Internal.Table' t) action = Internal.withCursor (Internal.OffsetKey (Internal.serialiseKey offset)) t $ action . Internal.Cursor' {-# SPECIALISE newCursor :: - Table IO k v blob - -> IO (Cursor IO k v blob) #-} + Table IO k v b + -> IO (Cursor IO k v b) #-} newCursor :: IOLike m - => Table m k v blob - -> m (Cursor m k v blob) + => Table m k v b + -> m (Cursor m k v b) newCursor (Internal.Table' t) = Internal.Cursor' <$!> Internal.newCursor Internal.NoOffsetKey t {-# SPECIALISE newCursorAtOffset :: SerialiseKey k => k - -> Table IO k v blob - -> IO (Cursor IO k v blob) #-} + -> Table IO k v b + -> IO (Cursor IO k v b) #-} newCursorAtOffset :: ( IOLike m , SerialiseKey k ) => k - -> Table m k v blob - -> m (Cursor m k v blob) + -> Table m k v b + -> m (Cursor m k v b) newCursorAtOffset offset (Internal.Table' t) = Internal.Cursor' <$!> Internal.newCursor (Internal.OffsetKey (Internal.serialiseKey offset)) t {-# SPECIALISE closeCursor :: - Cursor IO k v blob + Cursor IO k v b -> IO () #-} closeCursor :: IOLike m - => Cursor m k v blob + => Cursor m k v b -> m () closeCursor (Internal.Cursor' c) = Internal.closeCursor c {-# SPECIALISE readCursor :: (SerialiseKey k, SerialiseValue v, ResolveValue v) => Int - -> Cursor IO k v blob - -> IO (V.Vector (QueryResult k v (BlobRef IO blob))) #-} + -> Cursor IO k v b + -> IO (V.Vector (QueryResult k v (BlobRef IO b))) #-} readCursor :: - forall m k v blob. ( + forall m k v b. ( IOLike m , SerialiseKey k , SerialiseValue v , ResolveValue v ) => Int - -> Cursor m k v blob - -> m (V.Vector (QueryResult k v (BlobRef m blob))) + -> Cursor m k v b + -> m (V.Vector (QueryResult k v (BlobRef m b))) readCursor n (Internal.Cursor' c) = Internal.readCursor (resolve (Proxy @v)) n c $ \k v mblob -> toQueryResult @@ -341,38 +341,38 @@ readCursor n (Internal.Cursor' c) = toQueryResult :: k -> v -> Maybe b -> QueryResult k v b toQueryResult k v = \case Nothing -> FoundInQuery k v - Just blob -> FoundInQueryWithBlob k v blob + Just b -> FoundInQueryWithBlob k v b {------------------------------------------------------------------------------- Table updates -------------------------------------------------------------------------------} -data Update v blob = - Insert !v !(Maybe blob) +data Update v b = + Insert !v !(Maybe b) | Delete | Mupsert !v deriving stock (Show, Eq) -instance (NFData v, NFData blob) => NFData (Update v blob) where +instance (NFData v, NFData b) => NFData (Update v b) where rnf Delete = () rnf (Insert v b) = rnf v `seq` rnf b rnf (Mupsert v) = rnf v {-# SPECIALISE updates :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob, ResolveValue v) - => Table IO k v blob - -> V.Vector (k, Update v blob) + (SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v) + => Table IO k v b + -> V.Vector (k, Update v b) -> IO () #-} updates :: - forall m k v blob. ( + forall m k v b. ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b , ResolveValue v ) - => Table m k v blob - -> V.Vector (k, Update v blob) + => Table m k v b + -> V.Vector (k, Update v b) -> m () updates (Internal.Table' t) es = do Internal.updates (resolve @v Proxy) (V.mapStrict serialiseEntry es) t @@ -381,7 +381,7 @@ updates (Internal.Table' t) es = do serialiseOp = bimap Internal.serialiseValue Internal.serialiseBlob . updateToEntry - updateToEntry :: Update v blob -> Entry.Entry v blob + updateToEntry :: Update v b -> Entry.Entry v b updateToEntry = \case Insert v Nothing -> Entry.Insert v Insert v (Just b) -> Entry.InsertWithBlob v b @@ -389,68 +389,68 @@ updates (Internal.Table' t) es = do Mupsert v -> Entry.Mupdate v {-# SPECIALISE inserts :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob, ResolveValue v) - => Table IO k v blob - -> V.Vector (k, v, Maybe blob) + (SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v) + => Table IO k v b + -> V.Vector (k, v, Maybe b) -> IO () #-} inserts :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b , ResolveValue v ) - => Table m k v blob - -> V.Vector (k, v, Maybe blob) + => Table m k v b + -> V.Vector (k, v, Maybe b) -> m () -inserts t = updates t . fmap (\(k, v, blob) -> (k, Insert v blob)) +inserts t = updates t . fmap (\(k, v, b) -> (k, Insert v b)) {-# SPECIALISE deletes :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob, ResolveValue v) - => Table IO k v blob + (SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v) + => Table IO k v b -> V.Vector k -> IO () #-} deletes :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b , ResolveValue v ) - => Table m k v blob + => Table m k v b -> V.Vector k -> m () deletes t = updates t . fmap (,Delete) {-# SPECIALISE mupserts :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob, ResolveValue v) - => Table IO k v blob + (SerialiseKey k, SerialiseValue v, SerialiseValue b, ResolveValue v) + => Table IO k v b -> V.Vector (k, v) -> IO () #-} mupserts :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b , ResolveValue v ) - => Table m k v blob + => Table m k v b -> V.Vector (k, v) -> m () mupserts t = updates t . fmap (second Mupsert) {-# SPECIALISE retrieveBlobs :: - SerialiseValue blob + SerialiseValue b => Session IO - -> V.Vector (BlobRef IO blob) - -> IO (V.Vector blob) #-} + -> V.Vector (BlobRef IO b) + -> IO (V.Vector b) #-} retrieveBlobs :: ( IOLike m - , SerialiseValue blob + , SerialiseValue b ) => Session m - -> V.Vector (BlobRef m blob) - -> m (V.Vector blob) + -> V.Vector (BlobRef m b) + -> m (V.Vector b) retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs = V.map Internal.deserialiseBlob <$> Internal.retrieveBlobs sesh (V.imap checkBlobRefType refs) @@ -464,54 +464,54 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs = -------------------------------------------------------------------------------} {-# SPECIALISE createSnapshot :: - (Common.Labellable (k, v, blob), ResolveValue v) + (Common.Labellable (k, v, b), ResolveValue v) => SnapshotName - -> Table IO k v blob + -> Table IO k v b -> IO () #-} -createSnapshot :: forall m k v blob. +createSnapshot :: forall m k v b. ( IOLike m - , Common.Labellable (k, v, blob) + , Common.Labellable (k, v, b) , ResolveValue v ) => SnapshotName - -> Table m k v blob + -> Table m k v b -> m () createSnapshot snap (Internal.Table' t) = void $ Internal.createSnapshot (resolve (Proxy @v)) snap label Internal.SnapFullTable t where - label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob)) + label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, b)) {-# SPECIALISE openSnapshot :: - (Common.Labellable (k, v, blob), ResolveValue v) + (Common.Labellable (k, v, b), ResolveValue v) => Session IO -> Common.TableConfigOverride -> SnapshotName - -> IO (Table IO k v blob ) #-} -openSnapshot :: forall m k v blob. + -> IO (Table IO k v b ) #-} +openSnapshot :: forall m k v b. ( IOLike m - , Common.Labellable (k, v, blob) + , Common.Labellable (k, v, b) , ResolveValue v ) => Session m -> Common.TableConfigOverride -- ^ Optional config override -> SnapshotName - -> m (Table m k v blob) + -> m (Table m k v b) openSnapshot (Internal.Session' sesh) override snap = Internal.Table' <$!> Internal.openSnapshot sesh label Internal.SnapFullTable override snap (resolve (Proxy @v)) where - label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob)) + label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, b)) {------------------------------------------------------------------------------- Mutiple writable tables -------------------------------------------------------------------------------} {-# SPECIALISE duplicate :: - Table IO k v blob - -> IO (Table IO k v blob) #-} + Table IO k v b + -> IO (Table IO k v b) #-} duplicate :: IOLike m - => Table m k v blob - -> m (Table m k v blob) + => Table m k v b + -> m (Table m k v b) duplicate (Internal.Table' t) = Internal.Table' <$!> Internal.duplicate t {------------------------------------------------------------------------------- @@ -520,17 +520,17 @@ duplicate (Internal.Table' t) = Internal.Table' <$!> Internal.duplicate t {-# SPECIALISE union :: ResolveValue v - => Table IO k v blob - -> Table IO k v blob - -> IO (Table IO k v blob) #-} -union :: forall m k v blob. + => Table IO k v b + -> Table IO k v b + -> IO (Table IO k v b) #-} +union :: forall m k v b. ( IOLike m , ResolveValue v ) - => Table m k v blob - -> Table m k v blob - -> m (Table m k v blob) -union = error "union: not yet implemented" $ union @m @k @v @blob + => Table m k v b + -> Table m k v b + -> m (Table m k v b) +union = error "union: not yet implemented" $ union @m @k @v @b {------------------------------------------------------------------------------- Monoidal value resolution diff --git a/src/Database/LSMTree/Common.hs b/src/Database/LSMTree/Common.hs index 9f1ffb7ab..804dcafdb 100644 --- a/src/Database/LSMTree/Common.hs +++ b/src/Database/LSMTree/Common.hs @@ -260,10 +260,10 @@ listSnapshots (Internal.Session' sesh) = Internal.listSnapshots sesh -- TODO: get rid of the @m@ parameter? type BlobRef :: (Type -> Type) -> Type -> Type type role BlobRef nominal nominal -data BlobRef m blob where +data BlobRef m b where BlobRef :: Typeable h => Internal.WeakBlobRef m h - -> BlobRef m blob + -> BlobRef m b -instance Show (BlobRef m blob) where +instance Show (BlobRef m b) where showsPrec d (BlobRef b) = showsPrec d b diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs index ce398934b..9df8e2b54 100644 --- a/src/Database/LSMTree/Internal.hs +++ b/src/Database/LSMTree/Internal.hs @@ -151,7 +151,7 @@ instance NFData (NormalTable m k v b) where rnf (NormalTable t) = rnf t type NormalCursor :: (Type -> Type) -> Type -> Type -> Type -> Type -data NormalCursor m k v blob = forall h. Typeable h => +data NormalCursor m k v b = forall h. Typeable h => NormalCursor !(Cursor m h) instance NFData (NormalCursor m k v b) where diff --git a/src/Database/LSMTree/Internal/Entry.hs b/src/Database/LSMTree/Internal/Entry.hs index c0abebd12..4a283a42f 100644 --- a/src/Database/LSMTree/Internal/Entry.hs +++ b/src/Database/LSMTree/Internal/Entry.hs @@ -14,33 +14,33 @@ import Control.DeepSeq (NFData (..)) import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) -data Entry v blobref +data Entry v b = Insert !v - | InsertWithBlob !v !blobref + | InsertWithBlob !v !b | Mupdate !v | Delete deriving stock (Eq, Show, Functor, Foldable, Traversable) -hasBlob :: Entry v blobref -> Bool +hasBlob :: Entry v b -> Bool hasBlob Insert{} = False hasBlob InsertWithBlob{} = True hasBlob Mupdate{} = False hasBlob Delete{} = False -instance (NFData v, NFData blobref) => NFData (Entry v blobref) where +instance (NFData v, NFData b) => NFData (Entry v b) where rnf (Insert v) = rnf v rnf (InsertWithBlob v br) = rnf v `seq` rnf br rnf (Mupdate v) = rnf v rnf Delete = () -onValue :: v' -> (v -> v') -> Entry v blobref -> v' +onValue :: v' -> (v -> v') -> Entry v b -> v' onValue def f = \case Insert v -> f v InsertWithBlob v _ -> f v Mupdate v -> f v Delete -> def -onBlobRef :: blobref' -> (blobref -> blobref') -> Entry v blobref -> blobref' +onBlobRef :: b' -> (b -> b') -> Entry v b -> b' onBlobRef def g = \case Insert{} -> def InsertWithBlob _ br -> g br @@ -81,11 +81,11 @@ unNumEntries (NumEntries x) = x -------------------------------------------------------------------------------} -- | As long as values are a semigroup, an Entry is too -instance Semigroup v => Semigroup (Entry v blob) where +instance Semigroup v => Semigroup (Entry v b) where e1 <> e2 = combine (<>) e1 e2 -- | Given a value-merge function, combine entries -combine :: (v -> v -> v) -> Entry v blobref -> Entry v blobref -> Entry v blobref +combine :: (v -> v -> v) -> Entry v b -> Entry v b -> Entry v b combine _ e@Delete _ = e combine _ e@Insert {} _ = e combine _ e@InsertWithBlob {} _ = e @@ -94,7 +94,7 @@ combine f (Mupdate u) (Insert v) = Insert (f u v) combine f (Mupdate u) (InsertWithBlob v blob) = InsertWithBlob (f u v) blob combine f (Mupdate u) (Mupdate v) = Mupdate (f u v) -combineMaybe :: (v -> v -> v) -> Maybe (Entry v blobref) -> Maybe (Entry v blobref) -> Maybe (Entry v blobref) +combineMaybe :: (v -> v -> v) -> Maybe (Entry v b) -> Maybe (Entry v b) -> Maybe (Entry v b) combineMaybe _ e1 Nothing = e1 combineMaybe _ Nothing e2 = e2 combineMaybe f (Just e1) (Just e2) = Just $! combine f e1 e2 diff --git a/src/Database/LSMTree/Internal/PageAcc.hs b/src/Database/LSMTree/Internal/PageAcc.hs index ed2750c20..34f04b14f 100644 --- a/src/Database/LSMTree/Internal/PageAcc.hs +++ b/src/Database/LSMTree/Internal/PageAcc.hs @@ -132,7 +132,7 @@ maxBlobRefsMap = 12 -- 768 / 64 -- Checking entry size allows us to use 'Word16' arithmetic, we don't need to -- worry about overflows. -- -sizeofEntry :: SerialisedKey -> Entry SerialisedValue blob -> Int +sizeofEntry :: SerialisedKey -> Entry SerialisedValue b -> Int sizeofEntry k Delete = sizeofKey k sizeofEntry k (Mupdate v) = sizeofKey k + sizeofValue v sizeofEntry k (Insert v) = sizeofKey k + sizeofValue v @@ -145,7 +145,7 @@ sizeofEntry k (InsertWithBlob v _) = sizeofKey k + sizeofValue v + 12 -- If 'entryWouldFitInPage' is @True@ and the 'PageAcc' is empty (i.e. using --'resetPageAcc') then 'pageAccAddElem' is guaranteed to succeed. -- -entryWouldFitInPage :: SerialisedKey -> Entry SerialisedValue blob -> Bool +entryWouldFitInPage :: SerialisedKey -> Entry SerialisedValue b -> Bool entryWouldFitInPage k e = sizeofEntry k e + 32 <= pageSize -- | Whether 'Entry' adds a blob reference diff --git a/src/Database/LSMTree/Monoidal.hs b/src/Database/LSMTree/Monoidal.hs index 97d5e348f..860dbcde6 100644 --- a/src/Database/LSMTree/Monoidal.hs +++ b/src/Database/LSMTree/Monoidal.hs @@ -449,7 +449,7 @@ updates (Internal.MonoidalTable t) es = do serialiseEntry = bimap Internal.serialiseKey serialiseOp serialiseOp = first Internal.serialiseValue . updateToEntry - updateToEntry :: Update v -> Entry.Entry v blob + updateToEntry :: Update v -> Entry.Entry v b updateToEntry = \case Insert v -> Entry.Insert v Mupsert v -> Entry.Mupdate v diff --git a/src/Database/LSMTree/Normal.hs b/src/Database/LSMTree/Normal.hs index f6573a80d..fa5268763 100644 --- a/src/Database/LSMTree/Normal.hs +++ b/src/Database/LSMTree/Normal.hs @@ -239,7 +239,7 @@ type Table = Internal.NormalTable {-# SPECIALISE withTable :: Session IO -> Common.TableConfig - -> (Table IO k v blob -> IO a) + -> (Table IO k v b -> IO a) -> IO a #-} -- | (Asynchronous) exception-safe, bracketed opening and closing of a table. -- @@ -249,7 +249,7 @@ withTable :: IOLike m => Session m -> Common.TableConfig - -> (Table m k v blob -> m a) + -> (Table m k v b -> m a) -> m a withTable (Internal.Session' sesh) conf action = Internal.withTable sesh conf (action . Internal.NormalTable) @@ -257,7 +257,7 @@ withTable (Internal.Session' sesh) conf action = {-# SPECIALISE new :: Session IO -> Common.TableConfig - -> IO (Table IO k v blob) #-} + -> IO (Table IO k v b) #-} -- | Create a new empty table, returning a fresh table. -- -- NOTE: tables hold open resources (such as open files) and should be @@ -267,11 +267,11 @@ new :: IOLike m => Session m -> Common.TableConfig - -> m (Table m k v blob) + -> m (Table m k v b) new (Internal.Session' sesh) conf = Internal.NormalTable <$> Internal.new sesh conf {-# SPECIALISE close :: - Table IO k v blob + Table IO k v b -> IO () #-} -- | Close a table. 'close' is idempotent. All operations on a closed -- handle will throw an exception. @@ -281,7 +281,7 @@ new (Internal.Session' sesh) conf = Internal.NormalTable <$> Internal.new sesh c -- not lost. close :: IOLike m - => Table m k v blob + => Table m k v b -> m () close (Internal.NormalTable t) = Internal.close t @@ -290,10 +290,10 @@ close (Internal.NormalTable t) = Internal.close t -------------------------------------------------------------------------------} -- | Result of a single point lookup. -data LookupResult v blobref = +data LookupResult v b = NotFound | Found !v - | FoundWithBlob !v !blobref + | FoundWithBlob !v !b deriving stock (Eq, Show, Functor, Foldable, Traversable) instance Bifunctor LookupResult where @@ -309,9 +309,9 @@ instance Bifunctor LookupResult where {-# SPECIALISE lookups :: (SerialiseKey k, SerialiseValue v) - => Table IO k v blob + => Table IO k v b -> V.Vector k - -> IO (V.Vector (LookupResult v (BlobRef IO blob))) #-} + -> IO (V.Vector (LookupResult v (BlobRef IO b))) #-} {-# INLINEABLE lookups #-} -- | Perform a batch of lookups. -- @@ -321,9 +321,9 @@ lookups :: , SerialiseKey k , SerialiseValue v ) - => Table m k v blob + => Table m k v b -> V.Vector k - -> m (V.Vector (LookupResult v (BlobRef m blob))) + -> m (V.Vector (LookupResult v (BlobRef m b))) lookups (Internal.NormalTable t) ks = V.map toLookupResult <$> Internal.lookups const (V.map Internal.serialiseKey ks) t @@ -337,9 +337,9 @@ lookups (Internal.NormalTable t) ks = toLookupResult Nothing = NotFound -- | A result for one point in a cursor read or range lookup. -data QueryResult k v blobref = +data QueryResult k v b = FoundInQuery !k !v - | FoundInQueryWithBlob !k !v !blobref + | FoundInQueryWithBlob !k !v !b deriving stock (Eq, Show, Functor, Foldable, Traversable) instance Bifunctor (QueryResult k) where @@ -349,9 +349,9 @@ instance Bifunctor (QueryResult k) where {-# SPECIALISE rangeLookup :: (SerialiseKey k, SerialiseValue v) - => Table IO k v blob + => Table IO k v b -> Range k - -> IO (V.Vector (QueryResult k v (BlobRef IO blob))) #-} + -> IO (V.Vector (QueryResult k v (BlobRef IO b))) #-} -- | Perform a range lookup. -- -- Range lookups can be performed concurrently from multiple Haskell threads. @@ -360,9 +360,9 @@ rangeLookup :: , SerialiseKey k , SerialiseValue v ) - => Table m k v blob + => Table m k v b -> Range k - -> m (V.Vector (QueryResult k v (BlobRef m blob))) + -> m (V.Vector (QueryResult k v (BlobRef m b))) rangeLookup (Internal.NormalTable t) range = Internal.rangeLookup const (Internal.serialiseKey <$> range) t $ \k v mblob -> toNormalQueryResult @@ -386,8 +386,8 @@ type Cursor :: (Type -> Type) -> Type -> Type -> Type -> Type type Cursor = Internal.NormalCursor {-# SPECIALISE withCursor :: - Table IO k v blob - -> (Cursor IO k v blob -> IO a) + Table IO k v b + -> (Cursor IO k v b -> IO a) -> IO a #-} -- | (Asynchronous) exception-safe, bracketed opening and closing of a cursor. -- @@ -395,8 +395,8 @@ type Cursor = Internal.NormalCursor -- and 'closeCursor'. withCursor :: IOLike m - => Table m k v blob - -> (Cursor m k v blob -> m a) + => Table m k v b + -> (Cursor m k v b -> m a) -> m a withCursor (Internal.NormalTable t) action = Internal.withCursor Internal.NoOffsetKey t (action . Internal.NormalCursor) @@ -404,8 +404,8 @@ withCursor (Internal.NormalTable t) action = {-# SPECIALISE withCursorAtOffset :: SerialiseKey k => k - -> Table IO k v blob - -> (Cursor IO k v blob -> IO a) + -> Table IO k v b + -> (Cursor IO k v b -> IO a) -> IO a #-} -- | A variant of 'withCursor' that allows initialising the cursor at an offset -- within the table such that the first entry the cursor returns will be the @@ -419,16 +419,16 @@ withCursorAtOffset :: , SerialiseKey k ) => k - -> Table m k v blob - -> (Cursor m k v blob -> m a) + -> Table m k v b + -> (Cursor m k v b -> m a) -> m a withCursorAtOffset offset (Internal.NormalTable t) action = Internal.withCursor (Internal.OffsetKey (Internal.serialiseKey offset)) t $ action . Internal.NormalCursor {-# SPECIALISE newCursor :: - Table IO k v blob - -> IO (Cursor IO k v blob) #-} + Table IO k v b + -> IO (Cursor IO k v b) #-} -- | Create a new cursor to read from a given table. Future updates to the table -- will not be reflected in the cursor. The cursor starts at the beginning, i.e. -- the minimum key of the table. @@ -439,16 +439,16 @@ withCursorAtOffset offset (Internal.NormalTable t) action = -- using 'close' as soon as they are no longer used. newCursor :: IOLike m - => Table m k v blob - -> m (Cursor m k v blob) + => Table m k v b + -> m (Cursor m k v b) newCursor (Internal.NormalTable t) = Internal.NormalCursor <$!> Internal.newCursor Internal.NoOffsetKey t {-# SPECIALISE newCursorAtOffset :: SerialiseKey k => k - -> Table IO k v blob - -> IO (Cursor IO k v blob) #-} + -> Table IO k v b + -> IO (Cursor IO k v b) #-} -- | A variant of 'newCursor' that allows initialising the cursor at an offset -- within the table such that the first entry the cursor returns will be the -- one with the lowest key that is greater than or equal to the given key. @@ -461,28 +461,28 @@ newCursorAtOffset :: , SerialiseKey k ) => k - -> Table m k v blob - -> m (Cursor m k v blob) + -> Table m k v b + -> m (Cursor m k v b) newCursorAtOffset offset (Internal.NormalTable t) = Internal.NormalCursor <$!> Internal.newCursor (Internal.OffsetKey (Internal.serialiseKey offset)) t {-# SPECIALISE closeCursor :: - Cursor IO k v blob + Cursor IO k v b -> IO () #-} -- | Close a cursor. 'closeCursor' is idempotent. All operations on a closed -- cursor will throw an exception. closeCursor :: IOLike m - => Cursor m k v blob + => Cursor m k v b -> m () closeCursor (Internal.NormalCursor c) = Internal.closeCursor c {-# SPECIALISE readCursor :: (SerialiseKey k, SerialiseValue v) => Int - -> Cursor IO k v blob - -> IO (V.Vector (QueryResult k v (BlobRef IO blob))) #-} + -> Cursor IO k v b + -> IO (V.Vector (QueryResult k v (BlobRef IO b))) #-} -- | Read the next @n@ entries from the cursor. The resulting vector is shorter -- than @n@ if the end of the table has been reached. The cursor state is -- updated, so the next read will continue where this one ended. @@ -498,8 +498,8 @@ readCursor :: , SerialiseValue v ) => Int - -> Cursor m k v blob - -> m (V.Vector (QueryResult k v (BlobRef m blob))) + -> Cursor m k v b + -> m (V.Vector (QueryResult k v (BlobRef m b))) readCursor n (Internal.NormalCursor c) = Internal.readCursor const n c $ \k v mblob -> toNormalQueryResult @@ -520,19 +520,19 @@ toNormalQueryResult k v = \case -- -- An __update__ is a term that groups all types of table-manipulating -- operations, like inserts and deletes. -data Update v blob = - Insert !v !(Maybe blob) +data Update v b = + Insert !v !(Maybe b) | Delete deriving stock (Show, Eq) -instance (NFData v, NFData blob) => NFData (Update v blob) where +instance (NFData v, NFData b) => NFData (Update v b) where rnf Delete = () rnf (Insert v b) = rnf v `seq` rnf b {-# SPECIALISE updates :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob) - => Table IO k v blob - -> V.Vector (k, Update v blob) + (SerialiseKey k, SerialiseValue v, SerialiseValue b) + => Table IO k v b + -> V.Vector (k, Update v b) -> IO () #-} -- | Perform a mixed batch of inserts and deletes. -- @@ -544,10 +544,10 @@ updates :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b ) - => Table m k v blob - -> V.Vector (k, Update v blob) + => Table m k v b + -> V.Vector (k, Update v b) -> m () updates (Internal.NormalTable t) es = do Internal.updates const (V.mapStrict serialiseEntry es) t @@ -556,16 +556,16 @@ updates (Internal.NormalTable t) es = do serialiseOp = bimap Internal.serialiseValue Internal.serialiseBlob . updateToEntry - updateToEntry :: Update v blob -> Entry.Entry v blob + updateToEntry :: Update v b -> Entry.Entry v b updateToEntry = \case Insert v Nothing -> Entry.Insert v Insert v (Just b) -> Entry.InsertWithBlob v b Delete -> Entry.Delete {-# SPECIALISE inserts :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob) - => Table IO k v blob - -> V.Vector (k, v, Maybe blob) + (SerialiseKey k, SerialiseValue v, SerialiseValue b) + => Table IO k v b + -> V.Vector (k, v, Maybe b) -> IO () #-} -- | Perform a batch of inserts. -- @@ -574,16 +574,16 @@ inserts :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b ) - => Table m k v blob - -> V.Vector (k, v, Maybe blob) + => Table m k v b + -> V.Vector (k, v, Maybe b) -> m () inserts t = updates t . fmap (\(k, v, blob) -> (k, Insert v blob)) {-# SPECIALISE deletes :: - (SerialiseKey k, SerialiseValue v, SerialiseValue blob) - => Table IO k v blob + (SerialiseKey k, SerialiseValue v, SerialiseValue b) + => Table IO k v b -> V.Vector k -> IO () #-} -- | Perform a batch of deletes. @@ -593,18 +593,18 @@ deletes :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob + , SerialiseValue b ) - => Table m k v blob + => Table m k v b -> V.Vector k -> m () deletes t = updates t . fmap (,Delete) {-# SPECIALISE retrieveBlobs :: - SerialiseValue blob + SerialiseValue b => Session IO - -> V.Vector (BlobRef IO blob) - -> IO (V.Vector blob) #-} + -> V.Vector (BlobRef IO b) + -> IO (V.Vector b) #-} -- | Perform a batch of blob retrievals. -- -- This is a separate step from 'lookups' and 'rangeLookup'. The result of a @@ -617,11 +617,11 @@ deletes t = updates t . fmap (,Delete) -- Blob lookups can be performed concurrently from multiple Haskell threads. retrieveBlobs :: ( IOLike m - , SerialiseValue blob + , SerialiseValue b ) => Session m - -> V.Vector (BlobRef m blob) - -> m (V.Vector blob) + -> V.Vector (BlobRef m b) + -> m (V.Vector b) retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs = V.map Internal.deserialiseBlob <$> Internal.retrieveBlobs sesh (V.imap checkBlobRefType refs) @@ -635,9 +635,9 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs = -------------------------------------------------------------------------------} {-# SPECIALISE createSnapshot :: - Common.Labellable (k, v, blob) + Common.Labellable (k, v, b) => SnapshotName - -> Table IO k v blob + -> Table IO k v b -> IO () #-} -- | Make the current value of a table durable on-disk by taking a snapshot and -- giving the snapshot a name. This is the __only__ mechanism to make a table @@ -660,24 +660,24 @@ retrieveBlobs (Internal.Session' (sesh :: Internal.Session m h)) refs = -- -- * It is safe to concurrently make snapshots from any table, provided that -- the snapshot names are distinct (otherwise this would be a race). -createSnapshot :: forall m k v blob. +createSnapshot :: forall m k v b. ( IOLike m - , Common.Labellable (k, v, blob) + , Common.Labellable (k, v, b) ) => SnapshotName - -> Table m k v blob + -> Table m k v b -> m () createSnapshot snap (Internal.NormalTable t) = Internal.createSnapshot const snap label Internal.SnapNormalTable t where - label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob)) + label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, b)) {-# SPECIALISE openSnapshot :: - Common.Labellable (k, v, blob) + Common.Labellable (k, v, b) => Session IO -> Common.TableConfigOverride -> SnapshotName - -> IO (Table IO k v blob ) #-} + -> IO (Table IO k v b ) #-} -- | Open a table from a named snapshot, returning a new table. -- -- NOTE: close tables using 'close' as soon as they are @@ -696,14 +696,14 @@ createSnapshot snap (Internal.NormalTable t) = -- 'createSnapshot' "intTable" t -- 'openSnapshot' \@IO \@Bool \@Bool \@Bool session "intTable" -- @ -openSnapshot :: forall m k v blob. +openSnapshot :: forall m k v b. ( IOLike m - , Common.Labellable (k, v, blob) + , Common.Labellable (k, v, b) ) => Session m -> Common.TableConfigOverride -- ^ Optional config override -> SnapshotName - -> m (Table m k v blob) + -> m (Table m k v b) openSnapshot (Internal.Session' sesh) override snap = Internal.NormalTable <$!> Internal.openSnapshot @@ -714,15 +714,15 @@ openSnapshot (Internal.Session' sesh) override snap = snap const where - label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, blob)) + label = Internal.SnapshotLabel $ Common.makeSnapshotLabel (Proxy @(k, v, b)) {------------------------------------------------------------------------------- Mutiple writable tables -------------------------------------------------------------------------------} {-# SPECIALISE duplicate :: - Table IO k v blob - -> IO (Table IO k v blob) #-} + Table IO k v b + -> IO (Table IO k v b) #-} -- | Create a logically independent duplicate of a table. This returns a -- new table. -- @@ -755,8 +755,8 @@ openSnapshot (Internal.Session' sesh) override snap = -- longer needed. duplicate :: IOLike m - => Table m k v blob - -> m (Table m k v blob) + => Table m k v b + -> m (Table m k v b) duplicate (Internal.NormalTable t) = Internal.NormalTable <$!> Internal.duplicate t {------------------------------------------------------------------------------- @@ -764,9 +764,9 @@ duplicate (Internal.NormalTable t) = Internal.NormalTable <$!> Internal.duplicat -------------------------------------------------------------------------------} {-# SPECIALISE union :: - Table IO k v blob - -> Table IO k v blob - -> IO (Table IO k v blob) #-} + Table IO k v b + -> Table IO k v b + -> IO (Table IO k v b) #-} -- | Union two full tables, creating a new table. -- -- A good mental model of this operation is @'Data.Map.Lazy.union'@ on @@ -778,9 +778,9 @@ duplicate (Internal.NormalTable t) = Internal.NormalTable <$!> Internal.duplicat -- -- NOTE: unioning tables creates a new table, but does not close the tables that -- were used as inputs. -union :: forall m k v blob. +union :: forall m k v b. IOLike m - => Table m k v blob - -> Table m k v blob - -> m (Table m k v blob) + => Table m k v b + -> Table m k v b + -> m (Table m k v b) union = error "union: not yet implemented" $ union @m @k @v diff --git a/test/Database/LSMTree/Class/Monoidal.hs b/test/Database/LSMTree/Class/Monoidal.hs index aadd15125..ceabaa4aa 100644 --- a/test/Database/LSMTree/Class/Monoidal.hs +++ b/test/Database/LSMTree/Class/Monoidal.hs @@ -31,7 +31,7 @@ import Database.LSMTree.Monoidal as Types (LookupResult (..), import qualified Database.LSMTree.Monoidal as R -- | Model-specific constraints -type C k v blob = (C_ k, C_ v, C_ blob) +type C k v b = (C_ k, C_ v, C_ b) type C_ a = (Show a, Eq a, Typeable a) -- | Class abstracting over table operations. diff --git a/test/Database/LSMTree/Class/Normal.hs b/test/Database/LSMTree/Class/Normal.hs index 0334e2b35..d70f35494 100644 --- a/test/Database/LSMTree/Class/Normal.hs +++ b/test/Database/LSMTree/Class/Normal.hs @@ -32,7 +32,7 @@ import System.FS.API (FsPath, HasFS) import System.FS.BlockIO.API (HasBlockIO) -- | Model-specific constraints -type C k v blob = (C_ k, C_ v, C_ blob) +type C k v b = (C_ k, C_ v, C_ b) type C_ a = (Show a, Eq a, Typeable a) -- | Class abstracting over session operations. @@ -76,191 +76,191 @@ class (IsSession (Session h)) => IsTable h where new :: ( IOLike m - , C k v blob + , C k v b ) => Session h m -> TableConfig h - -> m (h m k v blob) + -> m (h m k v b) close :: ( IOLike m - , C k v blob + , C k v b ) - => h m k v blob + => h m k v b -> m () lookups :: ( IOLike m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) - => h m k v blob + => h m k v b -> V.Vector k - -> m (V.Vector (LookupResult v (BlobRef h m blob))) + -> m (V.Vector (LookupResult v (BlobRef h m b))) rangeLookup :: ( IOLike m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) - => h m k v blob + => h m k v b -> Range k - -> m (V.Vector (QueryResult k v (BlobRef h m blob))) + -> m (V.Vector (QueryResult k v (BlobRef h m b))) newCursor :: ( IOLike m , SerialiseKey k - , C k v blob + , C k v b ) => Maybe k - -> h m k v blob - -> m (Cursor h m k v blob) + -> h m k v b + -> m (Cursor h m k v b) closeCursor :: ( IOLike m - , C k v blob + , C k v b ) => proxy h - -> Cursor h m k v blob + -> Cursor h m k v b -> m () readCursor :: ( IOLike m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) => proxy h -> Int - -> Cursor h m k v blob - -> m (V.Vector (QueryResult k v (BlobRef h m blob))) + -> Cursor h m k v b + -> m (V.Vector (QueryResult k v (BlobRef h m b))) retrieveBlobs :: ( IOLike m - , SerialiseValue blob - , C_ blob + , SerialiseValue b + , C_ b ) => proxy h -> Session h m - -> V.Vector (BlobRef h m blob) - -> m (V.Vector blob) + -> V.Vector (BlobRef h m b) + -> m (V.Vector b) updates :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) - => h m k v blob - -> V.Vector (k, Update v blob) + => h m k v b + -> V.Vector (k, Update v b) -> m () inserts :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) - => h m k v blob - -> V.Vector (k, v, Maybe blob) + => h m k v b + -> V.Vector (k, v, Maybe b) -> m () deletes :: ( IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) - => h m k v blob + => h m k v b -> V.Vector k -> m () createSnapshot :: ( IOLike m - , Labellable (k, v, blob) + , Labellable (k, v, b) , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => SnapshotName - -> h m k v blob + -> h m k v b -> m () openSnapshot :: ( IOLike m - , Labellable (k, v, blob) + , Labellable (k, v, b) , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => Session h m -> SnapshotName - -> m (h m k v blob) + -> m (h m k v b) duplicate :: ( IOLike m - , C k v blob + , C k v b ) - => h m k v blob - -> m (h m k v blob) + => h m k v b + -> m (h m k v b) union :: ( IOLike m , SerialiseValue v - , C k v blob + , C k v b ) - => h m k v blob - -> h m k v blob - -> m (h m k v blob) + => h m k v b + -> h m k v b + -> m (h m k v b) -withTableNew :: forall h m k v blob a. +withTableNew :: forall h m k v b a. ( IOLike m , IsTable h - , C k v blob + , C k v b ) => Session h m -> TableConfig h - -> (h m k v blob -> m a) + -> (h m k v b -> m a) -> m a withTableNew sesh conf = bracket (new sesh conf) close -withTableFromSnapshot :: forall h m k v blob a. - ( IOLike m, IsTable h, Labellable (k, v, blob) - , SerialiseKey k, SerialiseValue v, SerialiseValue blob - , C k v blob +withTableFromSnapshot :: forall h m k v b a. + ( IOLike m, IsTable h, Labellable (k, v, b) + , SerialiseKey k, SerialiseValue v, SerialiseValue b + , C k v b ) => Session h m -> SnapshotName - -> (h m k v blob -> m a) + -> (h m k v b -> m a) -> m a withTableFromSnapshot sesh snap = bracket (openSnapshot sesh snap) close -withTableDuplicate :: forall h m k v blob a. +withTableDuplicate :: forall h m k v b a. ( IOLike m , IsTable h - , C k v blob + , C k v b ) - => h m k v blob - -> (h m k v blob -> m a) + => h m k v b + -> (h m k v b -> m a) -> m a withTableDuplicate table = bracket (duplicate table) close -withCursor :: forall h m k v blob a. +withCursor :: forall h m k v b a. ( IOLike m , IsTable h , SerialiseKey k - , C k v blob + , C k v b ) => Maybe k - -> h m k v blob - -> (Cursor h m k v blob -> m a) + -> h m k v b + -> (Cursor h m k v b -> m a) -> m a withCursor offset hdl = bracket (newCursor offset hdl) (closeCursor (Proxy @h)) diff --git a/test/Database/LSMTree/Model/IO/Normal.hs b/test/Database/LSMTree/Model/IO/Normal.hs index 7ea669aa6..093932cb9 100644 --- a/test/Database/LSMTree/Model/IO/Normal.hs +++ b/test/Database/LSMTree/Model/IO/Normal.hs @@ -27,19 +27,19 @@ import qualified Database.LSMTree.Model.Session as Model newtype Session m = Session (StrictTVar m (Maybe Model.Model)) -data Table m k v blob = Table { +data Table m k v b = Table { _thSession :: !(Session m) - , _thTable :: !(Model.Table k v blob) + , _thTable :: !(Model.Table k v b) } -data BlobRef m blob = BlobRef { +data BlobRef m b = BlobRef { _brSession :: !(Session m) - , _brBlobRef :: !(Model.BlobRef blob) + , _brBlobRef :: !(Model.BlobRef b) } -data Cursor m k v blob = Cursor { +data Cursor m k v b = Cursor { _cSession :: !(Session m) - , _cCursor :: !(Model.Cursor k v blob) + , _cCursor :: !(Model.Cursor k v b) } newtype Err = Err (Model.Err) diff --git a/test/Database/LSMTree/Model/Session.hs b/test/Database/LSMTree/Model/Session.hs index b574a84ad..f4d724001 100644 --- a/test/Database/LSMTree/Model/Session.hs +++ b/test/Database/LSMTree/Model/Session.hs @@ -123,27 +123,27 @@ newtype UpdateCounter = UpdateCounter Word64 deriving newtype (Num) data SomeTable where - SomeTable :: (Typeable k, Typeable v, Typeable blob) - => Model.Table k v blob -> SomeTable + SomeTable :: (Typeable k, Typeable v, Typeable b) + => Model.Table k v b -> SomeTable instance Show SomeTable where show (SomeTable table) = show table toSomeTable :: - (Typeable k, Typeable v, Typeable blob) - => Model.Table k v blob + (Typeable k, Typeable v, Typeable b) + => Model.Table k v b -> SomeTable toSomeTable = SomeTable fromSomeTable :: - (Typeable k, Typeable v, Typeable blob) + (Typeable k, Typeable v, Typeable b) => SomeTable - -> Maybe (Model.Table k v blob) + -> Maybe (Model.Table k v b) fromSomeTable (SomeTable tbl) = cast tbl withSomeTable :: - (forall k v blob. (Typeable k, Typeable v, Typeable blob) - => Model.Table k v blob -> a) + (forall k v b. (Typeable k, Typeable v, Typeable b) + => Model.Table k v b -> a) -> SomeTable -> a withSomeTable f (SomeTable tbl) = f tbl @@ -154,15 +154,15 @@ instance Show SomeCursor where show (SomeCursor c) = show c toSomeCursor :: - (Typeable k, Typeable v, Typeable blob) - => Model.Cursor k v blob + (Typeable k, Typeable v, Typeable b) + => Model.Cursor k v b -> SomeCursor toSomeCursor = SomeCursor . toDyn fromSomeCursor :: - (Typeable k, Typeable v, Typeable blob) + (Typeable k, Typeable v, Typeable b) => SomeCursor - -> Maybe (Model.Cursor k v blob) + -> Maybe (Model.Cursor k v b) fromSomeCursor (SomeCursor c) = fromDynamic c -- @@ -171,7 +171,7 @@ fromSomeCursor (SomeCursor c) = fromDynamic c -- | Common constraints for keys, values and blobs type C_ a = (Show a, Eq a, Typeable a) -type C k v blob = (C_ k, C_ v, C_ blob) +type C k v b = (C_ k, C_ v, C_ b) -- -- ModelT and ModelM @@ -216,7 +216,7 @@ type TableID = Int -- API -- -data Table k v blob = Table { +data Table k v b = Table { tableID :: TableID , config :: TableConfig } @@ -226,15 +226,15 @@ data TableConfig = TableConfig deriving stock (Show, Eq) new :: - forall k v blob m. (MonadState Model m, C k v blob) + forall k v b m. (MonadState Model m, C k v b) => TableConfig - -> m (Table k v blob) + -> m (Table k v b) new config = newTableWith config Model.empty -- | -- -- This is idempotent. -close :: MonadState Model m => Table k v blob -> m () +close :: MonadState Model m => Table k v b -> m () close Table{..} = state $ \Model{..} -> let tables' = Map.delete tableID tables model' = Model { @@ -248,12 +248,12 @@ close Table{..} = state $ \Model{..} -> -- guardTableIsOpen :: - forall k v blob m. ( + forall k v b m. ( MonadState Model m, MonadError Err m - , Typeable k, Typeable v, Typeable blob + , Typeable k, Typeable v, Typeable b ) - => Table k v blob - -> m (UpdateCounter, Model.Table k v blob) + => Table k v b + -> m (UpdateCounter, Model.Table k v b) guardTableIsOpen Table{..} = gets (Map.lookup tableID . tables) >>= \case Nothing -> @@ -262,10 +262,10 @@ guardTableIsOpen Table{..} = pure (updc, fromJust $ fromSomeTable tbl) newTableWith :: - (MonadState Model m, C k v blob) + (MonadState Model m, C k v b) => TableConfig - -> Model.Table k v blob - -> m (Table k v blob) + -> Model.Table k v b + -> m (Table k v b) newTableWith config tbl = state $ \Model{..} -> let table = Table { tableID = nextID @@ -290,11 +290,11 @@ lookups :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) => V.Vector k - -> Table k v blob - -> m (V.Vector (Model.LookupResult v (BlobRef blob))) + -> Table k v b + -> m (V.Vector (Model.LookupResult v (BlobRef b))) lookups ks t = do (updc, table) <- guardTableIsOpen t pure $ liftBlobRefs (SomeTableID updc (tableID t)) $ Model.lookups ks table @@ -304,11 +304,11 @@ rangeLookup :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) => Range k - -> Table k v blob - -> m (V.Vector (Model.QueryResult k v (BlobRef blob))) + -> Table k v b + -> m (V.Vector (Model.QueryResult k v (BlobRef b))) rangeLookup r t = do (updc, table) <- guardTableIsOpen t pure $ liftBlobRefs (SomeTableID updc (tableID t)) $ Model.rangeLookup r table @@ -322,12 +322,12 @@ updates :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => ResolveSerialisedValue v - -> V.Vector (k, Model.Update v blob) - -> Table k v blob + -> V.Vector (k, Model.Update v b) + -> Table k v b -> m () updates r ups t@Table{..} = do (updc, table) <- guardTableIsOpen t @@ -341,12 +341,12 @@ inserts :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => ResolveSerialisedValue v - -> V.Vector (k, v, Maybe blob) - -> Table k v blob + -> V.Vector (k, v, Maybe b) + -> Table k v b -> m () inserts r = updates r . fmap (\(k, v, blob) -> (k, Model.Insert v blob)) @@ -355,12 +355,12 @@ deletes :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => ResolveSerialisedValue v -> V.Vector k - -> Table k v blob + -> Table k v b -> m () deletes r = updates r . fmap (,Model.Delete) @@ -369,12 +369,12 @@ mupserts :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => ResolveSerialisedValue v -> V.Vector (k, v) - -> Table k v blob + -> Table k v b -> m () mupserts r = updates r . fmap (fmap Model.Mupsert) @@ -384,20 +384,20 @@ mupserts r = updates r . fmap (fmap Model.Mupsert) -- | For more details: 'Database.LSMTree.Internal.BlobRef' describes the -- intended semantics of blob references. -data BlobRef blob = BlobRef { - handleRef :: !(SomeHandleID blob) - , innerBlob :: !(Model.BlobRef blob) +data BlobRef b = BlobRef { + handleRef :: !(SomeHandleID b) + , innerBlob :: !(Model.BlobRef b) } -deriving stock instance Show blob => Show (BlobRef blob) +deriving stock instance Show b => Show (BlobRef b) retrieveBlobs :: - forall m blob. ( MonadState Model m + forall m b. ( MonadState Model m , MonadError Err m - , SerialiseValue blob + , SerialiseValue b ) - => V.Vector (BlobRef blob) - -> m (V.Vector blob) + => V.Vector (BlobRef b) + -> m (V.Vector b) retrieveBlobs refs = Model.retrieveBlobs <$> V.mapM guard refs where guard BlobRef{..} = do @@ -425,16 +425,16 @@ retrieveBlobs refs = Model.retrieveBlobs <$> V.mapM guard refs errInvalid :: m a errInvalid = throwError ErrBlobRefInvalidated -data SomeHandleID blob where - SomeTableID :: !UpdateCounter -> !TableID -> SomeHandleID blob - SomeCursorID :: !CursorID -> SomeHandleID blob +data SomeHandleID b where + SomeTableID :: !UpdateCounter -> !TableID -> SomeHandleID b + SomeCursorID :: !CursorID -> SomeHandleID b deriving stock Show liftBlobRefs :: (Functor f, Functor g) - => SomeHandleID blob - -> g (f (Model.BlobRef blob)) - -> g (f (BlobRef blob)) + => SomeHandleID b + -> g (f (Model.BlobRef b)) + -> g (f (BlobRef b)) liftBlobRefs hid = fmap (fmap (BlobRef hid)) {------------------------------------------------------------------------------- @@ -447,10 +447,10 @@ data Snapshot = Snapshot TableConfig SomeTable createSnapshot :: ( MonadState Model m , MonadError Err m - , C k v blob + , C k v b ) => SnapshotName - -> Table k v blob + -> Table k v b -> m () createSnapshot name t@Table{..} = do (updc, table) <- guardTableIsOpen t @@ -473,13 +473,13 @@ createSnapshot name t@Table{..} = do }) openSnapshot :: - forall k v blob m.( + forall k v b m.( MonadState Model m , MonadError Err m - , C k v blob + , C k v b ) => SnapshotName - -> m (Table k v blob) + -> m (Table k v b) openSnapshot name = do snaps <- gets snapshots case Map.lookup name snaps of @@ -518,10 +518,10 @@ listSnapshots = gets (Map.keys . snapshots) duplicate :: ( MonadState Model m , MonadError Err m - , C k v blob + , C k v b ) - => Table k v blob - -> m (Table k v blob) + => Table k v b + -> m (Table k v b) duplicate t@Table{..} = do table <- snd <$> guardTableIsOpen t newTableWith config $ Model.duplicate table @@ -532,20 +532,20 @@ duplicate t@Table{..} = do type CursorID = Int -data Cursor k v blob = Cursor { +data Cursor k v b = Cursor { cursorID :: !CursorID } deriving stock Show newCursor :: - forall k v blob m. ( + forall k v b m. ( MonadState Model m, MonadError Err m , SerialiseKey k - , C k v blob + , C k v b ) => Maybe k - -> Table k v blob - -> m (Cursor k v blob) + -> Table k v b + -> m (Cursor k v b) newCursor offset t = do table <- snd <$> guardTableIsOpen t state $ \Model{..} -> @@ -560,7 +560,7 @@ newCursor offset t = do } in (cursor, model') -closeCursor :: MonadState Model m => Cursor k v blob -> m () +closeCursor :: MonadState Model m => Cursor k v b -> m () closeCursor Cursor {..} = state $ \Model{..} -> let cursors' = Map.delete cursorID cursors model' = Model { @@ -574,11 +574,11 @@ readCursor :: , MonadError Err m , SerialiseKey k , SerialiseValue v - , C k v blob + , C k v b ) => Int - -> Cursor k v blob - -> m (V.Vector (Model.QueryResult k v (BlobRef blob))) + -> Cursor k v b + -> m (V.Vector (Model.QueryResult k v (BlobRef b))) readCursor n c = do cursor <- guardCursorIsOpen c let (qrs, cursor') = Model.readCursor n cursor @@ -588,12 +588,12 @@ readCursor n c = do pure $ liftBlobRefs (SomeCursorID (cursorID c)) $ qrs guardCursorIsOpen :: - forall k v blob m. ( + forall k v b m. ( MonadState Model m, MonadError Err m - , Typeable k, Typeable v, Typeable blob + , Typeable k, Typeable v, Typeable b ) - => Cursor k v blob - -> m (Model.Cursor k v blob) + => Cursor k v b + -> m (Model.Cursor k v b) guardCursorIsOpen Cursor{..} = gets (Map.lookup cursorID . cursors) >>= \case Nothing -> diff --git a/test/Database/LSMTree/Model/Table.hs b/test/Database/LSMTree/Model/Table.hs index cc45fbd15..f25e7b48d 100644 --- a/test/Database/LSMTree/Model/Table.hs +++ b/test/Database/LSMTree/Model/Table.hs @@ -123,7 +123,7 @@ type role Table nominal nominal nominal empty :: Table k v b empty = Table Map.empty -size :: Table k v blob -> Int +size :: Table k v b -> Int size (Table m) = Map.size m -- | This instance is for testing and debugging only. @@ -249,31 +249,31 @@ mupserts r = updates r . fmap (second Mupsert) -------------------------------------------------------------------------------} retrieveBlobs :: - SerialiseValue blob - => V.Vector (BlobRef blob) - -> V.Vector blob + SerialiseValue b + => V.Vector (BlobRef b) + -> V.Vector b retrieveBlobs refs = V.map getBlobFromRef refs -data BlobRef blob = BlobRef +data BlobRef b = BlobRef !BS.ByteString -- ^ digest !RawBytes -- ^ actual contents deriving stock (Show) type role BlobRef nominal -mkBlobRef :: SerialiseValue blob => blob -> BlobRef blob +mkBlobRef :: SerialiseValue b => b -> BlobRef b mkBlobRef blob = BlobRef (SHA256.hash bs) rb where !rb = serialiseValue blob !bs = deserialiseValue rb :: BS.ByteString -coerceBlobRef :: BlobRef blob -> BlobRef blob' +coerceBlobRef :: BlobRef b -> BlobRef b' coerceBlobRef (BlobRef d b) = BlobRef d b -getBlobFromRef :: SerialiseValue blob => BlobRef blob -> blob +getBlobFromRef :: SerialiseValue b => BlobRef b -> b getBlobFromRef (BlobRef _ rb) = deserialiseValue rb -instance Eq (BlobRef blob) where +instance Eq (BlobRef b) where BlobRef x _ == BlobRef y _ = x == y {------------------------------------------------------------------------------- diff --git a/test/Test/Database/LSMTree/Class/Normal.hs b/test/Test/Database/LSMTree/Class/Normal.hs index ded01d8c0..406a16323 100644 --- a/test/Test/Database/LSMTree/Class/Normal.hs +++ b/test/Test/Database/LSMTree/Class/Normal.hs @@ -131,14 +131,14 @@ withTableNew Setup{..} ups action = retrieveBlobsTrav :: ( IsTable h , IOLike m - , SerialiseValue blob + , SerialiseValue b , Traversable t - , C_ blob + , C_ b ) => proxy h -> Session h m - -> t (BlobRef h m blob) - -> m (t blob) + -> t (BlobRef h m b) + -> m (t b) retrieveBlobsTrav hdl ses brefs = do blobs <- retrieveBlobs hdl ses (V.fromList $ toList brefs) evalStateT (traverse (\_ -> state un) brefs) (V.toList blobs) @@ -146,68 +146,68 @@ retrieveBlobsTrav hdl ses brefs = do un [] = error "invalid traversal" un (x:xs) = (x, xs) -lookupsWithBlobs :: forall h m k v blob. +lookupsWithBlobs :: forall h m k v b. ( IsTable h , IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) - => h m k v blob + => h m k v b -> Session h m -> V.Vector k - -> m (V.Vector (LookupResult v blob)) + -> m (V.Vector (LookupResult v b)) lookupsWithBlobs hdl ses ks = do res <- lookups hdl ks getCompose <$> retrieveBlobsTrav (Proxy.Proxy @h) ses (Compose res) -rangeLookupWithBlobs :: forall h m k v blob. +rangeLookupWithBlobs :: forall h m k v b. ( IsTable h , IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) - => h m k v blob + => h m k v b -> Session h m -> Range k - -> m (V.Vector (QueryResult k v blob)) + -> m (V.Vector (QueryResult k v b)) rangeLookupWithBlobs hdl ses r = do res <- rangeLookup hdl r getCompose <$> retrieveBlobsTrav (Proxy.Proxy @h) ses (Compose res) -readCursorWithBlobs :: forall h m k v blob proxy. +readCursorWithBlobs :: forall h m k v b proxy. ( IsTable h , IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => proxy h -> Session h m - -> Cursor h m k v blob + -> Cursor h m k v b -> Int - -> m (V.Vector (QueryResult k v blob)) + -> m (V.Vector (QueryResult k v b)) readCursorWithBlobs hdl ses cursor n = do res <- readCursor hdl n cursor getCompose <$> retrieveBlobsTrav hdl ses (Compose res) -readCursorAllWithBlobs :: forall h m k v blob proxy. +readCursorAllWithBlobs :: forall h m k v b proxy. ( IsTable h , IOLike m , SerialiseKey k , SerialiseValue v - , SerialiseValue blob - , C k v blob + , SerialiseValue b + , C k v b ) => proxy h -> Session h m - -> Cursor h m k v blob + -> Cursor h m k v b -> CursorReadSchedule - -> m [V.Vector (QueryResult k v blob)] + -> m [V.Vector (QueryResult k v b)] readCursorAllWithBlobs hdl ses cursor = go . getCursorReadSchedule where go [] = error "readCursorAllWithBlobs: finite infinite list" diff --git a/test/Test/Database/LSMTree/Internal/Entry.hs b/test/Test/Database/LSMTree/Internal/Entry.hs index 09cdd5a0f..d17960e36 100644 --- a/test/Test/Database/LSMTree/Internal/Entry.hs +++ b/test/Test/Database/LSMTree/Internal/Entry.hs @@ -43,8 +43,8 @@ tests = adjustOption (\_ -> QuickCheckTests 10000) $ -- | @resolve == fromEntry . resolve . toEntry@ prop_resolveEntriesNormalSemantics :: - (Show v, Show blob, Eq v, Eq blob, Semigroup v) - => NonEmpty (Normal.Update v blob) + (Show v, Show b, Eq v, Eq b, Semigroup v) + => NonEmpty (Normal.Update v b) -> Property prop_resolveEntriesNormalSemantics es = expected === real where expected = Just . unNormalUpdateSG . sconcat . fmap NormalUpdateSG $ es @@ -72,10 +72,10 @@ instance Semigroup (Unlawful a) where _ <> _ = error "unlawful" -- | Semigroup wrapper for 'Normal.Update' -newtype NormalUpdateSG v blob = NormalUpdateSG (Normal.Update v blob) +newtype NormalUpdateSG v b = NormalUpdateSG (Normal.Update v b) deriving stock (Show, Eq) deriving newtype (Arbitrary) - deriving Semigroup via First (Normal.Update v blob) + deriving Semigroup via First (Normal.Update v b) unNormalUpdateSG :: NormalUpdateSG v b -> Normal.Update v b unNormalUpdateSG (NormalUpdateSG x) = x @@ -96,11 +96,11 @@ instance Semigroup v => Semigroup (MonoidalUpdateSG v) where (Monoidal.Mupsert v1 , Monoidal.Insert v2) -> Monoidal.Insert (v1 <> v2) (Monoidal.Mupsert v1 , Monoidal.Mupsert v2) -> Monoidal.Mupsert (v1 <> v2) -newtype EntrySG v blob = EntrySG (Entry v blob) +newtype EntrySG v b = EntrySG (Entry v b) deriving stock (Show, Eq) deriving newtype Semigroup -instance (Arbitrary v, Arbitrary blob) => Arbitrary (EntrySG v blob) where +instance (Arbitrary v, Arbitrary b) => Arbitrary (EntrySG v b) where arbitrary = arbitrary2 shrink = shrink2 @@ -134,26 +134,26 @@ instance Arbitrary BlobSpanSG where Injections/projections -------------------------------------------------------------------------------} -updateToEntryNormal :: Normal.Update v blob -> Entry v blob +updateToEntryNormal :: Normal.Update v b -> Entry v b updateToEntryNormal = \case Normal.Insert v Nothing -> Insert v Normal.Insert v (Just b) -> InsertWithBlob v b Normal.Delete -> Delete -entryToUpdateNormal :: Entry v blob -> Maybe (Normal.Update v blob) +entryToUpdateNormal :: Entry v b -> Maybe (Normal.Update v b) entryToUpdateNormal = \case Insert v -> Just (Normal.Insert v Nothing) InsertWithBlob v b -> Just (Normal.Insert v (Just b)) Mupdate _ -> Nothing Delete -> Just Normal.Delete -updateToEntryMonoidal :: Monoidal.Update v -> Entry v blob +updateToEntryMonoidal :: Monoidal.Update v -> Entry v b updateToEntryMonoidal = \case Monoidal.Insert v -> Insert v Monoidal.Mupsert v -> Mupdate v Monoidal.Delete -> Delete -entryToUpdateMonoidal :: Entry v blob -> Maybe (Monoidal.Update v) +entryToUpdateMonoidal :: Entry v b -> Maybe (Monoidal.Update v) entryToUpdateMonoidal = \case Insert v -> Just (Monoidal.Insert v) InsertWithBlob _ _ -> Nothing diff --git a/test/Test/Database/LSMTree/Normal/StateMachine.hs b/test/Test/Database/LSMTree/Normal/StateMachine.hs index 82251ffec..d67eac443 100644 --- a/test/Test/Database/LSMTree/Normal/StateMachine.hs +++ b/test/Test/Database/LSMTree/Normal/StateMachine.hs @@ -39,9 +39,9 @@ to also retrieve blob references from a mix of different batch lookups and/or range lookups. This would require some non-trivial changes, such as changes to 'Op' to also include expressions for manipulating lists, such that we can map - @'Var' ['R.BlobRef' blob]@ to @'Var' ('R.BlobRef' blob)@. 'RetrieveBlobs' - would then hold a list of variables (e.g., @['Var' ('R.BlobRef blob')]@) - instead of a variable of a list (@'Var' ['R.BlobRef' blob]@). + @'Var' ['R.BlobRef' b]@ to @'Var' ('R.BlobRef' b)@. 'RetrieveBlobs' + would then hold a list of variables (e.g., @['Var' ('R.BlobRef b')]@) + instead of a variable of a list (@'Var' ['R.BlobRef' b]@). TODO: it is currently not correctly modelled what happens if blob references are retrieved from an incorrect table. @@ -405,7 +405,7 @@ type V a = ( ) -- | Common constraints for keys, values and blobs -type C k v blob = (K k, V v, V blob) +type C k v b = (K k, V v, V b) {------------------------------------------------------------------------------- StateModel @@ -418,59 +418,59 @@ instance ( Show (Class.TableConfig h) ) => StateModel (Lockstep (ModelState h)) where data instance Action (Lockstep (ModelState h)) a where -- Tables - New :: C k v blob - => {-# UNPACK #-} !(PrettyProxy (k, v, blob)) + New :: C k v b + => {-# UNPACK #-} !(PrettyProxy (k, v, b)) -> Class.TableConfig h - -> Act h (WrapTable h IO k v blob) - Close :: C k v blob - => Var h (WrapTable h IO k v blob) + -> Act h (WrapTable h IO k v b) + Close :: C k v b + => Var h (WrapTable h IO k v b) -> Act h () -- Queries - Lookups :: C k v blob - => V.Vector k -> Var h (WrapTable h IO k v blob) - -> Act h (V.Vector (LookupResult v (WrapBlobRef h IO blob))) - RangeLookup :: (C k v blob, Ord k) - => R.Range k -> Var h (WrapTable h IO k v blob) - -> Act h (V.Vector (QueryResult k v (WrapBlobRef h IO blob))) + Lookups :: C k v b + => V.Vector k -> Var h (WrapTable h IO k v b) + -> Act h (V.Vector (LookupResult v (WrapBlobRef h IO b))) + RangeLookup :: (C k v b, Ord k) + => R.Range k -> Var h (WrapTable h IO k v b) + -> Act h (V.Vector (QueryResult k v (WrapBlobRef h IO b))) -- Cursor - NewCursor :: C k v blob + NewCursor :: C k v b => Maybe k - -> Var h (WrapTable h IO k v blob) - -> Act h (WrapCursor h IO k v blob) - CloseCursor :: C k v blob - => Var h (WrapCursor h IO k v blob) + -> Var h (WrapTable h IO k v b) + -> Act h (WrapCursor h IO k v b) + CloseCursor :: C k v b + => Var h (WrapCursor h IO k v b) -> Act h () - ReadCursor :: C k v blob + ReadCursor :: C k v b => Int - -> Var h (WrapCursor h IO k v blob) - -> Act h (V.Vector (QueryResult k v (WrapBlobRef h IO blob))) + -> Var h (WrapCursor h IO k v b) + -> Act h (V.Vector (QueryResult k v (WrapBlobRef h IO b))) -- Updates - Updates :: C k v blob - => V.Vector (k, R.Update v blob) -> Var h (WrapTable h IO k v blob) + Updates :: C k v b + => V.Vector (k, R.Update v b) -> Var h (WrapTable h IO k v b) -> Act h () - Inserts :: C k v blob - => V.Vector (k, v, Maybe blob) -> Var h (WrapTable h IO k v blob) + Inserts :: C k v b + => V.Vector (k, v, Maybe b) -> Var h (WrapTable h IO k v b) -> Act h () - Deletes :: C k v blob - => V.Vector k -> Var h (WrapTable h IO k v blob) + Deletes :: C k v b + => V.Vector k -> Var h (WrapTable h IO k v b) -> Act h () -- Blobs - RetrieveBlobs :: V blob - => Var h (V.Vector (WrapBlobRef h IO blob)) - -> Act h (V.Vector (WrapBlob blob)) + RetrieveBlobs :: V b + => Var h (V.Vector (WrapBlobRef h IO b)) + -> Act h (V.Vector (WrapBlob b)) -- Snapshots - CreateSnapshot :: (C k v blob, R.Labellable (k, v, blob)) - => R.SnapshotName -> Var h (WrapTable h IO k v blob) + CreateSnapshot :: (C k v b, R.Labellable (k, v, b)) + => R.SnapshotName -> Var h (WrapTable h IO k v b) -> Act h () - OpenSnapshot :: (C k v blob, R.Labellable (k, v, blob)) + OpenSnapshot :: (C k v b, R.Labellable (k, v, b)) => R.SnapshotName - -> Act h (WrapTable h IO k v blob) + -> Act h (WrapTable h IO k v b) DeleteSnapshot :: R.SnapshotName -> Act h () ListSnapshots :: Act h [R.SnapshotName] -- Multiple writable tables - Duplicate :: C k v blob - => Var h (WrapTable h IO k v blob) - -> Act h (WrapTable h IO k v blob) + Duplicate :: C k v b + => Var h (WrapTable h IO k v b) + -> Act h (WrapTable h IO k v b) initialState = Lockstep.Defaults.initialState initModelState nextState = Lockstep.Defaults.nextState @@ -562,21 +562,21 @@ instance ( Eq (Class.TableConfig h) type instance ModelOp (ModelState h) = Op data instance ModelValue (ModelState h) a where - MTable :: Model.Table k v blob - -> Val h (WrapTable h IO k v blob) - MCursor :: Model.Cursor k v blob -> Val h (WrapCursor h IO k v blob) - MBlobRef :: Class.C_ blob - => Model.BlobRef blob -> Val h (WrapBlobRef h IO blob) - - MLookupResult :: (Class.C_ v, Class.C_ blob) - => LookupResult v (Val h (WrapBlobRef h IO blob)) - -> Val h (LookupResult v (WrapBlobRef h IO blob)) - MQueryResult :: Class.C k v blob - => QueryResult k v (Val h (WrapBlobRef h IO blob)) - -> Val h (QueryResult k v (WrapBlobRef h IO blob)) - - MBlob :: (Show blob, Typeable blob, Eq blob) - => WrapBlob blob -> Val h (WrapBlob blob) + MTable :: Model.Table k v b + -> Val h (WrapTable h IO k v b) + MCursor :: Model.Cursor k v b -> Val h (WrapCursor h IO k v b) + MBlobRef :: Class.C_ b + => Model.BlobRef b -> Val h (WrapBlobRef h IO b) + + MLookupResult :: (Class.C_ v, Class.C_ b) + => LookupResult v (Val h (WrapBlobRef h IO b)) + -> Val h (LookupResult v (WrapBlobRef h IO b)) + MQueryResult :: Class.C k v b + => QueryResult k v (Val h (WrapBlobRef h IO b)) + -> Val h (QueryResult k v (WrapBlobRef h IO b)) + + MBlob :: (Show b, Typeable b, Eq b) + => WrapBlob b -> Val h (WrapBlob b) MSnapshotName :: R.SnapshotName -> Val h R.SnapshotName MErr :: Model.Err -> Val h Model.Err @@ -587,18 +587,18 @@ instance ( Eq (Class.TableConfig h) MVector :: V.Vector (Val h a) -> Val h (V.Vector a) data instance Observable (ModelState h) a where - OTable :: Obs h (WrapTable h IO k v blob) - OCursor :: Obs h (WrapCursor h IO k v blob) - OBlobRef :: Obs h (WrapBlobRef h IO blob) - - OLookupResult :: (Class.C_ v, Class.C_ blob) - => LookupResult v (Obs h (WrapBlobRef h IO blob)) - -> Obs h (LookupResult v (WrapBlobRef h IO blob)) - OQueryResult :: Class.C k v blob - => QueryResult k v (Obs h (WrapBlobRef h IO blob)) - -> Obs h (QueryResult k v (WrapBlobRef h IO blob)) - OBlob :: (Show blob, Typeable blob, Eq blob) - => WrapBlob blob -> Obs h (WrapBlob blob) + OTable :: Obs h (WrapTable h IO k v b) + OCursor :: Obs h (WrapCursor h IO k v b) + OBlobRef :: Obs h (WrapBlobRef h IO b) + + OLookupResult :: (Class.C_ v, Class.C_ b) + => LookupResult v (Obs h (WrapBlobRef h IO b)) + -> Obs h (LookupResult v (WrapBlobRef h IO b)) + OQueryResult :: Class.C k v b + => QueryResult k v (Obs h (WrapBlobRef h IO b)) + -> Obs h (QueryResult k v (WrapBlobRef h IO b)) + OBlob :: (Show b, Typeable b, Eq b) + => WrapBlob b -> Obs h (WrapBlob b) OId :: (Show a, Typeable a, Eq a) => a -> Obs h a @@ -926,16 +926,16 @@ runModel lookUp = \case . Model.runModelM (Model.duplicate (getTable $ lookUp tableVar)) where getTable :: - ModelValue (ModelState h) (WrapTable h IO k v blob) - -> Model.Table k v blob + ModelValue (ModelState h) (WrapTable h IO k v b) + -> Model.Table k v b getTable (MTable t) = t getCursor :: - ModelValue (ModelState h) (WrapCursor h IO k v blob) - -> Model.Cursor k v blob + ModelValue (ModelState h) (WrapCursor h IO k v b) + -> Model.Cursor k v b getCursor (MCursor t) = t - getBlobRefs :: ModelValue (ModelState h) (V.Vector (WrapBlobRef h IO blob)) -> V.Vector (Model.BlobRef blob) + getBlobRefs :: ModelValue (ModelState h) (V.Vector (WrapBlobRef h IO b)) -> V.Vector (Model.BlobRef b) getBlobRefs (MVector brs) = fmap (\(MBlobRef br) -> br) brs wrap :: @@ -1065,16 +1065,16 @@ catchErr (Handler f) action = catch (Right <$> action) f' -------------------------------------------------------------------------------} arbitraryActionWithVars :: - forall h k v blob. ( - C k v blob + forall h k v b. ( + C k v b , Ord k - , R.Labellable (k, v, blob) + , R.Labellable (k, v, b) , Eq (Class.TableConfig h) , Show (Class.TableConfig h) , Arbitrary (Class.TableConfig h) , Typeable h ) - => Proxy (k, v, blob) + => Proxy (k, v, b) -> ModelVarContext (ModelState h) -> ModelState h -> Gen (Any (LockstepAction (ModelState h))) @@ -1108,7 +1108,7 @@ arbitraryActionWithVars _ ctx (ModelState st _stats) = genTableVar = QC.elements tableVars - tableVars :: [Var h (WrapTable h IO k v blob)] + tableVars :: [Var h (WrapTable h IO k v b)] tableVars = [ fromRight v | v <- findVars ctx Proxy @@ -1120,7 +1120,7 @@ arbitraryActionWithVars _ ctx (ModelState st _stats) = genCursorVar = QC.elements cursorVars - cursorVars :: [Var h (WrapCursor h IO k v blob)] + cursorVars :: [Var h (WrapCursor h IO k v b)] cursorVars = [ fromRight v | v <- findVars ctx Proxy @@ -1132,12 +1132,12 @@ arbitraryActionWithVars _ ctx (ModelState st _stats) = genBlobRefsVar = QC.elements blobRefsVars - blobRefsVars :: [Var h (V.Vector (WrapBlobRef h IO blob))] + blobRefsVars :: [Var h (V.Vector (WrapBlobRef h IO b))] blobRefsVars = fmap (mapGVar (OpComp OpLookupResults)) lookupResultVars ++ fmap (mapGVar (OpComp OpQueryResults)) queryResultVars where - lookupResultVars :: [Var h (V.Vector (LookupResult v (WrapBlobRef h IO blob)))] - queryResultVars :: [Var h (V.Vector (QueryResult k v (WrapBlobRef h IO blob)))] + lookupResultVars :: [Var h (V.Vector (LookupResult v (WrapBlobRef h IO b)))] + queryResultVars :: [Var h (V.Vector (QueryResult k v (WrapBlobRef h IO b)))] lookupResultVars = fromRight <$> findVars ctx Proxy queryResultVars = fromRight <$> findVars ctx Proxy @@ -1157,10 +1157,10 @@ arbitraryActionWithVars _ ctx (ModelState st _stats) = genActionsSession :: [(Int, Gen (Any (LockstepAction (ModelState h))))] genActionsSession = - [ (1, fmap Some $ New @k @v @blob PrettyProxy <$> QC.arbitrary) + [ (1, fmap Some $ New @k @v @b PrettyProxy <$> QC.arbitrary) | length tableVars <= 5 ] -- no more than 5 tables at once - ++ [ (1, fmap Some $ OpenSnapshot @k @v @blob <$> genUsedSnapshotName) + ++ [ (1, fmap Some $ OpenSnapshot @k @v @b <$> genUsedSnapshotName) | not (null usedSnapshotNames) ] ++ [ (1, fmap Some $ DeleteSnapshot <$> genUsedSnapshotName) @@ -1216,24 +1216,24 @@ arbitraryActionWithVars _ ctx (ModelState st _stats) = genRange :: Gen (R.Range k) genRange = QC.arbitrary - genUpdates :: Gen (V.Vector (k, R.Update v blob)) + genUpdates :: Gen (V.Vector (k, R.Update v b)) genUpdates = QC.liftArbitrary ((,) <$> QC.arbitrary <*> QC.oneof [ R.Insert <$> QC.arbitrary <*> genBlob , pure R.Delete ]) where - _coveredAllCases :: R.Update v blob -> () + _coveredAllCases :: R.Update v b -> () _coveredAllCases = \case R.Insert{} -> () R.Delete{} -> () - genInserts :: Gen (V.Vector (k, v, Maybe blob)) + genInserts :: Gen (V.Vector (k, v, Maybe b)) genInserts = QC.liftArbitrary ((,,) <$> QC.arbitrary <*> QC.arbitrary <*> genBlob) genDeletes :: Gen (V.Vector k) genDeletes = QC.arbitrary - genBlob :: Gen (Maybe blob) + genBlob :: Gen (Maybe b) genBlob = QC.arbitrary shrinkActionWithVars :: @@ -1412,7 +1412,7 @@ updateStats action lookUp modelBefore _modelAfter result = } _ -> stats where - countAll :: forall k v blob. V.Vector (k, R.Update v blob) -> (Int, Int, Int) + countAll :: forall k v b. V.Vector (k, R.Update v b) -> (Int, Int, Int) countAll upds = let count :: (Int, Int, Int) -> (k, R.Update v blob) @@ -1472,7 +1472,7 @@ updateStats action lookUp modelBefore _modelAfter result = ListSnapshots{} -> stats where -- Init to 0 so we get an accurate count of tables with no actions. - initCount :: forall k v blob. Model.Table k v blob -> Stats + initCount :: forall k v b. Model.Table k v b -> Stats initCount table = let tid = Model.tableID table in stats { @@ -1480,8 +1480,8 @@ updateStats action lookUp modelBefore _modelAfter result = } -- Note that batches (of inserts lookups etc) count as one action. - updateCount :: forall k v blob. - Var h (WrapTable h IO k v blob) + updateCount :: forall k v b. + Var h (WrapTable h IO k v b) -> Stats updateCount tableVar = let tid = getTableId (lookUp tableVar) @@ -1545,7 +1545,7 @@ updateStats action lookUp modelBefore _modelAfter result = where -- add the current table to the front of the list of tables, if it's -- not the latest one already - updateLastActionLog :: GVar Op (WrapTable h IO k v blob) -> Stats + updateLastActionLog :: GVar Op (WrapTable h IO k v b) -> Stats updateLastActionLog tableVar = case Map.lookup pthid (dupTableActionLog stats) of Just (thid' : _) @@ -1565,7 +1565,7 @@ updateStats action lookUp modelBefore _modelAfter result = updDupTableActionLog stats = stats - getTableId :: ModelValue (ModelState h) (WrapTable h IO k v blob) + getTableId :: ModelValue (ModelState h) (WrapTable h IO k v b) -> Model.TableID getTableId (MTable t) = Model.tableID t diff --git a/test/Test/Database/LSMTree/Normal/StateMachine/Op.hs b/test/Test/Database/LSMTree/Normal/StateMachine/Op.hs index 451810743..8f98d5449 100644 --- a/test/Test/Database/LSMTree/Normal/StateMachine/Op.hs +++ b/test/Test/Database/LSMTree/Normal/StateMachine/Op.hs @@ -40,8 +40,8 @@ data Op a b where OpFromLeft :: Op (Either a b) a OpFromRight :: Op (Either a b) b OpComp :: Op b c -> Op a b -> Op a c - OpLookupResults :: Op (V.Vector (Class.LookupResult v (WrapBlobRef h IO blobref))) (V.Vector (WrapBlobRef h IO blobref)) - OpQueryResults :: Op (V.Vector (Class.QueryResult k v (WrapBlobRef h IO blobref))) (V.Vector (WrapBlobRef h IO blobref)) + OpLookupResults :: Op (V.Vector (Class.LookupResult v (WrapBlobRef h IO b))) (V.Vector (WrapBlobRef h IO b)) + OpQueryResults :: Op (V.Vector (Class.QueryResult k v (WrapBlobRef h IO b))) (V.Vector (WrapBlobRef h IO b)) intOpId :: Op a b -> a -> Maybe b intOpId OpId = Just @@ -155,7 +155,7 @@ instance Show (Op a b) where -------------------------------------------------------------------------------} class HasBlobRef f where - getBlobRef :: f blobref -> Maybe blobref + getBlobRef :: f b -> Maybe b instance HasBlobRef (Class.LookupResult v) where getBlobRef Class.NotFound{} = Nothing diff --git a/test/Test/Util/Orphans.hs b/test/Test/Util/Orphans.hs index 8f895f117..424541b9e 100644 --- a/test/Test/Util/Orphans.hs +++ b/test/Test/Util/Orphans.hs @@ -46,16 +46,16 @@ type family RealizeIOSim s a where RealizeIOSim s (Real.TMVar a) = TMVar (IOSim s) a RealizeIOSim s (Real.MVar a) = MVar (IOSim s) a -- lsm-tree - RealizeIOSim s (Table IO k v blob) = Table (IOSim s) k v blob - RealizeIOSim s (LookupResult v blobref) = LookupResult v (RealizeIOSim s blobref) - RealizeIOSim s (QueryResult k v blobref) = QueryResult k v (RealizeIOSim s blobref) - RealizeIOSim s (Cursor IO k v blob) = Table (IOSim s) k v blob - RealizeIOSim s (BlobRef IO blob) = BlobRef (IOSim s) blob + RealizeIOSim s (Table IO k v b) = Table (IOSim s) k v b + RealizeIOSim s (LookupResult v b) = LookupResult v (RealizeIOSim s b) + RealizeIOSim s (QueryResult k v b) = QueryResult k v (RealizeIOSim s b) + RealizeIOSim s (Cursor IO k v b) = Table (IOSim s) k v b + RealizeIOSim s (BlobRef IO b) = BlobRef (IOSim s) b -- Type family wrappers - RealizeIOSim s (WrapTable h IO k v blob) = WrapTable h (IOSim s) k v blob - RealizeIOSim s (WrapCursor h IO k v blob) = WrapCursor h (IOSim s) k v blob - RealizeIOSim s (WrapBlobRef h IO blob) = WrapBlobRef h (IOSim s) blob - RealizeIOSim s (WrapBlob blob) = WrapBlob blob + RealizeIOSim s (WrapTable h IO k v b) = WrapTable h (IOSim s) k v b + RealizeIOSim s (WrapCursor h IO k v b) = WrapCursor h (IOSim s) k v b + RealizeIOSim s (WrapBlobRef h IO b) = WrapBlobRef h (IOSim s) b + RealizeIOSim s (WrapBlob b) = WrapBlob b -- Congruence RealizeIOSim s (f a b) = f (RealizeIOSim s a) (RealizeIOSim s b) RealizeIOSim s (f a) = f (RealizeIOSim s a) diff --git a/test/Test/Util/TypeFamilyWrappers.hs b/test/Test/Util/TypeFamilyWrappers.hs index 3ad8b4c36..469f6b828 100644 --- a/test/Test/Util/TypeFamilyWrappers.hs +++ b/test/Test/Util/TypeFamilyWrappers.hs @@ -33,30 +33,30 @@ newtype WrapSession h m = WrapSession { type WrapTable :: ((Type -> Type) -> Type -> Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type -> Type -newtype WrapTable h m k v blob = WrapTable { - unwrapTable :: h m k v blob +newtype WrapTable h m k v b = WrapTable { + unwrapTable :: h m k v b } deriving stock (Show, Eq) type WrapCursor :: ((Type -> Type) -> Type -> Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type -> Type -newtype WrapCursor h m k v blob = WrapCursor { - unwrapCursor :: SUT.Class.Cursor h m k v blob +newtype WrapCursor h m k v b = WrapCursor { + unwrapCursor :: SUT.Class.Cursor h m k v b } type WrapBlobRef :: ((Type -> Type) -> Type -> Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -newtype WrapBlobRef h m blob = WrapBlobRef { - unwrapBlobRef :: SUT.Class.BlobRef h m blob +newtype WrapBlobRef h m b = WrapBlobRef { + unwrapBlobRef :: SUT.Class.BlobRef h m b } -deriving stock instance Show (SUT.Class.BlobRef h m blob) => Show (WrapBlobRef h m blob) -deriving stock instance Eq (SUT.Class.BlobRef h m blob) => Eq (WrapBlobRef h m blob) +deriving stock instance Show (SUT.Class.BlobRef h m b) => Show (WrapBlobRef h m b) +deriving stock instance Eq (SUT.Class.BlobRef h m b) => Eq (WrapBlobRef h m b) type WrapBlob :: Type -> Type -newtype WrapBlob blob = WrapBlob { - unwrapBlob :: blob +newtype WrapBlob b = WrapBlob { + unwrapBlob :: b } deriving stock (Show, Eq)