diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 82cfdca23ef..4997dfd1867 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -1913,7 +1913,7 @@ data SelectAssetsParams s result = SelectAssetsParams , randomSeed :: Maybe StdGenSeed , txContext :: TransactionCtx , utxoAvailableForCollateral :: Map InputId TokenBundle - , utxoAvailableForInputs :: UTxOSelection + , utxoAvailableForInputs :: UTxOSelection InputId , wallet :: Wallet s } deriving Generic diff --git a/lib/core/src/Cardano/Wallet/CoinSelection.hs b/lib/core/src/Cardano/Wallet/CoinSelection.hs index 29870b7ecb5..dd2644c7841 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection.hs @@ -225,7 +225,7 @@ data SelectionParams = SelectionParams -- This set is allowed to intersect with 'utxoAvailableForInputs', -- since the ledger does not require that these sets are disjoint. , utxoAvailableForInputs - :: !UTxOSelection + :: !(UTxOSelection InputId) -- ^ Specifies a set of UTxOs that are available for selection as -- ordinary inputs and optionally, a subset that has already been -- selected. diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs index 4534b4e2c6b..d71317140b8 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal.hs @@ -215,7 +215,7 @@ data SelectionParams = SelectionParams -- This set is allowed to intersect with 'utxoAvailableForInputs', -- since the ledger does not require that these sets are disjoint. , utxoAvailableForInputs - :: !UTxOSelection + :: !(UTxOSelection InputId) -- ^ Specifies a set of UTxOs that are available for selection as -- ordinary inputs and optionally, a subset that has already been -- selected. @@ -879,7 +879,7 @@ verifyBalanceInsufficientError cs ps e = -------------------------------------------------------------------------------- newtype FailureToVerifyEmptyUTxOError = FailureToVerifyEmptyUTxOError - { utxoAvailableForInputs :: UTxOSelection } + { utxoAvailableForInputs :: UTxOSelection InputId } deriving (Eq, Show) verifyEmptyUTxOError :: VerifySelectionError () diff --git a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs index e89b7eb95e2..f7e46e068fc 100644 --- a/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs +++ b/lib/core/src/Cardano/Wallet/CoinSelection/Internal/Balance.hs @@ -247,7 +247,7 @@ data SelectionParamsOf outputs = SelectionParams :: !outputs -- ^ The complete set of outputs to be covered. , utxoAvailable - :: !UTxOSelection + :: !(UTxOSelection InputId) -- ^ Specifies a set of UTxOs that are available for selection as -- inputs and optionally, a subset that has already been selected. -- @@ -436,7 +436,11 @@ instance Ord a => Ord (SelectionLimitOf a) where -- | Indicates whether or not the given selection limit has been exceeded. -- -selectionLimitExceeded :: IsUTxOSelection s => s -> SelectionLimit -> Bool +selectionLimitExceeded + :: IsUTxOSelection s InputId + => s InputId + -> SelectionLimit + -> Bool selectionLimitExceeded s = \case NoLimit -> False MaximumInputLimit n -> UTxOSelection.selectedSize s > n @@ -946,7 +950,7 @@ performSelectionNonEmpty constraints params -- assets of the final resulting selection). -- predictChange - :: UTxOSelectionNonEmpty + :: UTxOSelectionNonEmpty InputId -> [Set AssetId] predictChange s = either (const $ invariantResultWithNoCost $ UTxOSelection.selectedIndex s) @@ -988,7 +992,7 @@ performSelectionNonEmpty constraints params -- function won't make associated outputs for them. -- makeChangeRepeatedly - :: UTxOSelectionNonEmpty + :: UTxOSelectionNonEmpty InputId -> m ( Either SelectionBalanceError @@ -1092,7 +1096,7 @@ performSelectionNonEmpty constraints params data RunSelectionParams = RunSelectionParams { selectionLimit :: SelectionLimit -- ^ A limit to adhere to when performing a selection. - , utxoAvailable :: UTxOSelection + , utxoAvailable :: (UTxOSelection InputId) -- ^ UTxO entries available for selection. , minimumBalance :: TokenBundle -- ^ Minimum balance to cover. @@ -1100,23 +1104,27 @@ data RunSelectionParams = RunSelectionParams deriving (Eq, Generic, Show) runSelectionNonEmpty - :: MonadRandom m => RunSelectionParams -> m (Maybe UTxOSelectionNonEmpty) + :: MonadRandom m + => RunSelectionParams + -> m (Maybe (UTxOSelectionNonEmpty InputId)) runSelectionNonEmpty = (=<<) <$> runSelectionNonEmptyWith . selectCoinQuantity . view #selectionLimit <*> runSelection runSelectionNonEmptyWith :: Monad m - => (UTxOSelection -> m (Maybe UTxOSelectionNonEmpty)) - -> UTxOSelection - -> m (Maybe UTxOSelectionNonEmpty) + => (UTxOSelection InputId -> m (Maybe (UTxOSelectionNonEmpty InputId))) + -> UTxOSelection InputId + -> m (Maybe (UTxOSelectionNonEmpty InputId)) runSelectionNonEmptyWith selectSingleEntry result = UTxOSelection.toNonEmpty result & maybe (result & selectSingleEntry) (pure . Just) runSelection - :: forall m. MonadRandom m => RunSelectionParams -> m UTxOSelection + :: forall m. MonadRandom m + => RunSelectionParams + -> m (UTxOSelection InputId) runSelection params = runRoundRobinM utxoAvailable UTxOSelection.fromNonEmpty selectors where @@ -1130,7 +1138,8 @@ runSelection params = -- necessarily has a non-zero ada amount. By running the other selectors -- first, we increase the probability that the coin selector will be able -- to terminate without needing to select an additional coin. - selectors :: [UTxOSelection -> m (Maybe UTxOSelectionNonEmpty)] + selectors + :: [UTxOSelection InputId -> m (Maybe (UTxOSelectionNonEmpty InputId))] selectors = reverse (coinSelector : fmap assetSelector minimumAssetQuantities) where @@ -1146,7 +1155,7 @@ assetSelectionLens :: MonadRandom m => SelectionLimit -> (AssetId, TokenQuantity) - -> SelectionLens m UTxOSelection UTxOSelectionNonEmpty + -> SelectionLens m (UTxOSelection InputId) (UTxOSelectionNonEmpty InputId) assetSelectionLens limit (asset, minimumAssetQuantity) = SelectionLens { currentQuantity = selectedAssetQuantity asset , updatedQuantity = selectedAssetQuantity asset @@ -1159,7 +1168,7 @@ coinSelectionLens => SelectionLimit -> Coin -- ^ Minimum coin quantity. - -> SelectionLens m UTxOSelection UTxOSelectionNonEmpty + -> SelectionLens m (UTxOSelection InputId) (UTxOSelectionNonEmpty InputId) coinSelectionLens limit minimumCoinQuantity = SelectionLens { currentQuantity = selectedCoinQuantity , updatedQuantity = selectedCoinQuantity @@ -1171,11 +1180,11 @@ coinSelectionLens limit minimumCoinQuantity = SelectionLens -- selectAssetQuantity :: MonadRandom m - => IsUTxOSelection utxoSelection + => IsUTxOSelection utxoSelection InputId => AssetId -> SelectionLimit - -> utxoSelection - -> m (Maybe UTxOSelectionNonEmpty) + -> utxoSelection InputId + -> m (Maybe (UTxOSelectionNonEmpty InputId)) selectAssetQuantity asset = selectMatchingQuantity (WithAssetOnly asset :| [WithAsset asset]) @@ -1183,10 +1192,10 @@ selectAssetQuantity asset = -- selectCoinQuantity :: MonadRandom m - => IsUTxOSelection utxoSelection + => IsUTxOSelection utxoSelection InputId => SelectionLimit - -> utxoSelection - -> m (Maybe UTxOSelectionNonEmpty) + -> utxoSelection InputId + -> m (Maybe (UTxOSelectionNonEmpty InputId)) selectCoinQuantity = selectMatchingQuantity (WithAdaOnly :| [Any]) @@ -1208,15 +1217,15 @@ selectCoinQuantity = -- selectMatchingQuantity :: MonadRandom m - => IsUTxOSelection utxoSelection + => IsUTxOSelection utxoSelection InputId => NonEmpty SelectionFilter -- ^ A list of selection filters to be traversed from left-to-right, -- in descending order of priority. -> SelectionLimit -- ^ A limit to adhere to when selecting entries. - -> utxoSelection + -> utxoSelection InputId -- ^ The current selection state. - -> m (Maybe UTxOSelectionNonEmpty) + -> m (Maybe (UTxOSelectionNonEmpty InputId)) -- ^ An updated selection state that includes a matching UTxO entry, -- or 'Nothing' if no such entry could be found. selectMatchingQuantity filters limit s @@ -1232,7 +1241,7 @@ selectMatchingQuantity filters limit s updateState :: ((InputId, TokenBundle), UTxOIndex InputId) - -> Maybe UTxOSelectionNonEmpty + -> Maybe (UTxOSelectionNonEmpty InputId) updateState ((i, _b), _remaining) = UTxOSelection.select i s -------------------------------------------------------------------------------- @@ -2141,13 +2150,15 @@ runRoundRobinM state demote processors = go state processors [] -- Accessor functions -------------------------------------------------------------------------------- -selectedAssetQuantity :: IsUTxOSelection s => AssetId -> s -> Natural +selectedAssetQuantity + :: IsUTxOSelection s InputId => AssetId -> s InputId -> Natural selectedAssetQuantity asset = unTokenQuantity . flip TokenBundle.getQuantity asset . UTxOSelection.selectedBalance -selectedCoinQuantity :: IsUTxOSelection s => s -> Natural +selectedCoinQuantity + :: IsUTxOSelection s InputId => s InputId -> Natural selectedCoinQuantity = intCast . unCoin diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection.hs index 4ae7532b4c8..f011c862914 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -67,12 +70,12 @@ module Cardano.Wallet.Primitive.Types.UTxOSelection , leftoverSize , leftoverIndex , leftoverList - , leftoverUTxO + , leftoverMap , selectedBalance , selectedSize , selectedIndex , selectedList - , selectedUTxO + , selectedMap -- * Modification , select @@ -82,12 +85,8 @@ module Cardano.Wallet.Primitive.Types.UTxOSelection import Prelude -import Cardano.Wallet.Primitive.Types.Address - ( Address ) import Cardano.Wallet.Primitive.Types.TokenBundle ( TokenBundle ) -import Cardano.Wallet.Primitive.Types.Tx - ( TxIn ) import Cardano.Wallet.Primitive.Types.UTxOIndex ( UTxOIndex ) import Control.Monad @@ -120,66 +119,60 @@ import qualified Data.Map.Strict as Map -- Classes -------------------------------------------------------------------------------- -class HasUTxOSelectionState u where +class HasUTxOSelectionState s u where -- | Retrieves the internal state from a selection. - state :: u -> State + state :: s u -> State u -- | Reconstructs a selection from an internal state. - fromState :: State -> u + fromState :: State u -> s u -class HasUTxOSelectionState u => IsUTxOSelection u where +class HasUTxOSelectionState s u => IsUTxOSelection s u where -- | The type of the list of selected UTxOs. - type SelectedList u + type SelectedList s u -- | Retrieves a list of the selected UTxOs. - selectedList :: u -> SelectedList u + selectedList :: s u -> SelectedList s u -------------------------------------------------------------------------------- -- Types -------------------------------------------------------------------------------- --- TODO: ADP-1448: --- --- Replace this type synonym with a type parameter on types that use it. --- -type InputId = (TxIn, Address) - -- | The internal state of a selection. -- -data State = State - { leftover :: !(UTxOIndex InputId) +data State u = State + { leftover :: !(UTxOIndex u) -- ^ UTxOs that have not yet been selected. - , selected :: !(UTxOIndex InputId) + , selected :: !(UTxOIndex u) -- ^ UTxOs that have already been selected. } deriving (Eq, Generic, Show) -- | A selection for which 'isNonEmpty' may be 'False'. -- -newtype UTxOSelection = UTxOSelection State +newtype UTxOSelection u = UTxOSelection (State u) deriving (Eq, Generic, Show) -- | A selection for which 'isNonEmpty' must be 'True'. -- -newtype UTxOSelectionNonEmpty = UTxOSelectionNonEmpty State +newtype UTxOSelectionNonEmpty u = UTxOSelectionNonEmpty (State u) deriving (Eq, Generic, Show) -instance HasUTxOSelectionState UTxOSelection where +instance HasUTxOSelectionState UTxOSelection u where state (UTxOSelection s) = s fromState s = UTxOSelection s -instance HasUTxOSelectionState UTxOSelectionNonEmpty where +instance HasUTxOSelectionState UTxOSelectionNonEmpty u where state (UTxOSelectionNonEmpty s) = s fromState s = UTxOSelectionNonEmpty s -instance IsUTxOSelection UTxOSelection where - type SelectedList UTxOSelection = [(InputId, TokenBundle)] +instance IsUTxOSelection UTxOSelection u where + type SelectedList UTxOSelection u = [(u, TokenBundle)] selectedList = UTxOIndex.toList . selectedIndex -instance IsUTxOSelection UTxOSelectionNonEmpty where - type SelectedList UTxOSelectionNonEmpty = NonEmpty (InputId, TokenBundle) +instance IsUTxOSelection UTxOSelectionNonEmpty u where + type SelectedList UTxOSelectionNonEmpty u = NonEmpty (u, TokenBundle) selectedList = NE.fromList . UTxOIndex.toList . selectedIndex -------------------------------------------------------------------------------- @@ -188,14 +181,14 @@ instance IsUTxOSelection UTxOSelectionNonEmpty where -- | A completely empty selection with no selected or leftover UTxOs. -- -empty :: UTxOSelection +empty :: UTxOSelection u empty = fromIndex UTxOIndex.empty -- | Creates a selection where none of the UTxOs are selected. -- -- All UTxOs in the index will be added to the leftover set. -- -fromIndex :: UTxOIndex InputId -> UTxOSelection +fromIndex :: UTxOIndex u -> UTxOSelection u fromIndex i = UTxOSelection State { leftover = i , selected = UTxOIndex.empty @@ -206,7 +199,7 @@ fromIndex i = UTxOSelection State -- All UTxOs that match the given filter will be added to the selected set, -- whereas all UTxOs that do not match will be added to the leftover set. -- -fromIndexFiltered :: (InputId -> Bool) -> UTxOIndex InputId -> UTxOSelection +fromIndexFiltered :: Ord u => (u -> Bool) -> UTxOIndex u -> UTxOSelection u fromIndexFiltered f = UTxOSelection . uncurry State . swap . UTxOIndex.partition f @@ -217,7 +210,7 @@ fromIndexFiltered f = -- -- Any items that are in both sets are removed from the leftover set. -- -fromIndexPair :: (UTxOIndex InputId, UTxOIndex InputId) -> UTxOSelection +fromIndexPair :: Ord u => (UTxOIndex u, UTxOIndex u) -> UTxOSelection u fromIndexPair (leftover, selected) = UTxOSelection State { leftover = leftover `UTxOIndex.difference` selected @@ -229,7 +222,7 @@ fromIndexPair (leftover, selected) = -- The 1st index in the pair represents the leftover set. -- The 2nd index in the pair represents the selected set. -- -toIndexPair :: IsUTxOSelection u => u -> (UTxOIndex InputId, UTxOIndex InputId) +toIndexPair :: IsUTxOSelection s u => s u -> (UTxOIndex u, UTxOIndex u) toIndexPair s = (leftoverIndex s, selectedIndex s) -------------------------------------------------------------------------------- @@ -238,14 +231,14 @@ toIndexPair s = (leftoverIndex s, selectedIndex s) -- | Demotes a non-empty selection to an ordinary selection. -- -fromNonEmpty :: UTxOSelectionNonEmpty -> UTxOSelection +fromNonEmpty :: UTxOSelectionNonEmpty u -> UTxOSelection u fromNonEmpty = UTxOSelection . state -- | Promotes an ordinary selection to a non-empty selection. -- -- Returns 'Nothing' if the the selected set is empty. -- -toNonEmpty :: IsUTxOSelection u => u -> Maybe UTxOSelectionNonEmpty +toNonEmpty :: IsUTxOSelection s u => s u -> Maybe (UTxOSelectionNonEmpty u) toNonEmpty s = bool Nothing (Just $ fromState $ state s) (isNonEmpty s) -------------------------------------------------------------------------------- @@ -254,30 +247,30 @@ toNonEmpty s = bool Nothing (Just $ fromState $ state s) (isNonEmpty s) -- | Returns 'True' if and only if the selected set is empty. -- -isEmpty :: IsUTxOSelection u => u -> Bool +isEmpty :: IsUTxOSelection s u => s u -> Bool isEmpty = (== 0) . selectedSize -- | Returns 'True' if and only if the selected set is non-empty. -- -isNonEmpty :: IsUTxOSelection u => u -> Bool +isNonEmpty :: IsUTxOSelection s u => s u -> Bool isNonEmpty = not . isEmpty -- | Returns 'True' if the given 'InputId' is a member of either set. -- -- Otherwise, returns 'False'. -- -isMember :: IsUTxOSelection s => InputId -> s -> Bool -isMember i s = isLeftover i s || isSelected i s +isMember :: IsUTxOSelection s u => Ord u => u -> s u -> Bool +isMember u s = isLeftover u s || isSelected u s -- | Returns 'True' iff. the given 'InputId' is a member of the leftover set. -- -isLeftover :: IsUTxOSelection s => InputId -> s -> Bool -isLeftover i = UTxOIndex.member i . leftoverIndex +isLeftover :: IsUTxOSelection s u => Ord u => u -> s u -> Bool +isLeftover u = UTxOIndex.member u . leftoverIndex -- | Returns 'True' iff. the given 'InputId' is a member of the selected set. -- -isSelected :: IsUTxOSelection s => InputId -> s -> Bool -isSelected i = UTxOIndex.member i . selectedIndex +isSelected :: IsUTxOSelection s u => Ord u => u -> s u -> Bool +isSelected u = UTxOIndex.member u . selectedIndex -- | Returns 'True' iff. the first selection is a sub-selection of the second. -- @@ -286,12 +279,16 @@ isSelected i = UTxOIndex.member i . selectedIndex -- of the 'select' function. -- isSubSelectionOf - :: IsUTxOSelection u1 => IsUTxOSelection u2 => u1 -> u2 -> Bool -isSubSelectionOf u1 u2 = state (selectMany toSelect u1) == state u2 + :: IsUTxOSelection s1 u + => IsUTxOSelection s2 u + => Ord u + => s1 u + -> s2 u + -> Bool +isSubSelectionOf s1 s2 = state (selectMany toSelect s1) == state s2 where - toSelect :: [InputId] toSelect = fst <$> Map.toList - (selectedUTxO u2 `Map.difference` selectedUTxO u1) + (selectedMap s2 `Map.difference` selectedMap s1) -- | Returns 'True' iff. the first selection is a proper sub-selection of the -- second. @@ -301,8 +298,13 @@ isSubSelectionOf u1 u2 = state (selectMany toSelect u1) == state u2 -- applications of the 'select' function. -- isProperSubSelectionOf - :: IsUTxOSelection u1 => IsUTxOSelection u2 => u1 -> u2 -> Bool -isProperSubSelectionOf u1 u2 = state u1 /= state u2 && u1 `isSubSelectionOf` u2 + :: IsUTxOSelection s1 u + => IsUTxOSelection s2 u + => Ord u + => s1 u + -> s2 u + -> Bool +isProperSubSelectionOf s1 s2 = state s1 /= state s2 && s1 `isSubSelectionOf` s2 -------------------------------------------------------------------------------- -- Accessor functions @@ -318,69 +320,69 @@ isProperSubSelectionOf u1 u2 = state u1 /= state u2 && u1 `isSubSelectionOf` u2 -- This result of this function remains constant over applications of 'select' -- and 'selectMany': -- --- >>> availableBalance u == availableBalance (selectMany is u) +-- >>> availableBalance s == availableBalance (selectMany is s) -- -availableBalance :: IsUTxOSelection u => u -> TokenBundle -availableBalance u = leftoverBalance u <> selectedBalance u +availableBalance :: IsUTxOSelection s u => s u -> TokenBundle +availableBalance s = leftoverBalance s <> selectedBalance s -- | Computes the available UTxO set. -- -- The available UTxO set is the union of the selected and leftover UTxO sets. -- --- It predicts what 'selectedUTxO' would be if every single UTxO were selected. +-- It predicts what 'selectedMap' would be if every single UTxO were selected. -- -- This result of this function remains constant over applications of 'select' -- and 'selectMany': -- --- >>> availableUTxO u == availableUTxO (selectMany is u) +-- >>> availableUTxO s == availableUTxO (selectMany is s) -- -availableUTxO :: IsUTxOSelection u => u -> Map InputId TokenBundle -availableUTxO u = leftoverUTxO u <> selectedUTxO u +availableUTxO :: IsUTxOSelection s u => Ord u => s u -> Map u TokenBundle +availableUTxO s = leftoverMap s <> selectedMap s -- | Retrieves the balance of leftover UTxOs. -- -leftoverBalance :: IsUTxOSelection u => u -> TokenBundle +leftoverBalance :: IsUTxOSelection s u => s u -> TokenBundle leftoverBalance = UTxOIndex.balance . leftoverIndex -- | Retrieves the size of the leftover UTxO set. -- -leftoverSize :: IsUTxOSelection u => u -> Int +leftoverSize :: IsUTxOSelection s u => s u -> Int leftoverSize = UTxOIndex.size . leftoverIndex -- | Retrieves an index of the leftover UTxOs. -- -leftoverIndex :: IsUTxOSelection u => u -> UTxOIndex InputId +leftoverIndex :: IsUTxOSelection s u => s u -> UTxOIndex u leftoverIndex = leftover . state --- | Retrieves the leftover UTxO set. +-- | Retrieves a map of the leftover UTxOs. -- -leftoverUTxO :: IsUTxOSelection u => u -> Map InputId TokenBundle -leftoverUTxO = UTxOIndex.toMap . leftoverIndex +leftoverMap :: IsUTxOSelection s u => s u -> Map u TokenBundle +leftoverMap = UTxOIndex.toMap . leftoverIndex -- | Retrieves a list of the leftover UTxOs. -- -leftoverList :: IsUTxOSelection u => u -> [(InputId, TokenBundle)] +leftoverList :: IsUTxOSelection s u => s u -> [(u, TokenBundle)] leftoverList = UTxOIndex.toList . leftoverIndex -- | Retrieves the balance of selected UTxOs. -- -selectedBalance :: IsUTxOSelection u => u -> TokenBundle +selectedBalance :: IsUTxOSelection s u => s u -> TokenBundle selectedBalance = UTxOIndex.balance . selectedIndex -- | Retrieves the size of the selected UTxO set. -- -selectedSize :: IsUTxOSelection u => u -> Int +selectedSize :: IsUTxOSelection s u => s u -> Int selectedSize = UTxOIndex.size . selectedIndex -- | Retrieves an index of the selected UTxOs. -- -selectedIndex :: IsUTxOSelection u => u -> UTxOIndex InputId +selectedIndex :: IsUTxOSelection s u => s u -> UTxOIndex u selectedIndex = selected . state --- | Retrieves the selected UTxO set. +-- | Retrieves a map of the selected UTxOs. -- -selectedUTxO :: IsUTxOSelection u => u -> Map InputId TokenBundle -selectedUTxO = UTxOIndex.toMap . selectedIndex +selectedMap :: IsUTxOSelection s u => s u -> Map u TokenBundle +selectedMap = UTxOIndex.toMap . selectedIndex -------------------------------------------------------------------------------- -- Modification @@ -390,12 +392,23 @@ selectedUTxO = UTxOIndex.toMap . selectedIndex -- -- Returns 'Nothing' if the given entry is not a member of the leftover set. -- -select :: IsUTxOSelection u => InputId -> u -> Maybe UTxOSelectionNonEmpty +select + :: IsUTxOSelection s u + => Ord u + => u + -> s u + -> Maybe (UTxOSelectionNonEmpty u) select = (toNonEmpty <=<) . withState . selectState -- | Moves multiple entries from the leftover set to the selected set. -- -selectMany :: IsUTxOSelection u => Foldable f => f InputId -> u -> u +selectMany + :: IsUTxOSelection s u + => Ord u + => Foldable f + => f u + -> s u + -> s u selectMany = ap fromMaybe . withState . flip (F.foldrM selectState) -------------------------------------------------------------------------------- @@ -404,15 +417,20 @@ selectMany = ap fromMaybe . withState . flip (F.foldrM selectState) -- | Moves a single entry from the leftover set to the selected set. -- -selectState :: InputId -> State -> Maybe State -selectState i s = - updateFields <$> UTxOIndex.lookup i (leftover s) +selectState :: Ord u => u -> State u -> Maybe (State u) +selectState u s = + updateFields <$> UTxOIndex.lookup u (leftover s) where - updateFields o = s - & over #leftover (UTxOIndex.delete i) - & over #selected (UTxOIndex.insert i o) + updateFields b = s + & over #leftover (UTxOIndex.delete u) + & over #selected (UTxOIndex.insert u b) -- | Applies the given function to the internal state. -- -withState :: Functor f => IsUTxOSelection u => (State -> f State) -> u -> f u +withState + :: Functor f + => IsUTxOSelection s u + => (State u -> f (State u)) + -> s u + -> f (s u) withState f = fmap fromState . f . state 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 edbd74198c6..4754dde2570 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection/Gen.hs @@ -51,7 +51,7 @@ coarbitraryInputId = coarbitrary . show genInputIdFunction :: Gen a -> Gen (InputId -> a) genInputIdFunction = genFunction coarbitraryInputId -genUTxOSelection :: Gen UTxOSelection +genUTxOSelection :: Gen (UTxOSelection InputId) genUTxOSelection = UTxOSelection.fromIndexFiltered <$> genFilter <*> genUTxOIndex @@ -59,7 +59,7 @@ genUTxOSelection = UTxOSelection.fromIndexFiltered genFilter :: Gen (InputId -> Bool) genFilter = genInputIdFunction (arbitrary @Bool) -shrinkUTxOSelection :: UTxOSelection -> [UTxOSelection] +shrinkUTxOSelection :: UTxOSelection InputId -> [UTxOSelection InputId] shrinkUTxOSelection = shrinkMapBy UTxOSelection.fromIndexPair UTxOSelection.toIndexPair $ liftShrink2 @@ -70,11 +70,13 @@ shrinkUTxOSelection = -- Selections that are non-empty -------------------------------------------------------------------------------- -genUTxOSelectionNonEmpty :: Gen UTxOSelectionNonEmpty +genUTxOSelectionNonEmpty :: Gen (UTxOSelectionNonEmpty InputId) genUTxOSelectionNonEmpty = genUTxOSelection `suchThatMap` UTxOSelection.toNonEmpty -shrinkUTxOSelectionNonEmpty :: UTxOSelectionNonEmpty -> [UTxOSelectionNonEmpty] +shrinkUTxOSelectionNonEmpty + :: UTxOSelectionNonEmpty InputId + -> [UTxOSelectionNonEmpty InputId] shrinkUTxOSelectionNonEmpty = mapMaybe UTxOSelection.toNonEmpty . shrinkUTxOSelection 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 850ea8ecc27..7472249572b 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/Internal/BalanceSpec.hs @@ -1267,7 +1267,7 @@ prop_runSelection_UTxO_empty balanceRequested = monadicIO $ do where utxoAvailable = UTxOSelection.fromIndex UTxOIndex.empty -prop_runSelection_UTxO_notEnough :: UTxOSelection -> Property +prop_runSelection_UTxO_notEnough :: UTxOSelection InputId -> Property prop_runSelection_UTxO_notEnough utxoAvailable = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1290,7 +1290,7 @@ prop_runSelection_UTxO_notEnough utxoAvailable = monadicIO $ do balanceAvailable = UTxOSelection.availableBalance utxoAvailable balanceRequested = adjustAllTokenBundleQuantities (* 2) balanceAvailable -prop_runSelection_UTxO_exactlyEnough :: UTxOSelection -> Property +prop_runSelection_UTxO_exactlyEnough :: UTxOSelection InputId -> Property prop_runSelection_UTxO_exactlyEnough utxoAvailable = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1317,7 +1317,7 @@ prop_runSelection_UTxO_exactlyEnough utxoAvailable = monadicIO $ do where balanceRequested = UTxOSelection.availableBalance utxoAvailable -prop_runSelection_UTxO_moreThanEnough :: UTxOSelection -> Property +prop_runSelection_UTxO_moreThanEnough :: UTxOSelection InputId -> Property prop_runSelection_UTxO_moreThanEnough utxoAvailable = monadicIO $ do result <- run $ runSelection RunSelectionParams @@ -1410,7 +1410,7 @@ prop_runSelection_UTxO_muchMoreThanEnough (Blind (Large index)) = -- Running a selection (non-empty) -------------------------------------------------------------------------------- -prop_runSelectionNonEmpty :: UTxOSelection -> Property +prop_runSelectionNonEmpty :: UTxOSelection InputId -> Property prop_runSelectionNonEmpty result = case (haveLeftover, haveSelected) of (False, False) -> @@ -1452,20 +1452,22 @@ prop_runSelectionNonEmpty result = (UTxOSelection.leftoverIndex resultNonEmpty) === UTxOSelection.leftoverIndex result - maybeResultNonEmpty :: Maybe UTxOSelectionNonEmpty + maybeResultNonEmpty :: Maybe (UTxOSelectionNonEmpty InputId) maybeResultNonEmpty = runIdentity $ runSelectionNonEmptyWith (Identity <$> mockSelectSingleEntry) (result) -mockSelectSingleEntry :: UTxOSelection -> Maybe UTxOSelectionNonEmpty +mockSelectSingleEntry + :: UTxOSelection InputId -> Maybe (UTxOSelectionNonEmpty InputId) mockSelectSingleEntry state = selectEntry =<< firstLeftoverEntry state where - firstLeftoverEntry :: UTxOSelection -> Maybe (InputId, TokenBundle) + firstLeftoverEntry :: UTxOSelection InputId -> Maybe (InputId, TokenBundle) firstLeftoverEntry = listToMaybe . UTxOIndex.toList . UTxOSelection.leftoverIndex - selectEntry :: (InputId, TokenBundle) -> Maybe UTxOSelectionNonEmpty + selectEntry + :: (InputId, TokenBundle) -> Maybe (UTxOSelectionNonEmpty InputId) selectEntry (i, _b) = UTxOSelection.select i state -------------------------------------------------------------------------------- @@ -4066,7 +4068,7 @@ instance Arbitrary TxOut where arbitrary = genTxOut shrink = shrinkTxOut -instance Arbitrary UTxOSelection where +instance Arbitrary (UTxOSelection InputId) where arbitrary = genUTxOSelection shrink = shrinkUTxOSelection diff --git a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs index 86c7e432b24..afab8aa631e 100644 --- a/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/CoinSelection/InternalSpec.hs @@ -788,7 +788,7 @@ genUTxOAvailableForCollateral = genMapWith genInputId genCoinPositive genInputId :: Gen InputId genInputId = genSized2 genTxIn genAddress -genUTxOAvailableForInputs :: Gen UTxOSelection +genUTxOAvailableForInputs :: Gen (UTxOSelection InputId) genUTxOAvailableForInputs = frequency [ (49, genUTxOSelection) , (01, pure UTxOSelection.empty) @@ -804,7 +804,7 @@ shrinkUTxOAvailableForCollateral = <:> shrinkAddress <:> Nil -shrinkUTxOAvailableForInputs :: UTxOSelection -> [UTxOSelection] +shrinkUTxOAvailableForInputs :: UTxOSelection InputId -> [UTxOSelection InputId] shrinkUTxOAvailableForInputs = shrinkUTxOSelection -------------------------------------------------------------------------------- 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 aba6b942b01..a0198566a24 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/Types/UTxOSelectionSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- HLINT ignore "Use camelCase" -} @@ -167,7 +168,7 @@ prop_shrinkUTxOSelectionNonEmpty = conjoin (isValidSelectionNonEmpty <$> shrinkUTxOSelectionNonEmpty s) checkCoverage_UTxOSelection - :: Testable p => IsUTxOSelection s => s -> (p -> Property) + :: Testable p => IsUTxOSelection s InputId => s InputId -> (p -> Property) checkCoverage_UTxOSelection s = checkCoverage_UTxOSelectionNonEmpty s . cover 2 (0 == ssize && ssize == lsize) "0 == lsize && lsize == ssize" @@ -177,7 +178,7 @@ checkCoverage_UTxOSelection s ssize = UTxOSelection.selectedSize s checkCoverage_UTxOSelectionNonEmpty - :: Testable p => IsUTxOSelection s => s -> (p -> Property) + :: Testable p => IsUTxOSelection s InputId => s InputId -> (p -> Property) checkCoverage_UTxOSelectionNonEmpty s = checkCoverage . cover 2 (0 == lsize && lsize < ssize) "0 == lsize && lsize < ssize" @@ -222,7 +223,7 @@ prop_fromIndexFiltered_toIndexPair f u = UTxOSelection.toIndexPair (UTxOSelection.fromIndexFiltered f u) === (UTxOIndex.filter (not . f) u, UTxOIndex.filter f u) -prop_fromIndexPair_toIndexPair :: UTxOSelection -> Property +prop_fromIndexPair_toIndexPair :: UTxOSelection InputId -> Property prop_fromIndexPair_toIndexPair s = checkCoverage_UTxOSelection s $ UTxOSelection.fromIndexPair (UTxOSelection.toIndexPair s) @@ -232,13 +233,13 @@ prop_fromIndexPair_toIndexPair s = -- Promotion and demotion -------------------------------------------------------------------------------- -prop_fromNonEmpty_toNonEmpty :: UTxOSelectionNonEmpty -> Property +prop_fromNonEmpty_toNonEmpty :: UTxOSelectionNonEmpty InputId -> Property prop_fromNonEmpty_toNonEmpty s = checkCoverage_UTxOSelectionNonEmpty s $ UTxOSelection.toNonEmpty (UTxOSelection.fromNonEmpty s) === Just s -prop_toNonEmpty_fromNonEmpty :: UTxOSelection -> Property +prop_toNonEmpty_fromNonEmpty :: UTxOSelection InputId -> Property prop_toNonEmpty_fromNonEmpty s = checkCoverage_UTxOSelection s $ (UTxOSelection.fromNonEmpty <$> UTxOSelection.toNonEmpty s) @@ -248,31 +249,31 @@ prop_toNonEmpty_fromNonEmpty s = -- Indicator and accessor functions -------------------------------------------------------------------------------- -prop_availableBalance_availableUTxO :: UTxOSelection -> Property +prop_availableBalance_availableUTxO :: UTxOSelection InputId -> Property prop_availableBalance_availableUTxO s = checkCoverage_UTxOSelection s $ UTxOSelection.availableBalance s === F.fold (UTxOSelection.availableUTxO s) -prop_isNonEmpty_selectedSize :: UTxOSelection -> Property +prop_isNonEmpty_selectedSize :: UTxOSelection InputId -> Property prop_isNonEmpty_selectedSize s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === (UTxOSelection.selectedSize s > 0) -prop_isNonEmpty_selectedIndex :: UTxOSelection -> Property +prop_isNonEmpty_selectedIndex :: UTxOSelection InputId -> Property prop_isNonEmpty_selectedIndex s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === not (UTxOIndex.null (UTxOSelection.selectedIndex s)) -prop_isNonEmpty_selectedList :: UTxOSelection -> Property +prop_isNonEmpty_selectedList :: UTxOSelection InputId -> Property prop_isNonEmpty_selectedList s = checkCoverage_UTxOSelection s $ UTxOSelection.isNonEmpty s === not (null (UTxOSelection.selectedList s)) -prop_leftoverBalance_selectedBalance :: UTxOSelection -> Property +prop_leftoverBalance_selectedBalance :: UTxOSelection InputId -> Property prop_leftoverBalance_selectedBalance s = checkCoverage_UTxOSelection s $ (UTxOSelection.leftoverBalance s <> UTxOSelection.selectedBalance s) @@ -281,7 +282,7 @@ prop_leftoverBalance_selectedBalance s = (UTxOIndex.balance (UTxOSelection.leftoverIndex s)) (UTxOIndex.balance (UTxOSelection.selectedIndex s)) -prop_leftoverSize_selectedSize :: UTxOSelection -> Property +prop_leftoverSize_selectedSize :: UTxOSelection InputId -> Property prop_leftoverSize_selectedSize s = checkCoverage_UTxOSelection s $ (UTxOSelection.leftoverSize s + UTxOSelection.selectedSize s) @@ -298,33 +299,34 @@ prop_select_empty :: InputId -> Property prop_select_empty i = UTxOSelection.select i UTxOSelection.empty === Nothing -prop_select_isValid :: InputId -> UTxOSelection -> Property +prop_select_isValid :: InputId -> UTxOSelection InputId -> Property prop_select_isValid i s = property $ checkCoverage_select i s $ maybe True isValidSelectionNonEmpty (UTxOSelection.select i s) -prop_select_isLeftover :: InputId -> UTxOSelection -> Property +prop_select_isLeftover :: InputId -> UTxOSelection InputId -> 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 -> Property +prop_select_isSelected :: InputId -> UTxOSelection InputId -> Property prop_select_isSelected i s = checkCoverage_select i s $ (UTxOSelection.isSelected i <$> UTxOSelection.select i s) === if UTxOSelection.isLeftover i s then Just True else Nothing -prop_select_isProperSubSelectionOf :: InputId -> UTxOSelection -> Property +prop_select_isProperSubSelectionOf + :: InputId -> UTxOSelection InputId -> 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 -> Property +prop_select_availableBalance :: InputId -> UTxOSelection InputId -> Property prop_select_availableBalance i s = checkCoverage_select i s $ (UTxOSelection.availableBalance <$> UTxOSelection.select i s) @@ -333,7 +335,7 @@ prop_select_availableBalance i s = then Just (UTxOSelection.availableBalance s) else Nothing -prop_select_availableUTxO :: InputId -> UTxOSelection -> Property +prop_select_availableUTxO :: InputId -> UTxOSelection InputId -> Property prop_select_availableUTxO i s = checkCoverage_select i s $ (UTxOSelection.availableUTxO <$> UTxOSelection.select i s) @@ -342,7 +344,7 @@ prop_select_availableUTxO i s = then Just (UTxOSelection.availableUTxO s) else Nothing -prop_select_leftoverSize :: InputId -> UTxOSelection -> Property +prop_select_leftoverSize :: InputId -> UTxOSelection InputId -> Property prop_select_leftoverSize i s = checkCoverage_select i s $ (UTxOSelection.leftoverSize <$> UTxOSelection.select i s) @@ -351,7 +353,7 @@ prop_select_leftoverSize i s = then Just (UTxOSelection.leftoverSize s - 1) else Nothing -prop_select_selectedSize :: InputId -> UTxOSelection -> Property +prop_select_selectedSize :: InputId -> UTxOSelection InputId -> Property prop_select_selectedSize i s = checkCoverage_select i s $ (UTxOSelection.selectedSize <$> UTxOSelection.select i s) @@ -361,7 +363,7 @@ prop_select_selectedSize i s = else Nothing prop_selectMany_isSubSelectionOf - :: (InputId -> Bool) -> UTxOSelection -> Property + :: (InputId -> Bool) -> UTxOSelection InputId -> Property prop_selectMany_isSubSelectionOf f s = checkCoverage_UTxOSelection s $ UTxOSelection.isSubSelectionOf s (UTxOSelection.selectMany toSelect s) @@ -369,14 +371,14 @@ prop_selectMany_isSubSelectionOf f s = where toSelect = filter f $ fst <$> UTxOSelection.leftoverList s -prop_selectMany_leftoverSize_all :: UTxOSelection -> Property +prop_selectMany_leftoverSize_all :: UTxOSelection InputId -> Property prop_selectMany_leftoverSize_all s = checkCoverage_UTxOSelection s $ UTxOSelection.leftoverSize (UTxOSelection.selectMany (fst <$> UTxOSelection.leftoverList s) s) === 0 -prop_selectMany_selectedSize_all :: UTxOSelection -> Property +prop_selectMany_selectedSize_all :: UTxOSelection InputId -> Property prop_selectMany_selectedSize_all s = checkCoverage_UTxOSelection s $ UTxOSelection.selectedSize @@ -384,7 +386,7 @@ prop_selectMany_selectedSize_all s = === (UTxOSelection.leftoverSize s + UTxOSelection.selectedSize s) checkCoverage_select - :: Testable prop => InputId -> UTxOSelection -> (prop -> Property) + :: Testable prop => InputId -> UTxOSelection InputId -> (prop -> Property) checkCoverage_select i s = checkCoverage . cover 10 (UTxOSelection.isLeftover i s) @@ -398,12 +400,12 @@ checkCoverage_select i s -- Validity -------------------------------------------------------------------------------- -isValidSelection :: IsUTxOSelection s => s -> Bool +isValidSelection :: IsUTxOSelection s InputId => s InputId -> Bool isValidSelection s = UTxOIndex.disjoint (UTxOSelection.selectedIndex s) (UTxOSelection.leftoverIndex s) -isValidSelectionNonEmpty :: UTxOSelectionNonEmpty -> Bool +isValidSelectionNonEmpty :: UTxOSelectionNonEmpty InputId -> Bool isValidSelectionNonEmpty s = isValidSelection s && UTxOSelection.isNonEmpty s @@ -431,11 +433,11 @@ instance Arbitrary (UTxOIndex InputId) where arbitrary = genUTxOIndex shrink = shrinkUTxOIndex -instance Arbitrary UTxOSelection where +instance Arbitrary (UTxOSelection InputId) where arbitrary = genUTxOSelection shrink = shrinkUTxOSelection -instance Arbitrary UTxOSelectionNonEmpty where +instance Arbitrary (UTxOSelectionNonEmpty InputId) where arbitrary = genUTxOSelectionNonEmpty shrink = shrinkUTxOSelectionNonEmpty