Add tests for min/max bounds on (un)spent credits

And check max run size (2^40-1, or about 1 trillion)

Author: dcoutts

lsm-tree.cabal

@@ -366,6 +366,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Index.Ordinary
     Test.Database.LSMTree.Internal.Lookup
     Test.Database.LSMTree.Internal.Merge
+    Test.Database.LSMTree.Internal.MergingRun
     Test.Database.LSMTree.Internal.MergingTree
     Test.Database.LSMTree.Internal.Monkey
     Test.Database.LSMTree.Internal.PageAcc

src/Database/LSMTree/Internal/MergingRun.hs

@@ -23,6 +23,8 @@ module Database.LSMTree.Internal.MergingRun (
   , Credits (..)
   , CreditThreshold (..)
   , SuppliedCredits (..)
+  , SpentCredits (..)
+  , UnspentCredits (..)
 
   -- * Concurrency
   -- $concurrency
@@ -32,16 +34,19 @@ module Database.LSMTree.Internal.MergingRun (
   , MergingRunState (..)
   , MergeKnownCompleted (..)
   , CreditsVar (..)
+  , pattern CreditsPair
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.DeepSeq (NFData (..))
+import           Control.Exception (ErrorCall (..))
 import           Control.Monad (when)
 import           Control.Monad.Class.MonadST (MonadST)
 import           Control.Monad.Class.MonadSTM (MonadSTM (..))
 import           Control.Monad.Class.MonadThrow
-                     (MonadCatch (bracketOnError, onException), MonadMask)
+                     (MonadCatch (bracketOnError, onException), MonadMask,
+                     MonadThrow (throwIO))
 import           Control.Monad.Primitive
 import           Control.RefCount
 import           Data.Bits
@@ -183,6 +188,10 @@ unsafeNew ::
   -> MergeKnownCompleted
   -> MergingRunState m h
   -> m (Ref (MergingRun m h))
+unsafeNew _ mergeNumEntries _ _
+  | SpentCredits (numEntriesToTotalDebt mergeNumEntries) > maxBound
+  = throwIO (ErrorCall "MergingRun.new: run size exceeds maximum of 2^40")
+
 unsafeNew mergeNumRuns mergeNumEntries knownCompleted state = do
     mergeCreditsVar <- CreditsVar <$> newPrimVar 0
     case state of
@@ -340,6 +349,7 @@ newtype SuppliedCredits = SuppliedCredits Credits
 -- spent (by some thread calling 'supplyCredits').
 --
 newtype SpentCredits = SpentCredits Credits
+  deriving newtype (Eq, Ord)
 
 -- | 40 bit unsigned number
 instance Bounded SpentCredits where
@@ -355,6 +365,7 @@ instance Bounded SpentCredits where
 -- current unspent credits being negative for a time.
 --
 newtype UnspentCredits = UnspentCredits Credits
+  deriving newtype (Eq, Ord)
 
 -- | 24 bit signed number
 instance Bounded UnspentCredits where
@@ -386,11 +397,13 @@ pattern CreditsPair sc uc <- (unpackCreditsPair -> (sc, uc))
 #endif
 {-# COMPLETE CreditsPair #-}
 
--- TODO: test pack/unpack round trip with the minBound & maxBounds
-
 {-# INLINE packCreditsPair #-}
 packCreditsPair :: SpentCredits -> UnspentCredits -> Int
-packCreditsPair (SpentCredits (Credits sc)) (UnspentCredits (Credits uc)) =
+packCreditsPair spent@(SpentCredits (Credits sc))
+                unspent@(UnspentCredits (Credits uc)) =
+      assert (spent   >= minBound && spent   <= maxBound) $
+      assert (unspent >= minBound && unspent <= maxBound) $
+
       sc `unsafeShiftL` 24
   .|. (uc .&. 0xffffff)
 

test/Main.hs

@@ -17,6 +17,7 @@ import qualified Test.Database.LSMTree.Internal.Index.Compact
 import qualified Test.Database.LSMTree.Internal.Index.Ordinary
 import qualified Test.Database.LSMTree.Internal.Lookup
 import qualified Test.Database.LSMTree.Internal.Merge
+import qualified Test.Database.LSMTree.Internal.MergingRun
 import qualified Test.Database.LSMTree.Internal.MergingTree
 import qualified Test.Database.LSMTree.Internal.Monkey
 import qualified Test.Database.LSMTree.Internal.PageAcc
@@ -59,6 +60,7 @@ main = do
     , Test.Database.LSMTree.Internal.Entry.tests
     , Test.Database.LSMTree.Internal.Lookup.tests
     , Test.Database.LSMTree.Internal.Merge.tests
+    , Test.Database.LSMTree.Internal.MergingRun.tests
     , Test.Database.LSMTree.Internal.MergingTree.tests
     , Test.Database.LSMTree.Internal.Monkey.tests
     , Test.Database.LSMTree.Internal.PageAcc.tests

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

@@ -0,0 +1,57 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Database.LSMTree.Internal.MergingRun (tests) where
+
+import           Database.LSMTree.Internal.MergingRun
+import           Test.QuickCheck
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests = testGroup "Test.Database.LSMTree.Internal.MergingRun"
+    [ testProperty "prop_CreditsPair" prop_CreditsPair
+    ]
+
+-- | Check that the merging tree constructor functions preserve the property
+-- that if the inputs are obviously empty, the output is also obviously empty.
+--
+prop_CreditsPair :: SpentCredits -> UnspentCredits -> Property
+prop_CreditsPair spentCredits unspentCredits =
+    tabulate "bounds" [spentCreditsBound, unspentCreditsBound] $
+    let cp :: Int
+        !cp = CreditsPair spentCredits unspentCredits
+     in case cp of
+          CreditsPair spentCredits' unspentCredits' ->
+            (spentCredits, unspentCredits) === (spentCredits', unspentCredits')
+  where
+    spentCreditsBound
+      | spentCredits == minBound = "spentCredits == minBound"
+      | spentCredits == maxBound = "spentCredits == maxBound"
+      | otherwise                = "spentCredits == other"
+
+    unspentCreditsBound
+      | unspentCredits == minBound = "unspentCredits == minBound"
+      | unspentCredits == maxBound = "unspentCredits == maxBound"
+      | otherwise                  = "unspentCredits == other"
+
+deriving newtype instance Enum SpentCredits
+deriving newtype instance Enum UnspentCredits
+
+deriving stock instance Show Credits
+deriving stock instance Show SpentCredits
+deriving stock instance Show UnspentCredits
+
+instance Arbitrary SpentCredits where
+  arbitrary =
+    frequency [ (1, pure minBound)
+              , (1, pure maxBound)
+              , (10, arbitraryBoundedEnum)
+              ]
+
+instance Arbitrary UnspentCredits where
+  arbitrary =
+    frequency [ (1, pure minBound)
+              , (1, pure maxBound)
+              , (10, arbitraryBoundedEnum)
+              ]
+