diff --git a/src/Database/LSMTree/Internal/Serialise/Class.hs b/src/Database/LSMTree/Internal/Serialise/Class.hs index b63bbd843..4bab311e0 100644 --- a/src/Database/LSMTree/Internal/Serialise/Class.hs +++ b/src/Database/LSMTree/Internal/Serialise/Class.hs @@ -19,6 +19,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short.Internal as SBS +import Data.Monoid (Sum (..)) import qualified Data.Primitive as P import Data.Proxy (Proxy) import qualified Data.Vector.Primitive as VP @@ -88,6 +89,18 @@ class SerialiseValue v where -- TODO: Unused so far, we might not need it. deserialiseValueN :: [RawBytes] -> v + +-- | An instance for 'Sum' which is transparent to the serialisation of @a@. +-- +-- Note: If you want to serialize @Sum a@ differently than @a@, then you should +-- create another @newtype@ over 'Sum' and define your alternative serialization. +instance SerialiseValue a => SerialiseValue (Sum a) where + serialiseValue (Sum v) = serialiseValue v + + deserialiseValue = Sum . deserialiseValue + + deserialiseValueN = Sum . deserialiseValueN + -- | Test the __Identity__ law for the 'SerialiseValue' class serialiseValueIdentity :: (Eq v, SerialiseValue v) => v -> Bool serialiseValueIdentity x = deserialiseValue (serialiseValue x) == x diff --git a/src/Database/LSMTree/Monoidal.hs b/src/Database/LSMTree/Monoidal.hs index e086185f5..122abe582 100644 --- a/src/Database/LSMTree/Monoidal.hs +++ b/src/Database/LSMTree/Monoidal.hs @@ -99,7 +99,6 @@ module Database.LSMTree.Monoidal ( , resolveDeserialised -- ** Properties , resolveValueValidOutput - , resolveValueTotality , resolveValueAssociativity -- * Utility types @@ -111,9 +110,9 @@ import Control.Monad (void, (<$!>)) import Data.Bifunctor (Bifunctor (..)) import Data.Coerce (coerce) import Data.Kind (Type) +import Data.Monoid (Sum (..)) import Data.Typeable (Proxy (Proxy), Typeable) import qualified Data.Vector as V -import Data.Word (Word64) import Database.LSMTree.Common (IOLike, Range (..), SerialiseKey, SerialiseValue (..), Session (..), SnapshotName, closeSession, deleteSnapshot, listSnapshots, openSession, @@ -369,7 +368,7 @@ open (Session sesh) override snap = label = Common.makeSnapshotLabel (Proxy @(k, v)) <> " (monoidal)" {------------------------------------------------------------------------------- - Mutiple writable table handles + Multiple writable table handles -------------------------------------------------------------------------------} {-# SPECIALISE duplicate :: TableHandle IO k v -> IO (TableHandle IO k v) #-} @@ -435,25 +434,20 @@ merge = undefined -------------------------------------------------------------------------------} -- | A class to specify how to resolve/merge values when using monoidal updates --- (mupserts). This is required for merging entries during compaction and also --- for doing lookups, to resolve multiple entries of the same key on the fly. +-- ('Mupsert'). This is required for merging entries during compaction and also +-- for doing lookups, resolving multiple entries of the same key on the fly. -- The class has some laws, which should be tested (e.g. with QuickCheck). -- +-- It is okay to assume that the input bytes can be deserialised using +-- 'deserialiseValue', as they are produced by either 'serialiseValue' or +-- 'resolveValue' itself, which are required to produce deserialisable output. +-- -- Prerequisites: -- -- * [Valid Output] The result of resolution should always be deserialisable. -- See 'resolveValueValidOutput'. -- * [Associativity] Resolving values should be associative. -- See 'resolveValueAssociativity'. --- * [Totality] For any input 'RawBytes', resolution should successfully provide --- a result. This is a pretty strong requirement. Usually it is sufficient to --- handle input produced by 'serialiseValue' and 'resolveValue' (which are --- are required to be deserialisable by 'deserialiseValue'), --- but this makes sure no error occurs in the middle of compaction, which --- could lead to corruption. --- See 'resolveValueTotality'. --- --- TODO: Revisit Totality. How are errors handled during run merging? -- -- Future opportunities for optimisations: -- @@ -465,8 +459,10 @@ merge = undefined -- means that the inserted value is serialised and (if there is another value -- with the same key in the write buffer) immediately deserialised again. -- --- TODO: Should this go into @Internal.Monoidal@ or @Internal.ResolveValue@? -- TODO: The laws depend on 'SerialiseValue', should we make it a superclass? +-- TODO: should we additionally require Totality (for any input 'RawBytes', +-- resolution should successfully provide a result)? This could reduce the +-- risk of encountering errors during a run merge. class ResolveValue v where resolveValue :: Proxy v -> RawBytes -> RawBytes -> RawBytes @@ -486,13 +482,6 @@ resolveValueAssociativity (serialiseValue -> x) (serialiseValue -> y) (serialise where (<+>) = resolveValue (Proxy @v) --- | Test the __Totality__ law for the 'ResolveValue' class -resolveValueTotality :: - forall v. ResolveValue v - => Proxy v -> RawBytes -> RawBytes -> Bool -resolveValueTotality _ x y = - resolveValue (Proxy @v) x y `deepseq` True - -- | A helper function to implement 'resolveValue' by operating on the -- deserialised representation. Note that especially for simple types it -- should be possible to provide a more efficient implementation by directly @@ -502,14 +491,10 @@ resolveValueTotality _ x y = -- for 'resolveValue', but it's probably best to be explicit about instances. -- -- To satisfy the prerequisites of 'ResolveValue', the function provided to --- 'resolveDeserialised' should itself satisfy some properties. --- --- Prerequisites: +-- 'resolveDeserialised' should itself satisfy some properties: -- -- * [Associativity] The provided function should be associative. --- * [Total Resolution] The provided function should be total. --- * [Total Deserialisation] 'deserialiseValue' for @v@ should handle any input --- 'RawBytes'. +-- * [Totality] The provided function should be total. resolveDeserialised :: SerialiseValue v => (v -> v -> v) -> Proxy v -> RawBytes -> RawBytes -> RawBytes @@ -520,5 +505,7 @@ resolve :: ResolveValue v => Proxy v -> Internal.ResolveSerialisedValue resolve = coerce . resolveValue -- | Mostly to give an example instance (plus the property tests for it). -instance ResolveValue Word64 where +-- Additionally, this instance for 'Sum' provides a nice monoidal, numerical +-- aggregator. +instance (Num a, SerialiseValue a) => ResolveValue (Sum a) where resolveValue = resolveDeserialised (+) diff --git a/test/Test/Database/LSMTree/Monoidal.hs b/test/Test/Database/LSMTree/Monoidal.hs index d663d6685..09e60fd2c 100644 --- a/test/Test/Database/LSMTree/Monoidal.hs +++ b/test/Test/Database/LSMTree/Monoidal.hs @@ -1,35 +1,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Test.Database.LSMTree.Monoidal (tests) where import Control.DeepSeq (NFData) -import Data.Proxy (Proxy (Proxy)) +import Data.Monoid (Sum (..)) import Data.Word import Database.LSMTree.Extras.Generators () -import Database.LSMTree.Internal.RawBytes (RawBytes) import Database.LSMTree.Monoidal import Test.Tasty import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "Test.Database.LSMTree.Monoidal" - [ testGroup "Word64" (allProperties @Word64 False) - -- TODO: revisit totality (drop requirement or fix @SerialiseValue Word64@) + [ testGroup "Sum Word64" (allProperties @(Sum Word64)) ] allProperties :: forall v. (Show v, Arbitrary v, NFData v, SerialiseValue v, ResolveValue v) - => Bool -> [TestTree] -allProperties expectTotality = + => [TestTree] +allProperties = [ testProperty "prop_resolveValueValidOutput" $ withMaxSuccess 1000 $ prop_resolveValueValidOutput @v , testProperty "prop_resolveValueAssociativity" $ withMaxSuccess 1000 $ prop_resolveValueAssociativity @v - , testProperty "prop_resolveValueTotality" $ withMaxSuccess 1000 $ \x y -> - (if expectTotality then id else expectFailure) $ - prop_resolveValueTotality @v x y ] prop_resolveValueValidOutput :: @@ -45,10 +38,3 @@ prop_resolveValueAssociativity :: prop_resolveValueAssociativity x y z = counterexample ("inputs: " <> show (x, y)) $ resolveValueAssociativity x y z - -prop_resolveValueTotality :: - forall v. ResolveValue v - => RawBytes -> RawBytes -> Property -prop_resolveValueTotality x y = - counterexample ("inputs: " <> show (x, y)) $ - resolveValueTotality (Proxy @v) x y