Skip to content

Commit 11dba78

Browse files
recursion-ninjarecursion-ninja
committed
Adding type-class law properties for data-types exported from Database.LSMTree
1 parent c1bbd81 commit 11dba78

File tree

5 files changed

+1091
-9
lines changed

5 files changed

+1091
-9
lines changed

‎lsm-tree.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -689,6 +689,7 @@ test-suite lsm-tree-test
689689
Test.Database.LSMTree.Internal.BlobFile.FS
690690
Test.Database.LSMTree.Internal.BloomFilter
691691
Test.Database.LSMTree.Internal.Chunk
692+
Test.Database.LSMTree.Internal.Config
692693
Test.Database.LSMTree.Internal.CRC32C
693694
Test.Database.LSMTree.Internal.Entry
694695
Test.Database.LSMTree.Internal.Index.Compact
@@ -734,6 +735,7 @@ test-suite lsm-tree-test
734735
Test.Util.QC
735736
Test.Util.QLS
736737
Test.Util.RawPage
738+
Test.Util.TypeClassLaws
737739
Test.Util.TypeFamilyWrappers
738740

739741
build-depends:

‎test/Main.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ import qualified Test.Database.LSMTree.Internal.Arena
1212
import qualified Test.Database.LSMTree.Internal.BlobFile.FS
1313
import qualified Test.Database.LSMTree.Internal.BloomFilter
1414
import qualified Test.Database.LSMTree.Internal.Chunk
15+
import qualified Test.Database.LSMTree.Internal.Config
1516
import qualified Test.Database.LSMTree.Internal.CRC32C
1617
import qualified Test.Database.LSMTree.Internal.Entry
1718
import qualified Test.Database.LSMTree.Internal.Index.Compact
@@ -61,6 +62,7 @@ main = do
6162
, Test.Database.LSMTree.Internal.BlobFile.FS.tests
6263
, Test.Database.LSMTree.Internal.BloomFilter.tests
6364
, Test.Database.LSMTree.Internal.Chunk.tests
65+
, Test.Database.LSMTree.Internal.Config.tests
6466
, Test.Database.LSMTree.Internal.CRC32C.tests
6567
, Test.Database.LSMTree.Internal.Entry.tests
6668
, Test.Database.LSMTree.Internal.Index.Compact.tests

‎test/Test/Database/LSMTree.hs‎

