Generate UTxO sets (and indices) according to the size parameter.

This commit necessitates a few small adjustments to coverage conditions.

lib/core/src/Cardano/Wallet/Primitive/Types/UTxO/Gen.hs

@@ -1,8 +1,8 @@
 module Cardano.Wallet.Primitive.Types.UTxO.Gen
-    ( genUTxOSmall
+    ( genUTxO
     , genUTxOLarge
     , genUTxOLargeN
-    , shrinkUTxOSmall
+    , shrinkUTxO
     ) where
 
 import Prelude
@@ -21,27 +21,27 @@ import Cardano.Wallet.Primitive.Types.UTxO
 import Control.Monad
     ( replicateM )
 import Test.QuickCheck
-    ( Gen, choose, frequency, shrinkList )
+    ( Gen, choose, frequency, shrinkList, sized )
 import Test.QuickCheck.Extra
     ( shrinkInterleaved )
 
 import qualified Data.Map.Strict as Map
 
 --------------------------------------------------------------------------------
--- Small UTxO sets
+-- UTxO sets generated according to the size parameter
 --------------------------------------------------------------------------------
 
-genUTxOSmall :: Gen UTxO
-genUTxOSmall = do
+genUTxO :: Gen UTxO
+genUTxO = sized $ \size -> do
     entryCount <- frequency
         [ (1, pure 0)
         , (1, pure 1)
-        , (32, choose (2, 64))
+        , (32, choose (2, (max 2 size)))
         ]
     UTxO . Map.fromList <$> replicateM entryCount genEntrySmallRange
 
-shrinkUTxOSmall :: UTxO -> [UTxO]
-shrinkUTxOSmall
+shrinkUTxO :: UTxO -> [UTxO]
+shrinkUTxO
     = take 16
     . fmap (UTxO . Map.fromList)
     . shrinkList shrinkEntrySmallRange

lib/core/src/Cardano/Wallet/Primitive/Types/UTxOIndex/Gen.hs

@@ -1,14 +1,14 @@
 module Cardano.Wallet.Primitive.Types.UTxOIndex.Gen
-    ( genUTxOIndexSmall
+    ( genUTxOIndex
     , genUTxOIndexLarge
     , genUTxOIndexLargeN
-    , shrinkUTxOIndexSmall
+    , shrinkUTxOIndex
     ) where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Types.UTxO.Gen
-    ( genUTxOLarge, genUTxOLargeN, genUTxOSmall, shrinkUTxOSmall )
+    ( genUTxO, genUTxOLarge, genUTxOLargeN, shrinkUTxO )
 import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( UTxOIndex )
 import Test.QuickCheck
@@ -17,15 +17,14 @@ import Test.QuickCheck
 import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex
 
 --------------------------------------------------------------------------------
--- Small indices
+-- Indices generated according to the size parameter
 --------------------------------------------------------------------------------
 
-genUTxOIndexSmall :: Gen UTxOIndex
-genUTxOIndexSmall = UTxOIndex.fromUTxO <$> genUTxOSmall
+genUTxOIndex :: Gen UTxOIndex
+genUTxOIndex = UTxOIndex.fromUTxO <$> genUTxO
 
-shrinkUTxOIndexSmall :: UTxOIndex -> [UTxOIndex]
-shrinkUTxOIndexSmall =
-    fmap UTxOIndex.fromUTxO . shrinkUTxOSmall  . UTxOIndex.toUTxO
+shrinkUTxOIndex :: UTxOIndex -> [UTxOIndex]
+shrinkUTxOIndex = fmap UTxOIndex.fromUTxO . shrinkUTxO . UTxOIndex.toUTxO
 
 --------------------------------------------------------------------------------
 -- Large indices

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobinSpec.hs

@@ -108,11 +108,7 @@ import Cardano.Wallet.Primitive.Types.Tx.Gen
 import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( SelectionFilter (..), UTxOIndex )
 import Cardano.Wallet.Primitive.Types.UTxOIndex.Gen
-    ( genUTxOIndexLarge
-    , genUTxOIndexLargeN
-    , genUTxOIndexSmall
-    , shrinkUTxOIndexSmall
-    )
+    ( genUTxOIndex, genUTxOIndexLarge, genUTxOIndexLargeN, shrinkUTxOIndex )
 import Control.Monad
     ( forM_, replicateM )
 import Data.Bifunctor
@@ -177,6 +173,7 @@ import Test.QuickCheck
     , label
     , oneof
     , property
+    , scale
     , shrinkList
     , sublistOf
     , suchThat
@@ -583,8 +580,8 @@ type PerformSelectionResult =
     Either SelectionError (SelectionResult TokenBundle)
 
 genSelectionCriteria :: Gen UTxOIndex -> Gen SelectionCriteria
-genSelectionCriteria genUTxOIndex = do
-    utxoAvailable <- genUTxOIndex
+genSelectionCriteria genUTxOIndex' = do
+    utxoAvailable <- genUTxOIndex'
     outputCount <- max 1 <$>
         choose (1, UTxOIndex.size utxoAvailable `div` 8)
     outputsToCover <- NE.fromList <$>
@@ -3533,16 +3530,16 @@ instance Arbitrary (Large SelectionCriteria) where
     -- No shrinking
 
 instance Arbitrary (Small SelectionCriteria) where
-    arbitrary = Small <$> genSelectionCriteria genUTxOIndexSmall
+    arbitrary = Small <$> genSelectionCriteria genUTxOIndex
     -- No shrinking
 
 instance Arbitrary (Large UTxOIndex) where
     arbitrary = Large <$> genUTxOIndexLarge
     -- No shrinking
 
 instance Arbitrary (Small UTxOIndex) where
-    arbitrary = Small <$> genUTxOIndexSmall
-    shrink = fmap Small . shrinkUTxOIndexSmall . getSmall
+    arbitrary = Small <$> (scale (* 2) genUTxOIndex)
+    shrink = fmap Small . shrinkUTxOIndex . getSmall
 
 instance Arbitrary Coin where
     arbitrary = genCoinPositive

lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs

@@ -26,7 +26,7 @@ import Cardano.Wallet.Primitive.Types.Tx.Gen
 import Cardano.Wallet.Primitive.Types.UTxO
     ( UTxO (..) )
 import Cardano.Wallet.Primitive.Types.UTxOIndex.Gen
-    ( genUTxOIndexSmall, shrinkUTxOIndexSmall )
+    ( genUTxOIndex, shrinkUTxOIndex )
 import Cardano.Wallet.Primitive.Types.UTxOIndex.Internal
     ( InvariantStatus (..), SelectionFilter (..), UTxOIndex, checkInvariant )
 import Control.Monad.Random.Class
@@ -58,8 +58,10 @@ import Test.QuickCheck
     , counterexample
     , cover
     , forAll
+    , forAllBlind
     , oneof
     , property
+    , resize
     , stdConfidence
     , suchThat
     , withMaxSuccess
@@ -231,9 +233,9 @@ prop_toList_fromSequence u =
 prop_delete_balance :: TxIn -> UTxOIndex -> Property
 prop_delete_balance i u =
     checkCoverage $
-    cover 30 (UTxOIndex.member i u)
+    cover 20 (UTxOIndex.member i u)
         "input is a member of the index" $
-    cover 30 (not $ UTxOIndex.member i u)
+    cover 20 (not $ UTxOIndex.member i u)
         "input is not a member of the index" $
     UTxOIndex.balance (UTxOIndex.delete i u) === expected
   where
@@ -250,9 +252,9 @@ prop_delete_lookup i u =
 prop_delete_size :: TxIn -> UTxOIndex -> Property
 prop_delete_size i u =
     checkCoverage $
-    cover 30 (UTxOIndex.member i u)
+    cover 20 (UTxOIndex.member i u)
         "input is a member of the index" $
-    cover 30 (not $ UTxOIndex.member i u)
+    cover 20 (not $ UTxOIndex.member i u)
         "input is not a member of the index" $
     UTxOIndex.size (UTxOIndex.delete i u) === expected
   where
@@ -272,9 +274,9 @@ prop_insert_assets i o u =
 prop_insert_balance :: TxIn -> TxOut -> UTxOIndex -> Property
 prop_insert_balance i o u =
     checkCoverage $
-    cover 30 (UTxOIndex.member i u)
+    cover 20 (UTxOIndex.member i u)
         "input is already a member of the index" $
-    cover 30 (not $ UTxOIndex.member i u)
+    cover 20 (not $ UTxOIndex.member i u)
         "input is not already a member of the index" $
     UTxOIndex.balance (UTxOIndex.insert i o u) === expected
   where
@@ -287,9 +289,9 @@ prop_insert_balance i o u =
 prop_insert_delete :: TxIn -> TxOut -> UTxOIndex -> Property
 prop_insert_delete i o u =
     checkCoverage $
-    cover 30 (UTxOIndex.member i u)
+    cover 20 (UTxOIndex.member i u)
         "input is already a member of the index" $
-    cover 30 (not $ UTxOIndex.member i u)
+    cover 20 (not $ UTxOIndex.member i u)
         "input is not already a member of the index" $
     UTxOIndex.delete i (UTxOIndex.insert i o u) === expected
   where
@@ -303,9 +305,9 @@ prop_insert_lookup i o u =
 prop_insert_size :: TxIn -> TxOut -> UTxOIndex -> Property
 prop_insert_size i o u =
     checkCoverage $
-    cover 30 (UTxOIndex.member i u)
+    cover 20 (UTxOIndex.member i u)
         "input is already a member of the index" $
-    cover 30 (not $ UTxOIndex.member i u)
+    cover 20 (not $ UTxOIndex.member i u)
         "input is not already a member of the index" $
     UTxOIndex.size (UTxOIndex.insert i o u) === expected
   where
@@ -540,8 +542,9 @@ prop_selectRandom_all_withAssetOnly u a = checkCoverage $ monadicIO $ do
 -- | Verify that priority order is respected when selecting with more than
 --   one filter.
 --
-prop_selectRandomWithPriority :: UTxOIndex -> Property
-prop_selectRandomWithPriority u =
+prop_selectRandomWithPriority :: Property
+prop_selectRandomWithPriority =
+    forAllBlind (resize 64 genUTxOIndex) $ \u ->
     forAll (genAssetId) $ \a1 ->
     forAll (genAssetId `suchThat` (/= a1)) $ \a2 ->
     checkCoverage $ monadicIO $ do
@@ -553,7 +556,7 @@ prop_selectRandomWithPriority u =
             "have match for asset 1 but not for asset 2"
         monitor $ cover 4 (not haveMatchForAsset1 && haveMatchForAsset2)
             "have match for asset 2 but not for asset 1"
-        monitor $ cover 4 (haveMatchForAsset1 && haveMatchForAsset2)
+        monitor $ cover 1 (haveMatchForAsset1 && haveMatchForAsset2)
             "have match for both asset 1 and asset 2"
         monitor $ cover 4 (not haveMatchForAsset1 && not haveMatchForAsset2)
             "have match for neither asset 1 nor asset 2"
@@ -689,8 +692,8 @@ instance Arbitrary AssetId where
     shrink = shrinkAssetId
 
 instance Arbitrary UTxOIndex where
-    arbitrary = genUTxOIndexSmall
-    shrink = shrinkUTxOIndexSmall
+    arbitrary = genUTxOIndex
+    shrink = shrinkUTxOIndex
 
 instance Arbitrary TxIn where
     arbitrary = genTxInSmallRange