Merge #2885

2885: Add generators and shrinkers for `SelectionLimit` and `SelectionSkeleton`. r=jonathanknowles a=jonathanknowles ### Comments This PR adds generators and shrinkers for `SelectionLimit` and `SelectionSkeleton`. ### Issue Number ADP-1118 Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>
cardano-foundation · Sep 10, 2021 · 08106c1 · 08106c1
2 parents fe2269f + 7b73924
commit 08106c1
Show file tree

Hide file tree

Showing 8 changed files with 154 additions and 7 deletions.
diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
@@ -231,6 +231,7 @@ library
         -- The following modules define QC generators and shrinkers that can
         -- be used by both `cardano-wallet-core` and `cardano-wallet`:
         --
+      Cardano.Wallet.Primitive.CoinSelection.Gen
       Cardano.Wallet.Primitive.Types.Address.Gen
       Cardano.Wallet.Primitive.Types.Coin.Gen
       Cardano.Wallet.Primitive.Types.RewardAccount.Gen

diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -32,7 +33,8 @@ module Cardano.Wallet.Primitive.CoinSelection.Balance
     , emptySkeleton
     , selectionDelta
     , SelectionCriteria (..)
-    , SelectionLimit (..)
+    , SelectionLimit
+    , SelectionLimitOf (..)
     , SelectionSkeleton (..)
     , SelectionResult (..)
     , SelectionError (..)
@@ -233,12 +235,21 @@ emptySkeleton = SelectionSkeleton
 
 -- | Specifies a limit to adhere to when performing a selection.
 --
-data SelectionLimit
+type SelectionLimit = SelectionLimitOf Int
+
+data SelectionLimitOf a
     = NoLimit
       -- ^ Indicates that there is no limit.
-    | MaximumInputLimit Int
+    | MaximumInputLimit a
       -- ^ Indicates a maximum limit on the number of inputs to select.
-    deriving (Eq, Show)
+    deriving (Eq, Functor, Show)
+
+instance Ord a => Ord (SelectionLimitOf a) where
+    compare a b = case (a, b) of
+        (NoLimit            , NoLimit            ) -> EQ
+        (MaximumInputLimit _, NoLimit            ) -> LT
+        (NoLimit            , MaximumInputLimit _) -> GT
+        (MaximumInputLimit x, MaximumInputLimit y) -> compare x y
 
 -- | The result of performing a successful selection.
 --

diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Gen.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Wallet.Primitive.CoinSelection.Gen
+    ( genSelectionLimit
+    , genSelectionSkeleton
+    , shrinkSelectionLimit
+    , shrinkSelectionSkeleton
+    )
+    where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.CoinSelection.Balance
+    ( SelectionLimit, SelectionLimitOf (..), SelectionSkeleton (..) )
+import Cardano.Wallet.Primitive.Types.TokenMap.Gen
+    ( genAssetId, shrinkAssetId )
+import Cardano.Wallet.Primitive.Types.Tx.Gen
+    ( genTxOut, shrinkTxOut )
+import Test.QuickCheck
+    ( Gen
+    , NonNegative (..)
+    , arbitrary
+    , listOf
+    , oneof
+    , shrink
+    , shrinkList
+    , shrinkMapBy
+    )
+import Test.QuickCheck.Extra
+    ( liftShrink3 )
+
+import qualified Data.Set as Set
+
+--------------------------------------------------------------------------------
+-- Selection limits
+--------------------------------------------------------------------------------
+
+genSelectionLimit :: Gen SelectionLimit
+genSelectionLimit = oneof
+    [ MaximumInputLimit . getNonNegative <$> arbitrary
+    , pure NoLimit
+    ]
+
+shrinkSelectionLimit :: SelectionLimit -> [SelectionLimit]
+shrinkSelectionLimit = \case
+    MaximumInputLimit n ->
+        MaximumInputLimit . getNonNegative <$> shrink (NonNegative n)
+    NoLimit ->
+        []
+
+--------------------------------------------------------------------------------
+-- Selection skeletons
+--------------------------------------------------------------------------------
+
+genSelectionSkeleton :: Gen SelectionSkeleton
+genSelectionSkeleton = SelectionSkeleton
+    <$> genSkeletonInputCount
+    <*> genSkeletonOutputs
+    <*> genSkeletonChange
+  where
+    genSkeletonInputCount =
+        getNonNegative <$> arbitrary @(NonNegative Int)
+    genSkeletonOutputs =
+        listOf genTxOut
+    genSkeletonChange =
+        listOf (Set.fromList <$> listOf genAssetId)
+
+shrinkSelectionSkeleton :: SelectionSkeleton -> [SelectionSkeleton]
+shrinkSelectionSkeleton =
+    shrinkMapBy tupleToSkeleton skeletonToTuple $ liftShrink3
+        shrinkSkeletonInputCount
+        shrinkSkeletonOutputs
+        shrinkSkeletonChange
+  where
+    shrinkSkeletonInputCount =
+        shrink @Int
+    shrinkSkeletonOutputs =
+        shrinkList shrinkTxOut
+    shrinkSkeletonChange =
+        shrinkList $
+        shrinkMapBy Set.fromList Set.toList (shrinkList shrinkAssetId)
+
+    skeletonToTuple (SelectionSkeleton a b c) = (a, b, c)
+    tupleToSkeleton (a, b, c) = (SelectionSkeleton a b c)
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxO.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxO.hs
@@ -31,6 +31,7 @@ module Cardano.Wallet.Primitive.Types.UTxO
     , computeUtxoStatistics
     , excluding
     , isSubsetOf
