Add tests for semigroup+monoid InMemoryEntryMeasure

ledger-ondisk/src/LedgerOnDisk/Class.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
 module LedgerOnDisk.Class where
 
 import Data.HashMap.Strict(HashMap, (!))
@@ -28,6 +29,7 @@ import Test.QuickCheck
 import Data.TreeDiff.Class
 import Test.QuickCheck.Instances.UnorderedContainers ()
 import Data.Monoid
+import GHC.Generics (Generic)
 -- import Data.Proxy
 
 newtype QueryScope k = QueryScope (HashSet k)
@@ -76,8 +78,11 @@ type KVOperation k v a = (HashMap k (Maybe v) -> (KVOperationResult k v, a))
 
 data BaseError where
   BEBadResultSet :: BaseError
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Generic)
 
+instance Arbitrary BaseError where
+  arbitrary = pure BEBadResultSet
+  shrink = genericShrink
 
 class (Eq k, Hashable k, Monad m) => MonadKV k v m | m -> k v where
   type Err m

ledger-ondisk/src/LedgerOnDisk/Suite.hs

@@ -7,16 +7,19 @@ import qualified LedgerOnDisk.QSM.Suite(tests)
 import Test.Tasty
 import qualified Test.Tasty.QuickCheck.Laws as Laws
 
-import LedgerOnDisk.Class
+import qualified LedgerOnDisk.Class
+import qualified LedgerOnDisk.WWB
 import Data.Proxy
 
 testManyLaws :: forall a proxy. proxy a -> TestName -> [Proxy a -> TestTree] -> TestTree
 testManyLaws _ name = testGroup name . fmap ($ Proxy @ a)
 
 testLaws :: TestTree
 testLaws = testGroup "Laws"
-    [ testManyLaws (Proxy @ (D Int)) "D"
+    [ testManyLaws (Proxy @ (LedgerOnDisk.Class.D Int)) "D"
       [Laws.testEqLaws, Laws.testSemigroupLaws, Laws.testMonoidLaws ]
+    , testManyLaws (Proxy @ (LedgerOnDisk.WWB.InMemoryEntryMeasure Int Int)) "InMemoryEntryMeasure"
+      [Laws.testSemigroupLaws, Laws.testMonoidLaws]
     ]
 
 tests :: TestTree

ledger-ondisk/src/LedgerOnDisk/WWB.hs

@@ -49,6 +49,7 @@ import Data.Functor.Identity
 import Data.Foldable
 import Data.Either
 import qualified Control.Monad.State as Strict
+import Test.QuickCheck
 
 newtype WWBT k v m a = WWBT { unWWBT :: ReaderT (WWBConfig k v) m a }
   deriving newtype (Functor, Applicative, Monad)
@@ -64,13 +65,23 @@ data QueryState k v = QSPreexecuted
   -- ^ Either an error encountered while fetching, or the scope of the query
   | QSRetired
   -- ^ The query has been retired
-  deriving (Show, Eq)
+  deriving stock (Show, Eq, Generic)
+
+-- | WARNING: This instance upholds no invariants
+instance (Eq k, Hashable k, Arbitrary k) => Arbitrary (QueryState k v) where
+  arbitrary = oneof
+    [ QSPreexecuted <$> arbitrary <*> arbitrary
+    , QSExecuted <$> arbitrary
+    , pure QSRetired
+    ]
+  shrink = genericShrink
 
 data InMemoryEntry k v
   = IME !k !(Maybe v)
   | QueryStateChange !Int !(QueryState k v)
 
 type role MonoidalHashMap nominal representational
+
 newtype MonoidalHashMap k v = MonoidalHashMap { unMonoidalHashMap :: HashMap k v }
   deriving stock (Show)
   deriving newtype (Eq)
@@ -85,7 +96,11 @@ data InMemoryEntryMeasure k v = InMemoryEntryMeasure
   { imeMap :: !(HashMap k (Maybe v))
   , liveQueries :: !(HashMap Int (QueryState k v))
   }
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Generic)
+
+-- | WARNING: This instance upholds no invariants
+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (InMemoryEntryMeasure k v) where
+  arbitrary = InMemoryEntryMeasure <$> arbitrary <*> arbitrary
 
 measureInMemoryEntries :: (Eq k, Hashable k, Foldable f) => f (InMemoryEntry k v) -> InMemoryEntryMeasure k v
 measureInMemoryEntries f = InMemoryEntryMeasure{..} where
@@ -268,6 +283,15 @@ resetWWBTIO m WWBConfig{..} = liftIO . atomically $ do
 data WWBErr k v = WWBEBase BaseError | WWBEExpiredResultSet | WWBEWeird String
   deriving stock (Eq, Show, Generic)
 
+-- | WARNING: This instance upholds no invariants
+instance Arbitrary (WWBErr k v) where
+  arbitrary = oneof
+    [ WWBEBase <$> arbitrary
+    , pure WWBEExpiredResultSet
+    , pure $ WWBEWeird "weird"
+    ]
+  shrink = genericShrink
+
 wwbStateTVar :: TVar s -> Strict.State s a -> STM a
 wwbStateTVar v = stateTVar v . Strict.runState