Merge #2756

2756: Add coverage checks to property tests for `TokenMap.intersection` r=jonathanknowles a=jonathanknowles # Issue Number ADP-997 # Pre-merge checks - [x] Perform soak test of test suite to ensure no flakiness has been introduced. (✅ 1000 test runs with `--match "/Token map properties/Arithmetic/prop_intersection"` passed with no failures.) # Overview PR #2725 added a `TokenMap.intersection` function and property tests. This PR: - [x] adds coverage checks to the `prop_intersection_*` series of properties. - [x] where necessary, adjusts property inputs in order to attain the required level of coverage. Co-authored-by: Jonathan Knowles <[email protected]>
cardano-foundation · Jul 13, 2021 · dd41d30 · dd41d30
2 parents 5b4d3e2 + 5673f74
commit dd41d30
Show file tree

Hide file tree

Showing 4 changed files with 216 additions and 27 deletions.
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap/Gen.hs
@@ -1,11 +1,16 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Cardano.Wallet.Primitive.Types.TokenMap.Gen
- ( genAssetIdLargeRange
+ ( genAssetIdSized
+ , genAssetIdLargeRange
  , genAssetIdSmallRange
+ , genTokenMapSized
  , genTokenMapSmallRange
+ , shrinkAssetIdSized
  , shrinkAssetIdSmallRange
+ , shrinkTokenMapSized
  , shrinkTokenMapSmallRange
  , AssetIdF (..)
  ) where
@@ -16,16 +21,24 @@ import Cardano.Wallet.Primitive.Types.TokenMap
  ( AssetId (..), TokenMap )
 import Cardano.Wallet.Primitive.Types.TokenPolicy.Gen
  ( genTokenNameLargeRange
+ , genTokenNameSized
  , genTokenNameSmallRange
  , genTokenPolicyIdLargeRange
+ , genTokenPolicyIdSized
  , genTokenPolicyIdSmallRange
+ , shrinkTokenNameSized
  , shrinkTokenNameSmallRange
+ , shrinkTokenPolicyIdSized
  , shrinkTokenPolicyIdSmallRange
  , tokenNamesMediumRange
  , tokenPolicies
  )
 import Cardano.Wallet.Primitive.Types.TokenQuantity.Gen
- ( genTokenQuantitySmall, shrinkTokenQuantitySmall )
+ ( genTokenQuantitySized
+ , genTokenQuantitySmall
+ , shrinkTokenQuantitySized
+ , shrinkTokenQuantitySmall
+ )
 import Control.Monad
  ( replicateM )
 import Data.List
@@ -41,14 +54,43 @@ import Test.QuickCheck
  , choose
  , functionMap
  , oneof
+ , resize
  , shrinkList
+ , sized
  , variant
  )
 import Test.QuickCheck.Extra
  ( shrinkInterleaved )
 
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 
+--------------------------------------------------------------------------------
+-- Asset identifiers chosen from a range that depends on the size parameter
+--------------------------------------------------------------------------------
+
+genAssetIdSized :: Gen AssetId
+genAssetIdSized = sized $ \size -> do
+ -- Ideally, we want to choose asset identifiers from a range that scales
+ -- /linearly/ with the size parameter.
+ --
+ -- However, since each asset identifier has /two/ components that are
+ -- generated /separately/, naively combining the generators for these two
+ -- components will give rise to a range of asset identifiers that scales
+ -- /quadratically/ with the size parameter, which is /not/ what we want.
+ --
+ -- Therefore, we pass each individual generator a size parameter that
+ -- is the square root of the original.
+ --
+ let sizeSquareRoot = max 1 $ ceiling $ sqrt $ fromIntegral @Int @Double size
+ AssetId
+ <$> resize sizeSquareRoot genTokenPolicyIdSized
+ <*> resize sizeSquareRoot genTokenNameSized
+
+shrinkAssetIdSized :: AssetId -> [AssetId]
+shrinkAssetIdSized (AssetId p t) = uncurry AssetId <$> shrinkInterleaved
+ (p, shrinkTokenPolicyIdSized)
+ (t, shrinkTokenNameSized)
+
 --------------------------------------------------------------------------------
 -- Asset identifiers chosen from a small range (to allow collisions)
 --------------------------------------------------------------------------------
