Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add type
UTxOSelection
to represent an in-progress UTxO selection.
- Loading branch information
1 parent
0450d3c
commit eb1c09e
Showing
2 changed files
with
241 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
240 changes: 240 additions & 0 deletions
240
lib/core/src/Cardano/Wallet/Primitive/Types/UTxOSelection.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,240 @@ | ||
{-# LANGUAGE DeriveGeneric #-} | ||
{-# LANGUAGE DuplicateRecordFields #-} | ||
{-# LANGUAGE NamedFieldPuns #-} | ||
{-# LANGUAGE OverloadedLabels #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
|
||
module Cardano.Wallet.Primitive.Types.UTxOSelection | ||
( | ||
-- * Classes | ||
IsUTxOSelection | ||
|
||
-- * Types | ||
, UTxOSelection | ||
, UTxOSelectionNonEmpty | ||
|
||
-- * Construction and deconstruction | ||
, fromIndex | ||
, fromIndexFiltered | ||
, fromIndexPair | ||
, toIndexPair | ||
|
||
-- * Promotion and demotion | ||
, fromNonEmpty | ||
, toNonEmpty | ||
|
||
-- * Querying | ||
, leftoverBalance | ||
, leftoverCount | ||
, leftoverIndex | ||
, leftoverList | ||
, selectedBalance | ||
, selectedCount | ||
, selectedIndex | ||
, selectedList | ||
|
||
-- * Modification | ||
, select | ||
|
||
) where | ||
|
||
import Prelude | ||
|
||
import Cardano.Wallet.Primitive.Types.TokenBundle | ||
( TokenBundle ) | ||
import Cardano.Wallet.Primitive.Types.Tx | ||
( TxIn, TxOut ) | ||
import Cardano.Wallet.Primitive.Types.UTxOIndex | ||
( UTxOIndex ) | ||
import Data.Function | ||
( (&) ) | ||
import Data.Generics.Internal.VL.Lens | ||
( over ) | ||
import Data.Generics.Labels | ||
() | ||
import Data.List.NonEmpty | ||
( NonEmpty ) | ||
import GHC.Generics | ||
( Generic ) | ||
|
||
import qualified Cardano.Wallet.Primitive.Types.UTxOIndex as UTxOIndex | ||
import qualified Data.List.NonEmpty as NonEmpty | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Classes | ||
-------------------------------------------------------------------------------- | ||
|
||
class HasUTxOSelectionState s where | ||
|
||
-- | Retrieves the internal state. | ||
state :: s -> State | ||
|
||
class HasUTxOSelectionState s => IsUTxOSelection s where | ||
|
||
-- | The type of the list of selected UTxOs. | ||
type SelectedList s | ||
|
||
-- | Retrieves a list of the selected UTxOs. | ||
selectedList :: s -> SelectedList s | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Types | ||
-------------------------------------------------------------------------------- | ||
|
||
data State = State | ||
{ selected :: !UTxOIndex | ||
, leftover :: !UTxOIndex | ||
} | ||
deriving (Eq, Generic, Show) | ||
|
||
-- | A selection for which 'selectionCount' may be zero. | ||
-- | ||
newtype UTxOSelection = UTxOSelection State | ||
deriving (Eq, Generic, Show) | ||
|
||
-- | A selection for which 'selectionCount' cannot be zero. | ||
-- | ||
newtype UTxOSelectionNonEmpty = UTxOSelectionNonEmpty State | ||
deriving (Eq, Generic, Show) | ||
|
||
instance HasUTxOSelectionState UTxOSelection where | ||
state (UTxOSelection s) = s | ||
|
||
instance HasUTxOSelectionState UTxOSelectionNonEmpty where | ||
state (UTxOSelectionNonEmpty s) = s | ||
|
||
instance IsUTxOSelection UTxOSelection where | ||
type SelectedList UTxOSelection = [(TxIn, TxOut)] | ||
selectedList | ||
= UTxOIndex.toList | ||
. selectedIndex | ||
|
||
instance IsUTxOSelection UTxOSelectionNonEmpty where | ||
type SelectedList UTxOSelectionNonEmpty = NonEmpty (TxIn, TxOut) | ||
selectedList | ||
= NonEmpty.fromList | ||
. UTxOIndex.toList | ||
. selectedIndex | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Construction and deconstruction | ||
-------------------------------------------------------------------------------- | ||
|
||
-- | Creates a selection from an index. | ||
-- | ||
-- All UTxOs in the index will be added to the leftover set. | ||
-- | ||
fromIndex :: UTxOIndex -> UTxOSelection | ||
fromIndex i = UTxOSelection State | ||
{ leftover = i | ||
, selected = UTxOIndex.empty | ||
} | ||
|
||
-- | Creates a selection from an index and a filter. | ||
-- | ||
-- 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 :: UTxOIndex -> (TxIn -> Bool) -> UTxOSelection | ||
fromIndexFiltered index f = | ||
UTxOSelection State {selected, leftover} | ||
where | ||
(selected, leftover) = UTxOIndex.partition f index | ||
|
||
-- | Creates a selection from a pair of indices. | ||
-- | ||
-- The 1st index in the pair represents the selected set. | ||
-- The 2nd index in the pair represents the leftover set. | ||
-- | ||
-- Any items that are in both sets are removed from the leftover set. | ||
-- | ||
fromIndexPair :: (UTxOIndex, UTxOIndex) -> UTxOSelection | ||
fromIndexPair (selected, leftover) = | ||
UTxOSelection State | ||
{ selected | ||
, leftover = leftover `UTxOIndex.difference` selected | ||
} | ||
|
||
-- | Converts a selection to a pair of indices. | ||
-- | ||
-- The 1st index in the pair represents the selected set. | ||
-- The 2nd index in the pair represents the leftover set. | ||
-- | ||
toIndexPair :: IsUTxOSelection s => s -> (UTxOIndex, UTxOIndex) | ||
toIndexPair s = (selectedIndex s, leftoverIndex s) | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Promotion and demotion | ||
-------------------------------------------------------------------------------- | ||
|
||
-- | Demotes a non-empty selection to an ordinary selection. | ||
-- | ||
fromNonEmpty :: UTxOSelectionNonEmpty -> UTxOSelection | ||
fromNonEmpty = UTxOSelection . state | ||
|
||
-- | Promotes an ordinary selection to a non-empty selection. | ||
-- | ||
-- Returns 'Nothing' if the the selected set is empty. | ||
-- | ||
toNonEmpty :: UTxOSelection -> Maybe UTxOSelectionNonEmpty | ||
toNonEmpty s | ||
| selectedCount s == 0 = | ||
Nothing | ||
| otherwise = | ||
Just $ UTxOSelectionNonEmpty $ state s | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Querying | ||
-------------------------------------------------------------------------------- | ||
|
||
-- | Retrieves the balance of leftover UTxOs. | ||
-- | ||
leftoverBalance :: IsUTxOSelection s => s -> TokenBundle | ||
leftoverBalance = UTxOIndex.balance . leftoverIndex | ||
|
||
-- | Retrieves a count of the leftover UTxOs. | ||
-- | ||
leftoverCount :: IsUTxOSelection s => s -> Int | ||
leftoverCount = UTxOIndex.size . leftoverIndex | ||
|
||
-- | Retrieves an index of the leftover UTxOs. | ||
-- | ||
leftoverIndex :: IsUTxOSelection s => s -> UTxOIndex | ||
leftoverIndex = leftover . state | ||
|
||
-- | Retrieves a list of the leftover UTxOs. | ||
-- | ||
leftoverList :: IsUTxOSelection s => s -> [(TxIn, TxOut)] | ||
leftoverList = UTxOIndex.toList . leftoverIndex | ||
|
||
-- | Retrieves the balance of selected UTxOs. | ||
-- | ||
selectedBalance :: IsUTxOSelection s => s -> TokenBundle | ||
selectedBalance = UTxOIndex.balance . selectedIndex | ||
|
||
-- | Retrieves a count of the selected UTxOs. | ||
-- | ||
selectedCount :: IsUTxOSelection s => s -> Int | ||
selectedCount = UTxOIndex.size . selectedIndex | ||
|
||
-- | Retrieves an index of the selected UTxOs. | ||
-- | ||
selectedIndex :: IsUTxOSelection s => s -> UTxOIndex | ||
selectedIndex = selected . state | ||
|
||
-------------------------------------------------------------------------------- | ||
-- Modification | ||
-------------------------------------------------------------------------------- | ||
|
||
-- | Moves an entry from the leftover set to the selected set. | ||
-- | ||
select :: IsUTxOSelection s => TxIn -> s -> Maybe UTxOSelectionNonEmpty | ||
select i = fmap UTxOSelectionNonEmpty . updateState . state | ||
where | ||
updateState :: State -> Maybe State | ||
updateState s = | ||
updateFields <$> UTxOIndex.lookup i (leftover s) | ||
where | ||
updateFields o = s | ||
& over #selected (UTxOIndex.insert i o) | ||
& over #leftover (UTxOIndex.delete i) |