+    , empty
     , null
     , log10
     , restrictedBy
@@ -138,6 +139,9 @@ restrictedTo :: UTxO -> Set TxOut -> UTxO
 restrictedTo (UTxO utxo) outs =
     UTxO $ Map.filter (`Set.member` outs) utxo
 
+empty :: UTxO
+empty = UTxO Map.empty
+
 null :: UTxO -> Bool
 null (UTxO u) = Map.null u
 

diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs
@@ -32,7 +32,8 @@ import Cardano.Wallet.Primitive.CoinSelection.Balance
     , SelectionError (..)
     , SelectionInsufficientError (..)
     , SelectionLens (..)
-    , SelectionLimit (..)
+    , SelectionLimit
+    , SelectionLimitOf (..)
     , SelectionResult (..)
     , SelectionSkeleton (..)
     , SelectionState (..)
@@ -66,6 +67,8 @@ import Cardano.Wallet.Primitive.CoinSelection.Balance
     , splitBundlesWithExcessiveTokenQuantities
     , ungroupByKey
     )
+import Cardano.Wallet.Primitive.CoinSelection.Gen
+    ( genSelectionLimit, shrinkSelectionLimit )
 import Cardano.Wallet.Primitive.Types.Address
     ( Address (..) )
 import Cardano.Wallet.Primitive.Types.Coin
@@ -219,6 +222,10 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelection.BalanceSpec" $
             [ eqLaws
             , ordLaws
             ]
+        testLawsMany @SelectionLimit
+            [ eqLaws
+            , ordLaws
+            ]
 
     parallel $ describe "Ordering of token maps" $ do
 
@@ -3574,6 +3581,10 @@ genTokenMapLarge = do
         <$> genAssetIdLargeRange
         <*> genTokenQuantityPositive
 
+instance Arbitrary SelectionLimit where
+    arbitrary = genSelectionLimit
+    shrink = shrinkSelectionLimit
+
 instance Arbitrary TokenMap where
     arbitrary = genTokenMapSmallRange
     shrink = shrinkTokenMapSmallRange

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs
@@ -76,7 +76,7 @@ import Cardano.Wallet.Primitive.AddressDerivation.Icarus
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey, toRewardAccountRaw )
 import Cardano.Wallet.Primitive.CoinSelection.Balance