@@ -72,6 +114,30 @@ genAssetIdLargeRange = AssetId
  <$> genTokenPolicyIdLargeRange
  <*> genTokenNameLargeRange
 
+--------------------------------------------------------------------------------
+-- Token maps with assets and quantities chosen from ranges that depend on the
+-- size parameter
+--------------------------------------------------------------------------------
+
+genTokenMapSized :: Gen TokenMap
+genTokenMapSized = sized $ \size -> do
+ assetCount <- choose (0, size)
+ TokenMap.fromFlatList <$> replicateM assetCount genAssetQuantity
+ where
+ genAssetQuantity = (,)
+ <$> genAssetIdSized
+ <*> genTokenQuantitySized
+
+shrinkTokenMapSized :: TokenMap -> [TokenMap]
+shrinkTokenMapSized
+ = fmap TokenMap.fromFlatList
+ . shrinkList shrinkAssetQuantity
+ . TokenMap.toFlatList
+ where
+ shrinkAssetQuantity (a, q) = shrinkInterleaved
+ (a, shrinkAssetIdSized)
+ (q, shrinkTokenQuantitySized)
+
 --------------------------------------------------------------------------------
 -- Token maps with assets and quantities chosen from small ranges
 --------------------------------------------------------------------------------

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/TokenPolicy/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/TokenPolicy/Gen.hs
@@ -1,12 +1,16 @@
 module Cardano.Wallet.Primitive.Types.TokenPolicy.Gen
