diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/TokenMap/Gen.hs index 7b82e9c4eb8..26933d7f137 100644 --- 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,7 +54,9 @@ import Test.QuickCheck , choose , functionMap , oneof + , resize , shrinkList + , sized , variant ) import Test.QuickCheck.Extra @@ -49,6 +64,33 @@ import Test.QuickCheck.Extra 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 index 9be570e79c4..bb38fecf603 100644 --- 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 index 022c0fd6c31..57b9e5ff010 100644 --- 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 index ab491f97103..641b4b9ab07 100644 --- 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