Add tests for SomeSerialisationConstraint
- Include "not-so-trivial" instance for Word64
- Include "not-so-trivial" instance for Word64
main-is: Main.hs
other-modules:
Test.Database.LSMTree
Test.Database.LSMTree.Model.Common
Test.Database.LSMTree.Model.Monoidal
Test.Database.LSMTree.Model.Normal
build-depends:
, base >=4.14 && <4.19
, bytestring
, deepseq
, fs-api
, fs-sim ^>=0.2
, io-sim ^>=1.2
, SomeUpdateConstraint (..)
) where
import Data.Bits (shiftR, (.&.))
import qualified Data.ByteString as BS
import Data.Word (Word64)
class SomeSerialisationConstraint a where
serialise :: a -> BS.ByteString
instance SomeUpdateConstraint BS.ByteString where
merge = (<>)
-- | MSB, so order is preserved.
instance SomeSerialisationConstraint Word64 where
serialise w = BS.pack [b1,b2,b3,b4,b5,b6,b7,b8] where
b8 = fromIntegral $ w .&. 0xff
b7 = fromIntegral $ shiftR w 8 .&. 0xff
b6 = fromIntegral $ shiftR w 16 .&. 0xff
b5 = fromIntegral $ shiftR w 24 .&. 0xff
b4 = fromIntegral $ shiftR w 32 .&. 0xff
b3 = fromIntegral $ shiftR w 40 .&. 0xff
b2 = fromIntegral $ shiftR w 48 .&. 0xff
b1 = fromIntegral $ shiftR w 56 .&. 0xff
deserialise = BS.foldl' (\acc d -> acc * 0x100 + fromIntegral d) 0
module Main (main) where
import Test.Database.LSMTree (tests)
import qualified Test.Database.LSMTree.Model.Common
import qualified Test.Database.LSMTree.Model.Monoidal
import qualified Test.Database.LSMTree.Model.Normal
import Test.Tasty
main :: IO ()
main = defaultMain $ testGroup "lsm-tree"
[ tests
, Test.Database.LSMTree.Model.Common.tests
, Test.Database.LSMTree.Model.Normal.tests
, Test.Database.LSMTree.Model.Monoidal.tests
]
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Database.LSMTree.Model.Common (tests) where
import Control.DeepSeq (NFData, deepseq)
import qualified Data.ByteString as BS
import Data.Proxy (Proxy (..))
import Data.Word (Word64)
import Database.LSMTree.Model.Normal
(SomeSerialisationConstraint (..))
import Test.QuickCheck.Instances ()
import Test.Tasty
import Test.Tasty.QuickCheck
tests :: TestTree
tests = testGroup "Database.LSMTree.Model.Common"
[ testGroup "SomeSerialisationConstraint Word64"
-- Note: unfortunately Arbitrary Word64 doesn't generate uniformly from whole range.
[ decodeEncodeRoundtrip (Proxy @Word64)
, totalDeserialiseProp (Proxy @Word64)
, preservesOrderProp (Proxy @Word64)
]
, testGroup "SomeSerialisationConstraint ByteString"
[ decodeEncodeRoundtrip (Proxy @BS.ByteString)
, totalDeserialiseProp (Proxy @BS.ByteString)
, preservesOrderProp (Proxy @BS.ByteString)
]
]
-- | decode encode rountrip.
--
-- Note: this also indirectly tests that 'deserialise' doesn't fail
-- on bytestrings produced by 'serialise'.
--
-- All (?) serialisation libraries guarantee this.
--
decodeEncodeRoundtrip :: forall a.
(Eq a, Show a, Arbitrary a, SomeSerialisationConstraint a)
=> Proxy a -> TestTree
decodeEncodeRoundtrip _ = testProperty "decode-encode roundtrip" prop where
prop :: a -> Property
prop x = deserialise (serialise x) === x
-- | Strong 'deserialise' check.
-- We check that 'deserialise' is indeed total function.
--
-- Hardly any general serialisation library guarantee this.
--
totalDeserialiseProp :: forall a.
(NFData a, SomeSerialisationConstraint a)
=> Proxy a -> TestTree
totalDeserialiseProp _ = testProperty "deserialize total" prop where
prop bs = property $ deserialise @a bs `deepseq` True
-- | Serialisation MUST preserve order.
preservesOrderProp :: forall a.
(Ord a, Show a, Arbitrary a, SomeSerialisationConstraint a)
=> Proxy a -> TestTree
preservesOrderProp _ = testProperty "preserves order" prop where
prop :: a -> a -> Property
prop x y = compare x y === compare (serialise x) (serialise y)
Alonzo builds