From 99df1dcb9d4aaff34071248cf8f4e11521e69837 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 9 Mar 2022 06:54:21 +0000 Subject: [PATCH 01/13] Parameterize the type of address in module `Balance`. --- lib/core/src/Cardano/Wallet/Api/Server.hs | 2 +- lib/core/src/Cardano/Wallet/CoinSelection.hs | 4 +- .../Cardano/Wallet/CoinSelection/Internal.hs | 33 ++-- .../Wallet/CoinSelection/Internal/Balance.hs | 159 +++++++++++------- .../CoinSelection/Internal/Balance/Gen.hs | 8 +- .../CoinSelection/Internal/BalanceSpec.hs | 74 ++++---- .../Wallet/CoinSelection/InternalSpec.hs | 8 +- 7 files changed, 169 insertions(+), 119 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 9470542fa6f..093a73f469a 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -4391,7 +4391,7 @@ instance IsServerError ErrSelectAssets where ErrSelectAssetsSelectionError (SelectionOutputErrorOf e) -> toServerError e -instance IsServerError (SelectionBalanceError (TxIn, Address)) where +instance IsServerError (SelectionBalanceError Address (TxIn, Address)) where toServerError = \case BalanceInsufficient e -> apiError err403 NotEnoughMoney $ mconcat diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 86bd8ea3b02..ddeb92d9526 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -285,7 +285,9 @@ emptySkeleton = SelectionSkeleton , skeletonChange = mempty } -toExternalSelectionSkeleton :: Internal.SelectionSkeleton -> SelectionSkeleton +toExternalSelectionSkeleton + :: Internal.SelectionSkeleton Address + -> SelectionSkeleton toExternalSelectionSkeleton Internal.SelectionSkeleton {..} = SelectionSkeleton { skeletonOutputs = diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index f48b61c0142..5734e736709 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -162,7 +162,7 @@ data SelectionConstraints = SelectionConstraints :: TokenMap -> Coin -- ^ Computes the minimum ada quantity required for a given output. , computeMinimumCost - :: SelectionSkeleton -> Coin + :: SelectionSkeleton Address -> Coin -- ^ Computes the minimum cost of a given selection skeleton. , computeSelectionLimit :: [(Address, TokenBundle)] -> SelectionLimit @@ -233,7 +233,7 @@ data SelectionParams u = SelectionParams -- data SelectionError u = SelectionBalanceErrorOf - (SelectionBalanceError u) + (SelectionBalanceError Address u) | SelectionCollateralErrorOf (SelectionCollateralError u) | SelectionOutputErrorOf @@ -326,14 +326,14 @@ prepareOutputs cs ps = performSelectionBalance :: (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m (Balance.SelectionResult u) u + => PerformSelection m (Balance.SelectionResult Address u) u performSelectionBalance cs ps = withExceptT SelectionBalanceErrorOf $ ExceptT $ uncurry Balance.performSelection $ toBalanceConstraintsParams (cs, ps) performSelectionCollateral :: (Applicative m, Ord u) - => Balance.SelectionResult u + => Balance.SelectionResult Address u -> PerformSelection m (Collateral.SelectionResult u) u performSelectionCollateral balanceResult cs ps | selectionCollateralRequired ps = @@ -359,8 +359,8 @@ selectionAllOutputs selection = (<>) -- | Creates constraints and parameters for 'Balance.performSelection'. -- toBalanceConstraintsParams - :: ( SelectionConstraints, SelectionParams u) - -> (Balance.SelectionConstraints, Balance.SelectionParams u) + :: ( SelectionConstraints , SelectionParams u) + -> (Balance.SelectionConstraints Address, Balance.SelectionParams Address u) toBalanceConstraintsParams (constraints, params) = (balanceConstraints, balanceParams) where @@ -378,8 +378,8 @@ toBalanceConstraintsParams (constraints, params) = } where adjustComputeMinimumCost - :: (SelectionSkeleton -> Coin) - -> (SelectionSkeleton -> Coin) + :: (SelectionSkeleton Address -> Coin) + -> (SelectionSkeleton Address -> Coin) adjustComputeMinimumCost = whenCollateralRequired params (. adjustSelectionSkeleton) where @@ -399,7 +399,9 @@ toBalanceConstraintsParams (constraints, params) = -- small, and since the marginal cost of a single extra input is -- relatively small, this fee increase is likely to be very small. -- - adjustSelectionSkeleton :: SelectionSkeleton -> SelectionSkeleton + adjustSelectionSkeleton + :: SelectionSkeleton Address + -> SelectionSkeleton Address adjustSelectionSkeleton = over #skeletonInputCount (+ view #maximumCollateralInputCount constraints) @@ -446,7 +448,7 @@ toBalanceConstraintsParams (constraints, params) = -- | Creates constraints and parameters for 'Collateral.performSelection'. -- toCollateralConstraintsParams - :: Balance.SelectionResult u + :: Balance.SelectionResult Address u -> ( SelectionConstraints, SelectionParams u) -> (Collateral.SelectionConstraints, Collateral.SelectionParams u) toCollateralConstraintsParams balanceResult (constraints, params) = @@ -479,7 +481,7 @@ toCollateralConstraintsParams balanceResult (constraints, params) = -- mkSelection :: SelectionParams u - -> Balance.SelectionResult u + -> Balance.SelectionResult Address u -> Collateral.SelectionResult u -> Selection u mkSelection _params balanceResult collateralResult = Selection @@ -495,7 +497,7 @@ mkSelection _params balanceResult collateralResult = Selection -- | Converts a 'Selection' to a balance result. -- -toBalanceResult :: Selection u -> Balance.SelectionResult u +toBalanceResult :: Selection u -> Balance.SelectionResult Address u toBalanceResult selection = Balance.SelectionResult { inputsSelected = view #inputs selection , outputsCovered = view #outputs selection @@ -844,7 +846,8 @@ verifySelectionError cs ps = \case -------------------------------------------------------------------------------- verifySelectionBalanceError - :: (Ord u, Show u) => VerifySelectionError (SelectionBalanceError u) u + :: (Ord u, Show u) + => VerifySelectionError (SelectionBalanceError Address u) u verifySelectionBalanceError cs ps = \case Balance.BalanceInsufficient e -> verifyBalanceInsufficientError cs ps e @@ -908,7 +911,7 @@ data FailureToVerifyInsufficientMinCoinValueError = deriving (Eq, Show) verifyInsufficientMinCoinValueError - :: VerifySelectionError Balance.InsufficientMinCoinValueError u + :: VerifySelectionError (Balance.InsufficientMinCoinValueError Address) u verifyInsufficientMinCoinValueError cs _ps e = verifyAll [ reportedMinCoinValue == verifiedMinCoinValue @@ -950,7 +953,7 @@ data FailureToVerifySelectionLimitReachedError u = -- verifySelectionLimitReachedError :: forall u. Show u - => VerifySelectionError (Balance.SelectionLimitReachedError u) u + => VerifySelectionError (Balance.SelectionLimitReachedError Address u) u verifySelectionLimitReachedError cs ps e = verify (Balance.MaximumInputLimit selectedInputCount >= selectionLimitAdjusted) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index f968bf0383f..0813e31b81c 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -127,8 +127,6 @@ import Algebra.PartialOrd ( PartialOrd (..) ) import Cardano.Numeric.Util ( padCoalesce ) -import Cardano.Wallet.Primitive.Types.Address - ( Address (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -213,7 +211,7 @@ import qualified Data.Set as Set -- -- - are not specific to a given selection. -- -data SelectionConstraints = SelectionConstraints +data SelectionConstraints address = SelectionConstraints { assessTokenBundleSize :: TokenBundle -> TokenBundleSizeAssessment -- ^ Assesses the size of a token bundle relative to the upper limit of @@ -224,10 +222,10 @@ data SelectionConstraints = SelectionConstraints :: TokenMap -> Coin -- ^ Computes the minimum ada quantity required for a given output. , computeMinimumCost - :: SelectionSkeleton -> Coin + :: SelectionSkeleton address -> Coin -- ^ Computes the minimum cost of a given selection skeleton. , computeSelectionLimit - :: [(Address, TokenBundle)] -> SelectionLimit + :: [(address, TokenBundle)] -> SelectionLimit -- ^ Computes an upper bound for the number of ordinary inputs to -- select, given a current set of outputs. } @@ -237,9 +235,9 @@ type SelectionParams = SelectionParamsOf [] -- | Specifies all parameters that are specific to a given selection. -- -data SelectionParamsOf outputs u = SelectionParams +data SelectionParamsOf outputs address u = SelectionParams { outputsToCover - :: !(outputs (Address, TokenBundle)) + :: !(outputs (address, TokenBundle)) -- ^ The complete set of outputs to be covered. , utxoAvailable :: !(UTxOSelection u) @@ -274,12 +272,12 @@ data SelectionParamsOf outputs u = SelectionParams deriving Generic deriving instance - (Eq (outputs (Address, TokenBundle)), Eq u) => - Eq (SelectionParamsOf outputs u) + (Eq (outputs (address, TokenBundle)), Eq u) => + Eq (SelectionParamsOf outputs address u) deriving instance - (Show (outputs (Address, TokenBundle)), Show u) => - Show (SelectionParamsOf outputs u) + (Show (outputs (address, TokenBundle)), Show u) => + Show (SelectionParamsOf outputs address u) -- | Indicates a choice of selection strategy. -- @@ -347,19 +345,20 @@ data UTxOBalanceSufficiencyInfo = UTxOBalanceSufficiencyInfo -- | Computes the balance of UTxO entries available for selection. -- -computeUTxOBalanceAvailable :: SelectionParamsOf outputs u -> TokenBundle +computeUTxOBalanceAvailable + :: SelectionParamsOf outputs address u -> TokenBundle computeUTxOBalanceAvailable = UTxOSelection.availableBalance . view #utxoAvailable -- | Computes the balance of UTxO entries required to be selected. -- computeUTxOBalanceRequired - :: Foldable outputs => SelectionParamsOf outputs u -> TokenBundle + :: Foldable outputs => SelectionParamsOf outputs address u -> TokenBundle computeUTxOBalanceRequired = fst . computeDeficitInOut computeBalanceInOut :: Foldable outputs - => SelectionParamsOf outputs u + => SelectionParamsOf outputs address u -> (TokenBundle, TokenBundle) computeBalanceInOut params = (balanceIn, balanceOut) @@ -377,7 +376,7 @@ computeBalanceInOut params = computeDeficitInOut :: Foldable outputs - => SelectionParamsOf outputs u + => SelectionParamsOf outputs address u -> (TokenBundle, TokenBundle) computeDeficitInOut params = (deficitIn, deficitOut) @@ -395,7 +394,7 @@ computeDeficitInOut params = -- computeUTxOBalanceSufficiency :: Foldable outputs - => SelectionParamsOf outputs u + => SelectionParamsOf outputs address u -> UTxOBalanceSufficiency computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo @@ -405,7 +404,7 @@ computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo -- computeUTxOBalanceSufficiencyInfo :: Foldable outputs - => SelectionParamsOf outputs u + => SelectionParamsOf outputs address u -> UTxOBalanceSufficiencyInfo computeUTxOBalanceSufficiencyInfo params = UTxOBalanceSufficiencyInfo {available, required, difference, sufficiency} @@ -427,7 +426,7 @@ computeUTxOBalanceSufficiencyInfo params = -- is greater than or equal to the required balance. -- isUTxOBalanceSufficient - :: Foldable outputs => SelectionParamsOf outputs u -> Bool + :: Foldable outputs => SelectionParamsOf outputs address u -> Bool isUTxOBalanceSufficient params = case computeUTxOBalanceSufficiency params of UTxOBalanceSufficient -> True @@ -443,11 +442,11 @@ isUTxOBalanceSufficient params = -- Increasing or decreasing the quantity of a particular asset in a change -- output must not change the estimated cost of a selection. -- -data SelectionSkeleton = SelectionSkeleton +data SelectionSkeleton address = SelectionSkeleton { skeletonInputCount :: !Int , skeletonOutputs - :: ![(Address, TokenBundle)] + :: ![(address, TokenBundle)] , skeletonChange :: ![Set AssetId] } @@ -497,7 +496,7 @@ type SelectionResult = SelectionResultOf [] -- | The result of performing a successful selection. -- -data SelectionResultOf outputs u = SelectionResult +data SelectionResultOf outputs address u = SelectionResult { inputsSelected :: !(NonEmpty (u, TokenBundle)) -- ^ A (non-empty) list of inputs selected from 'utxoAvailable'. @@ -508,7 +507,7 @@ data SelectionResultOf outputs u = SelectionResult :: !Coin -- ^ An extra sink for ada. , outputsCovered - :: !(outputs (Address, TokenBundle)) + :: !(outputs (address, TokenBundle)) -- ^ A list of outputs covered. , changeGenerated :: ![TokenBundle] @@ -523,11 +522,11 @@ data SelectionResultOf outputs u = SelectionResult deriving Generic deriving instance - (Eq (outputs (Address, TokenBundle)), Eq u) => - Eq (SelectionResultOf outputs u) + (Eq (outputs (address, TokenBundle)), Eq u) => + Eq (SelectionResultOf outputs address u) deriving instance - (Show (outputs (Address, TokenBundle)), Show u) => - Show (SelectionResultOf outputs u) + (Show (outputs (address, TokenBundle)), Show u) => + Show (SelectionResultOf outputs address u) -- | Indicates the difference between total input value and total output value -- of a 'SelectionResult'. @@ -563,7 +562,7 @@ instance Buildable a => Buildable (SelectionDelta a) where -- selectionDeltaAllAssets :: Foldable outputs - => SelectionResultOf outputs u + => SelectionResultOf outputs address u -> SelectionDelta TokenBundle selectionDeltaAllAssets result | balanceOut `leq` balanceIn = @@ -600,15 +599,17 @@ selectionDeltaAllAssets result -- See 'SelectionDelta'. -- selectionDeltaCoin - :: Foldable outputs => SelectionResultOf outputs u -> SelectionDelta Coin + :: Foldable outputs + => SelectionResultOf outputs address u + -> SelectionDelta Coin selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- | Indicates whether or not a selection result has a valid surplus. -- selectionHasValidSurplus :: Foldable outputs - => SelectionConstraints - -> SelectionResultOf outputs u + => SelectionConstraints address + -> SelectionResultOf outputs address u -> Bool selectionHasValidSurplus constraints selection = case selectionDeltaAllAssets selection of @@ -645,7 +646,10 @@ selectionHasValidSurplus constraints selection = -- Use 'selectionDeltaCoin' if you wish to handle the case where there is -- a deficit. -- -selectionSurplusCoin :: Foldable outputs => SelectionResultOf outputs u -> Coin +selectionSurplusCoin + :: Foldable outputs + => SelectionResultOf outputs address u + -> Coin selectionSurplusCoin result = case selectionDeltaCoin result of SelectionSurplus surplus -> surplus @@ -654,7 +658,9 @@ selectionSurplusCoin result = -- | Converts a selection into a skeleton. -- selectionSkeleton - :: Foldable outputs => SelectionResultOf outputs u -> SelectionSkeleton + :: Foldable outputs + => SelectionResultOf outputs address u + -> SelectionSkeleton address selectionSkeleton s = SelectionSkeleton { skeletonInputCount = F.length (view #inputsSelected s) , skeletonOutputs = F.toList (view #outputsCovered s) @@ -665,8 +671,8 @@ selectionSkeleton s = SelectionSkeleton -- selectionMinimumCost :: Foldable outputs - => SelectionConstraints - -> SelectionResultOf outputs u + => SelectionConstraints address + -> SelectionResultOf outputs address u -> Coin selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton @@ -686,20 +692,20 @@ selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton -- selectionMaximumCost :: Foldable outputs - => SelectionConstraints - -> SelectionResultOf outputs u + => SelectionConstraints address + -> SelectionResultOf outputs address u -> Coin selectionMaximumCost c = mtimesDefault (2 :: Int) . selectionMinimumCost c -- | Represents the set of errors that may occur while performing a selection. -- -data SelectionBalanceError u +data SelectionBalanceError address u = BalanceInsufficient BalanceInsufficientError | SelectionLimitReached - (SelectionLimitReachedError u) + (SelectionLimitReachedError address u) | InsufficientMinCoinValues - (NonEmpty InsufficientMinCoinValueError) + (NonEmpty (InsufficientMinCoinValueError address)) | UnableToConstructChange UnableToConstructChangeError | EmptyUTxO @@ -708,7 +714,7 @@ data SelectionBalanceError u -- | Indicates that the balance of selected UTxO entries was insufficient to -- cover the balance required while remaining within the selection limit. -- -data SelectionLimitReachedError u = SelectionLimitReachedError +data SelectionLimitReachedError address u = SelectionLimitReachedError { utxoBalanceRequired :: !TokenBundle -- ^ The UTXO balance required. @@ -717,7 +723,7 @@ data SelectionLimitReachedError u = SelectionLimitReachedError -- ^ The inputs that could be selected while satisfying the -- 'selectionLimit'. , outputsToCover - :: !(NonEmpty (Address, TokenBundle)) + :: !(NonEmpty (address, TokenBundle)) } deriving (Generic, Eq, Show) -- | Indicates that the balance of available UTxO entries is insufficient to @@ -744,9 +750,9 @@ balanceMissing (BalanceInsufficientError available required) = -- -- See also: 'prepareOutputs'. -- -data InsufficientMinCoinValueError = InsufficientMinCoinValueError +data InsufficientMinCoinValueError address = InsufficientMinCoinValueError { outputWithInsufficientAda - :: !(Address, TokenBundle) + :: !(address, TokenBundle) -- ^ The particular output that does not have the minimum coin quantity -- expected by the protocol. , expectedMinCoinValue @@ -754,7 +760,9 @@ data InsufficientMinCoinValueError = InsufficientMinCoinValueError -- ^ The minimum coin quantity expected for this output. } deriving (Generic, Eq, Show) -instance Buildable InsufficientMinCoinValueError where +instance Buildable address => + Buildable (InsufficientMinCoinValueError address) + where build (InsufficientMinCoinValueError (a, b) c) = unlinesF [ nameF "Expected min coin value" (build c) , nameF "Address" (build a) @@ -772,10 +780,14 @@ data UnableToConstructChangeError = UnableToConstructChangeError -- selection cost and minimum coin quantity of each change output. } deriving (Generic, Eq, Show) -type PerformSelection m outputs u = - SelectionConstraints -> - SelectionParamsOf outputs u -> - m (Either (SelectionBalanceError u) (SelectionResultOf outputs u)) +type PerformSelection m outputs address u = + SelectionConstraints address -> + SelectionParamsOf outputs address u -> + m ( + Either + (SelectionBalanceError address u) + (SelectionResultOf outputs address u) + ) -- | Performs a coin selection and generates change bundles in one step. -- @@ -784,8 +796,9 @@ type PerformSelection m outputs u = -- for which 'selectionHasValidSurplus' returns 'True'. -- performSelection - :: forall m u. (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m [] u + :: forall m address u. + (HasCallStack, MonadRandom m, Ord u, Show address, Show u) + => PerformSelection m [] address u performSelection = performSelectionEmpty performSelectionNonEmpty -- | Transforms a coin selection function that requires a non-empty list of @@ -816,32 +829,41 @@ performSelection = performSelectionEmpty performSelectionNonEmpty -- selectionHasValidSurplus constraints (transformResult result) -- performSelectionEmpty - :: Functor m => PerformSelection m NonEmpty u -> PerformSelection m [] u + :: forall m address u. Functor m + => PerformSelection m NonEmpty address u + -> PerformSelection m [] address u performSelectionEmpty performSelectionFn constraints params = fmap transformResult <$> performSelectionFn constraints (transformParams params) where transformParams - :: SelectionParamsOf [] u - -> SelectionParamsOf NonEmpty u + :: SelectionParamsOf [] address u + -> SelectionParamsOf NonEmpty address u transformParams = over #extraCoinSource (transform (`Coin.add` minCoin) (const id)) . over #outputsToCover (transform (const (dummyOutput :| [])) (const . id)) - transformResult :: SelectionResultOf NonEmpty u -> SelectionResultOf [] u + transformResult + :: SelectionResultOf NonEmpty address u + -> SelectionResultOf [] address u transformResult = over #extraCoinSource (transform (`Coin.difference` minCoin) (const id)) . over #outputsCovered (transform (const []) (const . F.toList)) - transform :: a -> (NonEmpty (Address, TokenBundle) -> a) -> a + transform :: a -> (NonEmpty (address, TokenBundle) -> a) -> a transform x y = maybe x y $ NE.nonEmpty $ view #outputsToCover params - dummyOutput :: (Address, TokenBundle) - dummyOutput = (Address "", TokenBundle.fromCoin minCoin) + dummyOutput :: (address, TokenBundle) + dummyOutput = + -- TODO: ADP-1448 + -- + -- Replace this call to 'error' with a call to a function that + -- generates a dummy address. + (error "dummy address", TokenBundle.fromCoin minCoin) -- The 'performSelectionNonEmpty' function imposes a precondition that all -- outputs must have at least the minimum ada quantity. Therefore, the @@ -861,8 +883,9 @@ performSelectionEmpty performSelectionFn constraints params = (view #computeMinimumAdaQuantity constraints TokenMap.empty) performSelectionNonEmpty - :: forall m u. (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m NonEmpty u + :: forall m address u. + (HasCallStack, MonadRandom m, Ord u, Show address, Show u) + => PerformSelection m NonEmpty address u performSelectionNonEmpty constraints params -- Is the total available UTXO balance sufficient? | not utxoBalanceSufficient = @@ -913,7 +936,7 @@ performSelectionNonEmpty constraints params } = params selectionLimitReachedError - :: [(u, TokenBundle)] -> m (Either (SelectionBalanceError u) a) + :: [(u, TokenBundle)] -> m (Either (SelectionBalanceError address u) a) selectionLimitReachedError inputsSelected = pure $ Left $ SelectionLimitReached $ SelectionLimitReachedError { inputsSelected @@ -933,13 +956,13 @@ performSelectionNonEmpty constraints params utxoBalanceSufficient :: Bool utxoBalanceSufficient = isUTxOBalanceSufficient params - insufficientMinCoinValues :: [InsufficientMinCoinValueError] + insufficientMinCoinValues :: [InsufficientMinCoinValueError address] insufficientMinCoinValues = mapMaybe mkInsufficientMinCoinValueError outputsToCover where mkInsufficientMinCoinValueError - :: (Address, TokenBundle) - -> Maybe InsufficientMinCoinValueError + :: (address, TokenBundle) + -> Maybe (InsufficientMinCoinValueError address) mkInsufficientMinCoinValueError o | view #coin (snd o) >= expectedMinCoinValue = Nothing @@ -1022,7 +1045,11 @@ performSelectionNonEmpty constraints params -- makeChangeRepeatedly :: UTxOSelectionNonEmpty u - -> m (Either (SelectionBalanceError u) (SelectionResultOf NonEmpty u)) + -> m + (Either + (SelectionBalanceError address u) + (SelectionResultOf NonEmpty address u) + ) makeChangeRepeatedly s = case mChangeGenerated of Right change | length change >= length outputsToCover -> @@ -1075,7 +1102,9 @@ performSelectionNonEmpty constraints params , assetsToBurn } - mkSelectionResult :: [TokenBundle] -> SelectionResultOf NonEmpty u + mkSelectionResult + :: [TokenBundle] + -> SelectionResultOf NonEmpty address u mkSelectionResult changeGenerated = SelectionResult { inputsSelected , extraCoinSource diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs index af0b4144014..8c3c910e90a 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs @@ -19,6 +19,8 @@ import Cardano.Wallet.CoinSelection.Internal.Balance , SelectionSkeleton (..) , SelectionStrategy (..) ) +import Cardano.Wallet.Primitive.Types.Address + ( Address ) import Cardano.Wallet.Primitive.Types.Address.Gen ( genAddress, shrinkAddress ) import Cardano.Wallet.Primitive.Types.Coin @@ -70,7 +72,7 @@ shrinkSelectionLimit = \case -- Selection skeletons -------------------------------------------------------------------------------- -genSelectionSkeleton :: Gen SelectionSkeleton +genSelectionSkeleton :: Gen (SelectionSkeleton Address) genSelectionSkeleton = SelectionSkeleton <$> genSkeletonInputCount <*> genSkeletonOutputs @@ -86,7 +88,9 @@ genSelectionSkeleton = SelectionSkeleton genSkeletonChange = listOf (Set.fromList <$> listOf genAssetId) -shrinkSelectionSkeleton :: SelectionSkeleton -> [SelectionSkeleton] +shrinkSelectionSkeleton + :: SelectionSkeleton Address + -> [SelectionSkeleton Address] shrinkSelectionSkeleton = genericRoundRobinShrink <@> shrinkSkeletonInputCount <:> shrinkSkeletonOutputs diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index b6e8b2870d6..7a0619bb953 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -623,13 +623,14 @@ prop_AssetCount_TokenMap_placesEmptyMapsFirst maps = -- -- We define this type alias to shorten type signatures. -- -type PerformSelectionResult = - Either (SelectionBalanceError InputId) (SelectionResult InputId) +type PerformSelectionResult = Either + (SelectionBalanceError Address InputId) + (SelectionResult Address InputId) genSelectionParams :: Gen (InputId -> Bool) -> Gen (UTxOIndex InputId) - -> Gen (SelectionParams InputId) + -> Gen (SelectionParams Address InputId) genSelectionParams genPreselectedInputs genUTxOIndex' = do utxoAvailable <- genUTxOIndex' isInputPreselected <- oneof @@ -671,7 +672,9 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do genPreselectedInputsNone :: Gen (InputId -> Bool) genPreselectedInputsNone = pure $ const False -shrinkSelectionParams :: SelectionParams InputId -> [SelectionParams InputId] +shrinkSelectionParams + :: SelectionParams Address InputId + -> [SelectionParams Address InputId] shrinkSelectionParams = genericRoundRobinShrink <@> shrinkList shrinkOutput <:> shrinkUTxOSelection @@ -692,7 +695,7 @@ shrinkSelectionParams = genericRoundRobinShrink prop_performSelection_small :: MockSelectionConstraints - -> Blind (Small (SelectionParams InputId)) + -> Blind (Small (SelectionParams Address InputId)) -> Property prop_performSelection_small mockConstraints (Blind (Small params)) = checkCoverage $ @@ -804,7 +807,7 @@ prop_performSelection_small mockConstraints (Blind (Small params)) = . fmap snd $ view #outputsToCover params - constraints :: SelectionConstraints + constraints :: SelectionConstraints Address constraints = unMockSelectionConstraints mockConstraints selectionLimit :: SelectionLimit @@ -872,7 +875,7 @@ prop_performSelection_small mockConstraints (Blind (Small params)) = prop_performSelection_large :: MockSelectionConstraints - -> Blind (Large (SelectionParams InputId)) + -> Blind (Large (SelectionParams Address InputId)) -> Property prop_performSelection_large mockConstraints (Blind (Large params)) = -- Generation of large UTxO sets takes longer, so limit the number of runs: @@ -893,7 +896,7 @@ prop_performSelection_huge = ioProperty $ prop_performSelection_huge_inner :: UTxOIndex InputId -> MockSelectionConstraints - -> Large (SelectionParams InputId) + -> Large (SelectionParams Address InputId) -> Property prop_performSelection_huge_inner utxoAvailable mockConstraints (Large params) = withMaxSuccess 5 $ @@ -904,7 +907,7 @@ prop_performSelection_huge_inner utxoAvailable mockConstraints (Large params) = prop_performSelection :: MockSelectionConstraints - -> SelectionParams InputId + -> SelectionParams Address InputId -> (PerformSelectionResult -> Property -> Property) -> Property prop_performSelection mockConstraints params coverage = @@ -923,7 +926,7 @@ prop_performSelection mockConstraints params coverage = monitor (coverage result) pure $ either onFailure onSuccess result where - constraints :: SelectionConstraints + constraints :: SelectionConstraints Address constraints = unMockSelectionConstraints mockConstraints SelectionParams @@ -934,7 +937,7 @@ prop_performSelection mockConstraints params coverage = , assetsToBurn } = params - onSuccess :: SelectionResultOf [] InputId -> Property + onSuccess :: SelectionResultOf [] Address InputId -> Property onSuccess result = counterexample "onSuccess" $ report @@ -999,7 +1002,7 @@ prop_performSelection mockConstraints params coverage = (view #inputsSelected result <&> fst) (view #utxoAvailable params) - onFailure :: SelectionBalanceError InputId -> Property + onFailure :: SelectionBalanceError Address InputId -> Property onFailure = \case BalanceInsufficient e -> onBalanceInsufficient e @@ -1037,7 +1040,8 @@ prop_performSelection mockConstraints params coverage = where BalanceInsufficientError errorBalanceAvailable errorBalanceRequired = e - onSelectionLimitReached :: SelectionLimitReachedError InputId -> Property + onSelectionLimitReached + :: SelectionLimitReachedError Address InputId -> Property onSelectionLimitReached e = counterexample "onSelectionLimitReached" $ report errorBalanceRequired @@ -1061,7 +1065,7 @@ prop_performSelection mockConstraints params coverage = F.foldMap (view #tokens . snd) errorInputsSelected onInsufficientMinCoinValues - :: NonEmpty InsufficientMinCoinValueError -> Property + :: NonEmpty (InsufficientMinCoinValueError Address) -> Property onInsufficientMinCoinValues es = counterexample "onInsufficientMinCoinValues" $ report es @@ -1107,7 +1111,7 @@ prop_performSelection mockConstraints params coverage = -- -- We expect that the selection should succeed. -- - let constraints' :: SelectionConstraints = constraints + let constraints' :: SelectionConstraints Address = constraints { assessTokenBundleSize = unMockAssessTokenBundleSize MockAssessTokenBundleSizeUnlimited , computeMinimumAdaQuantity = computeMinimumAdaQuantityZero @@ -1150,7 +1154,9 @@ prop_performSelection mockConstraints params coverage = -- Both the parameters and the result are verified. -- prop_performSelectionEmpty - :: MockSelectionConstraints -> Small (SelectionParams InputId) -> Property + :: MockSelectionConstraints + -> Small (SelectionParams Address InputId) + -> Property prop_performSelectionEmpty mockConstraints (Small params) = checkCoverage $ cover 10 (null (view #outputsToCover params)) @@ -1207,16 +1213,16 @@ prop_performSelectionEmpty mockConstraints (Small params) = , resultTransformed === (result & over #outputsCovered F.toList) ] - constraints :: SelectionConstraints + constraints :: SelectionConstraints Address constraints = unMockSelectionConstraints mockConstraints - paramsTransformed :: SelectionParamsOf NonEmpty InputId + paramsTransformed :: SelectionParamsOf NonEmpty Address InputId paramsTransformed = view #paramsTransformed transformationReport - result :: SelectionResultOf NonEmpty InputId + result :: SelectionResultOf NonEmpty Address InputId result = expectRight $ view #result transformationReport - resultTransformed :: SelectionResultOf [] InputId + resultTransformed :: SelectionResultOf [] Address InputId resultTransformed = expectRight $ view #resultTransformed transformationReport @@ -1261,17 +1267,17 @@ withTransformationReport p r = TransformationReport p r r -- - a single change output to cover the output deficit. -- mockPerformSelectionNonEmpty - :: PerformSelection Identity NonEmpty InputId + :: PerformSelection Identity NonEmpty Address InputId mockPerformSelectionNonEmpty constraints params = Identity $ Right result where - result :: SelectionResultOf NonEmpty InputId + result :: SelectionResultOf NonEmpty Address InputId result = resultWithoutDelta & set #inputsSelected (makeInputsOfValue $ deficitIn <> TokenBundle.fromCoin minimumCost) where minimumCost :: Coin minimumCost = selectionMinimumCost constraints resultWithoutDelta - resultWithoutDelta :: SelectionResultOf NonEmpty InputId + resultWithoutDelta :: SelectionResultOf NonEmpty Address InputId resultWithoutDelta = SelectionResult { inputsSelected = makeInputsOfValue deficitIn , changeGenerated = makeChangeOfValue deficitOut @@ -1847,7 +1853,9 @@ mkBoundaryTestExpectation (BoundaryTestData params expectedResult) = do , computeSelectionLimit = const NoLimit } -encodeBoundaryTestCriteria :: BoundaryTestCriteria -> SelectionParams InputId +encodeBoundaryTestCriteria + :: BoundaryTestCriteria + -> SelectionParams Address InputId encodeBoundaryTestCriteria c = SelectionParams { outputsToCover = zip @@ -1879,7 +1887,9 @@ encodeBoundaryTestCriteria c = SelectionParams dummyTxIns :: [TxIn] dummyTxIns = [TxIn (Hash "") x | x <- [0 ..]] -decodeBoundaryTestResult :: SelectionResult InputId -> BoundaryTestResult +decodeBoundaryTestResult + :: SelectionResult Address InputId + -> BoundaryTestResult decodeBoundaryTestResult r = BoundaryTestResult { boundaryTestInputs = L.sort $ NE.toList $ TokenBundle.toFlatList . snd <$> view #inputsSelected r @@ -2457,7 +2467,9 @@ shrinkMockSelectionConstraints = genericRoundRobinShrink <:> shrinkMockComputeSelectionLimit <:> Nil -unMockSelectionConstraints :: MockSelectionConstraints -> SelectionConstraints +unMockSelectionConstraints + :: MockSelectionConstraints + -> SelectionConstraints Address unMockSelectionConstraints m = SelectionConstraints { assessTokenBundleSize = unMockAssessTokenBundleSize $ view #assessTokenBundleSize m @@ -2534,17 +2546,17 @@ shrinkMockComputeMinimumCost = \case [MockComputeMinimumCostZero] unMockComputeMinimumCost - :: MockComputeMinimumCost -> (SelectionSkeleton -> Coin) + :: MockComputeMinimumCost -> (SelectionSkeleton Address -> Coin) unMockComputeMinimumCost = \case MockComputeMinimumCostZero -> computeMinimumCostZero MockComputeMinimumCostLinear -> computeMinimumCostLinear -computeMinimumCostZero :: SelectionSkeleton -> Coin +computeMinimumCostZero :: SelectionSkeleton Address -> Coin computeMinimumCostZero = const $ Coin 0 -computeMinimumCostLinear :: SelectionSkeleton -> Coin +computeMinimumCostLinear :: SelectionSkeleton Address -> Coin computeMinimumCostLinear s = Coin $ fromIntegral @@ -4442,13 +4454,13 @@ newtype Small a = Small { getSmall:: a } deriving (Eq, Show) -instance Arbitrary (Large (SelectionParams InputId)) where +instance Arbitrary (Large (SelectionParams Address InputId)) where arbitrary = Large <$> genSelectionParams (genInputIdFunction (arbitrary @Bool)) (genUTxOIndexLarge) shrink = shrinkMapBy Large getLarge shrinkSelectionParams -instance Arbitrary (Small (SelectionParams InputId)) where +instance Arbitrary (Small (SelectionParams Address InputId)) where arbitrary = Small <$> genSelectionParams (genInputIdFunction (arbitrary @Bool)) (genUTxOIndex) diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index d77d91a565b..996e756e3c7 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -322,7 +322,7 @@ prop_performSelection_coverage params r innerProperty = prop_toBalanceConstraintsParams_computeMinimumCost :: MockSelectionConstraints -> SelectionParams InputId - -> SelectionSkeleton + -> SelectionSkeleton Address -> Property prop_toBalanceConstraintsParams_computeMinimumCost mockConstraints params skeleton = @@ -359,10 +359,10 @@ prop_toBalanceConstraintsParams_computeMinimumCost maximumCollateralInputCount :: Int maximumCollateralInputCount = constraints ^. #maximumCollateralInputCount - computeMinimumCostOriginal :: SelectionSkeleton -> Coin + computeMinimumCostOriginal :: SelectionSkeleton Address -> Coin computeMinimumCostOriginal = constraints ^. #computeMinimumCost - computeMinimumCostAdjusted :: SelectionSkeleton -> Coin + computeMinimumCostAdjusted :: SelectionSkeleton Address -> Coin computeMinimumCostAdjusted = toBalanceConstraintsParams (constraints, params) & fst & view #computeMinimumCost @@ -859,6 +859,6 @@ instance Arbitrary (SelectionParams InputId) where arbitrary = genSelectionParams shrink = shrinkSelectionParams -instance Arbitrary SelectionSkeleton where +instance Arbitrary (SelectionSkeleton Address) where arbitrary = genSelectionSkeleton shrink = shrinkSelectionSkeleton From df55b71ffb5aa851d86884a74dc39a69278e36d2 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 9 Mar 2022 10:21:03 +0000 Subject: [PATCH 02/13] Parameterize the type of address in module `CoinSelection.Internal`. --- lib/core/src/Cardano/Wallet.hs | 6 +- lib/core/src/Cardano/Wallet/Api/Server.hs | 7 +- lib/core/src/Cardano/Wallet/CoinSelection.hs | 12 +- .../Cardano/Wallet/CoinSelection/Internal.hs | 300 ++++++++++-------- .../Wallet/CoinSelection/InternalSpec.hs | 31 +- 5 files changed, 193 insertions(+), 163 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index dee784bbdee..27047929a9a 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -3269,10 +3269,10 @@ data ErrCreateMigrationPlan deriving (Generic, Eq, Show) data ErrSelectAssets - = ErrSelectAssetsPrepareOutputsError SelectionOutputError + = ErrSelectAssetsPrepareOutputsError (SelectionOutputError Address) | ErrSelectAssetsNoSuchWallet ErrNoSuchWallet | ErrSelectAssetsAlreadyWithdrawing Tx - | ErrSelectAssetsSelectionError (SelectionError InputId) + | ErrSelectAssetsSelectionError (SelectionError Address InputId) deriving (Generic, Eq, Show) data ErrStakePoolDelegation @@ -3422,7 +3422,7 @@ data WalletFollowLog -- | Log messages from API server actions running in a wallet worker context. data WalletLog = MsgSelectionStart UTxO [TxOut] - | MsgSelectionError (SelectionError InputId) + | MsgSelectionError (SelectionError Address InputId) | MsgSelectionReportSummarized SelectionReportSummarized | MsgSelectionReportDetailed SelectionReportDetailed | MsgMigrationUTxOBefore UTxOStatistics diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 093a73f469a..0f659031670 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -4319,14 +4319,14 @@ instance IsServerError (ErrInvalidDerivationIndex 'Soft level) where , "between ", pretty minIx, " and ", pretty maxIx, " without a suffix." ] -instance IsServerError SelectionOutputError where +instance IsServerError (SelectionOutputError Address) where toServerError = \case SelectionOutputSizeExceedsLimit e -> toServerError e SelectionOutputTokenQuantityExceedsLimit e -> toServerError e -instance IsServerError SelectionOutputSizeExceedsLimitError where +instance IsServerError (SelectionOutputSizeExceedsLimitError Address) where toServerError e = apiError err403 OutputTokenBundleSizeExceedsLimit $ mconcat [ "One of the outputs you've specified contains too many assets. " @@ -4340,7 +4340,8 @@ instance IsServerError SelectionOutputSizeExceedsLimitError where where output = view #outputThatExceedsLimit e -instance IsServerError SelectionOutputTokenQuantityExceedsLimitError where +instance IsServerError (SelectionOutputTokenQuantityExceedsLimitError Address) + where toServerError e = apiError err403 OutputTokenQuantityExceedsLimit $ mconcat [ "One of the token quantities you've specified is greater than the " , "maximum quantity allowed in a single transaction output. Try " diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index ddeb92d9526..329d8efd8b4 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -169,7 +169,7 @@ data SelectionConstraints = SelectionConstraints deriving Generic toInternalSelectionConstraints - :: SelectionConstraints -> Internal.SelectionConstraints + :: SelectionConstraints -> Internal.SelectionConstraints Address toInternalSelectionConstraints SelectionConstraints {..} = Internal.SelectionConstraints { computeMinimumCost = @@ -239,7 +239,9 @@ data SelectionParams = SelectionParams } deriving (Eq, Generic, Show) -toInternalSelectionParams :: SelectionParams -> Internal.SelectionParams InputId +toInternalSelectionParams + :: SelectionParams + -> Internal.SelectionParams Address InputId toInternalSelectionParams SelectionParams {..} = Internal.SelectionParams { utxoAvailableForCollateral = @@ -336,7 +338,7 @@ data SelectionOf change = Selection type Selection = SelectionOf TokenBundle toExternalSelection - :: SelectionParams -> Internal.Selection InputId -> Selection + :: SelectionParams -> Internal.Selection Address InputId -> Selection toExternalSelection _ps Internal.Selection {..} = Selection { collateral = @@ -353,7 +355,7 @@ toExternalSelection _ps Internal.Selection {..} = toInternalSelection :: (change -> TokenBundle) -> SelectionOf change - -> Internal.Selection InputId + -> Internal.Selection Address InputId toInternalSelection getChangeBundle Selection {..} = Internal.Selection { change = getChangeBundle @@ -386,7 +388,7 @@ performSelection :: (HasCallStack, MonadRandom m) => SelectionConstraints -> SelectionParams - -> ExceptT (SelectionError InputId) m Selection + -> ExceptT (SelectionError Address InputId) m Selection performSelection cs ps = toExternalSelection ps <$> Internal.performSelection diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index 5734e736709..7fc3de52ab3 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -76,8 +76,6 @@ import Cardano.Wallet.CoinSelection.Internal.Balance ) import Cardano.Wallet.CoinSelection.Internal.Collateral ( SelectionCollateralError ) -import Cardano.Wallet.Primitive.Types.Address - ( Address (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -147,7 +145,7 @@ import qualified Data.Map.Strict as Map -- - place limits on the coin selection algorithm, enabling it to produce -- selections that are acceptable to the ledger. -- -data SelectionConstraints = SelectionConstraints +data SelectionConstraints address = SelectionConstraints { assessTokenBundleSize :: TokenBundle -> TokenBundleSizeAssessment -- ^ Assesses the size of a token bundle relative to the upper limit of @@ -162,10 +160,10 @@ data SelectionConstraints = SelectionConstraints :: TokenMap -> Coin -- ^ Computes the minimum ada quantity required for a given output. , computeMinimumCost - :: SelectionSkeleton Address -> Coin + :: SelectionSkeleton address -> Coin -- ^ Computes the minimum cost of a given selection skeleton. , computeSelectionLimit - :: [(Address, TokenBundle)] -> SelectionLimit + :: [(address, TokenBundle)] -> SelectionLimit -- ^ Computes an upper bound for the number of ordinary inputs to -- select, given a current set of outputs. , maximumCollateralInputCount @@ -181,7 +179,7 @@ data SelectionConstraints = SelectionConstraints -- | Specifies all parameters that are specific to a given selection. -- -data SelectionParams u = SelectionParams +data SelectionParams address u = SelectionParams { assetsToBurn :: !TokenMap -- ^ Specifies a set of assets to burn. @@ -195,7 +193,7 @@ data SelectionParams u = SelectionParams :: !Coin -- ^ Specifies extra 'Coin' out. , outputsToCover - :: ![(Address, TokenBundle)] + :: ![(address, TokenBundle)] -- ^ Specifies a set of outputs that must be paid for. , rewardWithdrawal :: !Coin @@ -231,18 +229,18 @@ data SelectionParams u = SelectionParams -- | Indicates that an error occurred while performing a coin selection. -- -data SelectionError u +data SelectionError address u = SelectionBalanceErrorOf - (SelectionBalanceError Address u) + (SelectionBalanceError address u) | SelectionCollateralErrorOf (SelectionCollateralError u) | SelectionOutputErrorOf - SelectionOutputError + (SelectionOutputError address) deriving (Eq, Show) -- | Represents a balanced selection. -- -data Selection u = Selection +data Selection address u = Selection { inputs :: !(NonEmpty (u, TokenBundle)) -- ^ Selected inputs. @@ -250,7 +248,7 @@ data Selection u = Selection :: ![(u, Coin)] -- ^ Selected collateral inputs. , outputs - :: ![(Address, TokenBundle)] + :: ![(address, TokenBundle)] -- ^ User-specified outputs , change :: ![TokenBundle] @@ -272,10 +270,10 @@ data Selection u = Selection -- | Provides a context for functions related to 'performSelection'. -type PerformSelection m a u = - SelectionConstraints -> - SelectionParams u -> - ExceptT (SelectionError u) m a +type PerformSelection m address a u = + SelectionConstraints address -> + SelectionParams address u -> + ExceptT (SelectionError address u) m a -------------------------------------------------------------------------------- -- Performing a selection @@ -304,13 +302,13 @@ type PerformSelection m a u = -- >>> verifySelectionError cs ps e == VerificationSuccess -- performSelection - :: (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m (Selection u) u + :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) + => PerformSelection m address (Selection address u) u performSelection cs = performSelectionInner cs <=< prepareOutputs cs performSelectionInner - :: (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m (Selection u) u + :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) + => PerformSelection m address (Selection address u) u performSelectionInner cs ps = do balanceResult <- performSelectionBalance cs ps collateralResult <- performSelectionCollateral balanceResult cs ps @@ -318,23 +316,23 @@ performSelectionInner cs ps = do prepareOutputs :: Applicative m - => PerformSelection m (SelectionParams u) u + => PerformSelection m address (SelectionParams address u) u prepareOutputs cs ps = withExceptT SelectionOutputErrorOf $ ExceptT $ pure $ flip (set #outputsToCover) ps <$> prepareOutputsInternal cs (view #outputsToCover ps) performSelectionBalance - :: (HasCallStack, MonadRandom m, Ord u, Show u) - => PerformSelection m (Balance.SelectionResult Address u) u + :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) + => PerformSelection m address (Balance.SelectionResult address u) u performSelectionBalance cs ps = withExceptT SelectionBalanceErrorOf $ ExceptT $ uncurry Balance.performSelection $ toBalanceConstraintsParams (cs, ps) performSelectionCollateral :: (Applicative m, Ord u) - => Balance.SelectionResult Address u - -> PerformSelection m (Collateral.SelectionResult u) u + => Balance.SelectionResult address u + -> PerformSelection m address (Collateral.SelectionResult u) u performSelectionCollateral balanceResult cs ps | selectionCollateralRequired ps = withExceptT SelectionCollateralErrorOf $ ExceptT $ pure $ @@ -348,19 +346,25 @@ performSelectionCollateral balanceResult cs ps -- Since change outputs do not have addresses at the point of generation, -- this function assigns all change outputs with a dummy change address. -- -selectionAllOutputs :: Selection u -> [(Address, TokenBundle)] +selectionAllOutputs :: Selection address u -> [(address, TokenBundle)] selectionAllOutputs selection = (<>) (selection ^. #outputs) - (selection ^. #change <&> (dummyChangeAddress, )) + (selection ^. #change <&> (dummyChangeaddress, )) where - dummyChangeAddress :: Address - dummyChangeAddress = Address "" + dummyChangeaddress :: address + dummyChangeaddress = + -- TODO: ADP-1448 + -- + -- Replace this call to 'error' with a call to a function that + -- generates a dummy change address. + -- + error "change address" -- | Creates constraints and parameters for 'Balance.performSelection'. -- toBalanceConstraintsParams - :: ( SelectionConstraints , SelectionParams u) - -> (Balance.SelectionConstraints Address, Balance.SelectionParams Address u) + :: ( SelectionConstraints address, SelectionParams address u) + -> (Balance.SelectionConstraints address, Balance.SelectionParams address u) toBalanceConstraintsParams (constraints, params) = (balanceConstraints, balanceParams) where @@ -378,8 +382,8 @@ toBalanceConstraintsParams (constraints, params) = } where adjustComputeMinimumCost - :: (SelectionSkeleton Address -> Coin) - -> (SelectionSkeleton Address -> Coin) + :: (SelectionSkeleton address -> Coin) + -> (SelectionSkeleton address -> Coin) adjustComputeMinimumCost = whenCollateralRequired params (. adjustSelectionSkeleton) where @@ -400,14 +404,14 @@ toBalanceConstraintsParams (constraints, params) = -- relatively small, this fee increase is likely to be very small. -- adjustSelectionSkeleton - :: SelectionSkeleton Address - -> SelectionSkeleton Address + :: SelectionSkeleton address + -> SelectionSkeleton address adjustSelectionSkeleton = over #skeletonInputCount (+ view #maximumCollateralInputCount constraints) adjustComputeSelectionLimit - :: ([(Address, TokenBundle)] -> SelectionLimit) - -> ([(Address, TokenBundle)] -> SelectionLimit) + :: ([(address, TokenBundle)] -> SelectionLimit) + -> ([(address, TokenBundle)] -> SelectionLimit) adjustComputeSelectionLimit = whenCollateralRequired params (fmap adjustSelectionLimit) where @@ -448,9 +452,9 @@ toBalanceConstraintsParams (constraints, params) = -- | Creates constraints and parameters for 'Collateral.performSelection'. -- toCollateralConstraintsParams - :: Balance.SelectionResult Address u - -> ( SelectionConstraints, SelectionParams u) - -> (Collateral.SelectionConstraints, Collateral.SelectionParams u) + :: Balance.SelectionResult a u + -> ( SelectionConstraints a, SelectionParams a u) + -> (Collateral.SelectionConstraints , Collateral.SelectionParams u) toCollateralConstraintsParams balanceResult (constraints, params) = (collateralConstraints, collateralParams) where @@ -480,10 +484,10 @@ toCollateralConstraintsParams balanceResult (constraints, params) = -- | Creates a 'Selection' from selections of inputs and collateral. -- mkSelection - :: SelectionParams u - -> Balance.SelectionResult Address u + :: SelectionParams address u + -> Balance.SelectionResult address u -> Collateral.SelectionResult u - -> Selection u + -> Selection address u mkSelection _params balanceResult collateralResult = Selection { inputs = view #inputsSelected balanceResult , collateral = Map.toList $ view #coinsSelected collateralResult @@ -497,7 +501,7 @@ mkSelection _params balanceResult collateralResult = Selection -- | Converts a 'Selection' to a balance result. -- -toBalanceResult :: Selection u -> Balance.SelectionResult Address u +toBalanceResult :: Selection address u -> Balance.SelectionResult address u toBalanceResult selection = Balance.SelectionResult { inputsSelected = view #inputs selection , outputsCovered = view #outputs selection @@ -613,10 +617,10 @@ verifyEmpty xs failureReason = -- | The type of all 'Selection' verification functions. -- -type VerifySelection u = - SelectionConstraints -> - SelectionParams u -> - Selection u -> +type VerifySelection address u = + SelectionConstraints address -> + SelectionParams address u -> + Selection address u -> VerificationResult -- | Verifies a 'Selection' for correctness. @@ -625,7 +629,7 @@ type VerifySelection u = -- it's not usually necessary to call this function from ordinary application -- code, unless you suspect that a 'Selection' is incorrect in some way. -- -verifySelection :: (Ord u, Show u) => VerifySelection u +verifySelection :: (Ord u, Show address, Show u) => VerifySelection address u verifySelection = mconcat [ verifySelectionCollateralSufficient , verifySelectionCollateralSuitable @@ -647,7 +651,7 @@ data FailureToVerifySelectionCollateralSufficient = } deriving (Eq, Show) -verifySelectionCollateralSufficient :: VerifySelection u +verifySelectionCollateralSufficient :: VerifySelection address u verifySelectionCollateralSufficient cs ps selection = verify (collateralSelected >= collateralRequired) @@ -670,7 +674,7 @@ data FailureToVerifySelectionCollateralSuitable u = deriving (Eq, Show) verifySelectionCollateralSuitable - :: forall u. (Ord u, Show u) => VerifySelection u + :: forall address u. (Ord u, Show u) => VerifySelection address u verifySelectionCollateralSuitable _cs ps selection = verify (null collateralSelectedButUnsuitable) @@ -705,7 +709,7 @@ data FailureToVerifySelectionDeltaValid = FailureToVerifySelectionDeltaValid } deriving (Eq, Show) -verifySelectionDeltaValid :: VerifySelection u +verifySelectionDeltaValid :: VerifySelection address u verifySelectionDeltaValid cs ps selection = verify (selectionHasValidSurplus cs ps selection) @@ -732,7 +736,7 @@ data FailureToVerifySelectionInputCountWithinLimit = } deriving (Eq, Show) -verifySelectionInputCountWithinLimit :: VerifySelection u +verifySelectionInputCountWithinLimit :: VerifySelection address u verifySelectionInputCountWithinLimit cs _ps selection = verify (Balance.MaximumInputLimit totalInputCount <= selectionLimit) @@ -747,27 +751,29 @@ verifySelectionInputCountWithinLimit cs _ps selection = -- Selection verification: minimum ada quantities -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputCoinsSufficient = +newtype FailureToVerifySelectionOutputCoinsSufficient address = FailureToVerifySelectionOutputCoinsSufficient - (NonEmpty SelectionOutputCoinInsufficientError) + (NonEmpty (SelectionOutputCoinInsufficientError address)) deriving (Eq, Show) -data SelectionOutputCoinInsufficientError = SelectionOutputCoinInsufficientError - { minimumExpectedCoin :: Coin - , output :: (Address, TokenBundle) - } +data SelectionOutputCoinInsufficientError address = + SelectionOutputCoinInsufficientError + { minimumExpectedCoin :: Coin + , output :: (address, TokenBundle) + } deriving (Eq, Show) -verifySelectionOutputCoinsSufficient :: VerifySelection u +verifySelectionOutputCoinsSufficient + :: forall address u. Show address => VerifySelection address u verifySelectionOutputCoinsSufficient cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputCoinsSufficient where - errors :: [SelectionOutputCoinInsufficientError] + errors :: [SelectionOutputCoinInsufficientError address] errors = mapMaybe maybeError (selectionAllOutputs selection) maybeError - :: (Address, TokenBundle) - -> Maybe SelectionOutputCoinInsufficientError + :: (address, TokenBundle) + -> Maybe (SelectionOutputCoinInsufficientError address) maybeError output | snd output ^. #coin < minimumExpectedCoin = Just SelectionOutputCoinInsufficientError @@ -784,32 +790,35 @@ verifySelectionOutputCoinsSufficient cs _ps selection = -- Selection verification: output sizes -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputSizesWithinLimit = +newtype FailureToVerifySelectionOutputSizesWithinLimit address = FailureToVerifySelectionOutputSizesWithinLimit - (NonEmpty SelectionOutputSizeExceedsLimitError) + (NonEmpty (SelectionOutputSizeExceedsLimitError address)) deriving (Eq, Show) -verifySelectionOutputSizesWithinLimit :: VerifySelection u +verifySelectionOutputSizesWithinLimit + :: forall address u. Show address => VerifySelection address u verifySelectionOutputSizesWithinLimit cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputSizesWithinLimit where - errors :: [SelectionOutputSizeExceedsLimitError] + errors :: [SelectionOutputSizeExceedsLimitError address] errors = mapMaybe (verifyOutputSize cs) (selectionAllOutputs selection) -------------------------------------------------------------------------------- -- Selection verification: output token quantities -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputTokenQuantitiesWithinLimit = +newtype FailureToVerifySelectionOutputTokenQuantitiesWithinLimit address = FailureToVerifySelectionOutputTokenQuantitiesWithinLimit - (NonEmpty SelectionOutputTokenQuantityExceedsLimitError) + (NonEmpty (SelectionOutputTokenQuantityExceedsLimitError address)) deriving (Eq, Show) -verifySelectionOutputTokenQuantitiesWithinLimit :: VerifySelection u +verifySelectionOutputTokenQuantitiesWithinLimit + :: forall address u. Show address + => VerifySelection address u verifySelectionOutputTokenQuantitiesWithinLimit _cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputTokenQuantitiesWithinLimit where - errors :: [SelectionOutputTokenQuantityExceedsLimitError] + errors :: [SelectionOutputTokenQuantityExceedsLimitError address] errors = verifyOutputTokenQuantities =<< selectionAllOutputs selection -------------------------------------------------------------------------------- @@ -818,9 +827,9 @@ verifySelectionOutputTokenQuantitiesWithinLimit _cs _ps selection = -- | The type of all 'SelectionError' verification functions. -- -type VerifySelectionError e u = - SelectionConstraints -> - SelectionParams u -> +type VerifySelectionError e address u = + SelectionConstraints address -> + SelectionParams address u -> e -> VerificationResult @@ -831,8 +840,8 @@ type VerifySelectionError e u = -- code, unless you suspect that a 'SelectionError' is incorrect in some way. -- verifySelectionError - :: (Ord u, Show u) - => VerifySelectionError (SelectionError u) u + :: (Show address, Ord u, Show u) + => VerifySelectionError (SelectionError address u) address u verifySelectionError cs ps = \case SelectionBalanceErrorOf e -> verifySelectionBalanceError cs ps e @@ -846,8 +855,8 @@ verifySelectionError cs ps = \case -------------------------------------------------------------------------------- verifySelectionBalanceError - :: (Ord u, Show u) - => VerifySelectionError (SelectionBalanceError Address u) u + :: (Show address, Ord u, Show u) + => VerifySelectionError (SelectionBalanceError address u) address u verifySelectionBalanceError cs ps = \case Balance.BalanceInsufficient e -> verifyBalanceInsufficientError cs ps e @@ -872,7 +881,7 @@ data FailureToVerifyBalanceInsufficientError = deriving (Eq, Show) verifyBalanceInsufficientError - :: VerifySelectionError Balance.BalanceInsufficientError u + :: VerifySelectionError Balance.BalanceInsufficientError address u verifyBalanceInsufficientError cs ps e = verifyAll [ not (utxoBalanceRequired `leq` utxoBalanceAvailable) @@ -892,7 +901,7 @@ newtype FailureToVerifyEmptyUTxOError u = FailureToVerifyEmptyUTxOError { utxoAvailableForInputs :: UTxOSelection u } deriving (Eq, Show) -verifyEmptyUTxOError :: (Eq u, Show u) => VerifySelectionError () u +verifyEmptyUTxOError :: (Eq u, Show u) => VerifySelectionError () address u verifyEmptyUTxOError _cs SelectionParams {utxoAvailableForInputs} _e = verify (utxoAvailableForInputs == UTxOSelection.empty) @@ -902,16 +911,18 @@ verifyEmptyUTxOError _cs SelectionParams {utxoAvailableForInputs} _e = -- Selection error verification: insufficient minimum ada quantity errors -------------------------------------------------------------------------------- -data FailureToVerifyInsufficientMinCoinValueError = +data FailureToVerifyInsufficientMinCoinValueError address = FailureToVerifyInsufficientMinCoinValueError - { reportedOutput :: (Address, TokenBundle) + { reportedOutput :: (address, TokenBundle) , reportedMinCoinValue :: Coin , verifiedMinCoinValue :: Coin } deriving (Eq, Show) verifyInsufficientMinCoinValueError - :: VerifySelectionError (Balance.InsufficientMinCoinValueError Address) u + :: Show address + => VerifySelectionError + (Balance.InsufficientMinCoinValueError address) address u verifyInsufficientMinCoinValueError cs _ps e = verifyAll [ reportedMinCoinValue == verifiedMinCoinValue @@ -952,8 +963,9 @@ data FailureToVerifySelectionLimitReachedError u = -- given the amount of space we expect to be reserved for collateral inputs. -- verifySelectionLimitReachedError - :: forall u. Show u - => VerifySelectionError (Balance.SelectionLimitReachedError Address u) u + :: forall address u. Show u + => VerifySelectionError + (Balance.SelectionLimitReachedError address u) address u verifySelectionLimitReachedError cs ps e = verify (Balance.MaximumInputLimit selectedInputCount >= selectionLimitAdjusted) @@ -980,13 +992,13 @@ verifySelectionLimitReachedError cs ps e = -- Selection error verification: change construction errors -------------------------------------------------------------------------------- -data FailureToVerifyUnableToConstructChangeError u = +data FailureToVerifyUnableToConstructChangeError address u = FailureToVerifyUnableToConstructChangeError { errorOriginal :: Balance.UnableToConstructChangeError -- ^ The original error. , errorWithMinimalConstraints - :: SelectionError u + :: SelectionError address u -- ^ An error encountered when attempting to re-run the selection -- process with minimal constraints. } @@ -1016,8 +1028,9 @@ data FailureToVerifyUnableToConstructChangeError u = -- balance is insufficient by returning a 'BalanceInsufficientError' instead. -- verifyUnableToConstructChangeError - :: forall u. (Ord u, Show u) - => VerifySelectionError Balance.UnableToConstructChangeError u + :: forall address u. (Ord u, Show address, Show u) + => VerifySelectionError + Balance.UnableToConstructChangeError address u verifyUnableToConstructChangeError cs ps errorOriginal = case resultWithMinimalConstraints of Left errorWithMinimalConstraints -> @@ -1032,7 +1045,8 @@ verifyUnableToConstructChangeError cs ps errorOriginal = -- - a minimum cost function that always returns zero. -- - a minimum ada quantity function that always returns zero. -- - resultWithMinimalConstraints :: Either (SelectionError u) (Selection u) + resultWithMinimalConstraints + :: Either (SelectionError address u) (Selection address u) resultWithMinimalConstraints = -- The 'performSelection' function requires a 'MonadRandom' context so -- that it can select entries at random from the available UTxO set. @@ -1100,8 +1114,8 @@ data FailureToVerifySelectionCollateralError u = deriving (Eq, Show) verifySelectionCollateralError - :: forall u. (Ord u, Show u) - => VerifySelectionError (SelectionCollateralError u) u + :: forall address u. (Ord u, Show u) + => VerifySelectionError (SelectionCollateralError u) address u verifySelectionCollateralError cs ps e = verifyAll [ Map.null largestCombinationUnsuitableSubset @@ -1131,7 +1145,9 @@ verifySelectionCollateralError cs ps e = -- Selection error verification: output errors -------------------------------------------------------------------------------- -verifySelectionOutputError :: VerifySelectionError SelectionOutputError u +verifySelectionOutputError + :: Show address + => VerifySelectionError (SelectionOutputError address) address u verifySelectionOutputError cs ps = \case SelectionOutputSizeExceedsLimit e -> verifySelectionOutputSizeExceedsLimitError cs ps e @@ -1142,13 +1158,15 @@ verifySelectionOutputError cs ps = \case -- Selection error verification: output size errors -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputSizeExceedsLimitError = +newtype FailureToVerifySelectionOutputSizeExceedsLimitError address = FailureToVerifySelectionOutputSizeExceedsLimitError - { outputReportedAsExceedingLimit :: (Address, TokenBundle) } + { outputReportedAsExceedingLimit :: (address, TokenBundle) } deriving (Eq, Show) verifySelectionOutputSizeExceedsLimitError - :: VerifySelectionError SelectionOutputSizeExceedsLimitError u + :: Show address + => VerifySelectionError + (SelectionOutputSizeExceedsLimitError address) address u verifySelectionOutputSizeExceedsLimitError cs _ps e = verify (not isWithinLimit) @@ -1166,13 +1184,17 @@ verifySelectionOutputSizeExceedsLimitError cs _ps e = -- Selection error verification: output token quantity errors -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputTokenQuantityExceedsLimitError = +newtype FailureToVerifySelectionOutputTokenQuantityExceedsLimitError address = FailureToVerifySelectionOutputTokenQuantityExceedsLimitError - { reportedError :: SelectionOutputTokenQuantityExceedsLimitError } + { reportedError + :: SelectionOutputTokenQuantityExceedsLimitError address + } deriving (Eq, Show) verifySelectionOutputTokenQuantityExceedsLimitError - :: VerifySelectionError SelectionOutputTokenQuantityExceedsLimitError u + :: Show address + => VerifySelectionError + (SelectionOutputTokenQuantityExceedsLimitError address) address u verifySelectionOutputTokenQuantityExceedsLimitError _cs _ps e = verify (e ^. #quantity > e ^. #quantityMaxBound) @@ -1186,14 +1208,14 @@ verifySelectionOutputTokenQuantityExceedsLimitError _cs _ps e = -- -- See 'SelectionDelta'. -- -selectionDeltaAllAssets :: Selection u -> SelectionDelta TokenBundle +selectionDeltaAllAssets :: Selection address u -> SelectionDelta TokenBundle selectionDeltaAllAssets = Balance.selectionDeltaAllAssets . toBalanceResult -- | Calculates the ada selection delta. -- -- See 'SelectionDelta'. -- -selectionDeltaCoin :: Selection u -> SelectionDelta Coin +selectionDeltaCoin :: Selection address u -> SelectionDelta Coin selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- | Indicates whether or not a selection has a valid surplus. @@ -1205,9 +1227,9 @@ selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- See 'SelectionDelta'. -- selectionHasValidSurplus - :: SelectionConstraints - -> SelectionParams u - -> Selection u + :: SelectionConstraints address + -> SelectionParams address u + -> Selection address u -> Bool selectionHasValidSurplus constraints params selection = Balance.selectionHasValidSurplus @@ -1217,9 +1239,9 @@ selectionHasValidSurplus constraints params selection = -- | Computes the minimum required cost of a selection. -- selectionMinimumCost - :: SelectionConstraints - -> SelectionParams u - -> Selection u + :: SelectionConstraints address + -> SelectionParams address u + -> Selection address u -> Coin selectionMinimumCost constraints params selection = Balance.selectionMinimumCost @@ -1229,9 +1251,9 @@ selectionMinimumCost constraints params selection = -- | Computes the maximum acceptable cost of a selection. -- selectionMaximumCost - :: SelectionConstraints - -> SelectionParams u - -> Selection u + :: SelectionConstraints address + -> SelectionParams address u + -> Selection address u -> Coin selectionMaximumCost constraints params selection = Balance.selectionMaximumCost @@ -1246,7 +1268,7 @@ selectionMaximumCost constraints params selection = -- Use 'selectionDeltaCoin' if you wish to handle the case where there is -- a deficit. -- -selectionSurplusCoin :: Selection u -> Coin +selectionSurplusCoin :: Selection address u -> Coin selectionSurplusCoin = Balance.selectionSurplusCoin . toBalanceResult -------------------------------------------------------------------------------- @@ -1264,7 +1286,7 @@ data SelectionCollateralRequirement -- | Indicates 'True' if and only if collateral is required. -- -selectionCollateralRequired :: SelectionParams u -> Bool +selectionCollateralRequired :: SelectionParams address u -> Bool selectionCollateralRequired params = case view #collateralRequirement params of SelectionCollateralRequired -> True SelectionCollateralNotRequired -> False @@ -1272,7 +1294,7 @@ selectionCollateralRequired params = case view #collateralRequirement params of -- | Applies the given transformation function only when collateral is required. -- whenCollateralRequired - :: SelectionParams u + :: SelectionParams address u -> (a -> a) -> (a -> a) whenCollateralRequired params f @@ -1281,15 +1303,15 @@ whenCollateralRequired params f -- | Computes the total amount of collateral within a selection. -- -selectionCollateral :: Selection u -> Coin +selectionCollateral :: Selection address u -> Coin selectionCollateral = F.foldMap snd . view #collateral -- | Indicates whether or not a selection has sufficient collateral. -- selectionHasSufficientCollateral - :: SelectionConstraints - -> SelectionParams u - -> Selection u + :: SelectionConstraints address + -> SelectionParams address u + -> Selection address u -> Bool selectionHasSufficientCollateral constraints params selection = actual >= required @@ -1300,9 +1322,9 @@ selectionHasSufficientCollateral constraints params selection = -- | Computes the minimum required amount of collateral for a selection. -- selectionMinimumCollateral - :: SelectionConstraints - -> SelectionParams u - -> Selection u + :: SelectionConstraints address + -> SelectionParams address u + -> Selection address u -> Coin selectionMinimumCollateral constraints params selection | selectionCollateralRequired params = @@ -1339,9 +1361,9 @@ computeMinimumCollateral params = -- | Prepares the given user-specified outputs, ensuring that they are valid. -- prepareOutputsInternal - :: SelectionConstraints - -> [(Address, TokenBundle)] - -> Either SelectionOutputError [(Address, TokenBundle)] + :: forall address. SelectionConstraints address + -> [(address, TokenBundle)] + -> Either (SelectionOutputError address) [(address, TokenBundle)] prepareOutputsInternal constraints outputsUnprepared | e : _ <- excessivelyLargeBundles = Left $ @@ -1362,13 +1384,14 @@ prepareOutputsInternal constraints outputsUnprepared -- The complete list of token bundles whose serialized lengths are greater -- than the limit of what is allowed in a transaction output: - excessivelyLargeBundles :: [SelectionOutputSizeExceedsLimitError] + excessivelyLargeBundles :: [SelectionOutputSizeExceedsLimitError address] excessivelyLargeBundles = mapMaybe (verifyOutputSize constraints) outputsToCover -- The complete list of token quantities that exceed the maximum quantity -- allowed in a transaction output: - excessiveTokenQuantities :: [SelectionOutputTokenQuantityExceedsLimitError] + excessiveTokenQuantities + :: [SelectionOutputTokenQuantityExceedsLimitError address] excessiveTokenQuantities = verifyOutputTokenQuantities =<< outputsToCover outputsToCover = @@ -1390,8 +1413,8 @@ prepareOutputsInternal constraints outputsUnprepared prepareOutputsWith :: Functor f => (TokenMap -> Coin) - -> f (Address, TokenBundle) - -> f (Address, TokenBundle) + -> f (address, TokenBundle) + -> f (address, TokenBundle) prepareOutputsWith minCoinValueFor = fmap $ fmap augmentBundle where @@ -1404,16 +1427,16 @@ prepareOutputsWith minCoinValueFor = -- | Indicates a problem when preparing outputs for a coin selection. -- -data SelectionOutputError +data SelectionOutputError address = SelectionOutputSizeExceedsLimit - SelectionOutputSizeExceedsLimitError + (SelectionOutputSizeExceedsLimitError address) | SelectionOutputTokenQuantityExceedsLimit - SelectionOutputTokenQuantityExceedsLimitError + (SelectionOutputTokenQuantityExceedsLimitError address) deriving (Eq, Generic, Show) -newtype SelectionOutputSizeExceedsLimitError = +newtype SelectionOutputSizeExceedsLimitError address = SelectionOutputSizeExceedsLimitError - { outputThatExceedsLimit :: (Address, TokenBundle) + { outputThatExceedsLimit :: (address, TokenBundle) } deriving (Eq, Generic, Show) @@ -1423,9 +1446,9 @@ newtype SelectionOutputSizeExceedsLimitError = -- exceeds the limit defined by the protocol. -- verifyOutputSize - :: SelectionConstraints - -> (Address, TokenBundle) - -> Maybe SelectionOutputSizeExceedsLimitError + :: SelectionConstraints address + -> (address, TokenBundle) + -> Maybe (SelectionOutputSizeExceedsLimitError address) verifyOutputSize cs out | withinLimit = Nothing @@ -1441,9 +1464,9 @@ verifyOutputSize cs out -- | Indicates that a token quantity exceeds the maximum quantity that can -- appear in a transaction output's token bundle. -- -data SelectionOutputTokenQuantityExceedsLimitError = +data SelectionOutputTokenQuantityExceedsLimitError address = SelectionOutputTokenQuantityExceedsLimitError - { address :: !Address + { address :: !address -- ^ The address to which this token quantity was to be sent. , asset :: !AssetId -- ^ The asset identifier to which this token quantity corresponds. @@ -1460,7 +1483,8 @@ data SelectionOutputTokenQuantityExceedsLimitError = -- protocol. -- verifyOutputTokenQuantities - :: (Address, TokenBundle) -> [SelectionOutputTokenQuantityExceedsLimitError] + :: (address, TokenBundle) + -> [SelectionOutputTokenQuantityExceedsLimitError address] verifyOutputTokenQuantities out = [ SelectionOutputTokenQuantityExceedsLimitError {address, asset, quantity, quantityMaxBound = txOutMaxTokenQuantity} diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index 996e756e3c7..f739121d070 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -196,7 +196,7 @@ spec = describe "Cardano.Wallet.CoinSelection.InternalSpec" $ do prop_performSelection :: Pretty MockSelectionConstraints - -> Pretty (SelectionParams InputId) + -> Pretty (SelectionParams Address InputId) -> Property prop_performSelection (Pretty mockConstraints) (Pretty params) = monadicIO $ @@ -206,9 +206,9 @@ prop_performSelection (Pretty mockConstraints) (Pretty params) = constraints = unMockSelectionConstraints mockConstraints prop_performSelection_inner - :: SelectionConstraints - -> SelectionParams InputId - -> Either (SelectionError InputId) (Selection InputId) + :: SelectionConstraints Address + -> SelectionParams Address InputId + -> Either (SelectionError Address InputId) (Selection Address InputId) -> Property prop_performSelection_inner constraints params result = checkCoverage $ @@ -225,8 +225,8 @@ prop_performSelection_inner constraints params result = prop_performSelection_coverage :: Testable property - => SelectionParams InputId - -> Either (SelectionError InputId) (Selection InputId) + => SelectionParams Address InputId + -> Either (SelectionError Address InputId) (Selection Address InputId) -> property -> Property prop_performSelection_coverage params r innerProperty = @@ -321,7 +321,7 @@ prop_performSelection_coverage params r innerProperty = -- prop_toBalanceConstraintsParams_computeMinimumCost :: MockSelectionConstraints - -> SelectionParams InputId + -> SelectionParams Address InputId -> SelectionSkeleton Address -> Property prop_toBalanceConstraintsParams_computeMinimumCost @@ -353,7 +353,7 @@ prop_toBalanceConstraintsParams_computeMinimumCost else costOriginal === costAdjusted where - constraints :: SelectionConstraints + constraints :: SelectionConstraints Address constraints = unMockSelectionConstraints mockConstraints maximumCollateralInputCount :: Int @@ -378,7 +378,7 @@ prop_toBalanceConstraintsParams_computeMinimumCost -- prop_toBalanceConstraintsParams_computeSelectionLimit :: MockSelectionConstraints - -> SelectionParams InputId + -> SelectionParams Address InputId -> Property prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = checkCoverage $ @@ -404,7 +404,7 @@ prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = else selectionLimitOriginal === selectionLimitAdjusted where - constraints :: SelectionConstraints + constraints :: SelectionConstraints Address constraints = unMockSelectionConstraints mockConstraints maximumCollateralInputCount :: Int @@ -565,7 +565,8 @@ shrinkMockSelectionConstraints = genericRoundRobinShrink <:> shrinkMinimumCollateralPercentage <:> Nil -unMockSelectionConstraints :: MockSelectionConstraints -> SelectionConstraints +unMockSelectionConstraints + :: MockSelectionConstraints -> SelectionConstraints Address unMockSelectionConstraints m = SelectionConstraints { assessTokenBundleSize = unMockAssessTokenBundleSize $ view #assessTokenBundleSize m @@ -617,7 +618,7 @@ shrinkMinimumCollateralPercentage = shrinkNatural -- Selection parameters -------------------------------------------------------------------------------- -genSelectionParams :: Gen (SelectionParams InputId) +genSelectionParams :: Gen (SelectionParams Address InputId) genSelectionParams = SelectionParams <$> genAssetsToBurn <*> genAssetsToMint @@ -632,7 +633,9 @@ genSelectionParams = SelectionParams <*> genUTxOAvailableForInputs <*> genSelectionStrategy -shrinkSelectionParams :: SelectionParams InputId -> [SelectionParams InputId] +shrinkSelectionParams + :: SelectionParams Address InputId + -> [SelectionParams Address InputId] shrinkSelectionParams = genericRoundRobinShrink <@> shrinkAssetsToBurn <:> shrinkAssetsToMint @@ -855,7 +858,7 @@ instance Arbitrary MockSelectionConstraints where arbitrary = genMockSelectionConstraints shrink = shrinkMockSelectionConstraints -instance Arbitrary (SelectionParams InputId) where +instance Arbitrary (SelectionParams Address InputId) where arbitrary = genSelectionParams shrink = shrinkSelectionParams From 9d4665412c2c11cfb24e48a2f4bef683849ae3ef Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 9 Mar 2022 23:31:31 +0000 Subject: [PATCH 03/13] Use type parameter `f` for foldable containers in `Balance`. --- .../Wallet/CoinSelection/Internal/Balance.hs | 80 +++++++++---------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index 0813e31b81c..617e7ca52c2 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -235,9 +235,9 @@ type SelectionParams = SelectionParamsOf [] -- | Specifies all parameters that are specific to a given selection. -- -data SelectionParamsOf outputs address u = SelectionParams +data SelectionParamsOf f address u = SelectionParams { outputsToCover - :: !(outputs (address, TokenBundle)) + :: !(f (address, TokenBundle)) -- ^ The complete set of outputs to be covered. , utxoAvailable :: !(UTxOSelection u) @@ -272,12 +272,12 @@ data SelectionParamsOf outputs address u = SelectionParams deriving Generic deriving instance - (Eq (outputs (address, TokenBundle)), Eq u) => - Eq (SelectionParamsOf outputs address u) + (Eq (f (address, TokenBundle)), Eq u) => + Eq (SelectionParamsOf f address u) deriving instance - (Show (outputs (address, TokenBundle)), Show u) => - Show (SelectionParamsOf outputs address u) + (Show (f (address, TokenBundle)), Show u) => + Show (SelectionParamsOf f address u) -- | Indicates a choice of selection strategy. -- @@ -346,19 +346,19 @@ data UTxOBalanceSufficiencyInfo = UTxOBalanceSufficiencyInfo -- | Computes the balance of UTxO entries available for selection. -- computeUTxOBalanceAvailable - :: SelectionParamsOf outputs address u -> TokenBundle + :: SelectionParamsOf f address u -> TokenBundle computeUTxOBalanceAvailable = UTxOSelection.availableBalance . view #utxoAvailable -- | Computes the balance of UTxO entries required to be selected. -- computeUTxOBalanceRequired - :: Foldable outputs => SelectionParamsOf outputs address u -> TokenBundle + :: Foldable f => SelectionParamsOf f address u -> TokenBundle computeUTxOBalanceRequired = fst . computeDeficitInOut computeBalanceInOut - :: Foldable outputs - => SelectionParamsOf outputs address u + :: Foldable f + => SelectionParamsOf f address u -> (TokenBundle, TokenBundle) computeBalanceInOut params = (balanceIn, balanceOut) @@ -375,8 +375,8 @@ computeBalanceInOut params = F.foldMap snd (view #outputsToCover params) computeDeficitInOut - :: Foldable outputs - => SelectionParamsOf outputs address u + :: Foldable f + => SelectionParamsOf f address u -> (TokenBundle, TokenBundle) computeDeficitInOut params = (deficitIn, deficitOut) @@ -393,8 +393,8 @@ computeDeficitInOut params = -- See 'UTxOBalanceSufficiency'. -- computeUTxOBalanceSufficiency - :: Foldable outputs - => SelectionParamsOf outputs address u + :: Foldable f + => SelectionParamsOf f address u -> UTxOBalanceSufficiency computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo @@ -403,8 +403,8 @@ computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo -- See 'UTxOBalanceSufficiencyInfo'. -- computeUTxOBalanceSufficiencyInfo - :: Foldable outputs - => SelectionParamsOf outputs address u + :: Foldable f + => SelectionParamsOf f address u -> UTxOBalanceSufficiencyInfo computeUTxOBalanceSufficiencyInfo params = UTxOBalanceSufficiencyInfo {available, required, difference, sufficiency} @@ -426,7 +426,7 @@ computeUTxOBalanceSufficiencyInfo params = -- is greater than or equal to the required balance. -- isUTxOBalanceSufficient - :: Foldable outputs => SelectionParamsOf outputs address u -> Bool + :: Foldable f => SelectionParamsOf f address u -> Bool isUTxOBalanceSufficient params = case computeUTxOBalanceSufficiency params of UTxOBalanceSufficient -> True @@ -496,7 +496,7 @@ type SelectionResult = SelectionResultOf [] -- | The result of performing a successful selection. -- -data SelectionResultOf outputs address u = SelectionResult +data SelectionResultOf f address u = SelectionResult { inputsSelected :: !(NonEmpty (u, TokenBundle)) -- ^ A (non-empty) list of inputs selected from 'utxoAvailable'. @@ -507,7 +507,7 @@ data SelectionResultOf outputs address u = SelectionResult :: !Coin -- ^ An extra sink for ada. , outputsCovered - :: !(outputs (address, TokenBundle)) + :: !(f (address, TokenBundle)) -- ^ A list of outputs covered. , changeGenerated :: ![TokenBundle] @@ -522,11 +522,11 @@ data SelectionResultOf outputs address u = SelectionResult deriving Generic deriving instance - (Eq (outputs (address, TokenBundle)), Eq u) => - Eq (SelectionResultOf outputs address u) + (Eq (f (address, TokenBundle)), Eq u) => + Eq (SelectionResultOf f address u) deriving instance - (Show (outputs (address, TokenBundle)), Show u) => - Show (SelectionResultOf outputs address u) + (Show (f (address, TokenBundle)), Show u) => + Show (SelectionResultOf f address u) -- | Indicates the difference between total input value and total output value -- of a 'SelectionResult'. @@ -561,8 +561,8 @@ instance Buildable a => Buildable (SelectionDelta a) where -- See 'SelectionDelta'. -- selectionDeltaAllAssets - :: Foldable outputs - => SelectionResultOf outputs address u + :: Foldable f + => SelectionResultOf f address u -> SelectionDelta TokenBundle selectionDeltaAllAssets result | balanceOut `leq` balanceIn = @@ -599,17 +599,17 @@ selectionDeltaAllAssets result -- See 'SelectionDelta'. -- selectionDeltaCoin - :: Foldable outputs - => SelectionResultOf outputs address u + :: Foldable f + => SelectionResultOf f address u -> SelectionDelta Coin selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- | Indicates whether or not a selection result has a valid surplus. -- selectionHasValidSurplus - :: Foldable outputs + :: Foldable f => SelectionConstraints address - -> SelectionResultOf outputs address u + -> SelectionResultOf f address u -> Bool selectionHasValidSurplus constraints selection = case selectionDeltaAllAssets selection of @@ -647,8 +647,8 @@ selectionHasValidSurplus constraints selection = -- a deficit. -- selectionSurplusCoin - :: Foldable outputs - => SelectionResultOf outputs address u + :: Foldable f + => SelectionResultOf f address u -> Coin selectionSurplusCoin result = case selectionDeltaCoin result of @@ -658,8 +658,8 @@ selectionSurplusCoin result = -- | Converts a selection into a skeleton. -- selectionSkeleton - :: Foldable outputs - => SelectionResultOf outputs address u + :: Foldable f + => SelectionResultOf f address u -> SelectionSkeleton address selectionSkeleton s = SelectionSkeleton { skeletonInputCount = F.length (view #inputsSelected s) @@ -670,9 +670,9 @@ selectionSkeleton s = SelectionSkeleton -- | Computes the minimum required cost of a selection. -- selectionMinimumCost - :: Foldable outputs + :: Foldable f => SelectionConstraints address - -> SelectionResultOf outputs address u + -> SelectionResultOf f address u -> Coin selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton @@ -691,9 +691,9 @@ selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton -- See 'selectionHasValidSurplus'. -- selectionMaximumCost - :: Foldable outputs + :: Foldable f => SelectionConstraints address - -> SelectionResultOf outputs address u + -> SelectionResultOf f address u -> Coin selectionMaximumCost c = mtimesDefault (2 :: Int) . selectionMinimumCost c @@ -780,13 +780,13 @@ data UnableToConstructChangeError = UnableToConstructChangeError -- selection cost and minimum coin quantity of each change output. } deriving (Generic, Eq, Show) -type PerformSelection m outputs address u = +type PerformSelection m f address u = SelectionConstraints address -> - SelectionParamsOf outputs address u -> + SelectionParamsOf f address u -> m ( Either (SelectionBalanceError address u) - (SelectionResultOf outputs address u) + (SelectionResultOf f address u) ) -- | Performs a coin selection and generates change bundles in one step. From ac3fe985d5433e4907903000dc99270fa02a42b6 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 10 Mar 2022 00:42:55 +0000 Subject: [PATCH 04/13] Introduce class `SelectionContext` to group common coin selection types. For the moment, `SelectionContext` will only have two associated types: - Address represents target addresses to which payments can be made. - UTxO represents unique identifiers for individual UTxOs. A future commit will add an associated type to represent asset identifiers. --- lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/Wallet.hs | 8 +- lib/core/src/Cardano/Wallet/Api/Server.hs | 14 +- lib/core/src/Cardano/Wallet/CoinSelection.hs | 45 ++- .../Cardano/Wallet/CoinSelection/Internal.hs | 352 ++++++++++-------- .../Wallet/CoinSelection/Internal/Balance.hs | 226 ++++++----- .../CoinSelection/Internal/Balance/Gen.hs | 10 +- .../Wallet/CoinSelection/Internal/Context.hs | 25 ++ .../CoinSelection/Internal/BalanceSpec.hs | 108 +++--- .../Wallet/CoinSelection/InternalSpec.hs | 49 +-- 10 files changed, 462 insertions(+), 376 deletions(-) create mode 100644 lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 74b14729e73..907f5dbc342 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -179,6 +179,7 @@ library Cardano.Wallet.CoinSelection.Internal Cardano.Wallet.CoinSelection.Internal.Balance Cardano.Wallet.CoinSelection.Internal.Collateral + Cardano.Wallet.CoinSelection.Internal.Context Cardano.Wallet.Compat Cardano.Wallet.DB Cardano.Wallet.DB.Checkpoints diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 27047929a9a..4580725c7ed 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -233,6 +233,7 @@ import Cardano.Wallet.CoinSelection , SelectionSkeleton (..) , SelectionStrategy (..) , UnableToConstructChangeError (..) + , WalletSelectionContext , emptySkeleton , makeSelectionReportDetailed , makeSelectionReportSummarized @@ -3269,10 +3270,11 @@ data ErrCreateMigrationPlan deriving (Generic, Eq, Show) data ErrSelectAssets - = ErrSelectAssetsPrepareOutputsError (SelectionOutputError Address) + = ErrSelectAssetsPrepareOutputsError + (SelectionOutputError WalletSelectionContext) | ErrSelectAssetsNoSuchWallet ErrNoSuchWallet | ErrSelectAssetsAlreadyWithdrawing Tx - | ErrSelectAssetsSelectionError (SelectionError Address InputId) + | ErrSelectAssetsSelectionError (SelectionError WalletSelectionContext) deriving (Generic, Eq, Show) data ErrStakePoolDelegation @@ -3422,7 +3424,7 @@ data WalletFollowLog -- | Log messages from API server actions running in a wallet worker context. data WalletLog = MsgSelectionStart UTxO [TxOut] - | MsgSelectionError (SelectionError Address InputId) + | MsgSelectionError (SelectionError WalletSelectionContext) | MsgSelectionReportSummarized SelectionReportSummarized | MsgSelectionReportDetailed SelectionReportDetailed | MsgMigrationUTxOBefore UTxOStatistics diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 0f659031670..233e22b8995 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -315,6 +315,7 @@ import Cardano.Wallet.CoinSelection , SelectionOutputSizeExceedsLimitError (..) , SelectionOutputTokenQuantityExceedsLimitError (..) , SelectionStrategy (..) + , WalletSelectionContext , balanceMissing , selectionDelta , shortfall @@ -4319,14 +4320,16 @@ instance IsServerError (ErrInvalidDerivationIndex 'Soft level) where , "between ", pretty minIx, " and ", pretty maxIx, " without a suffix." ] -instance IsServerError (SelectionOutputError Address) where +instance IsServerError (SelectionOutputError WalletSelectionContext) where toServerError = \case SelectionOutputSizeExceedsLimit e -> toServerError e SelectionOutputTokenQuantityExceedsLimit e -> toServerError e -instance IsServerError (SelectionOutputSizeExceedsLimitError Address) where +instance IsServerError + (SelectionOutputSizeExceedsLimitError WalletSelectionContext) + where toServerError e = apiError err403 OutputTokenBundleSizeExceedsLimit $ mconcat [ "One of the outputs you've specified contains too many assets. " @@ -4340,7 +4343,8 @@ instance IsServerError (SelectionOutputSizeExceedsLimitError Address) where where output = view #outputThatExceedsLimit e -instance IsServerError (SelectionOutputTokenQuantityExceedsLimitError Address) +instance IsServerError + (SelectionOutputTokenQuantityExceedsLimitError WalletSelectionContext) where toServerError e = apiError err403 OutputTokenQuantityExceedsLimit $ mconcat [ "One of the token quantities you've specified is greater than the " @@ -4392,7 +4396,7 @@ instance IsServerError ErrSelectAssets where ErrSelectAssetsSelectionError (SelectionOutputErrorOf e) -> toServerError e -instance IsServerError (SelectionBalanceError Address (TxIn, Address)) where +instance IsServerError (SelectionBalanceError WalletSelectionContext) where toServerError = \case BalanceInsufficient e -> apiError err403 NotEnoughMoney $ mconcat @@ -4435,7 +4439,7 @@ instance IsServerError (SelectionBalanceError Address (TxIn, Address)) where , "required in order to create a transaction." ] -instance IsServerError (SelectionCollateralError (TxIn, Address)) where +instance IsServerError (SelectionCollateralError WalletSelectionContext) where toServerError e = apiError err403 InsufficientCollateral $ T.unwords [ "I'm unable to create this transaction because the balance" diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 329d8efd8b4..934c2538f1c 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -3,6 +3,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Copyright: © 2022 IOHK @@ -21,8 +25,11 @@ -- module Cardano.Wallet.CoinSelection ( + -- * Context + WalletSelectionContext + -- * Performing selections - performSelection + , performSelection , Selection , SelectionCollateralRequirement (..) , SelectionConstraints (..) @@ -59,7 +66,8 @@ module Cardano.Wallet.CoinSelection where import Cardano.Wallet.CoinSelection.Internal - ( SelectionCollateralRequirement (..) + ( SelectionCollateralError + , SelectionCollateralRequirement (..) , SelectionError (..) , SelectionOutputError (..) , SelectionOutputSizeExceedsLimitError (..) @@ -74,8 +82,6 @@ import Cardano.Wallet.CoinSelection.Internal.Balance , UnableToConstructChangeError (..) , balanceMissing ) -import Cardano.Wallet.CoinSelection.Internal.Collateral - ( SelectionCollateralError ) import Cardano.Wallet.Primitive.Collateral ( asCollateral ) import Cardano.Wallet.Primitive.Types.Address @@ -116,11 +122,22 @@ import Numeric.Natural import Prelude import qualified Cardano.Wallet.CoinSelection.Internal as Internal +import qualified Cardano.Wallet.CoinSelection.Internal.Context as SC import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle import qualified Data.Foldable as F import qualified Data.Map.Strict as Map import qualified Data.Set as Set +-------------------------------------------------------------------------------- +-- Selection context +-------------------------------------------------------------------------------- + +data WalletSelectionContext + +instance SC.SelectionContext WalletSelectionContext where + type Address WalletSelectionContext = Address + type UTxO WalletSelectionContext = InputId + -------------------------------------------------------------------------------- -- Selection constraints -------------------------------------------------------------------------------- @@ -169,7 +186,8 @@ data SelectionConstraints = SelectionConstraints deriving Generic toInternalSelectionConstraints - :: SelectionConstraints -> Internal.SelectionConstraints Address + :: SelectionConstraints + -> Internal.SelectionConstraints WalletSelectionContext toInternalSelectionConstraints SelectionConstraints {..} = Internal.SelectionConstraints { computeMinimumCost = @@ -189,6 +207,9 @@ toInternalSelectionConstraints SelectionConstraints {..} = -- type InputId = (TxIn, Address) +instance Buildable InputId where + build (i, a) = build i <> ":" <> build a + -- | Specifies all parameters that are specific to a given selection. -- data SelectionParams = SelectionParams @@ -241,7 +262,7 @@ data SelectionParams = SelectionParams toInternalSelectionParams :: SelectionParams - -> Internal.SelectionParams Address InputId + -> Internal.SelectionParams WalletSelectionContext toInternalSelectionParams SelectionParams {..} = Internal.SelectionParams { utxoAvailableForCollateral = @@ -288,7 +309,7 @@ emptySkeleton = SelectionSkeleton } toExternalSelectionSkeleton - :: Internal.SelectionSkeleton Address + :: Internal.SelectionSkeleton WalletSelectionContext -> SelectionSkeleton toExternalSelectionSkeleton Internal.SelectionSkeleton {..} = SelectionSkeleton @@ -338,7 +359,7 @@ data SelectionOf change = Selection type Selection = SelectionOf TokenBundle toExternalSelection - :: SelectionParams -> Internal.Selection Address InputId -> Selection + :: SelectionParams -> Internal.Selection WalletSelectionContext -> Selection toExternalSelection _ps Internal.Selection {..} = Selection { collateral = @@ -355,7 +376,7 @@ toExternalSelection _ps Internal.Selection {..} = toInternalSelection :: (change -> TokenBundle) -> SelectionOf change - -> Internal.Selection Address InputId + -> Internal.Selection WalletSelectionContext toInternalSelection getChangeBundle Selection {..} = Internal.Selection { change = getChangeBundle @@ -385,13 +406,13 @@ toInternalSelection getChangeBundle Selection {..} = -- See 'Internal.performSelection' for more details. -- performSelection - :: (HasCallStack, MonadRandom m) + :: forall m. (HasCallStack, MonadRandom m) => SelectionConstraints -> SelectionParams - -> ExceptT (SelectionError Address InputId) m Selection + -> ExceptT (SelectionError WalletSelectionContext) m Selection performSelection cs ps = toExternalSelection ps <$> - Internal.performSelection + Internal.performSelection @m @WalletSelectionContext (toInternalSelectionConstraints cs) (toInternalSelectionParams ps) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index 7fc3de52ab3..8bfa5e33c35 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -50,6 +50,7 @@ module Cardano.Wallet.CoinSelection.Internal , selectionSurplusCoin -- * Selection collateral + , SelectionCollateralError (..) , SelectionCollateralRequirement (..) , selectionCollateral , selectionCollateralRequired @@ -74,8 +75,8 @@ import Cardano.Wallet.CoinSelection.Internal.Balance , SelectionSkeleton , SelectionStrategy (..) ) -import Cardano.Wallet.CoinSelection.Internal.Collateral - ( SelectionCollateralError ) +import Cardano.Wallet.CoinSelection.Internal.Context + ( SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -145,7 +146,7 @@ import qualified Data.Map.Strict as Map -- - place limits on the coin selection algorithm, enabling it to produce -- selections that are acceptable to the ledger. -- -data SelectionConstraints address = SelectionConstraints +data SelectionConstraints ctx = SelectionConstraints { assessTokenBundleSize :: TokenBundle -> TokenBundleSizeAssessment -- ^ Assesses the size of a token bundle relative to the upper limit of @@ -160,10 +161,10 @@ data SelectionConstraints address = SelectionConstraints :: TokenMap -> Coin -- ^ Computes the minimum ada quantity required for a given output. , computeMinimumCost - :: SelectionSkeleton address -> Coin + :: SelectionSkeleton ctx -> Coin -- ^ Computes the minimum cost of a given selection skeleton. , computeSelectionLimit - :: [(address, TokenBundle)] -> SelectionLimit + :: [(Address ctx, TokenBundle)] -> SelectionLimit -- ^ Computes an upper bound for the number of ordinary inputs to -- select, given a current set of outputs. , maximumCollateralInputCount @@ -179,7 +180,7 @@ data SelectionConstraints address = SelectionConstraints -- | Specifies all parameters that are specific to a given selection. -- -data SelectionParams address u = SelectionParams +data SelectionParams ctx = SelectionParams { assetsToBurn :: !TokenMap -- ^ Specifies a set of assets to burn. @@ -193,7 +194,7 @@ data SelectionParams address u = SelectionParams :: !Coin -- ^ Specifies extra 'Coin' out. , outputsToCover - :: ![(address, TokenBundle)] + :: ![(Address ctx, TokenBundle)] -- ^ Specifies a set of outputs that must be paid for. , rewardWithdrawal :: !Coin @@ -208,14 +209,14 @@ data SelectionParams address u = SelectionParams :: !SelectionCollateralRequirement -- ^ Specifies the collateral requirement for this selection. , utxoAvailableForCollateral - :: !(Map u Coin) + :: !(Map (UTxO ctx) Coin) -- ^ Specifies a set of UTxOs that are available for selection as -- collateral inputs. -- -- This set is allowed to intersect with 'utxoAvailableForInputs', -- since the ledger does not require that these sets are disjoint. , utxoAvailableForInputs - :: !(UTxOSelection u) + :: !(UTxOSelection (UTxO ctx)) -- ^ Specifies a set of UTxOs that are available for selection as -- ordinary inputs and optionally, a subset that has already been -- selected. @@ -225,30 +226,48 @@ data SelectionParams address u = SelectionParams :: SelectionStrategy -- ^ Specifies which selection strategy to use. See 'SelectionStrategy'. } - deriving (Eq, Generic, Show) + deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionParams ctx) +deriving instance SelectionContext ctx => Show (SelectionParams ctx) -- | Indicates that an error occurred while performing a coin selection. -- -data SelectionError address u +data SelectionError ctx = SelectionBalanceErrorOf - (SelectionBalanceError address u) + (SelectionBalanceError ctx) | SelectionCollateralErrorOf - (SelectionCollateralError u) + (SelectionCollateralError ctx) | SelectionOutputErrorOf - (SelectionOutputError address) - deriving (Eq, Show) + (SelectionOutputError ctx) + +deriving instance SelectionContext ctx => Eq (SelectionError ctx) +deriving instance SelectionContext ctx => Show (SelectionError ctx) + +-- | Represents an unsuccessful attempt to select collateral. +-- +data SelectionCollateralError ctx = SelectionCollateralError + { largestCombinationAvailable :: Map (UTxO ctx) Coin + -- ^ The largest combination of coins available. + , minimumSelectionAmount :: Coin + -- ^ A lower bound on the sum of coins to be selected as collateral. + } + deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionCollateralError ctx) +deriving instance SelectionContext ctx => Show (SelectionCollateralError ctx) -- | Represents a balanced selection. -- -data Selection address u = Selection +data Selection ctx = Selection { inputs - :: !(NonEmpty (u, TokenBundle)) + :: !(NonEmpty (UTxO ctx, TokenBundle)) -- ^ Selected inputs. , collateral - :: ![(u, Coin)] + :: ![(UTxO ctx, Coin)] -- ^ Selected collateral inputs. , outputs - :: ![(address, TokenBundle)] + :: ![(Address ctx, TokenBundle)] -- ^ User-specified outputs , change :: ![TokenBundle] @@ -266,14 +285,17 @@ data Selection address u = Selection :: !Coin -- ^ An extra sink for ada. } - deriving (Generic, Eq, Show) + deriving Generic + +deriving instance SelectionContext ctx => Eq (Selection ctx) +deriving instance SelectionContext ctx => Show (Selection ctx) -- | Provides a context for functions related to 'performSelection'. -type PerformSelection m address a u = - SelectionConstraints address -> - SelectionParams address u -> - ExceptT (SelectionError address u) m a +type PerformSelection m ctx a = + SelectionConstraints ctx -> + SelectionParams ctx -> + ExceptT (SelectionError ctx) m a -------------------------------------------------------------------------------- -- Performing a selection @@ -302,57 +324,65 @@ type PerformSelection m address a u = -- >>> verifySelectionError cs ps e == VerificationSuccess -- performSelection - :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) - => PerformSelection m address (Selection address u) u + :: (HasCallStack, MonadRandom m, SelectionContext ctx) + => PerformSelection m ctx (Selection ctx) performSelection cs = performSelectionInner cs <=< prepareOutputs cs performSelectionInner - :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) - => PerformSelection m address (Selection address u) u + :: (HasCallStack, MonadRandom m, SelectionContext ctx) + => PerformSelection m ctx (Selection ctx) performSelectionInner cs ps = do balanceResult <- performSelectionBalance cs ps collateralResult <- performSelectionCollateral balanceResult cs ps pure $ mkSelection ps balanceResult collateralResult -prepareOutputs - :: Applicative m - => PerformSelection m address (SelectionParams address u) u +prepareOutputs :: Applicative m => PerformSelection m ctx (SelectionParams ctx) prepareOutputs cs ps = withExceptT SelectionOutputErrorOf $ ExceptT $ pure $ - flip (set #outputsToCover) ps <$> prepareOutputsInternal cs (view #outputsToCover ps) + <&> \outputsToCover -> ps {outputsToCover} performSelectionBalance - :: (HasCallStack, MonadRandom m, Ord u, Show address, Show u) - => PerformSelection m address (Balance.SelectionResult address u) u + :: (HasCallStack, MonadRandom m, SelectionContext ctx) + => PerformSelection m ctx (Balance.SelectionResult ctx) performSelectionBalance cs ps = withExceptT SelectionBalanceErrorOf $ ExceptT $ uncurry Balance.performSelection $ toBalanceConstraintsParams (cs, ps) performSelectionCollateral - :: (Applicative m, Ord u) - => Balance.SelectionResult address u - -> PerformSelection m address (Collateral.SelectionResult u) u + :: (Applicative m, SelectionContext ctx) + => Balance.SelectionResult ctx + -> PerformSelection m ctx (Collateral.SelectionResult (UTxO ctx)) performSelectionCollateral balanceResult cs ps | selectionCollateralRequired ps = - withExceptT SelectionCollateralErrorOf $ ExceptT $ pure $ + withExceptT mkCollateralError $ ExceptT $ pure $ uncurry Collateral.performSelection $ toCollateralConstraintsParams balanceResult (cs, ps) | otherwise = ExceptT $ pure $ Right Collateral.selectionResultEmpty + where + mkCollateralError + :: Collateral.SelectionCollateralError (UTxO ctx) + -> SelectionError ctx + mkCollateralError Collateral.SelectionCollateralError {..} = + SelectionCollateralErrorOf + SelectionCollateralError {..} -- | Returns a selection's ordinary outputs and change outputs in a single list. -- -- Since change outputs do not have addresses at the point of generation, -- this function assigns all change outputs with a dummy change address. -- -selectionAllOutputs :: Selection address u -> [(address, TokenBundle)] +selectionAllOutputs + :: forall ctx. SelectionContext ctx + => Selection ctx + -> [(Address ctx, TokenBundle)] selectionAllOutputs selection = (<>) (selection ^. #outputs) - (selection ^. #change <&> (dummyChangeaddress, )) + (selection ^. #change <&> (dummyChangeAddress, )) where - dummyChangeaddress :: address - dummyChangeaddress = + dummyChangeAddress :: Address ctx + dummyChangeAddress = -- TODO: ADP-1448 -- -- Replace this call to 'error' with a call to a function that @@ -363,8 +393,9 @@ selectionAllOutputs selection = (<>) -- | Creates constraints and parameters for 'Balance.performSelection'. -- toBalanceConstraintsParams - :: ( SelectionConstraints address, SelectionParams address u) - -> (Balance.SelectionConstraints address, Balance.SelectionParams address u) + :: forall ctx. + ( SelectionConstraints ctx, SelectionParams ctx) + -> (Balance.SelectionConstraints ctx, Balance.SelectionParams ctx) toBalanceConstraintsParams (constraints, params) = (balanceConstraints, balanceParams) where @@ -382,8 +413,8 @@ toBalanceConstraintsParams (constraints, params) = } where adjustComputeMinimumCost - :: (SelectionSkeleton address -> Coin) - -> (SelectionSkeleton address -> Coin) + :: (SelectionSkeleton ctx -> Coin) + -> (SelectionSkeleton ctx -> Coin) adjustComputeMinimumCost = whenCollateralRequired params (. adjustSelectionSkeleton) where @@ -404,14 +435,14 @@ toBalanceConstraintsParams (constraints, params) = -- relatively small, this fee increase is likely to be very small. -- adjustSelectionSkeleton - :: SelectionSkeleton address - -> SelectionSkeleton address + :: SelectionSkeleton ctx + -> SelectionSkeleton ctx adjustSelectionSkeleton = over #skeletonInputCount (+ view #maximumCollateralInputCount constraints) adjustComputeSelectionLimit - :: ([(address, TokenBundle)] -> SelectionLimit) - -> ([(address, TokenBundle)] -> SelectionLimit) + :: ([(Address ctx, TokenBundle)] -> SelectionLimit) + -> ([(Address ctx, TokenBundle)] -> SelectionLimit) adjustComputeSelectionLimit = whenCollateralRequired params (fmap adjustSelectionLimit) where @@ -452,9 +483,13 @@ toBalanceConstraintsParams (constraints, params) = -- | Creates constraints and parameters for 'Collateral.performSelection'. -- toCollateralConstraintsParams - :: Balance.SelectionResult a u - -> ( SelectionConstraints a, SelectionParams a u) - -> (Collateral.SelectionConstraints , Collateral.SelectionParams u) + :: Balance.SelectionResult ctx + -> ( SelectionConstraints ctx + , SelectionParams ctx + ) + -> ( Collateral.SelectionConstraints + , Collateral.SelectionParams (UTxO ctx) + ) toCollateralConstraintsParams balanceResult (constraints, params) = (collateralConstraints, collateralParams) where @@ -484,10 +519,10 @@ toCollateralConstraintsParams balanceResult (constraints, params) = -- | Creates a 'Selection' from selections of inputs and collateral. -- mkSelection - :: SelectionParams address u - -> Balance.SelectionResult address u - -> Collateral.SelectionResult u - -> Selection address u + :: SelectionParams ctx + -> Balance.SelectionResult ctx + -> Collateral.SelectionResult (UTxO ctx) + -> Selection ctx mkSelection _params balanceResult collateralResult = Selection { inputs = view #inputsSelected balanceResult , collateral = Map.toList $ view #coinsSelected collateralResult @@ -501,7 +536,7 @@ mkSelection _params balanceResult collateralResult = Selection -- | Converts a 'Selection' to a balance result. -- -toBalanceResult :: Selection address u -> Balance.SelectionResult address u +toBalanceResult :: Selection ctx -> Balance.SelectionResult ctx toBalanceResult selection = Balance.SelectionResult { inputsSelected = view #inputs selection , outputsCovered = view #outputs selection @@ -617,10 +652,10 @@ verifyEmpty xs failureReason = -- | The type of all 'Selection' verification functions. -- -type VerifySelection address u = - SelectionConstraints address -> - SelectionParams address u -> - Selection address u -> +type VerifySelection ctx = + SelectionConstraints ctx -> + SelectionParams ctx -> + Selection ctx -> VerificationResult -- | Verifies a 'Selection' for correctness. @@ -629,7 +664,7 @@ type VerifySelection address u = -- it's not usually necessary to call this function from ordinary application -- code, unless you suspect that a 'Selection' is incorrect in some way. -- -verifySelection :: (Ord u, Show address, Show u) => VerifySelection address u +verifySelection :: SelectionContext ctx => VerifySelection ctx verifySelection = mconcat [ verifySelectionCollateralSufficient , verifySelectionCollateralSuitable @@ -651,7 +686,7 @@ data FailureToVerifySelectionCollateralSufficient = } deriving (Eq, Show) -verifySelectionCollateralSufficient :: VerifySelection address u +verifySelectionCollateralSufficient :: VerifySelection ctx verifySelectionCollateralSufficient cs ps selection = verify (collateralSelected >= collateralRequired) @@ -674,7 +709,7 @@ data FailureToVerifySelectionCollateralSuitable u = deriving (Eq, Show) verifySelectionCollateralSuitable - :: forall address u. (Ord u, Show u) => VerifySelection address u + :: forall ctx. SelectionContext ctx => VerifySelection ctx verifySelectionCollateralSuitable _cs ps selection = verify (null collateralSelectedButUnsuitable) @@ -689,7 +724,7 @@ verifySelectionCollateralSuitable _cs ps selection = -- all entries within 'utxoAvailableForCollateral' are suitable for use as -- collateral, here we merely verify that the selected entry is indeed a -- member of this set. - utxoSuitableForCollateral :: (u, Coin) -> Bool + utxoSuitableForCollateral :: (UTxO ctx, Coin) -> Bool utxoSuitableForCollateral (i, c) = Map.singleton i c `Map.isSubmapOf` @@ -709,7 +744,7 @@ data FailureToVerifySelectionDeltaValid = FailureToVerifySelectionDeltaValid } deriving (Eq, Show) -verifySelectionDeltaValid :: VerifySelection address u +verifySelectionDeltaValid :: VerifySelection ctx verifySelectionDeltaValid cs ps selection = verify (selectionHasValidSurplus cs ps selection) @@ -736,7 +771,7 @@ data FailureToVerifySelectionInputCountWithinLimit = } deriving (Eq, Show) -verifySelectionInputCountWithinLimit :: VerifySelection address u +verifySelectionInputCountWithinLimit :: VerifySelection ctx verifySelectionInputCountWithinLimit cs _ps selection = verify (Balance.MaximumInputLimit totalInputCount <= selectionLimit) @@ -764,16 +799,16 @@ data SelectionOutputCoinInsufficientError address = deriving (Eq, Show) verifySelectionOutputCoinsSufficient - :: forall address u. Show address => VerifySelection address u + :: forall ctx. SelectionContext ctx => VerifySelection ctx verifySelectionOutputCoinsSufficient cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputCoinsSufficient where - errors :: [SelectionOutputCoinInsufficientError address] + errors :: [SelectionOutputCoinInsufficientError (Address ctx)] errors = mapMaybe maybeError (selectionAllOutputs selection) maybeError - :: (address, TokenBundle) - -> Maybe (SelectionOutputCoinInsufficientError address) + :: (Address ctx, TokenBundle) + -> Maybe (SelectionOutputCoinInsufficientError (Address ctx)) maybeError output | snd output ^. #coin < minimumExpectedCoin = Just SelectionOutputCoinInsufficientError @@ -796,11 +831,11 @@ newtype FailureToVerifySelectionOutputSizesWithinLimit address = deriving (Eq, Show) verifySelectionOutputSizesWithinLimit - :: forall address u. Show address => VerifySelection address u + :: forall ctx. (SelectionContext ctx) => VerifySelection ctx verifySelectionOutputSizesWithinLimit cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputSizesWithinLimit where - errors :: [SelectionOutputSizeExceedsLimitError address] + errors :: [SelectionOutputSizeExceedsLimitError ctx] errors = mapMaybe (verifyOutputSize cs) (selectionAllOutputs selection) -------------------------------------------------------------------------------- @@ -813,12 +848,11 @@ newtype FailureToVerifySelectionOutputTokenQuantitiesWithinLimit address = deriving (Eq, Show) verifySelectionOutputTokenQuantitiesWithinLimit - :: forall address u. Show address - => VerifySelection address u + :: forall ctx. SelectionContext ctx => VerifySelection ctx verifySelectionOutputTokenQuantitiesWithinLimit _cs _ps selection = verifyEmpty errors FailureToVerifySelectionOutputTokenQuantitiesWithinLimit where - errors :: [SelectionOutputTokenQuantityExceedsLimitError address] + errors :: [SelectionOutputTokenQuantityExceedsLimitError ctx] errors = verifyOutputTokenQuantities =<< selectionAllOutputs selection -------------------------------------------------------------------------------- @@ -827,11 +861,8 @@ verifySelectionOutputTokenQuantitiesWithinLimit _cs _ps selection = -- | The type of all 'SelectionError' verification functions. -- -type VerifySelectionError e address u = - SelectionConstraints address -> - SelectionParams address u -> - e -> - VerificationResult +type VerifySelectionError e ctx = + SelectionConstraints ctx -> SelectionParams ctx -> e -> VerificationResult -- | Verifies a 'SelectionError' for correctness. -- @@ -840,8 +871,7 @@ type VerifySelectionError e address u = -- code, unless you suspect that a 'SelectionError' is incorrect in some way. -- verifySelectionError - :: (Show address, Ord u, Show u) - => VerifySelectionError (SelectionError address u) address u + :: SelectionContext ctx => VerifySelectionError (SelectionError ctx) ctx verifySelectionError cs ps = \case SelectionBalanceErrorOf e -> verifySelectionBalanceError cs ps e @@ -855,8 +885,8 @@ verifySelectionError cs ps = \case -------------------------------------------------------------------------------- verifySelectionBalanceError - :: (Show address, Ord u, Show u) - => VerifySelectionError (SelectionBalanceError address u) address u + :: SelectionContext ctx + => VerifySelectionError (SelectionBalanceError ctx) ctx verifySelectionBalanceError cs ps = \case Balance.BalanceInsufficient e -> verifyBalanceInsufficientError cs ps e @@ -881,7 +911,7 @@ data FailureToVerifyBalanceInsufficientError = deriving (Eq, Show) verifyBalanceInsufficientError - :: VerifySelectionError Balance.BalanceInsufficientError address u + :: VerifySelectionError Balance.BalanceInsufficientError ctx verifyBalanceInsufficientError cs ps e = verifyAll [ not (utxoBalanceRequired `leq` utxoBalanceAvailable) @@ -901,7 +931,7 @@ newtype FailureToVerifyEmptyUTxOError u = FailureToVerifyEmptyUTxOError { utxoAvailableForInputs :: UTxOSelection u } deriving (Eq, Show) -verifyEmptyUTxOError :: (Eq u, Show u) => VerifySelectionError () address u +verifyEmptyUTxOError :: SelectionContext ctx => VerifySelectionError () ctx verifyEmptyUTxOError _cs SelectionParams {utxoAvailableForInputs} _e = verify (utxoAvailableForInputs == UTxOSelection.empty) @@ -920,9 +950,8 @@ data FailureToVerifyInsufficientMinCoinValueError address = deriving (Eq, Show) verifyInsufficientMinCoinValueError - :: Show address - => VerifySelectionError - (Balance.InsufficientMinCoinValueError address) address u + :: SelectionContext ctx + => VerifySelectionError (Balance.InsufficientMinCoinValueError ctx) ctx verifyInsufficientMinCoinValueError cs _ps e = verifyAll [ reportedMinCoinValue == verifiedMinCoinValue @@ -963,15 +992,14 @@ data FailureToVerifySelectionLimitReachedError u = -- given the amount of space we expect to be reserved for collateral inputs. -- verifySelectionLimitReachedError - :: forall address u. Show u - => VerifySelectionError - (Balance.SelectionLimitReachedError address u) address u + :: forall ctx. SelectionContext ctx + => VerifySelectionError (Balance.SelectionLimitReachedError ctx) ctx verifySelectionLimitReachedError cs ps e = verify (Balance.MaximumInputLimit selectedInputCount >= selectionLimitAdjusted) (FailureToVerifySelectionLimitReachedError {..}) where - selectedInputs :: [(u, TokenBundle)] + selectedInputs :: [(UTxO ctx, TokenBundle)] selectedInputs = e ^. #inputsSelected selectedInputCount :: Int @@ -992,17 +1020,21 @@ verifySelectionLimitReachedError cs ps e = -- Selection error verification: change construction errors -------------------------------------------------------------------------------- -data FailureToVerifyUnableToConstructChangeError address u = +data FailureToVerifyUnableToConstructChangeError ctx = FailureToVerifyUnableToConstructChangeError { errorOriginal :: Balance.UnableToConstructChangeError -- ^ The original error. , errorWithMinimalConstraints - :: SelectionError address u + :: SelectionError ctx -- ^ An error encountered when attempting to re-run the selection -- process with minimal constraints. } - deriving (Eq, Show) + +deriving instance SelectionContext ctx => + Eq (FailureToVerifyUnableToConstructChangeError ctx) +deriving instance SelectionContext ctx => + Show (FailureToVerifyUnableToConstructChangeError ctx) -- | Verifies a 'Balance.UnableToConstructChangeError'. -- @@ -1028,9 +1060,8 @@ data FailureToVerifyUnableToConstructChangeError address u = -- balance is insufficient by returning a 'BalanceInsufficientError' instead. -- verifyUnableToConstructChangeError - :: forall address u. (Ord u, Show address, Show u) - => VerifySelectionError - Balance.UnableToConstructChangeError address u + :: forall ctx. SelectionContext ctx + => VerifySelectionError Balance.UnableToConstructChangeError ctx verifyUnableToConstructChangeError cs ps errorOriginal = case resultWithMinimalConstraints of Left errorWithMinimalConstraints -> @@ -1045,8 +1076,7 @@ verifyUnableToConstructChangeError cs ps errorOriginal = -- - a minimum cost function that always returns zero. -- - a minimum ada quantity function that always returns zero. -- - resultWithMinimalConstraints - :: Either (SelectionError address u) (Selection address u) + resultWithMinimalConstraints :: Either (SelectionError ctx) (Selection ctx) resultWithMinimalConstraints = -- The 'performSelection' function requires a 'MonadRandom' context so -- that it can select entries at random from the available UTxO set. @@ -1114,8 +1144,8 @@ data FailureToVerifySelectionCollateralError u = deriving (Eq, Show) verifySelectionCollateralError - :: forall address u. (Ord u, Show u) - => VerifySelectionError (SelectionCollateralError u) address u + :: forall ctx. SelectionContext ctx + => VerifySelectionError (SelectionCollateralError ctx) ctx verifySelectionCollateralError cs ps e = verifyAll [ Map.null largestCombinationUnsuitableSubset @@ -1124,14 +1154,14 @@ verifySelectionCollateralError cs ps e = ] (FailureToVerifySelectionCollateralError {..}) where - largestCombination :: Map u Coin + largestCombination :: Map (UTxO ctx) Coin largestCombination = e ^. #largestCombinationAvailable largestCombinationSize :: Int largestCombinationSize = Map.size largestCombination largestCombinationValue :: Coin largestCombinationValue = F.fold largestCombination - largestCombinationUnsuitableSubset :: Map u Coin + largestCombinationUnsuitableSubset :: Map (UTxO ctx) Coin largestCombinationUnsuitableSubset = Map.withoutKeys (largestCombination) (Map.keysSet $ ps ^. #utxoAvailableForCollateral) @@ -1146,8 +1176,8 @@ verifySelectionCollateralError cs ps e = -------------------------------------------------------------------------------- verifySelectionOutputError - :: Show address - => VerifySelectionError (SelectionOutputError address) address u + :: SelectionContext ctx + => VerifySelectionError (SelectionOutputError ctx) ctx verifySelectionOutputError cs ps = \case SelectionOutputSizeExceedsLimit e -> verifySelectionOutputSizeExceedsLimitError cs ps e @@ -1164,9 +1194,8 @@ newtype FailureToVerifySelectionOutputSizeExceedsLimitError address = deriving (Eq, Show) verifySelectionOutputSizeExceedsLimitError - :: Show address - => VerifySelectionError - (SelectionOutputSizeExceedsLimitError address) address u + :: SelectionContext ctx + => VerifySelectionError (SelectionOutputSizeExceedsLimitError ctx) ctx verifySelectionOutputSizeExceedsLimitError cs _ps e = verify (not isWithinLimit) @@ -1184,17 +1213,17 @@ verifySelectionOutputSizeExceedsLimitError cs _ps e = -- Selection error verification: output token quantity errors -------------------------------------------------------------------------------- -newtype FailureToVerifySelectionOutputTokenQuantityExceedsLimitError address = +newtype FailureToVerifySelectionOutputTokenQuantityExceedsLimitError ctx = FailureToVerifySelectionOutputTokenQuantityExceedsLimitError { reportedError - :: SelectionOutputTokenQuantityExceedsLimitError address + :: SelectionOutputTokenQuantityExceedsLimitError ctx } deriving (Eq, Show) verifySelectionOutputTokenQuantityExceedsLimitError - :: Show address + :: SelectionContext ctx => VerifySelectionError - (SelectionOutputTokenQuantityExceedsLimitError address) address u + (SelectionOutputTokenQuantityExceedsLimitError ctx) ctx verifySelectionOutputTokenQuantityExceedsLimitError _cs _ps e = verify (e ^. #quantity > e ^. #quantityMaxBound) @@ -1208,14 +1237,14 @@ verifySelectionOutputTokenQuantityExceedsLimitError _cs _ps e = -- -- See 'SelectionDelta'. -- -selectionDeltaAllAssets :: Selection address u -> SelectionDelta TokenBundle +selectionDeltaAllAssets :: Selection ctx -> SelectionDelta TokenBundle selectionDeltaAllAssets = Balance.selectionDeltaAllAssets . toBalanceResult -- | Calculates the ada selection delta. -- -- See 'SelectionDelta'. -- -selectionDeltaCoin :: Selection address u -> SelectionDelta Coin +selectionDeltaCoin :: Selection ctx -> SelectionDelta Coin selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- | Indicates whether or not a selection has a valid surplus. @@ -1227,10 +1256,7 @@ selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- See 'SelectionDelta'. -- selectionHasValidSurplus - :: SelectionConstraints address - -> SelectionParams address u - -> Selection address u - -> Bool + :: SelectionConstraints ctx -> SelectionParams ctx -> Selection ctx -> Bool selectionHasValidSurplus constraints params selection = Balance.selectionHasValidSurplus (fst $ toBalanceConstraintsParams (constraints, params)) @@ -1239,10 +1265,7 @@ selectionHasValidSurplus constraints params selection = -- | Computes the minimum required cost of a selection. -- selectionMinimumCost - :: SelectionConstraints address - -> SelectionParams address u - -> Selection address u - -> Coin + :: SelectionConstraints ctx -> SelectionParams ctx -> Selection ctx -> Coin selectionMinimumCost constraints params selection = Balance.selectionMinimumCost (fst $ toBalanceConstraintsParams (constraints, params)) @@ -1251,10 +1274,7 @@ selectionMinimumCost constraints params selection = -- | Computes the maximum acceptable cost of a selection. -- selectionMaximumCost - :: SelectionConstraints address - -> SelectionParams address u - -> Selection address u - -> Coin + :: SelectionConstraints ctx -> SelectionParams ctx -> Selection ctx -> Coin selectionMaximumCost constraints params selection = Balance.selectionMaximumCost (fst $ toBalanceConstraintsParams (constraints, params)) @@ -1268,7 +1288,7 @@ selectionMaximumCost constraints params selection = -- Use 'selectionDeltaCoin' if you wish to handle the case where there is -- a deficit. -- -selectionSurplusCoin :: Selection address u -> Coin +selectionSurplusCoin :: Selection ctx -> Coin selectionSurplusCoin = Balance.selectionSurplusCoin . toBalanceResult -------------------------------------------------------------------------------- @@ -1286,7 +1306,7 @@ data SelectionCollateralRequirement -- | Indicates 'True' if and only if collateral is required. -- -selectionCollateralRequired :: SelectionParams address u -> Bool +selectionCollateralRequired :: SelectionParams ctx -> Bool selectionCollateralRequired params = case view #collateralRequirement params of SelectionCollateralRequired -> True SelectionCollateralNotRequired -> False @@ -1294,7 +1314,7 @@ selectionCollateralRequired params = case view #collateralRequirement params of -- | Applies the given transformation function only when collateral is required. -- whenCollateralRequired - :: SelectionParams address u + :: SelectionParams ctx -> (a -> a) -> (a -> a) whenCollateralRequired params f @@ -1303,16 +1323,13 @@ whenCollateralRequired params f -- | Computes the total amount of collateral within a selection. -- -selectionCollateral :: Selection address u -> Coin +selectionCollateral :: Selection ctx -> Coin selectionCollateral = F.foldMap snd . view #collateral -- | Indicates whether or not a selection has sufficient collateral. -- selectionHasSufficientCollateral - :: SelectionConstraints address - -> SelectionParams address u - -> Selection address u - -> Bool + :: SelectionConstraints ctx -> SelectionParams ctx -> Selection ctx -> Bool selectionHasSufficientCollateral constraints params selection = actual >= required where @@ -1322,10 +1339,7 @@ selectionHasSufficientCollateral constraints params selection = -- | Computes the minimum required amount of collateral for a selection. -- selectionMinimumCollateral - :: SelectionConstraints address - -> SelectionParams address u - -> Selection address u - -> Coin + :: SelectionConstraints ctx -> SelectionParams ctx -> Selection ctx -> Coin selectionMinimumCollateral constraints params selection | selectionCollateralRequired params = view #minimumSelectionAmount $ snd $ @@ -1361,9 +1375,9 @@ computeMinimumCollateral params = -- | Prepares the given user-specified outputs, ensuring that they are valid. -- prepareOutputsInternal - :: forall address. SelectionConstraints address - -> [(address, TokenBundle)] - -> Either (SelectionOutputError address) [(address, TokenBundle)] + :: forall ctx. SelectionConstraints ctx + -> [(Address ctx, TokenBundle)] + -> Either (SelectionOutputError ctx) [(Address ctx, TokenBundle)] prepareOutputsInternal constraints outputsUnprepared | e : _ <- excessivelyLargeBundles = Left $ @@ -1384,14 +1398,15 @@ prepareOutputsInternal constraints outputsUnprepared -- The complete list of token bundles whose serialized lengths are greater -- than the limit of what is allowed in a transaction output: - excessivelyLargeBundles :: [SelectionOutputSizeExceedsLimitError address] + excessivelyLargeBundles + :: [SelectionOutputSizeExceedsLimitError ctx] excessivelyLargeBundles = mapMaybe (verifyOutputSize constraints) outputsToCover -- The complete list of token quantities that exceed the maximum quantity -- allowed in a transaction output: excessiveTokenQuantities - :: [SelectionOutputTokenQuantityExceedsLimitError address] + :: [SelectionOutputTokenQuantityExceedsLimitError ctx] excessiveTokenQuantities = verifyOutputTokenQuantities =<< outputsToCover outputsToCover = @@ -1427,18 +1442,26 @@ prepareOutputsWith minCoinValueFor = -- | Indicates a problem when preparing outputs for a coin selection. -- -data SelectionOutputError address +data SelectionOutputError ctx = SelectionOutputSizeExceedsLimit - (SelectionOutputSizeExceedsLimitError address) + (SelectionOutputSizeExceedsLimitError ctx) | SelectionOutputTokenQuantityExceedsLimit - (SelectionOutputTokenQuantityExceedsLimitError address) - deriving (Eq, Generic, Show) + (SelectionOutputTokenQuantityExceedsLimitError ctx) + deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionOutputError ctx) +deriving instance SelectionContext ctx => Show (SelectionOutputError ctx) -newtype SelectionOutputSizeExceedsLimitError address = +newtype SelectionOutputSizeExceedsLimitError ctx = SelectionOutputSizeExceedsLimitError - { outputThatExceedsLimit :: (address, TokenBundle) + { outputThatExceedsLimit :: (Address ctx, TokenBundle) } - deriving (Eq, Generic, Show) + deriving Generic + +deriving instance SelectionContext ctx => + Eq (SelectionOutputSizeExceedsLimitError ctx) +deriving instance SelectionContext ctx => + Show (SelectionOutputSizeExceedsLimitError ctx) -- | Verifies the size of an output. -- @@ -1446,9 +1469,9 @@ newtype SelectionOutputSizeExceedsLimitError address = -- exceeds the limit defined by the protocol. -- verifyOutputSize - :: SelectionConstraints address - -> (address, TokenBundle) - -> Maybe (SelectionOutputSizeExceedsLimitError address) + :: SelectionConstraints ctx + -> (Address ctx, TokenBundle) + -> Maybe (SelectionOutputSizeExceedsLimitError ctx) verifyOutputSize cs out | withinLimit = Nothing @@ -1464,9 +1487,9 @@ verifyOutputSize cs out -- | Indicates that a token quantity exceeds the maximum quantity that can -- appear in a transaction output's token bundle. -- -data SelectionOutputTokenQuantityExceedsLimitError address = +data SelectionOutputTokenQuantityExceedsLimitError ctx = SelectionOutputTokenQuantityExceedsLimitError - { address :: !address + { address :: !(Address ctx) -- ^ The address to which this token quantity was to be sent. , asset :: !AssetId -- ^ The asset identifier to which this token quantity corresponds. @@ -1475,7 +1498,12 @@ data SelectionOutputTokenQuantityExceedsLimitError address = , quantityMaxBound :: !TokenQuantity -- ^ The maximum allowable token quantity. } - deriving (Eq, Generic, Show) + deriving Generic + +deriving instance SelectionContext ctx => + Eq (SelectionOutputTokenQuantityExceedsLimitError ctx) +deriving instance SelectionContext ctx => + Show (SelectionOutputTokenQuantityExceedsLimitError ctx) -- | Verifies the token quantities of an output. -- @@ -1483,8 +1511,8 @@ data SelectionOutputTokenQuantityExceedsLimitError address = -- protocol. -- verifyOutputTokenQuantities - :: (address, TokenBundle) - -> [SelectionOutputTokenQuantityExceedsLimitError address] + :: (Address ctx, TokenBundle) + -> [SelectionOutputTokenQuantityExceedsLimitError ctx] verifyOutputTokenQuantities out = [ SelectionOutputTokenQuantityExceedsLimitError {address, asset, quantity, quantityMaxBound = txOutMaxTokenQuantity} diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index 617e7ca52c2..e49844a8b54 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -4,13 +4,14 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | @@ -127,6 +128,8 @@ import Algebra.PartialOrd ( PartialOrd (..) ) import Cardano.Numeric.Util ( padCoalesce ) +import Cardano.Wallet.CoinSelection.Internal.Context + ( SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -158,7 +161,7 @@ import Data.Function import Data.Functor.Identity ( Identity (..) ) import Data.Generics.Internal.VL.Lens - ( over, view ) + ( view ) import Data.Generics.Labels () import Data.IntCast @@ -211,7 +214,7 @@ import qualified Data.Set as Set -- -- - are not specific to a given selection. -- -data SelectionConstraints address = SelectionConstraints +data SelectionConstraints ctx = SelectionConstraints { assessTokenBundleSize :: TokenBundle -> TokenBundleSizeAssessment -- ^ Assesses the size of a token bundle relative to the upper limit of @@ -222,10 +225,10 @@ data SelectionConstraints address = SelectionConstraints :: TokenMap -> Coin -- ^ Computes the minimum ada quantity required for a given output. , computeMinimumCost - :: SelectionSkeleton address -> Coin + :: SelectionSkeleton ctx -> Coin -- ^ Computes the minimum cost of a given selection skeleton. , computeSelectionLimit - :: [(address, TokenBundle)] -> SelectionLimit + :: [(Address ctx, TokenBundle)] -> SelectionLimit -- ^ Computes an upper bound for the number of ordinary inputs to -- select, given a current set of outputs. } @@ -235,12 +238,12 @@ type SelectionParams = SelectionParamsOf [] -- | Specifies all parameters that are specific to a given selection. -- -data SelectionParamsOf f address u = SelectionParams +data SelectionParamsOf f ctx = SelectionParams { outputsToCover - :: !(f (address, TokenBundle)) + :: !(f (Address ctx, TokenBundle)) -- ^ The complete set of outputs to be covered. , utxoAvailable - :: !(UTxOSelection u) + :: !(UTxOSelection (UTxO ctx)) -- ^ Specifies a set of UTxOs that are available for selection as -- inputs and optionally, a subset that has already been selected. -- @@ -272,12 +275,12 @@ data SelectionParamsOf f address u = SelectionParams deriving Generic deriving instance - (Eq (f (address, TokenBundle)), Eq u) => - Eq (SelectionParamsOf f address u) + (Eq (f (Address ctx, TokenBundle)), Eq (UTxO ctx)) => + Eq (SelectionParamsOf f ctx) deriving instance - (Show (f (address, TokenBundle)), Show u) => - Show (SelectionParamsOf f address u) + (Show (f (Address ctx, TokenBundle)), Show (UTxO ctx)) => + Show (SelectionParamsOf f ctx) -- | Indicates a choice of selection strategy. -- @@ -346,20 +349,18 @@ data UTxOBalanceSufficiencyInfo = UTxOBalanceSufficiencyInfo -- | Computes the balance of UTxO entries available for selection. -- computeUTxOBalanceAvailable - :: SelectionParamsOf f address u -> TokenBundle + :: SelectionParamsOf f ctx -> TokenBundle computeUTxOBalanceAvailable = UTxOSelection.availableBalance . view #utxoAvailable -- | Computes the balance of UTxO entries required to be selected. -- computeUTxOBalanceRequired - :: Foldable f => SelectionParamsOf f address u -> TokenBundle + :: Foldable f => SelectionParamsOf f ctx -> TokenBundle computeUTxOBalanceRequired = fst . computeDeficitInOut computeBalanceInOut - :: Foldable f - => SelectionParamsOf f address u - -> (TokenBundle, TokenBundle) + :: Foldable f => SelectionParamsOf f ctx -> (TokenBundle, TokenBundle) computeBalanceInOut params = (balanceIn, balanceOut) where @@ -375,9 +376,7 @@ computeBalanceInOut params = F.foldMap snd (view #outputsToCover params) computeDeficitInOut - :: Foldable f - => SelectionParamsOf f address u - -> (TokenBundle, TokenBundle) + :: Foldable f => SelectionParamsOf f ctx -> (TokenBundle, TokenBundle) computeDeficitInOut params = (deficitIn, deficitOut) where @@ -393,9 +392,7 @@ computeDeficitInOut params = -- See 'UTxOBalanceSufficiency'. -- computeUTxOBalanceSufficiency - :: Foldable f - => SelectionParamsOf f address u - -> UTxOBalanceSufficiency + :: Foldable f => SelectionParamsOf f ctx -> UTxOBalanceSufficiency computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo -- | Computes information about the UTxO balance sufficiency. @@ -403,9 +400,7 @@ computeUTxOBalanceSufficiency = sufficiency . computeUTxOBalanceSufficiencyInfo -- See 'UTxOBalanceSufficiencyInfo'. -- computeUTxOBalanceSufficiencyInfo - :: Foldable f - => SelectionParamsOf f address u - -> UTxOBalanceSufficiencyInfo + :: Foldable f => SelectionParamsOf f ctx -> UTxOBalanceSufficiencyInfo computeUTxOBalanceSufficiencyInfo params = UTxOBalanceSufficiencyInfo {available, required, difference, sufficiency} where @@ -426,7 +421,7 @@ computeUTxOBalanceSufficiencyInfo params = -- is greater than or equal to the required balance. -- isUTxOBalanceSufficient - :: Foldable f => SelectionParamsOf f address u -> Bool + :: Foldable f => SelectionParamsOf f ctx -> Bool isUTxOBalanceSufficient params = case computeUTxOBalanceSufficiency params of UTxOBalanceSufficient -> True @@ -442,15 +437,18 @@ isUTxOBalanceSufficient params = -- Increasing or decreasing the quantity of a particular asset in a change -- output must not change the estimated cost of a selection. -- -data SelectionSkeleton address = SelectionSkeleton +data SelectionSkeleton ctx = SelectionSkeleton { skeletonInputCount :: !Int , skeletonOutputs - :: ![(address, TokenBundle)] + :: ![(Address ctx, TokenBundle)] , skeletonChange :: ![Set AssetId] } - deriving (Eq, Generic, Show) + deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionSkeleton ctx) +deriving instance SelectionContext ctx => Show (SelectionSkeleton ctx) -- | Specifies a limit to adhere to when performing a selection. -- @@ -496,9 +494,9 @@ type SelectionResult = SelectionResultOf [] -- | The result of performing a successful selection. -- -data SelectionResultOf f address u = SelectionResult +data SelectionResultOf f ctx = SelectionResult { inputsSelected - :: !(NonEmpty (u, TokenBundle)) + :: !(NonEmpty (UTxO ctx, TokenBundle)) -- ^ A (non-empty) list of inputs selected from 'utxoAvailable'. , extraCoinSource :: !Coin @@ -507,7 +505,7 @@ data SelectionResultOf f address u = SelectionResult :: !Coin -- ^ An extra sink for ada. , outputsCovered - :: !(f (address, TokenBundle)) + :: !(f (Address ctx, TokenBundle)) -- ^ A list of outputs covered. , changeGenerated :: ![TokenBundle] @@ -522,11 +520,11 @@ data SelectionResultOf f address u = SelectionResult deriving Generic deriving instance - (Eq (f (address, TokenBundle)), Eq u) => - Eq (SelectionResultOf f address u) + (Eq (f (Address ctx, TokenBundle)), Eq (UTxO ctx)) => + Eq (SelectionResultOf f ctx) deriving instance - (Show (f (address, TokenBundle)), Show u) => - Show (SelectionResultOf f address u) + (Show (f (Address ctx, TokenBundle)), Show (UTxO ctx)) => + Show (SelectionResultOf f ctx) -- | Indicates the difference between total input value and total output value -- of a 'SelectionResult'. @@ -561,9 +559,7 @@ instance Buildable a => Buildable (SelectionDelta a) where -- See 'SelectionDelta'. -- selectionDeltaAllAssets - :: Foldable f - => SelectionResultOf f address u - -> SelectionDelta TokenBundle + :: Foldable f => SelectionResultOf f ctx -> SelectionDelta TokenBundle selectionDeltaAllAssets result | balanceOut `leq` balanceIn = SelectionSurplus $ TokenBundle.difference balanceIn balanceOut @@ -599,18 +595,13 @@ selectionDeltaAllAssets result -- See 'SelectionDelta'. -- selectionDeltaCoin - :: Foldable f - => SelectionResultOf f address u - -> SelectionDelta Coin + :: Foldable f => SelectionResultOf f ctx -> SelectionDelta Coin selectionDeltaCoin = fmap TokenBundle.getCoin . selectionDeltaAllAssets -- | Indicates whether or not a selection result has a valid surplus. -- selectionHasValidSurplus - :: Foldable f - => SelectionConstraints address - -> SelectionResultOf f address u - -> Bool + :: Foldable f => SelectionConstraints ctx -> SelectionResultOf f ctx -> Bool selectionHasValidSurplus constraints selection = case selectionDeltaAllAssets selection of SelectionSurplus s -> surplusIsValid s @@ -646,10 +637,7 @@ selectionHasValidSurplus constraints selection = -- Use 'selectionDeltaCoin' if you wish to handle the case where there is -- a deficit. -- -selectionSurplusCoin - :: Foldable f - => SelectionResultOf f address u - -> Coin +selectionSurplusCoin :: Foldable f => SelectionResultOf f ctx -> Coin selectionSurplusCoin result = case selectionDeltaCoin result of SelectionSurplus surplus -> surplus @@ -658,9 +646,7 @@ selectionSurplusCoin result = -- | Converts a selection into a skeleton. -- selectionSkeleton - :: Foldable f - => SelectionResultOf f address u - -> SelectionSkeleton address + :: Foldable f => SelectionResultOf f ctx -> SelectionSkeleton ctx selectionSkeleton s = SelectionSkeleton { skeletonInputCount = F.length (view #inputsSelected s) , skeletonOutputs = F.toList (view #outputsCovered s) @@ -670,10 +656,7 @@ selectionSkeleton s = SelectionSkeleton -- | Computes the minimum required cost of a selection. -- selectionMinimumCost - :: Foldable f - => SelectionConstraints address - -> SelectionResultOf f address u - -> Coin + :: Foldable f => SelectionConstraints ctx -> SelectionResultOf f ctx -> Coin selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton -- | Computes the maximum acceptable cost of a selection. @@ -691,40 +674,43 @@ selectionMinimumCost c = view #computeMinimumCost c . selectionSkeleton -- See 'selectionHasValidSurplus'. -- selectionMaximumCost - :: Foldable f - => SelectionConstraints address - -> SelectionResultOf f address u - -> Coin + :: Foldable f => SelectionConstraints ctx -> SelectionResultOf f ctx -> Coin selectionMaximumCost c = mtimesDefault (2 :: Int) . selectionMinimumCost c -- | Represents the set of errors that may occur while performing a selection. -- -data SelectionBalanceError address u +data SelectionBalanceError ctx = BalanceInsufficient BalanceInsufficientError | SelectionLimitReached - (SelectionLimitReachedError address u) + (SelectionLimitReachedError ctx) | InsufficientMinCoinValues - (NonEmpty (InsufficientMinCoinValueError address)) + (NonEmpty (InsufficientMinCoinValueError ctx)) | UnableToConstructChange UnableToConstructChangeError | EmptyUTxO - deriving (Generic, Eq, Show) + deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionBalanceError ctx) +deriving instance SelectionContext ctx => Show (SelectionBalanceError ctx) -- | Indicates that the balance of selected UTxO entries was insufficient to -- cover the balance required while remaining within the selection limit. -- -data SelectionLimitReachedError address u = SelectionLimitReachedError +data SelectionLimitReachedError ctx = SelectionLimitReachedError { utxoBalanceRequired :: !TokenBundle -- ^ The UTXO balance required. , inputsSelected - :: ![(u, TokenBundle)] + :: ![(UTxO ctx, TokenBundle)] -- ^ The inputs that could be selected while satisfying the -- 'selectionLimit'. , outputsToCover - :: !(NonEmpty (address, TokenBundle)) - } deriving (Generic, Eq, Show) + :: !(NonEmpty (Address ctx, TokenBundle)) + } deriving Generic + +deriving instance SelectionContext ctx => Eq (SelectionLimitReachedError ctx) +deriving instance SelectionContext ctx => Show (SelectionLimitReachedError ctx) -- | Indicates that the balance of available UTxO entries is insufficient to -- cover the balance required. @@ -750,18 +736,22 @@ balanceMissing (BalanceInsufficientError available required) = -- -- See also: 'prepareOutputs'. -- -data InsufficientMinCoinValueError address = InsufficientMinCoinValueError +data InsufficientMinCoinValueError ctx = InsufficientMinCoinValueError { outputWithInsufficientAda - :: !(address, TokenBundle) + :: !(Address ctx, TokenBundle) -- ^ The particular output that does not have the minimum coin quantity -- expected by the protocol. , expectedMinCoinValue :: !Coin -- ^ The minimum coin quantity expected for this output. - } deriving (Generic, Eq, Show) + } deriving Generic -instance Buildable address => - Buildable (InsufficientMinCoinValueError address) +deriving instance SelectionContext ctx => + Eq (InsufficientMinCoinValueError ctx) +deriving instance SelectionContext ctx => + Show (InsufficientMinCoinValueError ctx) + +instance SelectionContext ctx => Buildable (InsufficientMinCoinValueError ctx) where build (InsufficientMinCoinValueError (a, b) c) = unlinesF [ nameF "Expected min coin value" (build c) @@ -780,14 +770,10 @@ data UnableToConstructChangeError = UnableToConstructChangeError -- selection cost and minimum coin quantity of each change output. } deriving (Generic, Eq, Show) -type PerformSelection m f address u = - SelectionConstraints address -> - SelectionParamsOf f address u -> - m ( - Either - (SelectionBalanceError address u) - (SelectionResultOf f address u) - ) +type PerformSelection m f ctx = + SelectionConstraints ctx -> + SelectionParamsOf f ctx -> + m (Either (SelectionBalanceError ctx) (SelectionResultOf f ctx)) -- | Performs a coin selection and generates change bundles in one step. -- @@ -796,9 +782,8 @@ type PerformSelection m f address u = -- for which 'selectionHasValidSurplus' returns 'True'. -- performSelection - :: forall m address u. - (HasCallStack, MonadRandom m, Ord u, Show address, Show u) - => PerformSelection m [] address u + :: forall m ctx. (HasCallStack, MonadRandom m, SelectionContext ctx) + => PerformSelection m [] ctx performSelection = performSelectionEmpty performSelectionNonEmpty -- | Transforms a coin selection function that requires a non-empty list of @@ -829,35 +814,37 @@ performSelection = performSelectionEmpty performSelectionNonEmpty -- selectionHasValidSurplus constraints (transformResult result) -- performSelectionEmpty - :: forall m address u. Functor m - => PerformSelection m NonEmpty address u - -> PerformSelection m [] address u + :: forall m ctx. Functor m + => PerformSelection m NonEmpty ctx + -> PerformSelection m [] ctx performSelectionEmpty performSelectionFn constraints params = fmap transformResult <$> performSelectionFn constraints (transformParams params) where transformParams - :: SelectionParamsOf [] address u - -> SelectionParamsOf NonEmpty address u - transformParams - = over #extraCoinSource - (transform (`Coin.add` minCoin) (const id)) - . over #outputsToCover - (transform (const (dummyOutput :| [])) (const . id)) + :: SelectionParamsOf [] ctx + -> SelectionParamsOf NonEmpty ctx + transformParams p@SelectionParams {..} = p + { extraCoinSource = + transform (`Coin.add` minCoin) (const id) extraCoinSource + , outputsToCover = + transform (const (dummyOutput :| [])) (const . id) outputsToCover + } transformResult - :: SelectionResultOf NonEmpty address u - -> SelectionResultOf [] address u - transformResult - = over #extraCoinSource - (transform (`Coin.difference` minCoin) (const id)) - . over #outputsCovered - (transform (const []) (const . F.toList)) + :: SelectionResultOf NonEmpty ctx + -> SelectionResultOf [] ctx + transformResult r@SelectionResult {..} = r + { extraCoinSource = + transform (`Coin.difference` minCoin) (const id) extraCoinSource + , outputsCovered = + transform (const []) (const . F.toList) outputsCovered + } - transform :: a -> (NonEmpty (address, TokenBundle) -> a) -> a + transform :: a -> (NonEmpty (Address ctx, TokenBundle) -> a) -> a transform x y = maybe x y $ NE.nonEmpty $ view #outputsToCover params - dummyOutput :: (address, TokenBundle) + dummyOutput :: (Address ctx, TokenBundle) dummyOutput = -- TODO: ADP-1448 -- @@ -883,9 +870,8 @@ performSelectionEmpty performSelectionFn constraints params = (view #computeMinimumAdaQuantity constraints TokenMap.empty) performSelectionNonEmpty - :: forall m address u. - (HasCallStack, MonadRandom m, Ord u, Show address, Show u) - => PerformSelection m NonEmpty address u + :: forall m ctx. (HasCallStack, MonadRandom m, SelectionContext ctx) + => PerformSelection m NonEmpty ctx performSelectionNonEmpty constraints params -- Is the total available UTXO balance sufficient? | not utxoBalanceSufficient = @@ -936,7 +922,7 @@ performSelectionNonEmpty constraints params } = params selectionLimitReachedError - :: [(u, TokenBundle)] -> m (Either (SelectionBalanceError address u) a) + :: [(UTxO ctx, TokenBundle)] -> m (Either (SelectionBalanceError ctx) a) selectionLimitReachedError inputsSelected = pure $ Left $ SelectionLimitReached $ SelectionLimitReachedError { inputsSelected @@ -956,13 +942,13 @@ performSelectionNonEmpty constraints params utxoBalanceSufficient :: Bool utxoBalanceSufficient = isUTxOBalanceSufficient params - insufficientMinCoinValues :: [InsufficientMinCoinValueError address] + insufficientMinCoinValues :: [InsufficientMinCoinValueError ctx] insufficientMinCoinValues = mapMaybe mkInsufficientMinCoinValueError outputsToCover where mkInsufficientMinCoinValueError - :: (address, TokenBundle) - -> Maybe (InsufficientMinCoinValueError address) + :: (Address ctx, TokenBundle) + -> Maybe (InsufficientMinCoinValueError ctx) mkInsufficientMinCoinValueError o | view #coin (snd o) >= expectedMinCoinValue = Nothing @@ -1003,7 +989,7 @@ performSelectionNonEmpty constraints params -- (That is, the predicted change is necessarily equal to the change -- assets of the final resulting selection). -- - predictChange :: UTxOSelectionNonEmpty u -> [Set AssetId] + predictChange :: UTxOSelectionNonEmpty (UTxO ctx) -> [Set AssetId] predictChange s = either (const $ invariantResultWithNoCost $ UTxOSelection.selectedIndex s) (fmap (TokenMap.getAssets . view #tokens)) @@ -1044,12 +1030,10 @@ performSelectionNonEmpty constraints params -- function won't make associated outputs for them. -- makeChangeRepeatedly - :: UTxOSelectionNonEmpty u - -> m - (Either - (SelectionBalanceError address u) - (SelectionResultOf NonEmpty address u) - ) + :: UTxOSelectionNonEmpty (UTxO ctx) + -> m (Either + (SelectionBalanceError ctx) + (SelectionResultOf NonEmpty ctx)) makeChangeRepeatedly s = case mChangeGenerated of Right change | length change >= length outputsToCover -> @@ -1102,9 +1086,7 @@ performSelectionNonEmpty constraints params , assetsToBurn } - mkSelectionResult - :: [TokenBundle] - -> SelectionResultOf NonEmpty address u + mkSelectionResult :: [TokenBundle] -> SelectionResultOf NonEmpty ctx mkSelectionResult changeGenerated = SelectionResult { inputsSelected , extraCoinSource diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs index 8c3c910e90a..eb08f6fd4d6 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs @@ -13,14 +13,14 @@ module Cardano.Wallet.CoinSelection.Internal.Balance.Gen import Prelude +import Cardano.Wallet.CoinSelection + ( WalletSelectionContext ) import Cardano.Wallet.CoinSelection.Internal.Balance ( SelectionLimit , SelectionLimitOf (..) , SelectionSkeleton (..) , SelectionStrategy (..) ) -import Cardano.Wallet.Primitive.Types.Address - ( Address ) import Cardano.Wallet.Primitive.Types.Address.Gen ( genAddress, shrinkAddress ) import Cardano.Wallet.Primitive.Types.Coin @@ -72,7 +72,7 @@ shrinkSelectionLimit = \case -- Selection skeletons -------------------------------------------------------------------------------- -genSelectionSkeleton :: Gen (SelectionSkeleton Address) +genSelectionSkeleton :: Gen (SelectionSkeleton WalletSelectionContext) genSelectionSkeleton = SelectionSkeleton <$> genSkeletonInputCount <*> genSkeletonOutputs @@ -89,8 +89,8 @@ genSelectionSkeleton = SelectionSkeleton listOf (Set.fromList <$> listOf genAssetId) shrinkSelectionSkeleton - :: SelectionSkeleton Address - -> [SelectionSkeleton Address] + :: SelectionSkeleton WalletSelectionContext + -> [SelectionSkeleton WalletSelectionContext] shrinkSelectionSkeleton = genericRoundRobinShrink <@> shrinkSkeletonInputCount <:> shrinkSkeletonOutputs diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs new file mode 100644 index 00000000000..b480f4fd904 --- /dev/null +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Wallet.CoinSelection.Internal.Context + ( SelectionContext (..) + ) + where + +import Prelude + +import Fmt + ( Buildable ) + +class + ( Buildable (Address c) + , Buildable (UTxO c) + , Ord (Address c) + , Ord (UTxO c) + , Show (Address c) + , Show (UTxO c) + ) => + SelectionContext c + where + type Address c + type UTxO c diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index 7a0619bb953..082a0f72be0 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -10,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- HLINT ignore "Use camelCase" -} @@ -39,6 +40,8 @@ import Algebra.PartialOrd ( PartialOrd (..) ) import Cardano.Numeric.Util ( inAscendingPartialOrder ) +import Cardano.Wallet.CoinSelection + ( WalletSelectionContext ) import Cardano.Wallet.CoinSelection.Internal.Balance ( AssetCount (..) , BalanceInsufficientError (..) @@ -168,7 +171,7 @@ import Data.Functor import Data.Functor.Identity ( Identity (..) ) import Data.Generics.Internal.VL.Lens - ( over, set, view ) + ( view ) import Data.Generics.Labels () import Data.List.NonEmpty @@ -624,13 +627,13 @@ prop_AssetCount_TokenMap_placesEmptyMapsFirst maps = -- We define this type alias to shorten type signatures. -- type PerformSelectionResult = Either - (SelectionBalanceError Address InputId) - (SelectionResult Address InputId) + (SelectionBalanceError WalletSelectionContext) + (SelectionResult WalletSelectionContext) genSelectionParams :: Gen (InputId -> Bool) -> Gen (UTxOIndex InputId) - -> Gen (SelectionParams Address InputId) + -> Gen (SelectionParams WalletSelectionContext) genSelectionParams genPreselectedInputs genUTxOIndex' = do utxoAvailable <- genUTxOIndex' isInputPreselected <- oneof @@ -673,8 +676,8 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do genPreselectedInputsNone = pure $ const False shrinkSelectionParams - :: SelectionParams Address InputId - -> [SelectionParams Address InputId] + :: SelectionParams WalletSelectionContext + -> [SelectionParams WalletSelectionContext] shrinkSelectionParams = genericRoundRobinShrink <@> shrinkList shrinkOutput <:> shrinkUTxOSelection @@ -695,7 +698,7 @@ shrinkSelectionParams = genericRoundRobinShrink prop_performSelection_small :: MockSelectionConstraints - -> Blind (Small (SelectionParams Address InputId)) + -> Blind (Small (SelectionParams WalletSelectionContext)) -> Property prop_performSelection_small mockConstraints (Blind (Small params)) = checkCoverage $ @@ -807,7 +810,7 @@ prop_performSelection_small mockConstraints (Blind (Small params)) = . fmap snd $ view #outputsToCover params - constraints :: SelectionConstraints Address + constraints :: SelectionConstraints WalletSelectionContext constraints = unMockSelectionConstraints mockConstraints selectionLimit :: SelectionLimit @@ -875,7 +878,7 @@ prop_performSelection_small mockConstraints (Blind (Small params)) = prop_performSelection_large :: MockSelectionConstraints - -> Blind (Large (SelectionParams Address InputId)) + -> Blind (Large (SelectionParams WalletSelectionContext)) -> Property prop_performSelection_large mockConstraints (Blind (Large params)) = -- Generation of large UTxO sets takes longer, so limit the number of runs: @@ -896,18 +899,19 @@ prop_performSelection_huge = ioProperty $ prop_performSelection_huge_inner :: UTxOIndex InputId -> MockSelectionConstraints - -> Large (SelectionParams Address InputId) + -> Large (SelectionParams WalletSelectionContext) -> Property prop_performSelection_huge_inner utxoAvailable mockConstraints (Large params) = withMaxSuccess 5 $ prop_performSelection mockConstraints params' (const id) where - params' = params & set #utxoAvailable - (UTxOSelection.fromIndex utxoAvailable) + params' :: SelectionParams WalletSelectionContext + params' = params + { utxoAvailable = UTxOSelection.fromIndex utxoAvailable } prop_performSelection :: MockSelectionConstraints - -> SelectionParams Address InputId + -> SelectionParams WalletSelectionContext -> (PerformSelectionResult -> Property -> Property) -> Property prop_performSelection mockConstraints params coverage = @@ -926,7 +930,7 @@ prop_performSelection mockConstraints params coverage = monitor (coverage result) pure $ either onFailure onSuccess result where - constraints :: SelectionConstraints Address + constraints :: SelectionConstraints WalletSelectionContext constraints = unMockSelectionConstraints mockConstraints SelectionParams @@ -937,7 +941,7 @@ prop_performSelection mockConstraints params coverage = , assetsToBurn } = params - onSuccess :: SelectionResultOf [] Address InputId -> Property + onSuccess :: SelectionResultOf [] WalletSelectionContext -> Property onSuccess result = counterexample "onSuccess" $ report @@ -1002,7 +1006,7 @@ prop_performSelection mockConstraints params coverage = (view #inputsSelected result <&> fst) (view #utxoAvailable params) - onFailure :: SelectionBalanceError Address InputId -> Property + onFailure :: SelectionBalanceError WalletSelectionContext -> Property onFailure = \case BalanceInsufficient e -> onBalanceInsufficient e @@ -1041,7 +1045,7 @@ prop_performSelection mockConstraints params coverage = BalanceInsufficientError errorBalanceAvailable errorBalanceRequired = e onSelectionLimitReached - :: SelectionLimitReachedError Address InputId -> Property + :: SelectionLimitReachedError WalletSelectionContext -> Property onSelectionLimitReached e = counterexample "onSelectionLimitReached" $ report errorBalanceRequired @@ -1065,7 +1069,8 @@ prop_performSelection mockConstraints params coverage = F.foldMap (view #tokens . snd) errorInputsSelected onInsufficientMinCoinValues - :: NonEmpty (InsufficientMinCoinValueError Address) -> Property + :: NonEmpty (InsufficientMinCoinValueError WalletSelectionContext) + -> Property onInsufficientMinCoinValues es = counterexample "onInsufficientMinCoinValues" $ report es @@ -1111,13 +1116,14 @@ prop_performSelection mockConstraints params coverage = -- -- We expect that the selection should succeed. -- - let constraints' :: SelectionConstraints Address = constraints - { assessTokenBundleSize = unMockAssessTokenBundleSize - MockAssessTokenBundleSizeUnlimited - , computeMinimumAdaQuantity = computeMinimumAdaQuantityZero - , computeMinimumCost = computeMinimumCostZero - , computeSelectionLimit = const NoLimit - } + let constraints' :: SelectionConstraints WalletSelectionContext = + constraints + { assessTokenBundleSize = unMockAssessTokenBundleSize + MockAssessTokenBundleSizeUnlimited + , computeMinimumAdaQuantity = computeMinimumAdaQuantityZero + , computeMinimumCost = computeMinimumCostZero + , computeSelectionLimit = const NoLimit + } performSelection' = performSelection constraints' params in monadicIO $ run performSelection' >>= \case @@ -1155,7 +1161,7 @@ prop_performSelection mockConstraints params coverage = -- prop_performSelectionEmpty :: MockSelectionConstraints - -> Small (SelectionParams Address InputId) + -> Small (SelectionParams WalletSelectionContext) -> Property prop_performSelectionEmpty mockConstraints (Small params) = checkCoverage $ @@ -1209,20 +1215,28 @@ prop_performSelectionEmpty mockConstraints (Small params) = else -- If the initial list of outputs is non-empty, then no -- transformation should take place: - [ params === (paramsTransformed & over #outputsToCover F.toList) - , resultTransformed === (result & over #outputsCovered F.toList) + [ params === paramsTransformed' + , resultTransformed === result' ] - constraints :: SelectionConstraints Address + constraints :: SelectionConstraints WalletSelectionContext constraints = unMockSelectionConstraints mockConstraints - paramsTransformed :: SelectionParamsOf NonEmpty Address InputId + paramsTransformed :: SelectionParamsOf NonEmpty WalletSelectionContext paramsTransformed = view #paramsTransformed transformationReport - result :: SelectionResultOf NonEmpty Address InputId + paramsTransformed' :: SelectionParamsOf [] WalletSelectionContext + paramsTransformed' = paramsTransformed + { outputsToCover = F.toList (view #outputsToCover paramsTransformed) } + + result :: SelectionResultOf NonEmpty WalletSelectionContext result = expectRight $ view #result transformationReport - resultTransformed :: SelectionResultOf [] Address InputId + result' :: SelectionResultOf [] WalletSelectionContext + result' = result + { outputsCovered = F.toList (view #outputsCovered result) } + + resultTransformed :: SelectionResultOf [] WalletSelectionContext resultTransformed = expectRight $ view #resultTransformed transformationReport @@ -1267,17 +1281,19 @@ withTransformationReport p r = TransformationReport p r r -- - a single change output to cover the output deficit. -- mockPerformSelectionNonEmpty - :: PerformSelection Identity NonEmpty Address InputId + :: PerformSelection Identity NonEmpty WalletSelectionContext mockPerformSelectionNonEmpty constraints params = Identity $ Right result where - result :: SelectionResultOf NonEmpty Address InputId - result = resultWithoutDelta & set #inputsSelected - (makeInputsOfValue $ deficitIn <> TokenBundle.fromCoin minimumCost) + result :: SelectionResultOf NonEmpty WalletSelectionContext + result = resultWithoutDelta + { inputsSelected = + makeInputsOfValue $ deficitIn <> TokenBundle.fromCoin minimumCost + } where minimumCost :: Coin minimumCost = selectionMinimumCost constraints resultWithoutDelta - resultWithoutDelta :: SelectionResultOf NonEmpty Address InputId + resultWithoutDelta :: SelectionResultOf NonEmpty WalletSelectionContext resultWithoutDelta = SelectionResult { inputsSelected = makeInputsOfValue deficitIn , changeGenerated = makeChangeOfValue deficitOut @@ -1855,7 +1871,7 @@ mkBoundaryTestExpectation (BoundaryTestData params expectedResult) = do encodeBoundaryTestCriteria :: BoundaryTestCriteria - -> SelectionParams Address InputId + -> SelectionParams WalletSelectionContext encodeBoundaryTestCriteria c = SelectionParams { outputsToCover = zip @@ -1888,8 +1904,7 @@ encodeBoundaryTestCriteria c = SelectionParams dummyTxIns = [TxIn (Hash "") x | x <- [0 ..]] decodeBoundaryTestResult - :: SelectionResult Address InputId - -> BoundaryTestResult + :: SelectionResult WalletSelectionContext -> BoundaryTestResult decodeBoundaryTestResult r = BoundaryTestResult { boundaryTestInputs = L.sort $ NE.toList $ TokenBundle.toFlatList . snd <$> view #inputsSelected r @@ -2469,7 +2484,7 @@ shrinkMockSelectionConstraints = genericRoundRobinShrink unMockSelectionConstraints :: MockSelectionConstraints - -> SelectionConstraints Address + -> SelectionConstraints WalletSelectionContext unMockSelectionConstraints m = SelectionConstraints { assessTokenBundleSize = unMockAssessTokenBundleSize $ view #assessTokenBundleSize m @@ -2546,17 +2561,18 @@ shrinkMockComputeMinimumCost = \case [MockComputeMinimumCostZero] unMockComputeMinimumCost - :: MockComputeMinimumCost -> (SelectionSkeleton Address -> Coin) + :: MockComputeMinimumCost + -> (SelectionSkeleton WalletSelectionContext -> Coin) unMockComputeMinimumCost = \case MockComputeMinimumCostZero -> computeMinimumCostZero MockComputeMinimumCostLinear -> computeMinimumCostLinear -computeMinimumCostZero :: SelectionSkeleton Address -> Coin +computeMinimumCostZero :: SelectionSkeleton WalletSelectionContext -> Coin computeMinimumCostZero = const $ Coin 0 -computeMinimumCostLinear :: SelectionSkeleton Address -> Coin +computeMinimumCostLinear :: SelectionSkeleton WalletSelectionContext -> Coin computeMinimumCostLinear s = Coin $ fromIntegral @@ -4454,13 +4470,13 @@ newtype Small a = Small { getSmall:: a } deriving (Eq, Show) -instance Arbitrary (Large (SelectionParams Address InputId)) where +instance Arbitrary (Large (SelectionParams WalletSelectionContext)) where arbitrary = Large <$> genSelectionParams (genInputIdFunction (arbitrary @Bool)) (genUTxOIndexLarge) shrink = shrinkMapBy Large getLarge shrinkSelectionParams -instance Arbitrary (Small (SelectionParams Address InputId)) where +instance Arbitrary (Small (SelectionParams WalletSelectionContext)) where arbitrary = Small <$> genSelectionParams (genInputIdFunction (arbitrary @Bool)) (genUTxOIndex) diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index f739121d070..45ba4aba12e 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -16,9 +16,12 @@ module Cardano.Wallet.CoinSelection.InternalSpec import Prelude +import Cardano.Wallet.CoinSelection + ( WalletSelectionContext ) import Cardano.Wallet.CoinSelection.Internal ( ComputeMinimumCollateralParams (..) , Selection + , SelectionCollateralError (..) , SelectionCollateralRequirement (..) , SelectionConstraints (..) , SelectionError (..) @@ -59,8 +62,6 @@ import Cardano.Wallet.CoinSelection.Internal.BalanceSpec , unMockComputeMinimumCost , unMockComputeSelectionLimit ) -import Cardano.Wallet.CoinSelection.Internal.Collateral - ( SelectionCollateralError (..) ) import Cardano.Wallet.Primitive.Types.Address ( Address ) import Cardano.Wallet.Primitive.Types.Address.Gen @@ -196,7 +197,7 @@ spec = describe "Cardano.Wallet.CoinSelection.InternalSpec" $ do prop_performSelection :: Pretty MockSelectionConstraints - -> Pretty (SelectionParams Address InputId) + -> Pretty (SelectionParams WalletSelectionContext) -> Property prop_performSelection (Pretty mockConstraints) (Pretty params) = monadicIO $ @@ -206,9 +207,11 @@ prop_performSelection (Pretty mockConstraints) (Pretty params) = constraints = unMockSelectionConstraints mockConstraints prop_performSelection_inner - :: SelectionConstraints Address - -> SelectionParams Address InputId - -> Either (SelectionError Address InputId) (Selection Address InputId) + :: SelectionConstraints WalletSelectionContext + -> SelectionParams WalletSelectionContext + -> Either + (SelectionError WalletSelectionContext) + (Selection WalletSelectionContext) -> Property prop_performSelection_inner constraints params result = checkCoverage $ @@ -225,8 +228,10 @@ prop_performSelection_inner constraints params result = prop_performSelection_coverage :: Testable property - => SelectionParams Address InputId - -> Either (SelectionError Address InputId) (Selection Address InputId) + => SelectionParams WalletSelectionContext + -> Either + (SelectionError WalletSelectionContext) + (Selection WalletSelectionContext) -> property -> Property prop_performSelection_coverage params r innerProperty = @@ -321,8 +326,8 @@ prop_performSelection_coverage params r innerProperty = -- prop_toBalanceConstraintsParams_computeMinimumCost :: MockSelectionConstraints - -> SelectionParams Address InputId - -> SelectionSkeleton Address + -> SelectionParams WalletSelectionContext + -> SelectionSkeleton WalletSelectionContext -> Property prop_toBalanceConstraintsParams_computeMinimumCost mockConstraints params skeleton = @@ -353,16 +358,18 @@ prop_toBalanceConstraintsParams_computeMinimumCost else costOriginal === costAdjusted where - constraints :: SelectionConstraints Address + constraints :: SelectionConstraints WalletSelectionContext constraints = unMockSelectionConstraints mockConstraints maximumCollateralInputCount :: Int maximumCollateralInputCount = constraints ^. #maximumCollateralInputCount - computeMinimumCostOriginal :: SelectionSkeleton Address -> Coin + computeMinimumCostOriginal + :: SelectionSkeleton WalletSelectionContext -> Coin computeMinimumCostOriginal = constraints ^. #computeMinimumCost - computeMinimumCostAdjusted :: SelectionSkeleton Address -> Coin + computeMinimumCostAdjusted + :: SelectionSkeleton WalletSelectionContext -> Coin computeMinimumCostAdjusted = toBalanceConstraintsParams (constraints, params) & fst & view #computeMinimumCost @@ -378,7 +385,7 @@ prop_toBalanceConstraintsParams_computeMinimumCost -- prop_toBalanceConstraintsParams_computeSelectionLimit :: MockSelectionConstraints - -> SelectionParams Address InputId + -> SelectionParams WalletSelectionContext -> Property prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = checkCoverage $ @@ -404,7 +411,7 @@ prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = else selectionLimitOriginal === selectionLimitAdjusted where - constraints :: SelectionConstraints Address + constraints :: SelectionConstraints WalletSelectionContext constraints = unMockSelectionConstraints mockConstraints maximumCollateralInputCount :: Int @@ -566,7 +573,7 @@ shrinkMockSelectionConstraints = genericRoundRobinShrink <:> Nil unMockSelectionConstraints - :: MockSelectionConstraints -> SelectionConstraints Address + :: MockSelectionConstraints -> SelectionConstraints WalletSelectionContext unMockSelectionConstraints m = SelectionConstraints { assessTokenBundleSize = unMockAssessTokenBundleSize $ view #assessTokenBundleSize m @@ -618,7 +625,7 @@ shrinkMinimumCollateralPercentage = shrinkNatural -- Selection parameters -------------------------------------------------------------------------------- -genSelectionParams :: Gen (SelectionParams Address InputId) +genSelectionParams :: Gen (SelectionParams WalletSelectionContext) genSelectionParams = SelectionParams <$> genAssetsToBurn <*> genAssetsToMint @@ -634,8 +641,8 @@ genSelectionParams = SelectionParams <*> genSelectionStrategy shrinkSelectionParams - :: SelectionParams Address InputId - -> [SelectionParams Address InputId] + :: SelectionParams WalletSelectionContext + -> [SelectionParams WalletSelectionContext] shrinkSelectionParams = genericRoundRobinShrink <@> shrinkAssetsToBurn <:> shrinkAssetsToMint @@ -858,10 +865,10 @@ instance Arbitrary MockSelectionConstraints where arbitrary = genMockSelectionConstraints shrink = shrinkMockSelectionConstraints -instance Arbitrary (SelectionParams Address InputId) where +instance Arbitrary (SelectionParams WalletSelectionContext) where arbitrary = genSelectionParams shrink = shrinkSelectionParams -instance Arbitrary (SelectionSkeleton Address) where +instance Arbitrary (SelectionSkeleton WalletSelectionContext) where arbitrary = genSelectionSkeleton shrink = shrinkSelectionSkeleton From 053279ccbe32a5e118bc856a9531bdb3e6b598e9 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 10 Mar 2022 08:34:15 +0000 Subject: [PATCH 05/13] Introduce class `Dummy` to facilitate creation of dummy values. Within the coin selection algorithm we currently rely on dummy address values in a couple of places. Since internal coin selection modules no longer have access to the concrete type of address (which is now an abstract type parameter), we can no longer construct these dummy values ourselves. To solve this problem we provide the `Dummy` class, along with an instance for `Address`, so that internal coin selection modules can create these dummy values safely. --- lib/core/src/Cardano/Wallet/CoinSelection.hs | 5 ++++- .../src/Cardano/Wallet/CoinSelection/Internal.hs | 14 +++----------- .../Wallet/CoinSelection/Internal/Balance.hs | 11 +++-------- .../Wallet/CoinSelection/Internal/Context.hs | 7 ++++++- 4 files changed, 16 insertions(+), 21 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 934c2538f1c..11dbca9b997 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -85,7 +85,7 @@ import Cardano.Wallet.CoinSelection.Internal.Balance import Cardano.Wallet.Primitive.Collateral ( asCollateral ) import Cardano.Wallet.Primitive.Types.Address - ( Address ) + ( Address (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -138,6 +138,9 @@ instance SC.SelectionContext WalletSelectionContext where type Address WalletSelectionContext = Address type UTxO WalletSelectionContext = InputId +instance SC.Dummy Address where + dummy = Address "" + -------------------------------------------------------------------------------- -- Selection constraints -------------------------------------------------------------------------------- diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index 8bfa5e33c35..714dce66f3f 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Copyright: © 2021 IOHK @@ -76,7 +77,7 @@ import Cardano.Wallet.CoinSelection.Internal.Balance , SelectionStrategy (..) ) import Cardano.Wallet.CoinSelection.Internal.Context - ( SelectionContext (..) ) + ( Dummy (..), SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -379,16 +380,7 @@ selectionAllOutputs -> [(Address ctx, TokenBundle)] selectionAllOutputs selection = (<>) (selection ^. #outputs) - (selection ^. #change <&> (dummyChangeAddress, )) - where - dummyChangeAddress :: Address ctx - dummyChangeAddress = - -- TODO: ADP-1448 - -- - -- Replace this call to 'error' with a call to a function that - -- generates a dummy change address. - -- - error "change address" + (selection ^. #change <&> (dummy @(Address ctx), )) -- | Creates constraints and parameters for 'Balance.performSelection'. -- diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index e49844a8b54..8ab4eb51961 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -129,7 +129,7 @@ import Algebra.PartialOrd import Cardano.Numeric.Util ( padCoalesce ) import Cardano.Wallet.CoinSelection.Internal.Context - ( SelectionContext (..) ) + ( Dummy (..), SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -814,7 +814,7 @@ performSelection = performSelectionEmpty performSelectionNonEmpty -- selectionHasValidSurplus constraints (transformResult result) -- performSelectionEmpty - :: forall m ctx. Functor m + :: forall m ctx. (Functor m, SelectionContext ctx) => PerformSelection m NonEmpty ctx -> PerformSelection m [] ctx performSelectionEmpty performSelectionFn constraints params = @@ -845,12 +845,7 @@ performSelectionEmpty performSelectionFn constraints params = transform x y = maybe x y $ NE.nonEmpty $ view #outputsToCover params dummyOutput :: (Address ctx, TokenBundle) - dummyOutput = - -- TODO: ADP-1448 - -- - -- Replace this call to 'error' with a call to a function that - -- generates a dummy address. - (error "dummy address", TokenBundle.fromCoin minCoin) + dummyOutput = (dummy, TokenBundle.fromCoin minCoin) -- The 'performSelectionNonEmpty' function imposes a precondition that all -- outputs must have at least the minimum ada quantity. Therefore, the diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs index b480f4fd904..8d7b4c99c62 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs @@ -2,7 +2,8 @@ {-# LANGUAGE TypeFamilies #-} module Cardano.Wallet.CoinSelection.Internal.Context - ( SelectionContext (..) + ( Dummy (..) + , SelectionContext (..) ) where @@ -11,9 +12,13 @@ import Prelude import Fmt ( Buildable ) +class Dummy d where + dummy :: d + class ( Buildable (Address c) , Buildable (UTxO c) + , Dummy (Address c) , Ord (Address c) , Ord (UTxO c) , Show (Address c) From 0faf4ec1e893ec4881fcd3b09d53615405885fe6 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 10 Mar 2022 08:55:29 +0000 Subject: [PATCH 06/13] Add documentation comments. --- lib/core/src/Cardano/Wallet/CoinSelection.hs | 6 ++-- .../Wallet/CoinSelection/Internal/Context.hs | 30 +++++++++++++++---- 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 11dbca9b997..e9f4f755393 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -25,7 +25,7 @@ -- module Cardano.Wallet.CoinSelection ( - -- * Context + -- * Selection contexts WalletSelectionContext -- * Performing selections @@ -129,9 +129,11 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set -------------------------------------------------------------------------------- --- Selection context +-- Selection contexts -------------------------------------------------------------------------------- +-- | A selection context for the wallet. +-- data WalletSelectionContext instance SC.SelectionContext WalletSelectionContext where diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs index 8d7b4c99c62..13ec19d551a 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs @@ -1,9 +1,20 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +-- | +-- Copyright: © 2022 IOHK +-- License: Apache-2.0 +-- +-- This module provides the 'SelectionContext' class, which provides a shared +-- context for types used by coin selection. +-- module Cardano.Wallet.CoinSelection.Internal.Context - ( Dummy (..) - , SelectionContext (..) + ( + -- * Selection contexts + SelectionContext (..) + + -- * Dummy values + , Dummy (..) ) where @@ -12,9 +23,8 @@ import Prelude import Fmt ( Buildable ) -class Dummy d where - dummy :: d - +-- | Provides a shared context for types used by coin selection. +-- class ( Buildable (Address c) , Buildable (UTxO c) @@ -26,5 +36,15 @@ class ) => SelectionContext c where + + -- | A target address to which payments can be made. type Address c + + -- | A unique identifier for an individual UTxO. type UTxO c + +-- | Provides a dummy value for a given type. + +class Dummy d where + -- | Returns a dummy value. + dummy :: d From 1b7bf0c1b2185f91bbdbe432e115d7a8e4dcafb6 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 11 Mar 2022 02:40:11 +0000 Subject: [PATCH 07/13] Introduce type `WalletUTxO` to replace `InputId` type synonym. This allows us to remove orphan and overlapping instances for `InputId`. --- lib/core/src/Cardano/Wallet.hs | 34 ++--- lib/core/src/Cardano/Wallet/CoinSelection.hs | 82 ++++++++---- .../Wallet/Primitive/Types/UTxOIndex/Gen.hs | 44 +++---- .../Primitive/Types/UTxOSelection/Gen.hs | 43 ++----- .../CoinSelection/Internal/BalanceSpec.hs | 100 +++++++-------- .../Wallet/CoinSelection/InternalSpec.hs | 32 +++-- .../Wallet/Primitive/Types/UTxOIndexSpec.hs | 117 ++++++++++-------- .../Primitive/Types/UTxOSelectionSpec.hs | 101 ++++++++------- .../Cardano/Wallet/Shelley/TransactionSpec.hs | 30 ++--- 9 files changed, 288 insertions(+), 295 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 4580725c7ed..51641461bc6 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -234,6 +234,7 @@ import Cardano.Wallet.CoinSelection , SelectionStrategy (..) , UnableToConstructChangeError (..) , WalletSelectionContext + , WalletUTxO (..) , emptySkeleton , makeSelectionReportDetailed , makeSelectionReportSummarized @@ -562,6 +563,7 @@ import UnliftIO.MVar import qualified Cardano.Api.Shelley as Cardano import qualified Cardano.Crypto.Wallet as CC +import qualified Cardano.Wallet.CoinSelection as CS import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq import qualified Cardano.Wallet.Primitive.AddressDiscovery.Shared as Shared @@ -1470,7 +1472,7 @@ balanceTransaction -> ArgGenChange s -> (W.ProtocolParameters, Cardano.ProtocolParameters) -> TimeInterpreter (Either PastHorizonException) - -> (UTxOIndex InputId, Wallet s, Set Tx) + -> (UTxOIndex WalletUTxO, Wallet s, Set Tx) -> PartialTx -> ExceptT ErrBalanceTx m SealedTx balanceTransaction @@ -1491,7 +1493,8 @@ balanceTransaction (delta, extraInputs, extraCollateral, extraOutputs) <- do let externalSelectedUtxo = UTxOIndex.fromSequence $ - map (\(i, TxOut a b,_datumHash) -> ((i, a), b)) externalInputs + map (\(i, TxOut a b,_datumHash) -> (WalletUTxO i a, b)) + externalInputs let utxoAvailableForInputs = UTxOSelection.fromIndexPair (internalUtxoAvailable, externalSelectedUtxo) @@ -1609,7 +1612,7 @@ balanceTransaction Just x -> pure x Nothing -> throwE $ ErrBalanceTxUpdateError ErrByronTxNotSupported where - utxo = inputMapToUTxO $ UTxOIndex.toMap internalUtxoAvailable + utxo = CS.toExternalUTxOMap $ UTxOIndex.toMap internalUtxoAvailable assembleTransaction :: TxUpdate @@ -1884,10 +1887,11 @@ readWalletUTxOIndex :: forall ctx s k. HasDBLayer IO s k ctx => ctx -> WalletId - -> ExceptT ErrNoSuchWallet IO (UTxOIndex InputId, Wallet s, Set Tx) + -> ExceptT ErrNoSuchWallet IO (UTxOIndex WalletUTxO, Wallet s, Set Tx) readWalletUTxOIndex ctx wid = do (cp, _, pending) <- readWallet @ctx @s @k ctx wid - let utxo = UTxOIndex.fromMap $ utxoToInputMap $ availableUTxO @s pending cp + let utxo = UTxOIndex.fromMap $ + CS.toInternalUTxOMap $ availableUTxO @s pending cp return (utxo, cp, pending) -- | Calculate the minimum coin values required for a bunch of specified @@ -1910,20 +1914,6 @@ calcMinimumCoinValues ctx outs = do nl = ctx ^. networkLayer tl = ctx ^. transactionLayer @k --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - -utxoToInputMap :: UTxO -> Map InputId TokenBundle -utxoToInputMap = - Map.fromList . fmap (\(i, TxOut a b) -> ((i, a), b)) . Map.toList . unUTxO - -inputMapToUTxO :: Map InputId TokenBundle -> UTxO -inputMapToUTxO = - UTxO . Map.fromList . fmap (\((i, a), b) -> (i, TxOut a b)) . Map.toList - -- | Parameters for the 'selectAssets' function. -- data SelectAssetsParams s result = SelectAssetsParams @@ -1931,8 +1921,8 @@ data SelectAssetsParams s result = SelectAssetsParams , pendingTxs :: Set Tx , randomSeed :: Maybe StdGenSeed , txContext :: TransactionCtx - , utxoAvailableForCollateral :: Map InputId TokenBundle - , utxoAvailableForInputs :: UTxOSelection InputId + , utxoAvailableForCollateral :: Map WalletUTxO TokenBundle + , utxoAvailableForInputs :: UTxOSelection WalletUTxO , wallet :: Wallet s , selectionStrategy :: SelectionStrategy -- ^ Specifies which selection strategy to use. See 'SelectionStrategy'. @@ -1972,7 +1962,7 @@ selectAssets selectAssets ctx pp params transform = do guardPendingWithdrawal lift $ traceWith tr $ MsgSelectionStart - (inputMapToUTxO + (CS.toExternalUTxOMap $ UTxOSelection.availableMap $ params ^. #utxoAvailableForInputs) (params ^. #outputs) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index e9f4f755393..18bafa69282 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -27,6 +27,13 @@ module Cardano.Wallet.CoinSelection ( -- * Selection contexts WalletSelectionContext + , WalletUTxO (..) + + -- * Mapping between external (wallet) types and internal types + , toExternalUTxO + , toExternalUTxOMap + , toInternalUTxO + , toInternalUTxOMap -- * Performing selections , performSelection @@ -89,11 +96,13 @@ import Cardano.Wallet.Primitive.Types.Address import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle - ( TokenBundle ) + ( Flat (..), TokenBundle ) import Cardano.Wallet.Primitive.Types.TokenMap ( AssetId, TokenMap ) import Cardano.Wallet.Primitive.Types.Tx ( TokenBundleSizeAssessment, TxIn, TxOut (..) ) +import Cardano.Wallet.Primitive.Types.UTxO + ( UTxO (..) ) import Cardano.Wallet.Primitive.Types.UTxOSelection ( UTxOSelection ) import Control.Arrow @@ -138,11 +147,49 @@ data WalletSelectionContext instance SC.SelectionContext WalletSelectionContext where type Address WalletSelectionContext = Address - type UTxO WalletSelectionContext = InputId + type UTxO WalletSelectionContext = WalletUTxO instance SC.Dummy Address where dummy = Address "" +-------------------------------------------------------------------------------- +-- Mapping between external (wallet) and internal UTxO identifiers +-------------------------------------------------------------------------------- + +-- | A type of unique UTxO identifier for the wallet. +-- +data WalletUTxO = WalletUTxO + { txIn + :: TxIn + , address + :: Address + } + deriving (Eq, Generic, Ord, Show) + +instance Buildable WalletUTxO where + build (WalletUTxO i a) = build i <> ":" <> build a + +instance Buildable (WalletUTxO, TokenBundle) where + build (u, b) = build u <> ":" <> build (Flat b) + +toExternalUTxO :: (WalletUTxO, TokenBundle) -> (TxIn, TxOut) +toExternalUTxO = toExternalUTxO' id + +toExternalUTxOMap :: Map WalletUTxO TokenBundle -> UTxO +toExternalUTxOMap = UTxO . Map.fromList . fmap toExternalUTxO . Map.toList + +toInternalUTxO :: (TxIn, TxOut) -> (WalletUTxO, TokenBundle) +toInternalUTxO = toInternalUTxO' id + +toInternalUTxOMap :: UTxO -> Map WalletUTxO TokenBundle +toInternalUTxOMap = Map.fromList . fmap toInternalUTxO . Map.toList . unUTxO + +toExternalUTxO' :: (b -> TokenBundle) -> (WalletUTxO, b) -> (TxIn, TxOut) +toExternalUTxO' f (WalletUTxO i a, b) = (i, TxOut a (f b)) + +toInternalUTxO' :: (TokenBundle -> b) -> (TxIn, TxOut) -> (WalletUTxO, b) +toInternalUTxO' f (i, TxOut a b) = (WalletUTxO i a, f b) + -------------------------------------------------------------------------------- -- Selection constraints -------------------------------------------------------------------------------- @@ -206,15 +253,6 @@ toInternalSelectionConstraints SelectionConstraints {..} = -- Selection parameters -------------------------------------------------------------------------------- --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - -instance Buildable InputId where - build (i, a) = build i <> ":" <> build a - -- | Specifies all parameters that are specific to a given selection. -- data SelectionParams = SelectionParams @@ -246,14 +284,14 @@ data SelectionParams = SelectionParams :: !SelectionCollateralRequirement -- ^ Specifies the collateral requirement for this selection. , utxoAvailableForCollateral - :: !(Map InputId TokenBundle) + :: !(Map WalletUTxO TokenBundle) -- ^ Specifies a set of UTxOs that are available for selection as -- collateral inputs. -- -- This set is allowed to intersect with 'utxoAvailableForInputs', -- since the ledger does not require that these sets are disjoint. , utxoAvailableForInputs - :: !(UTxOSelection InputId) + :: !(UTxOSelection WalletUTxO) -- ^ Specifies a set of UTxOs that are available for selection as -- ordinary inputs and optionally, a subset that has already been -- selected. @@ -277,8 +315,8 @@ toInternalSelectionParams SelectionParams {..} = , .. } where - identifyCollateral :: InputId -> TokenBundle -> Maybe Coin - identifyCollateral (_, a) b = asCollateral (TxOut a b) + identifyCollateral :: WalletUTxO -> TokenBundle -> Maybe Coin + identifyCollateral (WalletUTxO _ a) b = asCollateral (TxOut a b) -------------------------------------------------------------------------------- -- Selection skeletons @@ -368,11 +406,9 @@ toExternalSelection toExternalSelection _ps Internal.Selection {..} = Selection { collateral = - (\((i, a), c) -> (i, TxOut a (TokenBundle.fromCoin c))) - <$> collateral + toExternalUTxO' TokenBundle.fromCoin <$> collateral , inputs = - (\((i, a), b) -> (i, TxOut a b)) - <$> inputs + toExternalUTxO <$> inputs , outputs = uncurry TxOut <$> outputs , .. @@ -386,10 +422,10 @@ toInternalSelection getChangeBundle Selection {..} = Internal.Selection { change = getChangeBundle <$> change - , collateral = (\(i, TxOut a b) -> ((i, a), TokenBundle.getCoin b)) - <$> collateral - , inputs = (\(i, TxOut a b) -> ((i, a), b)) - <$> inputs + , collateral = + toInternalUTxO' TokenBundle.getCoin <$> collateral + , inputs = + toInternalUTxO <$> inputs , outputs = (view #address &&& view #tokens) <$> outputs , .. diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOIndex/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOIndex/Gen.hs index fe8fa98afca..ea419039c9c 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOIndex/Gen.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOIndex/Gen.hs @@ -7,16 +7,14 @@ module Cardano.Wallet.Primitive.Types.UTxOIndex.Gen import Prelude -import Cardano.Wallet.Primitive.Types.Address - ( Address ) +import Cardano.Wallet.CoinSelection + ( WalletUTxO (..) ) import Cardano.Wallet.Primitive.Types.Address.Gen ( genAddress, shrinkAddress ) import Cardano.Wallet.Primitive.Types.TokenBundle ( TokenBundle ) import Cardano.Wallet.Primitive.Types.TokenBundle.Gen ( genTokenBundleSmallRangePositive, shrinkTokenBundleSmallRangePositive ) -import Cardano.Wallet.Primitive.Types.Tx - ( TxIn ) import Cardano.Wallet.Primitive.Types.Tx.Gen ( genTxIn, genTxInLargeRange, shrinkTxIn ) import Cardano.Wallet.Primitive.Types.UTxOIndex @@ -36,33 +34,27 @@ import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex -- Indices generated according to the size parameter -------------------------------------------------------------------------------- --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - -genUTxOIndex :: Gen (UTxOIndex InputId) +genUTxOIndex :: Gen (UTxOIndex WalletUTxO) genUTxOIndex = UTxOIndex.fromSequence <$> listOf genEntry where - genEntry :: Gen (InputId, TokenBundle) - genEntry = (,) <$> genInputId <*> genTokenBundleSmallRangePositive + genEntry :: Gen (WalletUTxO, TokenBundle) + genEntry = (,) <$> genWalletUTxO <*> genTokenBundleSmallRangePositive - genInputId :: Gen InputId - genInputId = genSized2 genTxIn genAddress + genWalletUTxO :: Gen WalletUTxO + genWalletUTxO = uncurry WalletUTxO <$> genSized2 genTxIn genAddress -shrinkUTxOIndex :: UTxOIndex InputId -> [UTxOIndex InputId] +shrinkUTxOIndex :: UTxOIndex WalletUTxO -> [UTxOIndex WalletUTxO] shrinkUTxOIndex = shrinkMapBy UTxOIndex.fromSequence UTxOIndex.toList (shrinkList shrinkEntry) where - shrinkEntry :: (InputId, TokenBundle) -> [(InputId, TokenBundle)] + shrinkEntry :: (WalletUTxO, TokenBundle) -> [(WalletUTxO, TokenBundle)] shrinkEntry = genericRoundRobinShrink - <@> shrinkInputId + <@> shrinkWalletUTxO <:> shrinkTokenBundleSmallRangePositive <:> Nil - shrinkInputId :: InputId -> [InputId] - shrinkInputId = genericRoundRobinShrink + shrinkWalletUTxO :: WalletUTxO -> [WalletUTxO] + shrinkWalletUTxO = genericRoundRobinShrink <@> shrinkTxIn <:> shrinkAddress <:> Nil @@ -71,14 +63,14 @@ shrinkUTxOIndex = -- Large indices -------------------------------------------------------------------------------- -genUTxOIndexLarge :: Gen (UTxOIndex InputId) +genUTxOIndexLarge :: Gen (UTxOIndex WalletUTxO) genUTxOIndexLarge = genUTxOIndexLargeN =<< choose (1024, 4096) -genUTxOIndexLargeN :: Int -> Gen (UTxOIndex InputId) +genUTxOIndexLargeN :: Int -> Gen (UTxOIndex WalletUTxO) genUTxOIndexLargeN n = UTxOIndex.fromSequence <$> replicateM n genEntry where - genEntry :: Gen (InputId, TokenBundle) - genEntry = (,) <$> genInputId <*> genTokenBundleSmallRangePositive + genEntry :: Gen (WalletUTxO, TokenBundle) + genEntry = (,) <$> genWalletUTxO <*> genTokenBundleSmallRangePositive - genInputId :: Gen InputId - genInputId = (,) <$> genTxInLargeRange <*> genAddress + genWalletUTxO :: Gen WalletUTxO + genWalletUTxO = WalletUTxO <$> genTxInLargeRange <*> genAddress diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs index 4754dde2570..6bc302a0ba5 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs @@ -10,10 +10,8 @@ module Cardano.Wallet.Primitive.Types.UTxOSelection.Gen import Prelude -import Cardano.Wallet.Primitive.Types.Address - ( Address ) -import Cardano.Wallet.Primitive.Types.Tx - ( TxIn ) +import Cardano.Wallet.CoinSelection + ( WalletUTxO ) import Cardano.Wallet.Primitive.Types.UTxOIndex.Gen ( genUTxOIndex, shrinkUTxOIndex ) import Cardano.Wallet.Primitive.Types.UTxOSelection @@ -31,35 +29,21 @@ import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection -- Selections that may be empty -------------------------------------------------------------------------------- --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) +coarbitraryWalletUTxO :: WalletUTxO -> Gen a -> Gen a +coarbitraryWalletUTxO = coarbitrary . show --- TODO: ADP-1448: --- --- Remove this function once 'InputId' has been replaced with a type parameter. --- -coarbitraryInputId :: InputId -> Gen a -> Gen a -coarbitraryInputId = coarbitrary . show +genWalletUTxOFunction :: Gen a -> Gen (WalletUTxO -> a) +genWalletUTxOFunction = genFunction coarbitraryWalletUTxO --- TODO: ADP-1448: --- --- Remove this function once 'InputId' has been replaced with a type parameter. --- -genInputIdFunction :: Gen a -> Gen (InputId -> a) -genInputIdFunction = genFunction coarbitraryInputId - -genUTxOSelection :: Gen (UTxOSelection InputId) +genUTxOSelection :: Gen (UTxOSelection WalletUTxO) genUTxOSelection = UTxOSelection.fromIndexFiltered <$> genFilter <*> genUTxOIndex where - genFilter :: Gen (InputId -> Bool) - genFilter = genInputIdFunction (arbitrary @Bool) + genFilter :: Gen (WalletUTxO -> Bool) + genFilter = genWalletUTxOFunction (arbitrary @Bool) -shrinkUTxOSelection :: UTxOSelection InputId -> [UTxOSelection InputId] +shrinkUTxOSelection :: UTxOSelection WalletUTxO -> [UTxOSelection WalletUTxO] shrinkUTxOSelection = shrinkMapBy UTxOSelection.fromIndexPair UTxOSelection.toIndexPair $ liftShrink2 @@ -70,15 +54,14 @@ shrinkUTxOSelection = -- Selections that are non-empty -------------------------------------------------------------------------------- -genUTxOSelectionNonEmpty :: Gen (UTxOSelectionNonEmpty InputId) +genUTxOSelectionNonEmpty :: Gen (UTxOSelectionNonEmpty WalletUTxO) genUTxOSelectionNonEmpty = genUTxOSelection `suchThatMap` UTxOSelection.toNonEmpty shrinkUTxOSelectionNonEmpty - :: UTxOSelectionNonEmpty InputId - -> [UTxOSelectionNonEmpty InputId] + :: UTxOSelectionNonEmpty WalletUTxO + -> [UTxOSelectionNonEmpty WalletUTxO] shrinkUTxOSelectionNonEmpty = mapMaybe UTxOSelection.toNonEmpty . shrinkUTxOSelection . UTxOSelection.fromNonEmpty - diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index 082a0f72be0..e4308319b95 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -41,7 +41,7 @@ import Algebra.PartialOrd import Cardano.Numeric.Util ( inAscendingPartialOrder ) import Cardano.Wallet.CoinSelection - ( WalletSelectionContext ) + ( WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal.Balance ( AssetCount (..) , BalanceInsufficientError (..) @@ -187,7 +187,7 @@ import Data.Tuple import Data.Word ( Word64, Word8 ) import Fmt - ( Buildable (..), blockListF, pretty ) + ( blockListF, pretty ) import Generics.SOP ( NP (..) ) import GHC.Generics @@ -260,33 +260,6 @@ import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - --- TODO: ADP-1448: --- --- Remove this instance once 'InputId' has been replaced with a type parameter. --- -instance Buildable (InputId, TokenBundle) where - build ((i, a), b) = build i <> ":" <> build a <> ":" <> build (Flat b) - --- TODO: ADP-1448: --- --- Remove this function once 'InputId' has been replaced with a type parameter. --- -coarbitraryInputId :: InputId -> Gen a -> Gen a -coarbitraryInputId = coarbitrary . show - --- TODO: ADP-1448: --- --- Remove this function once 'InputId' has been replaced with a type parameter. --- -genInputIdFunction :: Gen a -> Gen (InputId -> a) -genInputIdFunction = genFunction coarbitraryInputId - spec :: Spec spec = describe "Cardano.Wallet.CoinSelection.Internal.BalanceSpec" $ @@ -538,7 +511,7 @@ spec = describe "Cardano.Wallet.CoinSelection.Internal.BalanceSpec" $ -- Coverage -------------------------------------------------------------------------------- -prop_Small_UTxOIndex_coverage :: Small (UTxOIndex InputId) -> Property +prop_Small_UTxOIndex_coverage :: Small (UTxOIndex WalletUTxO) -> Property prop_Small_UTxOIndex_coverage (Small index) = checkCoverage $ property -- Asset counts: @@ -560,7 +533,7 @@ prop_Small_UTxOIndex_coverage (Small index) = assetCount = Set.size $ UTxOIndex.assets index entryCount = UTxOIndex.size index -prop_Large_UTxOIndex_coverage :: Large (UTxOIndex InputId) -> Property +prop_Large_UTxOIndex_coverage :: Large (UTxOIndex WalletUTxO) -> Property prop_Large_UTxOIndex_coverage (Large index) = -- Generation of large UTxO sets takes longer, so limit the number of runs: withMaxSuccess 100 $ checkCoverage $ property @@ -631,8 +604,8 @@ type PerformSelectionResult = Either (SelectionResult WalletSelectionContext) genSelectionParams - :: Gen (InputId -> Bool) - -> Gen (UTxOIndex InputId) + :: Gen (WalletUTxO -> Bool) + -> Gen (UTxOIndex WalletUTxO) -> Gen (SelectionParams WalletSelectionContext) genSelectionParams genPreselectedInputs genUTxOIndex' = do utxoAvailable <- genUTxOIndex' @@ -661,7 +634,7 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do , selectionStrategy } where - genAssetsToMintAndBurn :: UTxOIndex InputId -> Gen (TokenMap, TokenMap) + genAssetsToMintAndBurn :: UTxOIndex WalletUTxO -> Gen (TokenMap, TokenMap) genAssetsToMintAndBurn utxoAvailable = do assetsToMint <- genTokenMapSmallRange let assetsToBurn = adjustAllTokenMapQuantities @@ -672,7 +645,7 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do utxoAvailableAssets :: TokenMap utxoAvailableAssets = view (#balance . #tokens) utxoAvailable - genPreselectedInputsNone :: Gen (InputId -> Bool) + genPreselectedInputsNone :: Gen (WalletUTxO -> Bool) genPreselectedInputsNone = pure $ const False shrinkSelectionParams @@ -897,7 +870,7 @@ prop_performSelection_huge = ioProperty $ <$> generate (genUTxOIndexLargeN 50000) prop_performSelection_huge_inner - :: UTxOIndex InputId + :: UTxOIndex WalletUTxO -> MockSelectionConstraints -> Large (SelectionParams WalletSelectionContext) -> Property @@ -1304,8 +1277,8 @@ mockPerformSelectionNonEmpty constraints params = Identity $ Right result , outputsCovered = view #outputsToCover params } - makeInputsOfValue :: TokenBundle -> NonEmpty (InputId, TokenBundle) - makeInputsOfValue v = ((TxIn (Hash "") 0, Address ""), v) :| [] + makeInputsOfValue :: TokenBundle -> NonEmpty (WalletUTxO, TokenBundle) + makeInputsOfValue v = (WalletUTxO (TxIn (Hash "") 0) (Address ""), v) :| [] makeChangeOfValue :: TokenBundle -> [TokenBundle] makeChangeOfValue v = [v] @@ -1319,7 +1292,7 @@ mockPerformSelectionNonEmpty constraints params = Identity $ Right result prop_runSelection_UTxO_empty :: TokenBundle -> SelectionStrategy -> Property prop_runSelection_UTxO_empty balanceRequested strategy = monadicIO $ do - result <- run $ runSelection @_ @InputId + result <- run $ runSelection @_ @WalletUTxO RunSelectionParams { selectionLimit = NoLimit , utxoAvailable @@ -1341,7 +1314,7 @@ prop_runSelection_UTxO_empty balanceRequested strategy = monadicIO $ do utxoAvailable = UTxOSelection.fromIndex UTxOIndex.empty prop_runSelection_UTxO_notEnough - :: UTxOSelection InputId -> SelectionStrategy -> Property + :: UTxOSelection WalletUTxO -> SelectionStrategy -> Property prop_runSelection_UTxO_notEnough utxoAvailable strategy = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1366,7 +1339,7 @@ prop_runSelection_UTxO_notEnough utxoAvailable strategy = monadicIO $ do balanceRequested = adjustAllTokenBundleQuantities (* 2) balanceAvailable prop_runSelection_UTxO_exactlyEnough - :: UTxOSelection InputId -> SelectionStrategy -> Property + :: UTxOSelection WalletUTxO -> SelectionStrategy -> Property prop_runSelection_UTxO_exactlyEnough utxoAvailable strategy = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1395,7 +1368,7 @@ prop_runSelection_UTxO_exactlyEnough utxoAvailable strategy = monadicIO $ do balanceRequested = UTxOSelection.availableBalance utxoAvailable prop_runSelection_UTxO_moreThanEnough - :: UTxOSelection InputId -> SelectionStrategy -> Property + :: UTxOSelection WalletUTxO -> SelectionStrategy -> Property prop_runSelection_UTxO_moreThanEnough utxoAvailable strategy = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1438,7 +1411,7 @@ prop_runSelection_UTxO_moreThanEnough utxoAvailable strategy = monadicIO $ do cutAssetSetSizeInHalf balanceAvailable prop_runSelection_UTxO_muchMoreThanEnough - :: Blind (Large (UTxOIndex InputId)) + :: Blind (Large (UTxOIndex WalletUTxO)) -> SelectionStrategy -> Property prop_runSelection_UTxO_muchMoreThanEnough (Blind (Large index)) strategy = @@ -1491,7 +1464,7 @@ prop_runSelection_UTxO_muchMoreThanEnough (Blind (Large index)) strategy = -- Running a selection (non-empty) -------------------------------------------------------------------------------- -prop_runSelectionNonEmpty :: UTxOSelection InputId -> Property +prop_runSelectionNonEmpty :: UTxOSelection WalletUTxO -> Property prop_runSelectionNonEmpty result = case (haveLeftover, haveSelected) of (False, False) -> @@ -1533,22 +1506,23 @@ prop_runSelectionNonEmpty result = (UTxOSelection.leftoverIndex resultNonEmpty) === UTxOSelection.leftoverIndex result - maybeResultNonEmpty :: Maybe (UTxOSelectionNonEmpty InputId) + maybeResultNonEmpty :: Maybe (UTxOSelectionNonEmpty WalletUTxO) maybeResultNonEmpty = runIdentity $ runSelectionNonEmptyWith (Identity <$> mockSelectSingleEntry) (result) mockSelectSingleEntry - :: UTxOSelection InputId -> Maybe (UTxOSelectionNonEmpty InputId) + :: UTxOSelection WalletUTxO -> Maybe (UTxOSelectionNonEmpty WalletUTxO) mockSelectSingleEntry state = selectEntry =<< firstLeftoverEntry state where - firstLeftoverEntry :: UTxOSelection InputId -> Maybe (InputId, TokenBundle) + firstLeftoverEntry + :: UTxOSelection WalletUTxO -> Maybe (WalletUTxO, TokenBundle) firstLeftoverEntry = listToMaybe . UTxOIndex.toList . UTxOSelection.leftoverIndex selectEntry - :: (InputId, TokenBundle) -> Maybe (UTxOSelectionNonEmpty InputId) + :: (WalletUTxO, TokenBundle) -> Maybe (UTxOSelectionNonEmpty WalletUTxO) selectEntry (i, _b) = UTxOSelection.select i state -------------------------------------------------------------------------------- @@ -1751,7 +1725,7 @@ prop_runSelectionStep_exceedsOptimalTargetAndGetsFurtherAway -------------------------------------------------------------------------------- prop_assetSelectionLens_givesPriorityToSingletonAssets - :: Blind (Small (UTxOIndex InputId)) + :: Blind (Small (UTxOIndex WalletUTxO)) -> Property prop_assetSelectionLens_givesPriorityToSingletonAssets (Blind (Small u)) = assetCount >= 2 ==> monadicIO $ do @@ -1788,7 +1762,7 @@ prop_assetSelectionLens_givesPriorityToSingletonAssets (Blind (Small u)) = minimumAssetQuantity = TokenQuantity 1 prop_coinSelectionLens_givesPriorityToCoins - :: Blind (Small (UTxOIndex InputId)) + :: Blind (Small (UTxOIndex WalletUTxO)) -> Property prop_coinSelectionLens_givesPriorityToCoins (Blind (Small u)) = entryCount > 0 ==> monadicIO $ do @@ -1880,7 +1854,7 @@ encodeBoundaryTestCriteria c = SelectionParams , utxoAvailable = UTxOSelection.fromIndex $ UTxOIndex.fromSequence - $ zip dummyInputIds + $ zip dummyWalletUTxOs $ uncurry TokenBundle.fromFlatList <$> boundaryTestUTxO c , extraCoinSource = Coin 0 @@ -1894,8 +1868,8 @@ encodeBoundaryTestCriteria c = SelectionParams boundaryTestSelectionStrategy c } where - dummyInputIds :: [InputId] - dummyInputIds = zip dummyTxIns dummyAddresses + dummyWalletUTxOs :: [WalletUTxO] + dummyWalletUTxOs = zipWith WalletUTxO dummyTxIns dummyAddresses dummyAddresses :: [Address] dummyAddresses = [Address (B8.pack $ show x) | x :: Word64 <- [0 ..]] @@ -4396,6 +4370,16 @@ unitTests lbl cases = forM_ (zip [1..] cases) $ \(i, test) -> it (lbl <> " example #" <> show @Int i) test +-------------------------------------------------------------------------------- +-- Wallet UTxO identifiers +-------------------------------------------------------------------------------- + +coarbitraryWalletUTxO :: WalletUTxO -> Gen a -> Gen a +coarbitraryWalletUTxO = coarbitrary . show + +genWalletUTxOFunction :: Gen a -> Gen (WalletUTxO -> a) +genWalletUTxOFunction = genFunction coarbitraryWalletUTxO + -------------------------------------------------------------------------------- -- Arbitrary instances -------------------------------------------------------------------------------- @@ -4458,7 +4442,7 @@ instance Arbitrary TxOut where arbitrary = genTxOut shrink = shrinkTxOut -instance Arbitrary (UTxOSelection InputId) where +instance Arbitrary (UTxOSelection WalletUTxO) where arbitrary = genUTxOSelection shrink = shrinkUTxOSelection @@ -4472,21 +4456,21 @@ newtype Small a = Small instance Arbitrary (Large (SelectionParams WalletSelectionContext)) where arbitrary = Large <$> genSelectionParams - (genInputIdFunction (arbitrary @Bool)) + (genWalletUTxOFunction (arbitrary @Bool)) (genUTxOIndexLarge) shrink = shrinkMapBy Large getLarge shrinkSelectionParams instance Arbitrary (Small (SelectionParams WalletSelectionContext)) where arbitrary = Small <$> genSelectionParams - (genInputIdFunction (arbitrary @Bool)) + (genWalletUTxOFunction (arbitrary @Bool)) (genUTxOIndex) shrink = shrinkMapBy Small getSmall shrinkSelectionParams -instance Arbitrary (Large (UTxOIndex InputId)) where +instance Arbitrary (Large (UTxOIndex WalletUTxO)) where arbitrary = Large <$> genUTxOIndexLarge shrink = shrinkMapBy Large getLarge shrinkUTxOIndex -instance Arbitrary (Small (UTxOIndex InputId)) where +instance Arbitrary (Small (UTxOIndex WalletUTxO)) where arbitrary = Small <$> genUTxOIndex shrink = shrinkMapBy Small getSmall shrinkUTxOIndex diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index 45ba4aba12e..b626642524e 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -17,7 +17,7 @@ module Cardano.Wallet.CoinSelection.InternalSpec import Prelude import Cardano.Wallet.CoinSelection - ( WalletSelectionContext ) + ( WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal ( ComputeMinimumCollateralParams (..) , Selection @@ -81,7 +81,7 @@ import Cardano.Wallet.Primitive.Types.TokenMap.Gen import Cardano.Wallet.Primitive.Types.TokenQuantity ( TokenQuantity (..) ) import Cardano.Wallet.Primitive.Types.Tx - ( TxIn, txOutMaxTokenQuantity ) + ( txOutMaxTokenQuantity ) import Cardano.Wallet.Primitive.Types.Tx.Gen ( genTxIn, shrinkTxIn ) import Cardano.Wallet.Primitive.Types.UTxOSelection @@ -155,12 +155,6 @@ import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection import qualified Data.Foldable as F --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - spec :: Spec spec = describe "Cardano.Wallet.CoinSelection.InternalSpec" $ do @@ -799,29 +793,31 @@ shrinkCollateralRequirement = genericShrink -- UTxO available for inputs and collateral -------------------------------------------------------------------------------- -genUTxOAvailableForCollateral :: Gen (Map InputId Coin) -genUTxOAvailableForCollateral = genMapWith genInputId genCoinPositive +genUTxOAvailableForCollateral :: Gen (Map WalletUTxO Coin) +genUTxOAvailableForCollateral = genMapWith genWalletUTxO genCoinPositive where - genInputId :: Gen InputId - genInputId = genSized2 genTxIn genAddress + genWalletUTxO :: Gen WalletUTxO + genWalletUTxO = uncurry WalletUTxO <$> genSized2 genTxIn genAddress -genUTxOAvailableForInputs :: Gen (UTxOSelection InputId) +genUTxOAvailableForInputs :: Gen (UTxOSelection WalletUTxO) genUTxOAvailableForInputs = frequency [ (49, genUTxOSelection) , (01, pure UTxOSelection.empty) ] -shrinkUTxOAvailableForCollateral :: Map InputId Coin -> [Map InputId Coin] +shrinkUTxOAvailableForCollateral + :: Map WalletUTxO Coin -> [Map WalletUTxO Coin] shrinkUTxOAvailableForCollateral = - shrinkMapWith shrinkInputId shrinkCoinPositive + shrinkMapWith shrinkWalletUTxO shrinkCoinPositive where - shrinkInputId :: InputId -> [InputId] - shrinkInputId = genericRoundRobinShrink + shrinkWalletUTxO :: WalletUTxO -> [WalletUTxO] + shrinkWalletUTxO = genericRoundRobinShrink <@> shrinkTxIn <:> shrinkAddress <:> Nil -shrinkUTxOAvailableForInputs :: UTxOSelection InputId -> [UTxOSelection InputId] +shrinkUTxOAvailableForInputs + :: UTxOSelection WalletUTxO -> [UTxOSelection WalletUTxO] shrinkUTxOAvailableForInputs = shrinkUTxOSelection -------------------------------------------------------------------------------- diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs index 2893b585bdd..c35d39cb79c 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOIndexSpec.hs @@ -12,6 +12,8 @@ module Cardano.Wallet.Primitive.Types.UTxOIndexSpec import Prelude +import Cardano.Wallet.CoinSelection + ( WalletUTxO (..) ) import Cardano.Wallet.Primitive.Types.Address ( Address ) import Cardano.Wallet.Primitive.Types.Address.Gen @@ -55,6 +57,7 @@ import Test.QuickCheck , Testable , checkCoverage , checkCoverageWith + , coarbitraryShow , conjoin , counterexample , cover @@ -81,18 +84,12 @@ import qualified Data.List as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - spec :: Spec spec = describe "Cardano.Wallet.Primitive.Types.UTxOIndexSpec" $ do parallel $ describe "Class instances obey laws" $ do - testLawsMany @(UTxOIndex InputId) + testLawsMany @(UTxOIndex WalletUTxO) [ eqLaws ] @@ -195,31 +192,33 @@ spec = -- Invariant properties -------------------------------------------------------------------------------- -invariantHolds :: UTxOIndex InputId -> Property +invariantHolds :: UTxOIndex WalletUTxO -> Property invariantHolds u = checkInvariant u === InvariantHolds -prop_arbitrary_invariant :: UTxOIndex InputId -> Property +prop_arbitrary_invariant :: UTxOIndex WalletUTxO -> Property prop_arbitrary_invariant = invariantHolds -prop_shrink_invariant :: UTxOIndex InputId -> Property +prop_shrink_invariant :: UTxOIndex WalletUTxO -> Property prop_shrink_invariant = conjoin . fmap invariantHolds . shrink prop_empty_invariant :: Property prop_empty_invariant = invariantHolds UTxOIndex.empty -prop_singleton_invariant :: InputId -> TokenBundle -> Property +prop_singleton_invariant :: WalletUTxO -> TokenBundle -> Property prop_singleton_invariant i b = invariantHolds $ UTxOIndex.singleton i b -prop_fromSequence_invariant :: [(InputId, TokenBundle)] -> Property +prop_fromSequence_invariant :: [(WalletUTxO, TokenBundle)] -> Property prop_fromSequence_invariant = invariantHolds . UTxOIndex.fromSequence -prop_insert_invariant :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_invariant + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_invariant i b u = invariantHolds $ UTxOIndex.insert i b u -prop_delete_invariant :: InputId -> UTxOIndex InputId -> Property +prop_delete_invariant :: WalletUTxO -> UTxOIndex WalletUTxO -> Property prop_delete_invariant i u = invariantHolds $ UTxOIndex.delete i u -prop_selectRandom_invariant :: UTxOIndex InputId -> SelectionFilter -> Property +prop_selectRandom_invariant + :: UTxOIndex WalletUTxO -> SelectionFilter -> Property prop_selectRandom_invariant i f = monadicIO $ do result <- run $ UTxOIndex.selectRandom i f assert $ case result of @@ -234,13 +233,13 @@ prop_selectRandom_invariant i f = monadicIO $ do prop_empty_toList :: Property prop_empty_toList = - UTxOIndex.toList (UTxOIndex.empty @InputId) === [] + UTxOIndex.toList (UTxOIndex.empty @WalletUTxO) === [] -prop_singleton_toList :: InputId -> TokenBundle -> Property +prop_singleton_toList :: WalletUTxO -> TokenBundle -> Property prop_singleton_toList i b = UTxOIndex.toList (UTxOIndex.singleton i b) === [(i, b)] -prop_toList_fromSequence :: UTxOIndex InputId -> Property +prop_toList_fromSequence :: UTxOIndex WalletUTxO -> Property prop_toList_fromSequence u = UTxOIndex.fromSequence (UTxOIndex.toList u) === u @@ -248,7 +247,7 @@ prop_toList_fromSequence u = -- Modification properties -------------------------------------------------------------------------------- -prop_delete_balance :: InputId -> UTxOIndex InputId -> Property +prop_delete_balance :: WalletUTxO -> UTxOIndex WalletUTxO -> Property prop_delete_balance i u = checkCoverage $ cover 30 (UTxOIndex.member i u) @@ -263,11 +262,11 @@ prop_delete_balance i u = Just b -> UTxOIndex.balance u `TokenBundle.unsafeSubtract` b -prop_delete_lookup :: InputId -> UTxOIndex InputId -> Property +prop_delete_lookup :: WalletUTxO -> UTxOIndex WalletUTxO -> Property prop_delete_lookup i u = UTxOIndex.lookup i (UTxOIndex.delete i u) === Nothing -prop_delete_size :: InputId -> UTxOIndex InputId -> Property +prop_delete_size :: WalletUTxO -> UTxOIndex WalletUTxO -> Property prop_delete_size i u = checkCoverage $ cover 30 (UTxOIndex.member i u) @@ -282,14 +281,16 @@ prop_delete_size i u = Just _ -> UTxOIndex.size u - 1 -prop_insert_assets :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_assets + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_assets i b u = UTxOIndex.assets (UTxOIndex.insert i b u) `Set.intersection` insertedAssets === insertedAssets where insertedAssets = TokenBundle.getAssets b -prop_insert_balance :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_balance + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_balance i b u = checkCoverage $ cover 30 (UTxOIndex.member i u) @@ -304,7 +305,8 @@ prop_insert_balance i b u = Just b' -> UTxOIndex.balance u `TokenBundle.unsafeSubtract` b' -prop_insert_delete :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_delete + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_delete i b u = checkCoverage $ cover 30 (UTxOIndex.member i u) @@ -316,11 +318,13 @@ prop_insert_delete i b u = expected = if UTxOIndex.member i u then UTxOIndex.delete i u else u -prop_insert_lookup :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_lookup + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_lookup i b u = UTxOIndex.lookup i (UTxOIndex.insert i b u) === Just b -prop_insert_size :: InputId -> TokenBundle -> UTxOIndex InputId -> Property +prop_insert_size + :: WalletUTxO -> TokenBundle -> UTxOIndex WalletUTxO -> Property prop_insert_size i b u = checkCoverage $ cover 30 (UTxOIndex.member i u) @@ -339,33 +343,37 @@ prop_insert_size i b u = -- Filtering and partitioning -------------------------------------------------------------------------------- -prop_filter_disjoint :: (InputId -> Bool) -> UTxOIndex InputId -> Property +prop_filter_disjoint + :: (WalletUTxO -> Bool) -> UTxOIndex WalletUTxO -> Property prop_filter_disjoint f u = checkCoverage_filter_partition f u $ UTxOIndex.filter f u `UTxOIndex.disjoint` UTxOIndex.filter (not . f) u === True -prop_filter_partition :: (InputId -> Bool) -> UTxOIndex InputId -> Property +prop_filter_partition + :: (WalletUTxO -> Bool) -> UTxOIndex WalletUTxO -> Property prop_filter_partition f u = checkCoverage_filter_partition f u $ (UTxOIndex.filter f u, UTxOIndex.filter (not . f) u) === UTxOIndex.partition f u -prop_filter_toList :: (InputId -> Bool) -> UTxOIndex InputId -> Property +prop_filter_toList + :: (WalletUTxO -> Bool) -> UTxOIndex WalletUTxO -> Property prop_filter_toList f u = checkCoverage_filter_partition f u $ UTxOIndex.toList (UTxOIndex.filter f u) === L.filter (f . fst) (UTxOIndex.toList u) -prop_partition_disjoint :: (InputId -> Bool) -> UTxOIndex InputId -> Property +prop_partition_disjoint + :: (WalletUTxO -> Bool) -> UTxOIndex WalletUTxO -> Property prop_partition_disjoint f u = checkCoverage_filter_partition f u $ uncurry UTxOIndex.disjoint (UTxOIndex.partition f u) === True checkCoverage_filter_partition :: Testable prop - => (InputId -> Bool) - -> UTxOIndex InputId + => (WalletUTxO -> Bool) + -> UTxOIndex WalletUTxO -> (prop -> Property) checkCoverage_filter_partition f u = checkCoverage @@ -431,7 +439,7 @@ prop_SelectionFilter_coverage selectionFilter = checkCoverage $ property -- prop_selectRandom_empty :: SelectionFilter -> Property prop_selectRandom_empty f = monadicIO $ do - result <- run $ UTxOIndex.selectRandom (UTxOIndex.empty @InputId) f + result <- run $ UTxOIndex.selectRandom (UTxOIndex.empty @WalletUTxO) f assert $ isNothing result -- | Attempt to select a random entry from a singleton index with entry 'e'. @@ -440,7 +448,7 @@ prop_selectRandom_empty f = monadicIO $ do -- prop_selectRandom_singleton :: SelectionFilter - -> InputId + -> WalletUTxO -> TokenBundle -> Property prop_selectRandom_singleton selectionFilter i b = monadicIO $ do @@ -468,7 +476,7 @@ prop_selectRandom_singleton selectionFilter i b = monadicIO $ do -- -- This should always succeed, provided the index is not empty. -- -prop_selectRandom_one_any :: UTxOIndex InputId -> Property +prop_selectRandom_one_any :: UTxOIndex WalletUTxO -> Property prop_selectRandom_one_any u = checkCoverage $ monadicIO $ do result <- run $ UTxOIndex.selectRandom u Any monitor $ cover 90 (isJust result) @@ -485,7 +493,7 @@ prop_selectRandom_one_any u = checkCoverage $ monadicIO $ do -- | Attempt to select a random entry with only ada. -- -prop_selectRandom_one_withAdaOnly :: UTxOIndex InputId -> Property +prop_selectRandom_one_withAdaOnly :: UTxOIndex WalletUTxO -> Property prop_selectRandom_one_withAdaOnly u = checkCoverage $ monadicIO $ do result <- run $ UTxOIndex.selectRandom u WithAdaOnly monitor $ cover 50 (isJust result) @@ -508,7 +516,7 @@ prop_selectRandom_one_withAdaOnly u = checkCoverage $ monadicIO $ do -- This should only succeed if there is at least one element with a non-zero -- quantity of the asset. -- -prop_selectRandom_one_withAsset :: UTxOIndex InputId -> AssetId -> Property +prop_selectRandom_one_withAsset :: UTxOIndex WalletUTxO -> AssetId -> Property prop_selectRandom_one_withAsset u a = checkCoverage $ monadicIO $ do result <- run $ UTxOIndex.selectRandom u (WithAsset a) monitor $ cover 50 (a `Set.member` UTxOIndex.assets u) @@ -534,7 +542,8 @@ prop_selectRandom_one_withAsset u a = checkCoverage $ monadicIO $ do -- This should only succeed if there is at least one element with a non-zero -- quantity of the asset and no other assets. -- -prop_selectRandom_one_withAssetOnly :: UTxOIndex InputId -> AssetId -> Property +prop_selectRandom_one_withAssetOnly + :: UTxOIndex WalletUTxO -> AssetId -> Property prop_selectRandom_one_withAssetOnly u a = checkCoverage $ monadicIO $ do result <- run $ UTxOIndex.selectRandom u (WithAssetOnly a) monitor $ cover 50 (a `Set.member` UTxOIndex.assets u) @@ -558,7 +567,7 @@ prop_selectRandom_one_withAssetOnly u a = checkCoverage $ monadicIO $ do -- -- This should always succeed. -- -prop_selectRandom_all_any :: UTxOIndex InputId -> Property +prop_selectRandom_all_any :: UTxOIndex WalletUTxO -> Property prop_selectRandom_all_any u = checkCoverage $ monadicIO $ do (selectedEntries, u') <- run $ selectAll Any u monitor $ cover 90 (not (null selectedEntries)) @@ -574,7 +583,7 @@ prop_selectRandom_all_any u = checkCoverage $ monadicIO $ do -- | Attempt to select all entries with only ada from the index. -- -prop_selectRandom_all_withAdaOnly :: UTxOIndex InputId -> Property +prop_selectRandom_all_withAdaOnly :: UTxOIndex WalletUTxO -> Property prop_selectRandom_all_withAdaOnly u = checkCoverage $ monadicIO $ do (selectedEntries, u') <- run $ selectAll WithAdaOnly u monitor $ cover 70 (not (null selectedEntries)) @@ -588,7 +597,7 @@ prop_selectRandom_all_withAdaOnly u = checkCoverage $ monadicIO $ do -- | Attempt to select all entries with the given asset from the index. -- -prop_selectRandom_all_withAsset :: UTxOIndex InputId -> AssetId -> Property +prop_selectRandom_all_withAsset :: UTxOIndex WalletUTxO -> AssetId -> Property prop_selectRandom_all_withAsset u a = checkCoverage $ monadicIO $ do (selectedEntries, u') <- run $ selectAll (WithAsset a) u monitor $ cover 50 (a `Set.member` UTxOIndex.assets u) @@ -607,7 +616,8 @@ prop_selectRandom_all_withAsset u a = checkCoverage $ monadicIO $ do -- | Attempt to select all entries with only the given asset from the index. -- -prop_selectRandom_all_withAssetOnly :: UTxOIndex InputId -> AssetId -> Property +prop_selectRandom_all_withAssetOnly + :: UTxOIndex WalletUTxO -> AssetId -> Property prop_selectRandom_all_withAssetOnly u a = checkCoverage $ monadicIO $ do (selectedEntries, u') <- run $ selectAll (WithAssetOnly a) u monitor $ cover 50 (a `Set.member` UTxOIndex.assets u) @@ -626,7 +636,7 @@ 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 InputId -> Property +prop_selectRandomWithPriority :: UTxOIndex WalletUTxO -> Property prop_selectRandomWithPriority u = forAll (genAssetId) $ \a1 -> forAll (genAssetId `suchThat` (/= a1)) $ \a2 -> @@ -734,8 +744,8 @@ prop_selectRandomSetMember_coversRangeUniformly i j = selectAll :: MonadRandom m => SelectionFilter - -> UTxOIndex InputId - -> m ([(InputId, TokenBundle)], UTxOIndex InputId) + -> UTxOIndex WalletUTxO + -> m ([(WalletUTxO, TokenBundle)], UTxOIndex WalletUTxO) selectAll sf = go [] where go !selectedEntries !u = do @@ -770,11 +780,14 @@ tokenBundleIsAdaOnly = TokenBundle.isCoin -- Arbitrary instances -------------------------------------------------------------------------------- -instance {-# OVERLAPS #-} Arbitrary InputId where - arbitrary = genInputId +instance Arbitrary WalletUTxO where + arbitrary = genWalletUTxO + +genWalletUTxO :: Gen WalletUTxO +genWalletUTxO = uncurry WalletUTxO <$> genSized2 genTxIn genAddress -genInputId :: Gen InputId -genInputId = genSized2 genTxIn genAddress +instance CoArbitrary WalletUTxO where + coarbitrary = coarbitraryShow instance CoArbitrary Address where coarbitrary = coarbitraryAddress @@ -783,7 +796,7 @@ instance Arbitrary AssetId where arbitrary = genAssetId shrink = shrinkAssetId -instance Arbitrary (UTxOIndex InputId) where +instance Arbitrary (UTxOIndex WalletUTxO) where arbitrary = genUTxOIndex shrink = shrinkUTxOIndex @@ -827,5 +840,5 @@ shrinkSelectionFilterSmallRange = \case -- Show instances -------------------------------------------------------------------------------- -instance Show (InputId -> Bool) where - show = const "(InputId -> Bool)" +instance Show (WalletUTxO -> Bool) where + show = const "(WalletUTxO -> Bool)" diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs index 0b2d5f719ab..b6cc8619224 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs @@ -10,6 +10,8 @@ module Cardano.Wallet.Primitive.Types.UTxOSelectionSpec import Prelude +import Cardano.Wallet.CoinSelection + ( WalletUTxO (..) ) import Cardano.Wallet.Primitive.Types.Address ( Address ) import Cardano.Wallet.Primitive.Types.Address.Gen @@ -42,6 +44,7 @@ import Test.QuickCheck , Property , Testable , checkCoverage + , coarbitraryShow , conjoin , cover , forAll @@ -56,12 +59,6 @@ import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex import qualified Cardano.Wallet.Primitive.Types.UTxOSelection as UTxOSelection import qualified Data.Foldable as F --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - spec :: Spec spec = describe "Cardano.Wallet.Primitive.Types.UTxOSelectionSpec" $ do @@ -168,7 +165,10 @@ prop_shrinkUTxOSelectionNonEmpty = conjoin (isValidSelectionNonEmpty <$> shrinkUTxOSelectionNonEmpty s) checkCoverage_UTxOSelection - :: Testable p => IsUTxOSelection s InputId => s InputId -> (p -> Property) + :: Testable p + => IsUTxOSelection s WalletUTxO + => s WalletUTxO + -> (p -> Property) checkCoverage_UTxOSelection s = checkCoverage_UTxOSelectionNonEmpty s . cover 2 (0 == ssize && ssize == lsize) "0 == lsize && lsize == ssize" @@ -178,7 +178,10 @@ checkCoverage_UTxOSelection s ssize = UTxOSelection.selectedSize s checkCoverage_UTxOSelectionNonEmpty - :: Testable p => IsUTxOSelection s InputId => s InputId -> (p -> Property) + :: Testable p + => IsUTxOSelection s WalletUTxO + => s WalletUTxO + -> (p -> Property) checkCoverage_UTxOSelectionNonEmpty s = checkCoverage . cover 2 (0 == lsize && lsize < ssize) "0 == lsize && lsize < ssize" @@ -194,36 +197,37 @@ checkCoverage_UTxOSelectionNonEmpty s -- Construction and deconstruction -------------------------------------------------------------------------------- -prop_fromIndex_isValid :: UTxOIndex InputId -> Property +prop_fromIndex_isValid :: UTxOIndex WalletUTxO -> Property prop_fromIndex_isValid u = isValidSelection (UTxOSelection.fromIndex u) === True prop_fromIndexFiltered_isValid - :: (InputId -> Bool) -> UTxOIndex InputId -> Property + :: (WalletUTxO -> Bool) -> UTxOIndex WalletUTxO -> Property prop_fromIndexFiltered_isValid f u = isValidSelection (UTxOSelection.fromIndexFiltered f u) === True -prop_fromIndexPair_isValid :: (UTxOIndex InputId, UTxOIndex InputId) -> Property +prop_fromIndexPair_isValid + :: (UTxOIndex WalletUTxO, UTxOIndex WalletUTxO) -> Property prop_fromIndexPair_isValid (u1, u2) = isValidSelection (UTxOSelection.fromIndexPair (u1, u2)) === True -prop_fromIndex_toIndexPair :: UTxOIndex InputId-> Property +prop_fromIndex_toIndexPair :: UTxOIndex WalletUTxO-> Property prop_fromIndex_toIndexPair u = UTxOSelection.toIndexPair (UTxOSelection.fromIndex u) === (u, UTxOIndex.empty) prop_fromIndexFiltered_toIndexPair - :: (InputId -> Bool) - -> UTxOIndex InputId + :: (WalletUTxO -> Bool) + -> UTxOIndex WalletUTxO -> Property prop_fromIndexFiltered_toIndexPair f u = UTxOSelection.toIndexPair (UTxOSelection.fromIndexFiltered f u) === (UTxOIndex.filter (not . f) u, UTxOIndex.filter f u) -prop_fromIndexPair_toIndexPair :: UTxOSelection InputId -> Property +prop_fromIndexPair_toIndexPair :: UTxOSelection WalletUTxO -> Property prop_fromIndexPair_toIndexPair s = checkCoverage_UTxOSelection s $ UTxOSelection.fromIndexPair (UTxOSelection.toIndexPair s) @@ -233,13 +237,13 @@ prop_fromIndexPair_toIndexPair s = -- Promotion and demotion -------------------------------------------------------------------------------- -prop_fromNonEmpty_toNonEmpty :: UTxOSelectionNonEmpty InputId -> Property +prop_fromNonEmpty_toNonEmpty :: UTxOSelectionNonEmpty WalletUTxO -> Property prop_fromNonEmpty_toNonEmpty s = checkCoverage_UTxOSelectionNonEmpty s $ UTxOSelection.toNonEmpty (UTxOSelection.fromNonEmpty s) === Just s -prop_toNonEmpty_fromNonEmpty :: UTxOSelection InputId -> Property +prop_toNonEmpty_fromNonEmpty :: UTxOSelection WalletUTxO -> Property prop_toNonEmpty_fromNonEmpty s = checkCoverage_UTxOSelection s $ (UTxOSelection.fromNonEmpty <$> UTxOSelection.toNonEmpty s) @@ -249,31 +253,31 @@ prop_toNonEmpty_fromNonEmpty s = -- Indicator and accessor functions -------------------------------------------------------------------------------- -prop_availableBalance_availableMap :: UTxOSelection InputId -> Property +prop_availableBalance_availableMap :: UTxOSelection WalletUTxO -> Property prop_availableBalance_availableMap s = checkCoverage_UTxOSelection s $ UTxOSelection.availableBalance s === F.fold (UTxOSelection.availableMap s) -prop_isNonEmpty_selectedSize :: UTxOSelection InputId -> Property +prop_isNonEmpty_selectedSize :: UTxOSelection WalletUTxO -> Property prop_isNonEmpty_selectedSize s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === (UTxOSelection.selectedSize s > 0) -prop_isNonEmpty_selectedIndex :: UTxOSelection InputId -> Property +prop_isNonEmpty_selectedIndex :: UTxOSelection WalletUTxO -> Property prop_isNonEmpty_selectedIndex s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === not (UTxOIndex.null (UTxOSelection.selectedIndex s)) -prop_isNonEmpty_selectedList :: UTxOSelection InputId -> Property +prop_isNonEmpty_selectedList :: UTxOSelection WalletUTxO -> Property prop_isNonEmpty_selectedList s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === not (null (UTxOSelection.selectedList s)) -prop_leftoverBalance_selectedBalance :: UTxOSelection InputId -> Property +prop_leftoverBalance_selectedBalance :: UTxOSelection WalletUTxO -> Property prop_leftoverBalance_selectedBalance s = checkCoverage_UTxOSelection s $ (UTxOSelection.leftoverBalance s <> UTxOSelection.selectedBalance s) @@ -282,7 +286,7 @@ prop_leftoverBalance_selectedBalance s = (UTxOIndex.balance (UTxOSelection.leftoverIndex s)) (UTxOIndex.balance (UTxOSelection.selectedIndex s)) -prop_leftoverSize_selectedSize :: UTxOSelection InputId -> Property +prop_leftoverSize_selectedSize :: UTxOSelection WalletUTxO -> Property prop_leftoverSize_selectedSize s = checkCoverage_UTxOSelection s $ (UTxOSelection.leftoverSize s + UTxOSelection.selectedSize s) @@ -295,23 +299,23 @@ prop_leftoverSize_selectedSize s = -- Modification -------------------------------------------------------------------------------- -prop_select_empty :: InputId -> Property +prop_select_empty :: WalletUTxO -> Property prop_select_empty i = UTxOSelection.select i UTxOSelection.empty === Nothing -prop_select_isValid :: InputId -> UTxOSelection InputId -> Property +prop_select_isValid :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_isValid i s = property $ checkCoverage_select i s $ maybe True isValidSelectionNonEmpty (UTxOSelection.select i s) -prop_select_isLeftover :: InputId -> UTxOSelection InputId -> Property +prop_select_isLeftover :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_isLeftover i s = checkCoverage_select i s $ (UTxOSelection.isLeftover i <$> UTxOSelection.select i s) === if UTxOSelection.isLeftover i s then Just False else Nothing -prop_select_isSelected :: InputId -> UTxOSelection InputId -> Property +prop_select_isSelected :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_isSelected i s = checkCoverage_select i s $ (UTxOSelection.isSelected i <$> UTxOSelection.select i s) @@ -319,14 +323,15 @@ prop_select_isSelected i s = if UTxOSelection.isLeftover i s then Just True else Nothing prop_select_isProperSubSelectionOf - :: InputId -> UTxOSelection InputId -> Property + :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_isProperSubSelectionOf i s = checkCoverage_select i s $ (UTxOSelection.isProperSubSelectionOf s <$> UTxOSelection.select i s) === if UTxOSelection.isLeftover i s then Just True else Nothing -prop_select_availableBalance :: InputId -> UTxOSelection InputId -> Property +prop_select_availableBalance + :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_availableBalance i s = checkCoverage_select i s $ (UTxOSelection.availableBalance <$> UTxOSelection.select i s) @@ -335,7 +340,7 @@ prop_select_availableBalance i s = then Just (UTxOSelection.availableBalance s) else Nothing -prop_select_availableMap :: InputId -> UTxOSelection InputId -> Property +prop_select_availableMap :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_availableMap i s = checkCoverage_select i s $ (UTxOSelection.availableMap <$> UTxOSelection.select i s) @@ -344,7 +349,7 @@ prop_select_availableMap i s = then Just (UTxOSelection.availableMap s) else Nothing -prop_select_leftoverSize :: InputId -> UTxOSelection InputId -> Property +prop_select_leftoverSize :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_leftoverSize i s = checkCoverage_select i s $ (UTxOSelection.leftoverSize <$> UTxOSelection.select i s) @@ -353,7 +358,7 @@ prop_select_leftoverSize i s = then Just (UTxOSelection.leftoverSize s - 1) else Nothing -prop_select_selectedSize :: InputId -> UTxOSelection InputId -> Property +prop_select_selectedSize :: WalletUTxO -> UTxOSelection WalletUTxO -> Property prop_select_selectedSize i s = checkCoverage_select i s $ (UTxOSelection.selectedSize <$> UTxOSelection.select i s) @@ -363,7 +368,7 @@ prop_select_selectedSize i s = else Nothing prop_selectMany_isSubSelectionOf - :: (InputId -> Bool) -> UTxOSelection InputId -> Property + :: (WalletUTxO -> Bool) -> UTxOSelection WalletUTxO -> Property prop_selectMany_isSubSelectionOf f s = checkCoverage_UTxOSelection s $ UTxOSelection.isSubSelectionOf s (UTxOSelection.selectMany toSelect s) @@ -371,14 +376,14 @@ prop_selectMany_isSubSelectionOf f s = where toSelect = filter f $ fst <$> UTxOSelection.leftoverList s -prop_selectMany_leftoverSize_all :: UTxOSelection InputId -> Property +prop_selectMany_leftoverSize_all :: UTxOSelection WalletUTxO -> Property prop_selectMany_leftoverSize_all s = checkCoverage_UTxOSelection s $ UTxOSelection.leftoverSize (UTxOSelection.selectMany (fst <$> UTxOSelection.leftoverList s) s) === 0 -prop_selectMany_selectedSize_all :: UTxOSelection InputId -> Property +prop_selectMany_selectedSize_all :: UTxOSelection WalletUTxO -> Property prop_selectMany_selectedSize_all s = checkCoverage_UTxOSelection s $ UTxOSelection.selectedSize @@ -386,7 +391,10 @@ prop_selectMany_selectedSize_all s = === (UTxOSelection.leftoverSize s + UTxOSelection.selectedSize s) checkCoverage_select - :: Testable prop => InputId -> UTxOSelection InputId -> (prop -> Property) + :: Testable prop + => WalletUTxO + -> UTxOSelection WalletUTxO + -> (prop -> Property) checkCoverage_select i s = checkCoverage . cover 10 (UTxOSelection.isLeftover i s) @@ -400,12 +408,12 @@ checkCoverage_select i s -- Validity -------------------------------------------------------------------------------- -isValidSelection :: IsUTxOSelection s InputId => s InputId -> Bool +isValidSelection :: IsUTxOSelection s WalletUTxO => s WalletUTxO -> Bool isValidSelection s = UTxOIndex.disjoint (UTxOSelection.selectedIndex s) (UTxOSelection.leftoverIndex s) -isValidSelectionNonEmpty :: UTxOSelectionNonEmpty InputId -> Bool +isValidSelectionNonEmpty :: UTxOSelectionNonEmpty WalletUTxO -> Bool isValidSelectionNonEmpty s = isValidSelection s && UTxOSelection.isNonEmpty s @@ -422,22 +430,22 @@ isValidSelectionNonEmpty s = -- Replace this instance with one for a mock input identifier, after the type -- of input identifier has been made into a type parameter. -- -instance {-# OVERLAPPING #-} Arbitrary InputId where - arbitrary = genSized2 genTxIn genAddress +instance Arbitrary WalletUTxO where + arbitrary = uncurry WalletUTxO <$> genSized2 genTxIn genAddress shrink = genericRoundRobinShrink <@> shrinkTxIn <:> shrinkAddress <:> Nil -instance Arbitrary (UTxOIndex InputId) where +instance Arbitrary (UTxOIndex WalletUTxO) where arbitrary = genUTxOIndex shrink = shrinkUTxOIndex -instance Arbitrary (UTxOSelection InputId) where +instance Arbitrary (UTxOSelection WalletUTxO) where arbitrary = genUTxOSelection shrink = shrinkUTxOSelection -instance Arbitrary (UTxOSelectionNonEmpty InputId) where +instance Arbitrary (UTxOSelectionNonEmpty WalletUTxO) where arbitrary = genUTxOSelectionNonEmpty shrink = shrinkUTxOSelectionNonEmpty @@ -451,9 +459,12 @@ instance CoArbitrary Address where instance CoArbitrary TxIn where coarbitrary = coarbitraryTxIn +instance CoArbitrary WalletUTxO where + coarbitrary = coarbitraryShow + -------------------------------------------------------------------------------- -- Show instances -------------------------------------------------------------------------------- -instance Show (InputId -> Bool) where - show = const "(InputId -> Bool)" +instance Show (WalletUTxO -> Bool) where + show = const "(WalletUTxO -> Bool)" diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs index 192a7bb7f6f..5512e934c31 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs @@ -88,6 +88,7 @@ import Cardano.Wallet.CoinSelection , SelectionError (..) , SelectionOf (..) , UnableToConstructChangeError (..) + , WalletUTxO (..) , balanceMissing , emptySkeleton , selectionDelta @@ -377,6 +378,7 @@ import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Crypto as Crypto import qualified Cardano.Ledger.Shelley.API as SL +import qualified Cardano.Wallet.CoinSelection as CS import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley import qualified Cardano.Wallet.Primitive.Types.Coin as Coin import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle @@ -2042,14 +2044,8 @@ instance MonadRandom Gen where getRandomR range = mkGen (fst . randomR range) getRandomRs range = mkGen (randomRs range) --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - data Wallet' = Wallet' - (UTxOIndex InputId) + (UTxOIndex WalletUTxO) (Wallet (SeqState 'Mainnet ShelleyKey)) (Set Tx) @@ -2063,10 +2059,7 @@ instance Show Wallet' where mkTestWallet :: ShelleyKey 'RootK XPrv -> UTxO -> Wallet' mkTestWallet rootK utxo = Wallet' - (UTxOIndex.fromSequence - $ fmap (\(i, TxOut a b) -> ((i, a), b)) - $ Map.toList - $ unUTxO utxo) + (UTxOIndex.fromMap $ CS.toInternalUTxOMap utxo) (unsafeInitWallet utxo (header block0) s) mempty where @@ -2096,16 +2089,12 @@ instance Arbitrary Wallet' where setUTxO :: UTxO -> Wallet' -> Wallet' setUTxO u (Wallet' _ wal pending) = Wallet' - (UTxOIndex.fromSequence - $ fmap (\(i, TxOut a b) -> ((i, a), b)) - $ Map.toList - $ unUTxO u) - (wal { utxo = u}) + (UTxOIndex.fromMap $ CS.toInternalUTxOMap u) + (wal {utxo = u}) pending - getUTxO (Wallet' u _ _) = UTxO - $ Map.fromList - $ (\((i, a), b) -> (i, TxOut a b)) <$> UTxOIndex.toList u + getUTxO (Wallet' u _ _) = + CS.toExternalUTxOMap $ UTxOIndex.toMap u shrinkUTxO' u | UTxO.size u > 1 && simplifyUTxO u /= u @@ -2279,9 +2268,8 @@ shrinkTxBody (Cardano.ShelleyTxBody e bod scripts scriptData aux val) = tail shrinkUpdates SNothing = [] shrinkUpdates (SJust _) = [SNothing] - balanceTransaction' - :: (UTxOIndex InputId, Wallet (SeqState 'Mainnet ShelleyKey), Set Tx) + :: (UTxOIndex WalletUTxO, Wallet (SeqState 'Mainnet ShelleyKey), Set Tx) -> StdGenSeed -> PartialTx -> Either ErrBalanceTx SealedTx From 13a090a6e4f7d75fc8d90683d00b6f2f403c5004 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 11 Mar 2022 03:21:07 +0000 Subject: [PATCH 08/13] Introduce type `WalletAddress`. This allows us to define a non-orphan `Dummy` instance for addresses. --- lib/core/src/Cardano/Wallet/CoinSelection.hs | 30 +++++++++++++------ .../CoinSelection/Internal/Balance/Gen.hs | 6 ++-- .../CoinSelection/Internal/BalanceSpec.hs | 11 +++---- .../Wallet/CoinSelection/InternalSpec.hs | 25 +++++++++------- 4 files changed, 45 insertions(+), 27 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 18bafa69282..05cdbcebc29 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Copyright: © 2022 IOHK @@ -27,6 +27,7 @@ module Cardano.Wallet.CoinSelection ( -- * Selection contexts WalletSelectionContext + , WalletAddress (..) , WalletUTxO (..) -- * Mapping between external (wallet) types and internal types @@ -111,6 +112,8 @@ import Control.Monad.Random.Class ( MonadRandom (..) ) import Control.Monad.Trans.Except ( ExceptT (..) ) +import Data.Bifunctor + ( first ) import Data.Generics.Internal.VL.Lens ( over, view ) import Data.List.NonEmpty @@ -146,11 +149,19 @@ import qualified Data.Set as Set data WalletSelectionContext instance SC.SelectionContext WalletSelectionContext where - type Address WalletSelectionContext = Address + type Address WalletSelectionContext = WalletAddress type UTxO WalletSelectionContext = WalletUTxO -instance SC.Dummy Address where - dummy = Address "" +-------------------------------------------------------------------------------- +-- Mapping between external (wallet) and internal addresses +-------------------------------------------------------------------------------- + +newtype WalletAddress = WalletAddress + { unWalletAddress :: Address } + deriving (Buildable, Eq, Generic, Ord, Show) + +instance SC.Dummy WalletAddress where + dummy = WalletAddress $ Address "" -------------------------------------------------------------------------------- -- Mapping between external (wallet) and internal UTxO identifiers @@ -245,7 +256,7 @@ toInternalSelectionConstraints SelectionConstraints {..} = { computeMinimumCost = computeMinimumCost . toExternalSelectionSkeleton , computeSelectionLimit = - computeSelectionLimit . fmap (uncurry TxOut) + computeSelectionLimit . fmap (uncurry TxOut . first unWalletAddress) , .. } @@ -311,7 +322,8 @@ toInternalSelectionParams SelectionParams {..} = { utxoAvailableForCollateral = Map.mapMaybeWithKey identifyCollateral utxoAvailableForCollateral , outputsToCover = - (view #address &&& view #tokens) <$> outputsToCover + ((WalletAddress . view #address) &&& view #tokens) + <$> outputsToCover , .. } where @@ -357,7 +369,7 @@ toExternalSelectionSkeleton toExternalSelectionSkeleton Internal.SelectionSkeleton {..} = SelectionSkeleton { skeletonOutputs = - uncurry TxOut <$> skeletonOutputs + uncurry TxOut . first unWalletAddress <$> skeletonOutputs , .. } @@ -410,7 +422,7 @@ toExternalSelection _ps Internal.Selection {..} = , inputs = toExternalUTxO <$> inputs , outputs = - uncurry TxOut <$> outputs + uncurry TxOut . first unWalletAddress <$> outputs , .. } @@ -426,7 +438,7 @@ toInternalSelection getChangeBundle Selection {..} = toInternalUTxO' TokenBundle.getCoin <$> collateral , inputs = toInternalUTxO <$> inputs - , outputs = (view #address &&& view #tokens) + , outputs = ((WalletAddress . view #address) &&& view #tokens) <$> outputs , .. } diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs index eb08f6fd4d6..8b260819c6c 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs @@ -14,7 +14,7 @@ module Cardano.Wallet.CoinSelection.Internal.Balance.Gen import Prelude import Cardano.Wallet.CoinSelection - ( WalletSelectionContext ) + ( WalletAddress (..), WalletSelectionContext ) import Cardano.Wallet.CoinSelection.Internal.Balance ( SelectionLimit , SelectionLimitOf (..) @@ -83,7 +83,7 @@ genSelectionSkeleton = SelectionSkeleton genSkeletonOutputs = listOf genSkeletonOutput genSkeletonOutput = (,) - <$> genAddress + <$> (WalletAddress <$> genAddress) <*> genTokenBundleSmallRange `suchThat` tokenBundleHasNonZeroCoin genSkeletonChange = listOf (Set.fromList <$> listOf genAssetId) @@ -103,7 +103,7 @@ shrinkSelectionSkeleton = genericRoundRobinShrink shrinkList shrinkSkeletonOutput shrinkSkeletonOutput = genericRoundRobinShrink - <@> shrinkAddress + <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress <:> filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange <:> Nil shrinkSkeletonChange = diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index e4308319b95..c3ad69cfaa8 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -41,7 +41,7 @@ import Algebra.PartialOrd import Cardano.Numeric.Util ( inAscendingPartialOrder ) import Cardano.Wallet.CoinSelection - ( WalletSelectionContext, WalletUTxO (..) ) + ( WalletAddress (..), WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal.Balance ( AssetCount (..) , BalanceInsufficientError (..) @@ -616,7 +616,8 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do outputCount <- elements [0, 1, max 2 $ UTxOIndex.size utxoAvailable `div` 8] outputsToCover <- - replicateM outputCount ((view #address &&& view #tokens) <$> genTxOut) + replicateM outputCount + (((WalletAddress . view #address) &&& view #tokens) <$> genTxOut) extraCoinSource <- oneof [pure $ Coin 0, genCoinPositive] extraCoinSink <- @@ -662,7 +663,7 @@ shrinkSelectionParams = genericRoundRobinShrink <:> Nil where shrinkOutput = genericRoundRobinShrink - <@> shrinkAddress + <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress <:> (filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange) <:> Nil where @@ -1849,7 +1850,7 @@ encodeBoundaryTestCriteria encodeBoundaryTestCriteria c = SelectionParams { outputsToCover = zip - (dummyAddresses) + (WalletAddress <$> dummyAddresses) (uncurry TokenBundle.fromFlatList <$> boundaryTestOutputs c) , utxoAvailable = UTxOSelection.fromIndex @@ -2579,7 +2580,7 @@ shrinkMockComputeSelectionLimit = \case unMockComputeSelectionLimit :: MockComputeSelectionLimit - -> ([(Address, TokenBundle)] -> SelectionLimit) + -> ([(WalletAddress, TokenBundle)] -> SelectionLimit) unMockComputeSelectionLimit = \case MockComputeSelectionLimitNone -> const NoLimit diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index b626642524e..b249b65d19d 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -17,7 +17,7 @@ module Cardano.Wallet.CoinSelection.InternalSpec import Prelude import Cardano.Wallet.CoinSelection - ( WalletSelectionContext, WalletUTxO (..) ) + ( WalletAddress (..), WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal ( ComputeMinimumCollateralParams (..) , Selection @@ -130,6 +130,7 @@ import Test.QuickCheck , scale , shrink , shrinkList + , shrinkMapBy , suchThat , vectorOf , (===) @@ -411,10 +412,12 @@ prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = maximumCollateralInputCount :: Int maximumCollateralInputCount = constraints ^. #maximumCollateralInputCount - computeSelectionLimitOriginal :: [(Address, TokenBundle)] -> SelectionLimit + computeSelectionLimitOriginal + :: [(WalletAddress, TokenBundle)] -> SelectionLimit computeSelectionLimitOriginal = constraints ^. #computeSelectionLimit - computeSelectionLimitAdjusted :: [(Address, TokenBundle)] -> SelectionLimit + computeSelectionLimitAdjusted + :: [(WalletAddress, TokenBundle)] -> SelectionLimit computeSelectionLimitAdjusted = toBalanceConstraintsParams (constraints, params) & fst & view #computeSelectionLimit @@ -694,24 +697,24 @@ shrinkExtraCoinOut = shrinkCoin -- Outputs to cover -------------------------------------------------------------------------------- -genOutputsToCover :: Gen [(Address, TokenBundle)] +genOutputsToCover :: Gen [(WalletAddress, TokenBundle)] genOutputsToCover = do count <- choose (1, 4) vectorOf count genOutputToCover where - genOutputToCover :: Gen (Address, TokenBundle) + genOutputToCover :: Gen (WalletAddress, TokenBundle) genOutputToCover = frequency [ (49, scale (`mod` 8) genOutput) , (01, genOutputWith genTokenQuantityThatMayExceedLimit) ] where genOutput = (,) - <$> genAddress + <$> (WalletAddress <$> genAddress) <*> genTokenBundleSmallRange `suchThat` tokenBundleHasNonZeroCoin - genOutputWith :: Gen TokenQuantity -> Gen (Address, TokenBundle) + genOutputWith :: Gen TokenQuantity -> Gen (WalletAddress, TokenBundle) genOutputWith genTokenQuantityFn = (,) - <$> genAddress + <$> (WalletAddress <$> genAddress) <*> genTokenBundleWith genTokenQuantityFn genTokenBundleWith :: Gen TokenQuantity -> Gen TokenBundle @@ -741,11 +744,13 @@ genOutputsToCover = do limit :: Natural limit = unTokenQuantity txOutMaxTokenQuantity -shrinkOutputsToCover :: [(Address, TokenBundle)] -> [[(Address, TokenBundle)]] +shrinkOutputsToCover + :: [(WalletAddress, TokenBundle)] + -> [[(WalletAddress, TokenBundle)]] shrinkOutputsToCover = shrinkList shrinkOutput where shrinkOutput = genericRoundRobinShrink - <@> shrinkAddress + <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress <:> (filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange) <:> Nil From de158de4c85fee13cc5b4bafd33b623b0b002b3e Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 11 Mar 2022 05:47:22 +0000 Subject: [PATCH 09/13] Tweak `balanceTx` golden test data to account for usage of `WalletUTxO`. This fix adjusts the golden test data to account for the change in type from `InputId` (which was just a synonym for a pair of `TxIn` and `Address`) to `WalletUTxO` (which is a record type). --- .../test/data/balanceTx/pingPong_2/golden | 40 +++++++++---------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/lib/shelley/test/data/balanceTx/pingPong_2/golden b/lib/shelley/test/data/balanceTx/pingPong_2/golden index d0dd34e204c..5231dc6cb06 100644 --- a/lib/shelley/test/data/balanceTx/pingPong_2/golden +++ b/lib/shelley/test/data/balanceTx/pingPong_2/golden @@ -33,26 +33,26 @@ 1.600000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionBalanceErrorOf (UnableToConstructChange (UnableToConstructChangeError {requiredCost = Coin 1723825, shortfall = Coin 123825})))) 1.650000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionBalanceErrorOf (UnableToConstructChange (UnableToConstructChangeError {requiredCost = Coin 1723825, shortfall = Coin 73825})))) 1.700000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionBalanceErrorOf (UnableToConstructChange (UnableToConstructChangeError {requiredCost = Coin 1723825, shortfall = Coin 23825})))) - 1.750000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 1750000)], minimumSelectionAmount = Coin 2625000}))) - 1.800000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 1800000)], minimumSelectionAmount = Coin 2700000}))) - 1.850000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 1850000)], minimumSelectionAmount = Coin 2775000}))) - 1.900000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 1900000)], minimumSelectionAmount = Coin 2850000}))) - 1.950000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 1950000)], minimumSelectionAmount = Coin 2925000}))) - 2.000000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2000000)], minimumSelectionAmount = Coin 3000000}))) - 2.050000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2050000)], minimumSelectionAmount = Coin 3075000}))) - 2.100000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2100000)], minimumSelectionAmount = Coin 3150000}))) - 2.150000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2150000)], minimumSelectionAmount = Coin 3225000}))) - 2.200000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2200000)], minimumSelectionAmount = Coin 3300000}))) - 2.250000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2250000)], minimumSelectionAmount = Coin 3375000}))) - 2.300000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2300000)], minimumSelectionAmount = Coin 3450000}))) - 2.350000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2350000)], minimumSelectionAmount = Coin 3525000}))) - 2.400000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2400000)], minimumSelectionAmount = Coin 3600000}))) - 2.450000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2450000)], minimumSelectionAmount = Coin 3675000}))) - 2.500000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2500000)], minimumSelectionAmount = Coin 3750000}))) - 2.550000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2550000)], minimumSelectionAmount = Coin 3825000}))) - 2.600000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2600000)], minimumSelectionAmount = Coin 3900000}))) - 2.650000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2650000)], minimumSelectionAmount = Coin 3975000}))) - 2.700000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [((TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0},Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"),Coin 2700000)], minimumSelectionAmount = Coin 4050000}))) + 1.750000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 1750000)], minimumSelectionAmount = Coin 2625000}))) + 1.800000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 1800000)], minimumSelectionAmount = Coin 2700000}))) + 1.850000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 1850000)], minimumSelectionAmount = Coin 2775000}))) + 1.900000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 1900000)], minimumSelectionAmount = Coin 2850000}))) + 1.950000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 1950000)], minimumSelectionAmount = Coin 2925000}))) + 2.000000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2000000)], minimumSelectionAmount = Coin 3000000}))) + 2.050000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2050000)], minimumSelectionAmount = Coin 3075000}))) + 2.100000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2100000)], minimumSelectionAmount = Coin 3150000}))) + 2.150000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2150000)], minimumSelectionAmount = Coin 3225000}))) + 2.200000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2200000)], minimumSelectionAmount = Coin 3300000}))) + 2.250000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2250000)], minimumSelectionAmount = Coin 3375000}))) + 2.300000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2300000)], minimumSelectionAmount = Coin 3450000}))) + 2.350000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2350000)], minimumSelectionAmount = Coin 3525000}))) + 2.400000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2400000)], minimumSelectionAmount = Coin 3600000}))) + 2.450000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2450000)], minimumSelectionAmount = Coin 3675000}))) + 2.500000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2500000)], minimumSelectionAmount = Coin 3750000}))) + 2.550000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2550000)], minimumSelectionAmount = Coin 3825000}))) + 2.600000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2600000)], minimumSelectionAmount = Coin 3900000}))) + 2.650000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2650000)], minimumSelectionAmount = Coin 3975000}))) + 2.700000,ErrBalanceTxSelectAssets (ErrSelectAssetsSelectionError (SelectionCollateralErrorOf (SelectionCollateralError {largestCombinationAvailable = fromList [(WalletUTxO {txIn = TxIn {inputId = Hash "00000000000000000000000000000000", inputIx = 0}, address = Address "`\177\229\224\251t\200l\128\USdhA\224|\219B\223\139\130\239<\228\229|\181A.w"},Coin 2700000)], minimumSelectionAmount = Coin 4050000}))) 2.750000,0.612050,0.612050 2.800000,0.612050,0.612050 2.850000,0.612050,0.612050 From bd9314f37519cf30f096ffc63bebf68f9bf445f2 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Fri, 11 Mar 2022 20:13:50 +0100 Subject: [PATCH 10/13] Remove need for `WalletAddress` wrapper. by merging the `Dummy` class into `SelectionContext`. --- lib/core/src/Cardano/Wallet/CoinSelection.hs | 27 +++++-------------- .../Cardano/Wallet/CoinSelection/Internal.hs | 6 +++-- .../Wallet/CoinSelection/Internal/Balance.hs | 6 +++-- .../CoinSelection/Internal/Balance/Gen.hs | 6 ++--- .../Wallet/CoinSelection/Internal/Context.hs | 12 +++------ .../CoinSelection/Internal/BalanceSpec.hs | 10 +++---- .../Wallet/CoinSelection/InternalSpec.hs | 23 ++++++++-------- 7 files changed, 37 insertions(+), 53 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 05cdbcebc29..7e842b22e6a 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -27,7 +26,6 @@ module Cardano.Wallet.CoinSelection ( -- * Selection contexts WalletSelectionContext - , WalletAddress (..) , WalletUTxO (..) -- * Mapping between external (wallet) types and internal types @@ -112,8 +110,6 @@ import Control.Monad.Random.Class ( MonadRandom (..) ) import Control.Monad.Trans.Except ( ExceptT (..) ) -import Data.Bifunctor - ( first ) import Data.Generics.Internal.VL.Lens ( over, view ) import Data.List.NonEmpty @@ -149,19 +145,10 @@ import qualified Data.Set as Set data WalletSelectionContext instance SC.SelectionContext WalletSelectionContext where - type Address WalletSelectionContext = WalletAddress + type Address WalletSelectionContext = Address type UTxO WalletSelectionContext = WalletUTxO --------------------------------------------------------------------------------- --- Mapping between external (wallet) and internal addresses --------------------------------------------------------------------------------- - -newtype WalletAddress = WalletAddress - { unWalletAddress :: Address } - deriving (Buildable, Eq, Generic, Ord, Show) - -instance SC.Dummy WalletAddress where - dummy = WalletAddress $ Address "" + dummyAddress _ = Address "" -------------------------------------------------------------------------------- -- Mapping between external (wallet) and internal UTxO identifiers @@ -256,7 +243,7 @@ toInternalSelectionConstraints SelectionConstraints {..} = { computeMinimumCost = computeMinimumCost . toExternalSelectionSkeleton , computeSelectionLimit = - computeSelectionLimit . fmap (uncurry TxOut . first unWalletAddress) + computeSelectionLimit . fmap (uncurry TxOut) , .. } @@ -322,7 +309,7 @@ toInternalSelectionParams SelectionParams {..} = { utxoAvailableForCollateral = Map.mapMaybeWithKey identifyCollateral utxoAvailableForCollateral , outputsToCover = - ((WalletAddress . view #address) &&& view #tokens) + ((view #address) &&& view #tokens) <$> outputsToCover , .. } @@ -369,7 +356,7 @@ toExternalSelectionSkeleton toExternalSelectionSkeleton Internal.SelectionSkeleton {..} = SelectionSkeleton { skeletonOutputs = - uncurry TxOut . first unWalletAddress <$> skeletonOutputs + uncurry TxOut <$> skeletonOutputs , .. } @@ -422,7 +409,7 @@ toExternalSelection _ps Internal.Selection {..} = , inputs = toExternalUTxO <$> inputs , outputs = - uncurry TxOut . first unWalletAddress <$> outputs + uncurry TxOut <$> outputs , .. } @@ -438,7 +425,7 @@ toInternalSelection getChangeBundle Selection {..} = toInternalUTxO' TokenBundle.getCoin <$> collateral , inputs = toInternalUTxO <$> inputs - , outputs = ((WalletAddress . view #address) &&& view #tokens) + , outputs = ((view #address) &&& view #tokens) <$> outputs , .. } diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index 714dce66f3f..3c9a14adf5c 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -77,7 +77,7 @@ import Cardano.Wallet.CoinSelection.Internal.Balance , SelectionStrategy (..) ) import Cardano.Wallet.CoinSelection.Internal.Context - ( Dummy (..), SelectionContext (..) ) + ( SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -112,6 +112,8 @@ import Data.Map.Strict ( Map ) import Data.Maybe ( mapMaybe ) +import Data.Proxy + ( Proxy (..) ) import Data.Ratio ( (%) ) import Data.Semigroup @@ -380,7 +382,7 @@ selectionAllOutputs -> [(Address ctx, TokenBundle)] selectionAllOutputs selection = (<>) (selection ^. #outputs) - (selection ^. #change <&> (dummy @(Address ctx), )) + (selection ^. #change <&> (dummyAddress (Proxy @ctx), )) -- | Creates constraints and parameters for 'Balance.performSelection'. -- diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index 8ab4eb51961..571c313461c 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -129,7 +129,7 @@ import Algebra.PartialOrd import Cardano.Numeric.Util ( padCoalesce ) import Cardano.Wallet.CoinSelection.Internal.Context - ( Dummy (..), SelectionContext (..) ) + ( SelectionContext (..) ) import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) import Cardano.Wallet.Primitive.Types.TokenBundle @@ -174,6 +174,8 @@ import Data.Maybe ( fromMaybe ) import Data.Ord ( comparing ) +import Data.Proxy + ( Proxy (..) ) import Data.Semigroup ( mtimesDefault ) import Data.Set @@ -845,7 +847,7 @@ performSelectionEmpty performSelectionFn constraints params = transform x y = maybe x y $ NE.nonEmpty $ view #outputsToCover params dummyOutput :: (Address ctx, TokenBundle) - dummyOutput = (dummy, TokenBundle.fromCoin minCoin) + dummyOutput = (dummyAddress (Proxy @ctx), TokenBundle.fromCoin minCoin) -- The 'performSelectionNonEmpty' function imposes a precondition that all -- outputs must have at least the minimum ada quantity. Therefore, the diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs index 8b260819c6c..eb08f6fd4d6 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance/Gen.hs @@ -14,7 +14,7 @@ module Cardano.Wallet.CoinSelection.Internal.Balance.Gen import Prelude import Cardano.Wallet.CoinSelection - ( WalletAddress (..), WalletSelectionContext ) + ( WalletSelectionContext ) import Cardano.Wallet.CoinSelection.Internal.Balance ( SelectionLimit , SelectionLimitOf (..) @@ -83,7 +83,7 @@ genSelectionSkeleton = SelectionSkeleton genSkeletonOutputs = listOf genSkeletonOutput genSkeletonOutput = (,) - <$> (WalletAddress <$> genAddress) + <$> genAddress <*> genTokenBundleSmallRange `suchThat` tokenBundleHasNonZeroCoin genSkeletonChange = listOf (Set.fromList <$> listOf genAssetId) @@ -103,7 +103,7 @@ shrinkSelectionSkeleton = genericRoundRobinShrink shrinkList shrinkSkeletonOutput shrinkSkeletonOutput = genericRoundRobinShrink - <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress + <@> shrinkAddress <:> filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange <:> Nil shrinkSkeletonChange = diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs index 13ec19d551a..af92f0ab8db 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs @@ -12,14 +12,13 @@ module Cardano.Wallet.CoinSelection.Internal.Context ( -- * Selection contexts SelectionContext (..) - - -- * Dummy values - , Dummy (..) ) where import Prelude +import Data.Proxy + ( Proxy (..) ) import Fmt ( Buildable ) @@ -28,7 +27,6 @@ import Fmt class ( Buildable (Address c) , Buildable (UTxO c) - , Dummy (Address c) , Ord (Address c) , Ord (UTxO c) , Show (Address c) @@ -43,8 +41,4 @@ class -- | A unique identifier for an individual UTxO. type UTxO c --- | Provides a dummy value for a given type. - -class Dummy d where - -- | Returns a dummy value. - dummy :: d + dummyAddress :: Proxy c -> Address c diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index c3ad69cfaa8..4d3cbe81a32 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -41,7 +41,7 @@ import Algebra.PartialOrd import Cardano.Numeric.Util ( inAscendingPartialOrder ) import Cardano.Wallet.CoinSelection - ( WalletAddress (..), WalletSelectionContext, WalletUTxO (..) ) + ( WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal.Balance ( AssetCount (..) , BalanceInsufficientError (..) @@ -617,7 +617,7 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do [0, 1, max 2 $ UTxOIndex.size utxoAvailable `div` 8] outputsToCover <- replicateM outputCount - (((WalletAddress . view #address) &&& view #tokens) <$> genTxOut) + (((view #address) &&& view #tokens) <$> genTxOut) extraCoinSource <- oneof [pure $ Coin 0, genCoinPositive] extraCoinSink <- @@ -663,7 +663,7 @@ shrinkSelectionParams = genericRoundRobinShrink <:> Nil where shrinkOutput = genericRoundRobinShrink - <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress + <@> shrinkAddress <:> (filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange) <:> Nil where @@ -1850,7 +1850,7 @@ encodeBoundaryTestCriteria encodeBoundaryTestCriteria c = SelectionParams { outputsToCover = zip - (WalletAddress <$> dummyAddresses) + dummyAddresses (uncurry TokenBundle.fromFlatList <$> boundaryTestOutputs c) , utxoAvailable = UTxOSelection.fromIndex @@ -2580,7 +2580,7 @@ shrinkMockComputeSelectionLimit = \case unMockComputeSelectionLimit :: MockComputeSelectionLimit - -> ([(WalletAddress, TokenBundle)] -> SelectionLimit) + -> ([(Address, TokenBundle)] -> SelectionLimit) unMockComputeSelectionLimit = \case MockComputeSelectionLimitNone -> const NoLimit diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index b249b65d19d..581ce8f3e78 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -17,7 +17,7 @@ module Cardano.Wallet.CoinSelection.InternalSpec import Prelude import Cardano.Wallet.CoinSelection - ( WalletAddress (..), WalletSelectionContext, WalletUTxO (..) ) + ( WalletSelectionContext, WalletUTxO (..) ) import Cardano.Wallet.CoinSelection.Internal ( ComputeMinimumCollateralParams (..) , Selection @@ -130,7 +130,6 @@ import Test.QuickCheck , scale , shrink , shrinkList - , shrinkMapBy , suchThat , vectorOf , (===) @@ -413,11 +412,11 @@ prop_toBalanceConstraintsParams_computeSelectionLimit mockConstraints params = maximumCollateralInputCount = constraints ^. #maximumCollateralInputCount computeSelectionLimitOriginal - :: [(WalletAddress, TokenBundle)] -> SelectionLimit + :: [(Address, TokenBundle)] -> SelectionLimit computeSelectionLimitOriginal = constraints ^. #computeSelectionLimit computeSelectionLimitAdjusted - :: [(WalletAddress, TokenBundle)] -> SelectionLimit + :: [(Address, TokenBundle)] -> SelectionLimit computeSelectionLimitAdjusted = toBalanceConstraintsParams (constraints, params) & fst & view #computeSelectionLimit @@ -697,24 +696,24 @@ shrinkExtraCoinOut = shrinkCoin -- Outputs to cover -------------------------------------------------------------------------------- -genOutputsToCover :: Gen [(WalletAddress, TokenBundle)] +genOutputsToCover :: Gen [(Address, TokenBundle)] genOutputsToCover = do count <- choose (1, 4) vectorOf count genOutputToCover where - genOutputToCover :: Gen (WalletAddress, TokenBundle) + genOutputToCover :: Gen (Address, TokenBundle) genOutputToCover = frequency [ (49, scale (`mod` 8) genOutput) , (01, genOutputWith genTokenQuantityThatMayExceedLimit) ] where genOutput = (,) - <$> (WalletAddress <$> genAddress) + <$> genAddress <*> genTokenBundleSmallRange `suchThat` tokenBundleHasNonZeroCoin - genOutputWith :: Gen TokenQuantity -> Gen (WalletAddress, TokenBundle) + genOutputWith :: Gen TokenQuantity -> Gen (Address, TokenBundle) genOutputWith genTokenQuantityFn = (,) - <$> (WalletAddress <$> genAddress) + <$> genAddress <*> genTokenBundleWith genTokenQuantityFn genTokenBundleWith :: Gen TokenQuantity -> Gen TokenBundle @@ -745,12 +744,12 @@ genOutputsToCover = do limit = unTokenQuantity txOutMaxTokenQuantity shrinkOutputsToCover - :: [(WalletAddress, TokenBundle)] - -> [[(WalletAddress, TokenBundle)]] + :: [(Address, TokenBundle)] + -> [[(Address, TokenBundle)]] shrinkOutputsToCover = shrinkList shrinkOutput where shrinkOutput = genericRoundRobinShrink - <@> shrinkMapBy WalletAddress unWalletAddress shrinkAddress + <@> shrinkAddress <:> (filter tokenBundleHasNonZeroCoin . shrinkTokenBundleSmallRange) <:> Nil From 3f759e06ab5044d5110da33d59fde96d8d2d8fe2 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Sat, 12 Mar 2022 02:15:45 +0000 Subject: [PATCH 11/13] Remove redundant brackets around `&&&` combinator operands. Change `(a) &&& b` to `a &&& b`. (and other minor tweaks to layout) --- lib/core/src/Cardano/Wallet/CoinSelection.hs | 25 +++++++++---------- .../CoinSelection/Internal/BalanceSpec.hs | 2 +- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 7e842b22e6a..88e5250b2dd 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -309,8 +309,7 @@ toInternalSelectionParams SelectionParams {..} = { utxoAvailableForCollateral = Map.mapMaybeWithKey identifyCollateral utxoAvailableForCollateral , outputsToCover = - ((view #address) &&& view #tokens) - <$> outputsToCover + (view #address &&& view #tokens) <$> outputsToCover , .. } where @@ -404,12 +403,12 @@ toExternalSelection :: SelectionParams -> Internal.Selection WalletSelectionContext -> Selection toExternalSelection _ps Internal.Selection {..} = Selection - { collateral = - toExternalUTxO' TokenBundle.fromCoin <$> collateral - , inputs = - toExternalUTxO <$> inputs - , outputs = - uncurry TxOut <$> outputs + { collateral = toExternalUTxO' TokenBundle.fromCoin + <$> collateral + , inputs = toExternalUTxO + <$> inputs + , outputs = uncurry TxOut + <$> outputs , .. } @@ -421,11 +420,11 @@ toInternalSelection getChangeBundle Selection {..} = Internal.Selection { change = getChangeBundle <$> change - , collateral = - toInternalUTxO' TokenBundle.getCoin <$> collateral - , inputs = - toInternalUTxO <$> inputs - , outputs = ((view #address) &&& view #tokens) + , collateral = toInternalUTxO' TokenBundle.getCoin + <$> collateral + , inputs = toInternalUTxO + <$> inputs + , outputs = (view #address &&& view #tokens) <$> outputs , .. } diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs index 4d3cbe81a32..80e6e819e5b 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -617,7 +617,7 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do [0, 1, max 2 $ UTxOIndex.size utxoAvailable `div` 8] outputsToCover <- replicateM outputCount - (((view #address) &&& view #tokens) <$> genTxOut) + ((view #address &&& view #tokens) <$> genTxOut) extraCoinSource <- oneof [pure $ Coin 0, genCoinPositive] extraCoinSink <- From 383f6eebf1c8a25d409db529f9fe5e2629b96523 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Sat, 12 Mar 2022 02:32:50 +0000 Subject: [PATCH 12/13] Add comment for function `dummyAddress`. --- lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs index af92f0ab8db..a5de76e4b34 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Context.hs @@ -41,4 +41,5 @@ class -- | A unique identifier for an individual UTxO. type UTxO c + -- | Generates a dummy address value. dummyAddress :: Proxy c -> Address c From 2ee0db4193c768b5b4ce8a934fc96d317cbb85fc Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 10 Mar 2022 08:11:52 +0000 Subject: [PATCH 13/13] Update nix. --- nix/materialized/stack-nix/cardano-wallet-core.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/nix/materialized/stack-nix/cardano-wallet-core.nix b/nix/materialized/stack-nix/cardano-wallet-core.nix index c662508473b..d2290acd3d2 100644 --- a/nix/materialized/stack-nix/cardano-wallet-core.nix +++ b/nix/materialized/stack-nix/cardano-wallet-core.nix @@ -174,6 +174,7 @@ "Cardano/Wallet/CoinSelection/Internal" "Cardano/Wallet/CoinSelection/Internal/Balance" "Cardano/Wallet/CoinSelection/Internal/Collateral" + "Cardano/Wallet/CoinSelection/Internal/Context" "Cardano/Wallet/Compat" "Cardano/Wallet/DB" "Cardano/Wallet/DB/Checkpoints"