- ( genTokenNameLargeRange
+ ( genTokenNameSized
+ , genTokenNameLargeRange
  , genTokenNameMediumRange
  , genTokenNameSmallRange
+ , genTokenPolicyIdSized
  , genTokenPolicyIdLargeRange
  , genTokenPolicyIdSmallRange
  , mkTokenPolicyId
+ , shrinkTokenNameSized
  , shrinkTokenNameMediumRange
  , shrinkTokenNameSmallRange
+ , shrinkTokenPolicyIdSized
  , shrinkTokenPolicyIdSmallRange
  , tokenNamesMediumRange
  , tokenNamesSmallRange
@@ -24,12 +28,27 @@ import Data.Either
 import Data.Text.Class
  ( FromText (..) )
 import Test.QuickCheck
- ( Gen, elements, vector )
+ ( Gen, elements, sized, vector )
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Text as T
 
+--------------------------------------------------------------------------------
+-- Token names chosen from a range that depends on the size parameter
+--------------------------------------------------------------------------------
+
+genTokenNameSized :: Gen TokenName
+genTokenNameSized = sized $ \size ->
+ elements $ UnsafeTokenName . B8.snoc "Token" <$> take size ['A' ..]
+
+shrinkTokenNameSized :: TokenName -> [TokenName]
+shrinkTokenNameSized x
+ | x == simplest = []
+ | otherwise = [simplest]
+ where
+ simplest = UnsafeTokenName "TokenA"
+
 --------------------------------------------------------------------------------
 -- Token names chosen from a small range (to allow collisions)
 --------------------------------------------------------------------------------
@@ -72,6 +91,22 @@ tokenNamesMediumRange = UnsafeTokenName . B8.snoc "Token" <$> ['A' .. 'Z']
 genTokenNameLargeRange :: Gen TokenName
 genTokenNameLargeRange = UnsafeTokenName . BS.pack <$> vector 32
 
+--------------------------------------------------------------------------------
+-- Token policy identifiers chosen from a range that depends on the size
+-- parameter
+--------------------------------------------------------------------------------
+
+genTokenPolicyIdSized :: Gen TokenPolicyId
+genTokenPolicyIdSized = sized $ \size ->
+ elements $ mkTokenPolicyId <$> take size mkTokenPolicyIdValidChars
+
+shrinkTokenPolicyIdSized :: TokenPolicyId -> [TokenPolicyId]
+shrinkTokenPolicyIdSized x
+ | x == simplest = []
+ | otherwise = [simplest]
+ where
+ simplest = mkTokenPolicyId 'A'
+
 --------------------------------------------------------------------------------
 -- Token policy identifiers chosen from a small range (to allow collisions)
 --------------------------------------------------------------------------------
@@ -101,7 +136,12 @@ genTokenPolicyIdLargeRange = UnsafeTokenPolicyId . Hash . BS.pack <$> vector 28
 -- Internal utilities
 --------------------------------------------------------------------------------
 
--- The input must be a character in the range [0-9] or [A-Z].
+-- The set of characters that can be passed to the 'mkTokenPolicyId' function.
+--
+mkTokenPolicyIdValidChars :: [Char]
+mkTokenPolicyIdValidChars = ['0' .. '9'] <> ['A' .. 'F']
+
+-- The input must be a character in the range [0-9] or [A-F].
 --
 mkTokenPolicyId :: Char -> TokenPolicyId
 mkTokenPolicyId c

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/TokenQuantity/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/TokenQuantity/Gen.hs
@@ -1,9 +1,11 @@
 module Cardano.Wallet.Primitive.Types.TokenQuantity.Gen
- ( genTokenQuantitySmall
+ ( genTokenQuantitySized
+ , genTokenQuantitySmall
  , genTokenQuantitySmallPositive
  , genTokenQuantityLarge
  , genTokenQuantityMassive
  , genTokenQuantityMixed
+ , shrinkTokenQuantitySized
  , shrinkTokenQuantitySmall
  , shrinkTokenQuantitySmallPositive
  , shrinkTokenQuantityLarge
@@ -23,7 +25,18 @@ import Data.Word
 import Numeric.Natural
  ( Natural )
 import Test.QuickCheck
- ( Gen, choose, oneof, shrink )
+ ( Gen, choose, oneof, shrink, sized )
+
+--------------------------------------------------------------------------------
+-- Token quantities chosen from a range that depends on the size parameter
+--------------------------------------------------------------------------------
+
+genTokenQuantitySized :: Gen TokenQuantity
+genTokenQuantitySized = sized $ \n ->
+ quantityFromInt <$> choose (0, n)
+
+shrinkTokenQuantitySized :: TokenQuantity -> [TokenQuantity]
+shrinkTokenQuantitySized = shrinkTokenQuantity
 
 --------------------------------------------------------------------------------
 -- Small token quantities
@@ -119,6 +132,11 @@ tokenQuantityMassive = TokenQuantity $ (10 :: Natural) ^ (1000 :: Natural)
 quantityToInteger :: TokenQuantity -> Integer
 quantityToInteger (TokenQuantity q) = fromIntegral q
 
+quantityFromInt :: Int -> TokenQuantity
+quantityFromInt i
+ | i < 0 = error $ "Unable to convert integer to token quantity: " <> show i
+ | otherwise = TokenQuantity $ fromIntegral i
+
 quantityFromInteger :: Integer -> TokenQuantity
 quantityFromInteger i
  | i < 0 = error $ "Unable to convert integer to token quantity: " <> show i

diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/TokenMapSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/TokenMapSpec.hs
@@ -23,6 +23,7 @@ import Cardano.Wallet.Primitive.Types.TokenMap.Gen
  ( AssetIdF (..)
  , genAssetIdLargeRange
  , genAssetIdSmallRange
+ , genTokenMapSized
  , genTokenMapSmallRange
  , shrinkAssetIdSmallRange
  , shrinkTokenMapSmallRange
@@ -96,8 +97,10 @@ import Test.QuickCheck
  , conjoin
  , counterexample
  , cover
+ , forAllBlind
  , frequency
  , property
+ , scale
  , (.||.)
  , (===)
  , (==>)
@@ -519,38 +522,100 @@ prop_difference_equality x y = checkCoverage $
  xExcess = x `TokenMap.difference` y
  yExcess = y `TokenMap.difference` x
 
-prop_intersection_associativity :: TokenMap -> TokenMap -> TokenMap -> Property
-prop_intersection_associativity x y z = (===)
- ((x `TokenMap.intersection` y) `TokenMap.intersection` z)
- (x `TokenMap.intersection` (y `TokenMap.intersection` z))
-
-prop_intersection_commutativity :: TokenMap -> TokenMap -> Property
-prop_intersection_commutativity x y =
- x `TokenMap.intersection` y === y `TokenMap.intersection` x
+prop_intersection_associativity :: Property
+prop_intersection_associativity =
+ forAllBlind genTokenMap $ \x ->
+ forAllBlind genTokenMap $ \y ->
+ forAllBlind genTokenMap $ \z ->
+ prop_inner x y z
+ where
+ genTokenMap = scale (* 4) genTokenMapSized
+ prop_inner x y z =
+ checkCoverage $
+ cover 50 (x /= y && y /= z)
+ "maps are different" $
+ cover 50 (TokenMap.isNotEmpty r1 && TokenMap.isNotEmpty r2)
+ "intersection is not empty" $
+ counterexample (pretty (Flat <$> [x, y, z, r1, r2])) $
+ r1 == r2
+ where
+ r1 = (x `TokenMap.intersection` y) `TokenMap.intersection` z
+ r2 = x `TokenMap.intersection` (y `TokenMap.intersection` z)
+
+prop_intersection_commutativity :: Property
+prop_intersection_commutativity =
+ forAllBlind genTokenMap $ \x ->
+ forAllBlind genTokenMap $ \y ->
+ prop_inner x y
+ where
+ genTokenMap = scale (* 2) genTokenMapSized
+ prop_inner x y =
+ checkCoverage $
+ cover 50 (x /= y)
+ "maps are different" $
+ cover 50 (TokenMap.isNotEmpty r1 && TokenMap.isNotEmpty r2)
+ "intersection is not empty" $
+ counterexample (pretty (Flat <$> [x, y, r1, r2])) $
+ r1 == r2
+ where
+ r1 = x `TokenMap.intersection` y
+ r2 = y `TokenMap.intersection` x
 
 prop_intersection_empty :: TokenMap -> Property
 prop_intersection_empty x =
+ checkCoverage $
+ cover 50 (TokenMap.isNotEmpty x)
+ "map is not empty" $
  x `TokenMap.intersection` TokenMap.empty === TokenMap.empty
 
-prop_intersection_equality :: TokenMap -> TokenMap -> Property
-prop_intersection_equality x y = conjoin
- [ total `TokenMap.intersection` x === x
- , total `TokenMap.intersection` y === y
- ]
+prop_intersection_equality :: Property
+prop_intersection_equality =
+ forAllBlind genTokenMap $ \x ->
+ forAllBlind genTokenMap $ \y ->
+ prop_inner x y
  where
- total = x <> y
+ genTokenMap = scale (* 2) genTokenMapSized
+ prop_inner x y =
+ checkCoverage $
+ cover 50 (x /= y)
+ "maps are different" $
+ cover 50 (TokenMap.isNotEmpty x && TokenMap.isNotEmpty y)
+ "maps are not empty" $
+ counterexample (pretty (Flat <$> [x, y, total])) $
+ conjoin
+ [ total `TokenMap.intersection` x === x
+ , total `TokenMap.intersection` y === y
+ ]
+ where
+ total = x <> y
 
 prop_intersection_identity :: TokenMap -> Property
 prop_intersection_identity x =
+ checkCoverage $
+ cover 50 (TokenMap.isNotEmpty x)
+ "map is not empty" $
  x `TokenMap.intersection` x === x
 
-prop_intersection_subset :: TokenMap -> TokenMap -> Property
-prop_intersection_subset x y = conjoin
- [ intersection `leq` x
- , intersection `leq` y
- ]
+prop_intersection_subset :: Property
+prop_intersection_subset =
+ forAllBlind genTokenMap $ \x ->
+ forAllBlind genTokenMap $ \y ->
+ prop_inner x y
  where
- intersection = x `TokenMap.intersection` y
+ genTokenMap = scale (* 2) genTokenMapSized
+ prop_inner x y =
+ checkCoverage $
+ cover 50 (x /= y)
+ "maps are different" $
+ cover 50 (TokenMap.isNotEmpty x && TokenMap.isNotEmpty y)
+ "maps are not empty" $
+ counterexample (pretty (Flat <$> [x, y, intersection])) $
+ conjoin
+ [ intersection `leq` x
+ , intersection `leq` y
+ ]
+ where
+ intersection = x `TokenMap.intersection` y
 
 --------------------------------------------------------------------------------
 -- Quantity properties