remove Totality requirement for ResolveValue

Author: mheinzel

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

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 (+)

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