Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
23 changes: 13 additions & 10 deletions src/Database/LSMTree/Monoidal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -100,8 +100,8 @@ module Database.LSMTree.Monoidal (
-- * Persistence
, duplicate

-- * Merging tables
, merge
-- * Table union
, union

-- * Concurrency
-- $concurrency
Expand Down Expand Up @@ -652,30 +652,33 @@ duplicate :: forall m k v.
duplicate (Internal.MonoidalTable t) = Internal.MonoidalTable <$> Internal.duplicate t

{-------------------------------------------------------------------------------
Merging tables
Table union
-------------------------------------------------------------------------------}

{-# SPECIALISE merge ::
{-# SPECIALISE union ::
ResolveValue v
=> Table IO k v
-> Table IO k v
-> IO (Table IO k v) #-}
-- | Merge full tables, creating a new table.
-- | Union two full tables, creating a new table.
--
-- A good mental model of this operation is @'Data.Map.unionWith' (<>)@ on
-- @'Data.Map.Map' k v@.
--
-- Multiple tables of the same type but with different configuration parameters
-- can live in the same session. However, 'merge' only works for tables that
-- can live in the same session. However, 'union' only works for tables that
-- have the same key\/value types and configuration parameters.
--
-- NOTE: merging tables creates a new table, but does not close
-- the tables that were used as inputs.
merge :: forall m k v.
-- NOTE: unioning tables creates a new table, but does not close the tables that
-- were used as inputs.
union :: forall m k v.
( IOLike m
, ResolveValue v
)
=> Table m k v
-> Table m k v
-> m (Table m k v)
merge = undefined
union = undefined

{-------------------------------------------------------------------------------
Monoidal value resolution
Expand Down
10 changes: 5 additions & 5 deletions test/Database/LSMTree/Class/Monoidal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ module Database.LSMTree.Class.Monoidal (
, withTableNew
, withTableOpen
, withTableDuplicate
, withTableMerge
, withTableUnion
, withCursor
, module Types
) where
Expand Down Expand Up @@ -183,7 +183,7 @@ class (IsSession (Session h)) => IsTable h where
=> h m k v
-> m (h m k v)

merge ::
union ::
( IOLike m
, ResolveValue v
, SerialiseValue v
Expand Down Expand Up @@ -229,7 +229,7 @@ withTableDuplicate :: forall h m k v a.
-> m a
withTableDuplicate table = bracket (duplicate table) close

withTableMerge :: forall h m k v a.
withTableUnion :: forall h m k v a.
( IOLike m
, IsTable h
, SerialiseValue v
Expand All @@ -240,7 +240,7 @@ withTableMerge :: forall h m k v a.
-> h m k v
-> (h m k v -> m a)
-> m a
withTableMerge table1 table2 = bracket (merge table1 table2) close
withTableUnion table1 table2 = bracket (table1 `union` table2) close

withCursor :: forall h m k v a.
( IOLike m
Expand Down Expand Up @@ -281,4 +281,4 @@ instance IsTable R.Table where
open sesh snap = R.open sesh R.configNoOverride snap

duplicate = R.duplicate
merge = R.merge
union = R.union
4 changes: 2 additions & 2 deletions test/Database/LSMTree/Model/IO/Monoidal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,8 +72,8 @@ instance Class.IsTable Table where

duplicate (Table s t) = Table s <$> runInOpenSession s (Model.duplicate t)

merge (Table s1 t1) (Table _s2 t2) =
Table s1 <$> runInOpenSession s1 (Model.merge Model.getResolve t1 t2)
union (Table s1 t1) (Table _s2 t2) =
Table s1 <$> runInOpenSession s1 (Model.union Model.getResolve t1 t2)

convLookupResult :: Model.LookupResult v b -> Class.LookupResult v
convLookupResult = \case
Expand Down
12 changes: 6 additions & 6 deletions test/Database/LSMTree/Model/Session.hs
Original file line number Diff line number Diff line change
Expand Up @@ -71,8 +71,8 @@ module Database.LSMTree.Model.Session (
, listSnapshots
-- * Multiple writable tables
, duplicate
-- * Table merge
, merge
-- * Table union
, union
) where

import Control.Monad (when)
Expand Down Expand Up @@ -602,10 +602,10 @@ guardCursorIsOpen Cursor{..} =
pure (fromJust $ fromSomeCursor c)

{-------------------------------------------------------------------------------
Merging tables
Table union
-------------------------------------------------------------------------------}

merge ::
union ::
( MonadState Model m
, MonadError Err m
, C k v b
Expand All @@ -614,7 +614,7 @@ merge ::
-> Table k v b
-> Table k v b
-> m (Table k v b)
merge r th1 th2 = do
union r th1 th2 = do
(_, t1) <- guardTableIsOpen th1
(_, t2) <- guardTableIsOpen th2
newTableWith TableConfig $ Model.merge r t1 t2
newTableWith TableConfig $ Model.union r t1 t2
8 changes: 4 additions & 4 deletions test/Database/LSMTree/Model/Table.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,8 +36,8 @@ module Database.LSMTree.Model.Table (
, snapshot
-- * Multiple writable tables
, duplicate
-- * Table merge
, merge
-- * Table union
, union
-- * Testing
, size
) where
Expand Down Expand Up @@ -343,12 +343,12 @@ readCursor n c =
--
-- Multiple tables of the same type but with different configuration parameters
-- can live in the same session. However, some operations, like
merge ::
union ::
ResolveSerialisedValue v
-> Table k v b
-> Table k v b
-> Table k v b
merge r (Table xs) (Table ys) =
union r (Table xs) (Table ys) =
Table (Map.unionWith f xs ys)
where
f (v1, bMay1) (v2, bMay2) =
Expand Down
26 changes: 13 additions & 13 deletions test/Test/Database/LSMTree/Class/Monoidal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -98,7 +98,7 @@ tests = testGroup "Test.Database.LSMTree.Class.Monoidal"
, testProperty' "snapshot-nochanges" $ prop_snapshotNoChanges tbl
, testProperty' "snapshot-nochanges2" $ prop_snapshotNoChanges2 tbl
, testProperty' "lookup-mupsert" $ prop_lookupUpdate tbl
, testProperty' "merge" $ prop_merge tbl
, testProperty' "merge" $ prop_union tbl
]

-------------------------------------------------------------------------------
Expand Down Expand Up @@ -450,33 +450,33 @@ prop_lookupUpdate h ups k v1 v2 = ioProperty $ do
return $ res === V.singleton (Found (resolve v2 v1))

-------------------------------------------------------------------------------
-- implement classic QC tests for monoidal table merges
-- implement classic QC tests for monoidal table unions
-------------------------------------------------------------------------------

prop_merge :: forall h.
prop_union :: forall h.
IsTable h
=> Proxy h -> [(Key, Update Value)] -> [(Key, Update Value)]
-> [Key] -> Property
prop_merge h ups1 ups2 (V.fromList -> testKeys) = ioProperty $ do
prop_union h ups1 ups2 (V.fromList -> testKeys) = ioProperty $ do
withTableNew h ups1 $ \s hdl1 -> do
Class.withTableNew s (testTableConfig h) $ \hdl2 -> do
updates hdl2 $ V.fromList ups2

-- merge them.
Class.withTableMerge hdl1 hdl2 $ \hdl3 -> do
-- union them.
Class.withTableUnion hdl1 hdl2 $ \hdl3 -> do

-- results in parts and the merge table
-- results in parts and the union table
res1 <- lookups hdl1 testKeys
res2 <- lookups hdl2 testKeys
res3 <- lookups hdl3 testKeys

let mergeResult :: LookupResult Value -> LookupResult Value -> LookupResult Value
mergeResult r@NotFound NotFound = r
mergeResult NotFound r@(Found _) = r
mergeResult r@(Found _) NotFound = r
mergeResult (Found v1) (Found v2) = Found (resolve v1 v2)
let unionResult :: LookupResult Value -> LookupResult Value -> LookupResult Value
unionResult r@NotFound NotFound = r
unionResult NotFound r@(Found _) = r
unionResult r@(Found _) NotFound = r
unionResult (Found v1) (Found v2) = Found (resolve v1 v2)

return $ V.zipWith mergeResult res1 res2 == res3
return $ V.zipWith unionResult res1 res2 == res3

-------------------------------------------------------------------------------
-- implement classic QC tests for snapshots
Expand Down
2 changes: 1 addition & 1 deletion test/Test/Database/LSMTree/Class/Normal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -559,7 +559,7 @@ prop_updatesMayInvalidateBlobRefs h ups k1 v1 blob1 ups' = monadicIO $ do
{- Not applicable -}

-------------------------------------------------------------------------------
-- implement classic QC tests for monoidal table merges
-- implement classic QC tests for monoidal table unions
-------------------------------------------------------------------------------

{- Not applicable -}
Expand Down