Merge pull request #548 from IntersectMBO/jdral/normal-union

`First` semigroup instead of `First` monoid for blob semantics

Author: jorisdral

prototypes/ScheduledMerges.hs

@@ -235,10 +235,6 @@ newtype Value  = V Int
 resolveValue :: Value -> Value -> Value
 resolveValue (V x) (V y) = V (x + y)
 
-resolveBlob :: Maybe Blob -> Maybe Blob -> Maybe Blob
-resolveBlob (Just b) _ = Just b
-resolveBlob Nothing mb = mb
-
 newtype Blob = B Int
   deriving stock (Eq, Show)
 
@@ -456,29 +452,30 @@ mergek t =
     . Map.unionsWith (if isUnion t then combineUnion else combine)
 
 -- | Combines two entries that have been performed after another. Therefore, the
--- newer one overwrites the old one (or modifies it for 'Mupsert').
+-- newer one overwrites the old one (or modifies it for 'Mupsert'). Only take a
+-- blob from the left entry.
 combine :: Op -> Op -> Op
 combine new_ old = case new_ of
     Insert{}  -> new_
     Delete{}  -> new_
     Mupsert v -> case old of
-      Insert v' b -> Insert (resolveValue v v') b
+      Insert v' _ -> Insert (resolveValue v v') Nothing
       Delete      -> Insert v Nothing
       Mupsert v'  -> Mupsert (resolveValue v v')
 
 -- | Combines two entries of runs that have been 'union'ed together. If any one
 -- has a value, the result should have a value (represented by 'Insert'). If
--- both have a value, these values get combined monoidally.
+-- both have a value, these values get combined monoidally. Only take a blob
+-- from the left entry.
 --
 -- See 'MergeUnion'.
 combineUnion :: Op -> Op -> Op
 combineUnion Delete         old          = old
 combineUnion new_           Delete       = new_
 combineUnion (Mupsert v')   (Mupsert v ) = Insert (resolveValue v' v) Nothing