-    ( SelectionLimit (..)
+    ( SelectionLimitOf (..)
     , SelectionResult (changeGenerated, inputsSelected, outputsCovered)
     , SelectionSkeleton (..)
     , selectionDelta

diff --git a/lib/test-utils/src/Test/QuickCheck/Extra.hs b/lib/test-utils/src/Test/QuickCheck/Extra.hs
@@ -16,6 +16,7 @@ module Test.QuickCheck.Extra
     , reasonablySized
 
       -- * Shrinking
+    , liftShrink3
     , liftShrink7
     , shrinkInterleaved
     , shrinkMapWith
@@ -24,6 +25,9 @@ module Test.QuickCheck.Extra
     , report
     , verify
 
+      -- * Combinators
+    , NotNull (..)
+
       -- * Utilities
     , interleaveRoundRobin
 
@@ -36,7 +40,8 @@ import Data.Map.Strict
 import Fmt
     ( indentF, (+|), (|+) )
 import Test.QuickCheck
-    ( Gen
+    ( Arbitrary (..)
+    , Gen
     , Property
     , Testable
     , counterexample
@@ -47,6 +52,7 @@ import Test.QuickCheck
     , scale
     , shrinkList
     , shrinkMapBy
+    , suchThat
     , (.&&.)
     )
 import Test.Utils.Pretty
@@ -114,6 +120,21 @@ genSized2 genA genB = (,)
 genSized2With :: (a -> b -> c) -> Gen a -> Gen b -> Gen c
 genSized2With f genA genB = uncurry f <$> genSized2 genA genB
 
+-- | Similar to 'liftShrink2', but applicable to 3-tuples.
+--
+liftShrink3
+    :: (a1 -> [a1])
+    -> (a2 -> [a2])
+    -> (a3 -> [a3])
+    -> (a1, a2, a3)
+    -> [(a1, a2, a3)]
+liftShrink3 s1 s2 s3 (a1, a2, a3) =
+    interleaveRoundRobin
+    [ [ (a1', a2 , a3 ) | a1' <- s1 a1 ]
+    , [ (a1 , a2', a3 ) | a2' <- s2 a2 ]
+    , [ (a1 , a2 , a3') | a3' <- s3 a3 ]
+    ]
+
 -- | Similar to 'liftShrink2', but applicable to 7-tuples.
 --
 liftShrink7
@@ -208,3 +229,14 @@ verify condition conditionTitle =
     (.&&.) (counterexample counterexampleText $ property condition)
   where
     counterexampleText = "Condition violated: " <> conditionTitle
+
+--------------------------------------------------------------------------------
+-- Non-null values
+--------------------------------------------------------------------------------
+
+newtype NotNull a = NotNull { unNotNull :: a }
+    deriving (Eq, Show)
+
+instance (Arbitrary a, Eq a, Monoid a) => Arbitrary (NotNull a) where
+    arbitrary = NotNull <$> arbitrary `suchThat` (/= mempty)
+    shrink (NotNull u) = NotNull <$> filter (/= mempty) (shrink u)
diff --git a/weeder.dhall b/weeder.dhall
@@ -9,13 +9,16 @@
   , "^Cardano\\.Wallet\\.Api\\.Client\\.byron(Address|Transaction|Wallet)Client\$"
   , "^Cardano\\.Wallet\\.Api\\.Link\\.(mintBurnAssets|patchSharedWallet|postExternalTransaction)\$"
   , "^Cardano\\.Wallet\\.DB\\.Sqlite\\.Types\\.sqlSettings'\$"
+  , "^Cardano\\.Wallet\\.Primitive\\.CoinSelection\\.Gen\\."
   , "^Cardano\\.Wallet\\.Primitive\\.Types.\\stabilityWindow(Byron|Shelley)\$"
+  , "^Cardano\\.Wallet\\.Primitive\\.Types\\.UTxO\\.empty\$"
   , "^Cardano\\.Wallet\\.Unsafe\\."
   , "^Cardano\\.Wallet\\.Version\\.TH\\.gitRevFromGit\$"
   , "^Data\\.Set\\.Strict\\.NonEmptySet\\."
   , "^UnliftIO\\.Compat\\.mkRetryHandler\$"
   , "^Spec\\.main\$"
   , "^Test\\..*\\.spec\$"
+  , "^Test\\.QuickCheck\\.Extra\\.liftShrink3\$"
   , "^Test\\.Utils\\.Paths\\.getTestData"
   , "^Cardano\\.Wallet\\.Api\\.Malformed\\."
   , "^Cardano\\.Wallet\\.DB\\.StateMachine\\.showLabelledExamples\$"