Lines changed: 207 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,23 @@
1-
{-# LANGUAGE LambdaCase #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
{-# LANGUAGE RecordWildCards #-}
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# OPTIONS_GHC -Wno-orphans #-}
5+
6+
{-# LANGUAGE AllowAmbiguousTypes #-}
7+
{-# LANGUAGE ExplicitForAll #-}
8+
{-# LANGUAGE FlexibleContexts #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
10+
{-# LANGUAGE TypeApplications #-}
411

512
module Test.Database.LSMTree (tests) where
613

714
import Control.Exception
815
import Control.Tracer
16+
import Data.Foldable
917
import Data.Function (on)
1018
import Data.IORef
11-
import Data.Monoid
19+
import Data.Monoid (Sum (..))
20+
import Data.String (fromString)
1221
import Data.Typeable (Typeable)
1322
import qualified Data.Vector as V
1423
import qualified Data.Vector.Algorithms as VA
@@ -19,15 +28,17 @@ import Database.LSMTree.Extras (showRangesOf)
1928
import Database.LSMTree.Extras.Generators ()
2029
import qualified System.FS.API as FS
2130
import qualified System.FS.BlockIO.API as FS
22-
import Test.QuickCheck
23-
import Test.Tasty
31+
import Test.Database.LSMTree.Internal.Config ()
32+
import Test.Tasty (TestTree, testGroup)
2433
import Test.Tasty.QuickCheck
2534
import Test.Util.FS
35+
import Test.Util.TypeClassLaws
36+
2637

2738
tests :: TestTree
28-
tests = testGroup "Test.Database.LSMTree" [
29-
testGroup "Session" [
30-
-- openSession
39+
tests = testGroup "Test.Database.LSMTree"
40+
[ testGroup "Session"
41+
[ -- openSession
3142
testProperty "prop_openSession_newSession" prop_openSession_newSession
3243
, testProperty "prop_openSession_restoreSession" prop_openSession_restoreSession
3344
-- happy path
@@ -41,6 +52,16 @@ tests = testGroup "Test.Database.LSMTree" [
4152
-- salt
4253
, testProperty "prop_goodAndBadSessionSalt" prop_goodAndBadSessionSalt
4354
]
55+
, laws_Entry
56+
, laws_LookupResult
57+
, laws_Range
58+
, laws_RawBytes
59+
, laws_SnapshotName
60+
, laws_SnapshotLabel
61+
, laws_TableConfigOverride
62+
, laws_UnionCredits
63+
, laws_UnionDebt
64+
, laws_Update
4465
]
4566

4667
{-------------------------------------------------------------------------------
@@ -312,3 +333,180 @@ prop_goodAndBadSessionSalt (Positive (Small bufferSize)) ins =
312333
conf = defaultTableConfig {
313334
confWriteBufferAlloc = AllocNumEntries bufferSize
314335
}
336+
337+
{-------------------------------------------------------------------------------
338+
Type-class Laws
339+
-------------------------------------------------------------------------------}
340+
341+
-- |
342+
-- This alias exists for brevity in type signatures
343+
type W = Word
344+
345+
-- Entry
346+
347+
instance (Arbitrary k, Arbitrary v, Arbitrary b) => Arbitrary (Entry k v b) where
348+
349+
arbitrary = oneof
350+
[ Entry <$> arbitrary <*> arbitrary
351+
, EntryWithBlob <$> arbitrary <*> arbitrary <*> arbitrary
352+
]
353+
354+
shrink (Entry k v) = [ Entry k' v' | k' <- shrink k, v' <- shrink v ]
355+
shrink (EntryWithBlob k v b) =
356+
[ EntryWithBlob k' v' b' | k' <- shrink k, v' <- shrink v, b' <- shrink b ]
357+
358+
laws_Entry :: TestTree
359+
laws_Entry = testGroup "Entry"
360+
-- Basic control structures
361+
[ functorLaws @(Entry W W)
362+
, bifunctorLaws @(Entry W)
363+
, foldableLaws @(Entry W W)
364+
, traversableLaws @(Entry W W)
365+
-- Data structures
366+
, equalityLaws @(Entry W W W)
367+
, normalFormDataLaws @(Entry W W W)
368+
, showProperties @(Entry W W W)
369+
]
370+
371+
-- LookupResult
372+
373+
instance (Arbitrary v, Arbitrary b) => Arbitrary (LookupResult v b) where
374+
375+
arbitrary = oneof
376+
[ pure NotFound
377+
, Found <$> arbitrary
378+
, FoundWithBlob <$> arbitrary <*> arbitrary
379+
]
380+
381+
shrink NotFound = []
382+
shrink (Found v) = NotFound : [Found v' | v' <- shrink v]
383+
shrink (FoundWithBlob v b) = fold
384+
[ [NotFound, Found v]
385+
, [FoundWithBlob v' b | v' <- shrink v]
386+
, [FoundWithBlob v b' | b' <- shrink b]
387+
]
388+
389+
laws_LookupResult :: TestTree
390+
laws_LookupResult = testGroup "LookupResult"
391+
-- Basic control structures
392+
[ functorLaws @(LookupResult W)
393+
, bifunctorLaws @(LookupResult)
394+
, foldableLaws @(LookupResult W)
395+
, traversableLaws @(LookupResult W)
396+
-- Data structures
397+
, equalityLaws @(LookupResult W W)
398+
, normalFormDataLaws @(LookupResult W W)
399+
, showProperties @(LookupResult W W)
400+
]
401+
402+
-- Range
403+
404+
laws_Range :: TestTree
405+
laws_Range = testGroup "Range"
406+
[ functorLaws @(Range)
407+
, equalityLaws @(Range W)
408+
, normalFormDataLaws @(Range W)
409+
, showProperties @(Range W)
410+
]
411+
412+
-- RawBytes
413+
414+
laws_RawBytes :: TestTree
415+
laws_RawBytes = testGroup "RawBytes"
416+
[ equalityLaws @(RawBytes)
417+
, orderingLaws @(RawBytes)
418+
, semigroupLaws @(RawBytes)
419+
, monoidLaws @(RawBytes)
420+
, normalFormDataLaws @(RawBytes)
421+
, showProperties @(RawBytes)
422+
]
423+
424+
-- SnapshotName
425+
426+
instance Arbitrary SnapshotName where
427+
428+
arbitrary = toSnapshotName . getPrintableString <$>
429+
(arbitrary `suchThat` (isValidSnapshotName . getPrintableString))
430+
431+
shrink = fmap toSnapshotName . filter isValidSnapshotName .
432+
fmap getPrintableString . shrink . PrintableString . show
433+
434+
laws_SnapshotName :: TestTree
435+
laws_SnapshotName = testGroup "SnapshotName"
436+
[ equalityLaws @(SnapshotName)
437+
, orderingLaws @(SnapshotName)
438+
, showProperties @(SnapshotName)
439+
]
440+
441+
-- SnapshotLabel
442+
443+
instance Arbitrary SnapshotLabel where
444+
445+
arbitrary = fromString . getPrintableString <$>
446+
(arbitrary `suchThat` (isValidSnapshotName . getPrintableString))
447+
448+
shrink = fmap fromString. filter isValidSnapshotName .
449+
fmap getPrintableString . shrink . PrintableString . show
450+
451+
laws_SnapshotLabel :: TestTree
452+
laws_SnapshotLabel = testGroup "SnapshotLabel"
453+
[ equalityLaws @(SnapshotLabel)
454+
, normalFormDataLaws @(SnapshotLabel)
455+
, showProperties @(SnapshotLabel)
456+
]
457+
458+
-- TableConfigOverride
459+
460+
instance Arbitrary TableConfigOverride where
461+
462+
arbitrary = TableConfigOverride <$> arbitrary <*> arbitrary
463+
464+
shrink (TableConfigOverride x y) =
465+
[ TableConfigOverride x' y' | x' <- shrink x, y' <- shrink y ]
466+
467+
laws_TableConfigOverride :: TestTree
468+
laws_TableConfigOverride = testGroup "TableConfigOverride"
469+
[ equalityLaws @(SnapshotLabel)
470+
, showProperties @(SnapshotLabel)
471+
]
472+
473+
-- UnionCredits
474+
475+
instance Arbitrary UnionCredits where
476+
477+
arbitrary = UnionCredits . getNonNegative <$> arbitrary
478+
479+
shrink (UnionCredits x) = UnionCredits . getNonNegative <$> shrink (NonNegative x)
480+
481+
laws_UnionCredits :: TestTree
482+
laws_UnionCredits = testGroup "UnionCredits"
483+
[ equalityLaws @(UnionCredits)
484+
, orderingLaws @(UnionCredits)
485+
, numLaws @(UnionCredits)
486+
, showProperties @(UnionCredits)
487+
]
488+
489+
-- UnionDebt
490+
491+
instance Arbitrary UnionDebt where
492+
493+
arbitrary = UnionDebt . getNonNegative <$> arbitrary
494+
495+
shrink (UnionDebt x) = UnionDebt . getNonNegative <$> shrink (NonNegative x)
496+
497+
laws_UnionDebt :: TestTree
498+
laws_UnionDebt = testGroup "UnionDebt"
499+
[ equalityLaws @(UnionDebt)
500+
, orderingLaws @(UnionDebt)
501+
, numLaws @(UnionDebt)
502+
, showProperties @(UnionDebt)
503+
]
504+
505+
-- Update
506+
507+
laws_Update :: TestTree
508+
laws_Update = testGroup "Update"
509+
[ equalityLaws @(Update W W)
510+
, normalFormDataLaws @(Update W W)
511+
, showProperties @(Update W W)
512+
]

0 commit comments

Comments
 (0)