-combineUnion (Mupsert v')   (Insert v b) = Insert (resolveValue v' v) b
+combineUnion (Mupsert v')   (Insert v _) = Insert (resolveValue v' v) Nothing
 combineUnion (Insert v' b') (Mupsert v)  = Insert (resolveValue v' v) b'
-combineUnion (Insert v' b') (Insert v b) = Insert (resolveValue v' v)
-                                                  (resolveBlob b' b)
+combineUnion (Insert v' b') (Insert v _) = Insert (resolveValue v' v) b'
 
 expectCompletedMergingRun :: HasCallStack => MergingRun t s -> ST s Run
 expectCompletedMergingRun (MergingRun _ ref) = do

prototypes/ScheduledMergesTestQLS.hs

@@ -8,8 +8,8 @@ import           Data.Constraint (Dict (..))
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromJust)
-import           Data.Monoid (First (..))
 import           Data.Proxy
+import           Data.Semigroup (First (..))
 import           Prelude hiding (lookup)
 
 import           ScheduledMerges as LSM

src/Database/LSMTree/Internal.hs

@@ -1409,8 +1409,8 @@ matchBy eq (x0 :| xs) =
     matchOne :: a -> Int -> a -> Either Int ()
     matchOne x i y =
       if (x `eq` y)
-        then Left i
-        else Right ()
+        then Right ()
+        else Left i
 
 -- | Check that all tables in the session match. If so, return the matched
 -- session. If there is a mismatch, return the list indices of the mismatching

src/Database/LSMTree/Internal/Entry.hs

@@ -96,32 +96,34 @@ unNumEntries (NumEntries x) = x
 instance Semigroup v => Semigroup (Entry v b) where
   e1 <> e2 = combine (<>) e1 e2
 
--- | Given a value-merge function, combine entries
+-- | Given a value-merge function, combine entries. Only take a blob from the
+-- left entry.
 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
-combine _   (Mupdate u)       Delete                  = Insert u
-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)
+combine _ e@Delete            _                    = e
+combine _ e@Insert {}         _                    = e
+combine _ e@InsertWithBlob {} _                    = e
+combine _   (Mupdate u)       Delete               = Insert u
+combine f   (Mupdate u)       (Insert v)           = Insert (f u v)
+combine f   (Mupdate u)       (InsertWithBlob v _) = Insert (f u v)
+combine f   (Mupdate u)       (Mupdate v)          = Mupdate (f u v)
 
 -- | Combine two entries of runs that have been 'union'ed together. If any one
 -- has a value, the result should have a value (represented by 'Insert'). If
--- both have a value, these values get combined monoidally.
+-- both have a value, these values get combined monoidally. Only take a blob
+-- from the left entry.
 combineUnion :: (v -> v -> v) -> Entry v b -> Entry v b -> Entry v b
 combineUnion f = go
   where
     go Delete               e                    = e
     go e                    Delete               = e
     go (Insert u)           (Insert v)           = Insert (f u v)
-    go (Insert u)           (InsertWithBlob v b) = InsertWithBlob (f u v) b
+    go (Insert u)           (InsertWithBlob v _) = Insert (f u v)
     go (Insert u)           (Mupdate v)          = Insert (f u v)
     go (InsertWithBlob u b) (Insert v)           = InsertWithBlob (f u v) b
     go (InsertWithBlob u b) (InsertWithBlob v _) = InsertWithBlob (f u v) b
     go (InsertWithBlob u b) (Mupdate v)          = InsertWithBlob (f u v) b
     go (Mupdate u)          (Insert v)           = Insert (f u v)
-    go (Mupdate u)          (InsertWithBlob v b) = InsertWithBlob (f u v) b
+    go (Mupdate u)          (InsertWithBlob v _) = Insert (f u v)
     go (Mupdate u)          (Mupdate v)          = Insert (f u v)
 
 combineMaybe :: (v -> v -> v) -> Maybe (Entry v b) -> Maybe (Entry v b) -> Maybe (Entry v b)

src/Database/LSMTree/Internal/Merge.hs

@@ -363,6 +363,11 @@ doStepsUnion Merge {..} requestedSteps = go 0
     -- Similar to 'handleMupdate' in 'stepsLevel', but here we have to combine
     -- all entries monoidally, so there are no obsolete/overwritten entries
     -- that we could skip.
+    --
+    -- TODO(optimisation): If mergeMappend is const (which happens when calling
+    -- `union` on a non-monoidal table), we could skip all remaining entries for
+    -- the key. Unfortunately, we can't inspect the function. This would require
+    -- encoding it as something like `Const | Resolve (_ -> _ -> _)`.
     handleEntry !n !key !entry Readers.Drained = do
         -- no future entries, no previous entry to resolve, just write!
         writeReaderEntry mergeType mergeBuilder key entry

test/Database/LSMTree/Model/Table.hs

@@ -51,8 +51,8 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Map (Map)
 import qualified Data.Map.Range as Map.R
 import qualified Data.Map.Strict as Map
-import           Data.Monoid (First (..))
 import           Data.Proxy (Proxy (Proxy))
+import           Data.Semigroup (First (..))
 import qualified Data.Vector as V
 import           Database.LSMTree (LookupResult (..), QueryResult (..),
                      ResolveValue (..), Update (..))

test/Test/Database/LSMTree/Class.hs

@@ -591,9 +591,7 @@ prop_lookupUpdate h ups k v1 mb1 v2 = ioProperty $ do
       res <- lookupsWithBlobs tbl s (V.singleton k)
 
       -- notice the order.
-      return $ case mb1 of
-        Nothing -> res === V.singleton (Found (resolve v2 v1))
-        Just b1 -> res === V.singleton (FoundWithBlob (resolve v2 v1) b1)
+      return $ res === V.singleton (Found (resolve v2 v1))
 
 -------------------------------------------------------------------------------
 -- implement classic QC tests for monoidal table unions
@@ -629,8 +627,8 @@ prop_union h ups1 ups2 (V.fromList -> testKeys) = ioProperty $ do
                 = r
               unionResult   (Found v1) (Found v2)
                 = Found (resolve v1 v2)
-              unionResult   (Found v1) (FoundWithBlob v2 b2)
-                = FoundWithBlob (resolve v1 v2) b2
+              unionResult   (Found v1) (FoundWithBlob v2 _)
+                = Found (resolve v1 v2)
 
               unionResult r@(FoundWithBlob _ _)   NotFound
                 = r

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

@@ -170,8 +170,7 @@ prop_MergeUnion fs hbio stepSize (SmallList rds) =
         Entry.Mupdate v          -> Just (v, Nothing)
         Entry.Delete             -> Nothing
 
-    resolveValueAndBlob (v', Nothing) (v, b) = (mappendValues v' v, b)
-    resolveValueAndBlob (v', Just b)  (v, _) = (mappendValues v' v, Just b)
+    resolveValueAndBlob (v', b') (v, _) = (mappendValues v' v, b')
 
 -- | After merging for a few steps, we can prematurely abort the merge, which
 -- should clean up properly.

test/Test/Database/LSMTree/Model/Table.hs

@@ -7,7 +7,7 @@ import qualified Data.ByteString as BS
 import qualified Data.Vector as V
 import           Database.LSMTree.Common
 import           Database.LSMTree.Model.Table (LookupResult (..), Table,
-                     Update (..), lookups, retrieveBlobs)
+                     Update (..), lookups)
 import qualified Database.LSMTree.Model.Table as Model
 import           Database.LSMTree.Monoidal (ResolveValue (..),
                      resolveDeserialised)
@@ -84,9 +84,7 @@ prop_upsertDef k v tbl =
   where
     tbl' = case toList (lookups (V.singleton k) tbl) of
         [Found v'] -> inserts (V.singleton (k, resolve v v', Nothing)) tbl
-        [FoundWithBlob v' b'] ->
-              let [b] = V.toList $ retrieveBlobs (V.singleton b') in
-              inserts (V.singleton (k, resolve v v', Just b)) tbl
+        [FoundWithBlob v' _] -> inserts (V.singleton (k, resolve v v', Nothing)) tbl
         _          -> inserts (V.singleton (k, v, Nothing)) tbl
 
 -- | Different key inserts commute.