{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Copyright: © 2021 IOHK
-- License: Apache-2.0
--
-- This module contains an algorithm for planning migrations at a high level.
--
-- It determines how to partition the UTxO set into entries of different types,
-- and in which order to add entries to selections, in order to maximize the
-- number of entries that can be successfully migrated.
--
-- Use 'createPlan' to create a migration plan.
--
module Cardano.Wallet.Primitive.Migration.Planning
    (
    -- * Migration planning
      createPlan
    , MigrationPlan (..)

    -- * UTxO entry categorization
    , CategorizedUTxO (..)
    , UTxOEntryCategory (..)
    , categorizeUTxO
    , categorizeUTxOEntries
    , categorizeUTxOEntry
    , uncategorizeUTxO
    , uncategorizeUTxOEntries

    ) where

import Prelude

import Cardano.Wallet.Primitive.Migration.Selection
    ( RewardWithdrawal (..), Selection (..), SelectionError (..) )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin (..) )
import Cardano.Wallet.Primitive.Types.TokenBundle
    ( TokenBundle (..) )
import Cardano.Wallet.Primitive.Types.Tx
    ( TxConstraints (..), TxIn, TxOut )
import Cardano.Wallet.Primitive.Types.UTxO
    ( UTxO (..) )
import Data.Either
    ( isRight )
import Data.Functor
    ( (<&>) )
import Data.Generics.Internal.VL.Lens
    ( view )
import Data.Generics.Labels
    ()
import GHC.Generics
    ( Generic )

import qualified Cardano.Wallet.Primitive.Migration.Selection as Selection
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Data.Foldable as F
import qualified Data.List as L
import qualified Data.Map.Strict as Map

--------------------------------------------------------------------------------
-- Migration planning
--------------------------------------------------------------------------------

-- | Represents a plan for migrating a set of UTxO entries.
--
-- Use 'createPlan' to create a migration plan.
--
data MigrationPlan input = MigrationPlan
    { MigrationPlan input -> [Selection input]
selections :: ![Selection input]
      -- ^ A list of generated selections: each selection is the basis for a
      -- single transaction.
    , MigrationPlan input -> CategorizedUTxO input
unselected :: !(CategorizedUTxO input)
      -- ^ The portion of the UTxO that was not selected.
    , MigrationPlan input -> Coin
totalFee :: !Coin
      -- ^ The total fee payable: equal to the sum of the fees of the
      -- individual selections.
    }
    deriving (MigrationPlan input -> MigrationPlan input -> Bool
(MigrationPlan input -> MigrationPlan input -> Bool)
-> (MigrationPlan input -> MigrationPlan input -> Bool)
-> Eq (MigrationPlan input)
forall input.
Eq input =>
MigrationPlan input -> MigrationPlan input -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationPlan input -> MigrationPlan input -> Bool
$c/= :: forall input.
Eq input =>
MigrationPlan input -> MigrationPlan input -> Bool
== :: MigrationPlan input -> MigrationPlan input -> Bool
$c== :: forall input.
Eq input =>
MigrationPlan input -> MigrationPlan input -> Bool
Eq, (forall x. MigrationPlan input -> Rep (MigrationPlan input) x)
-> (forall x. Rep (MigrationPlan input) x -> MigrationPlan input)
-> Generic (MigrationPlan input)
forall x. Rep (MigrationPlan input) x -> MigrationPlan input
forall x. MigrationPlan input -> Rep (MigrationPlan input) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall input x. Rep (MigrationPlan input) x -> MigrationPlan input
forall input x. MigrationPlan input -> Rep (MigrationPlan input) x
$cto :: forall input x. Rep (MigrationPlan input) x -> MigrationPlan input
$cfrom :: forall input x. MigrationPlan input -> Rep (MigrationPlan input) x
Generic, Int -> MigrationPlan input -> ShowS
[MigrationPlan input] -> ShowS
MigrationPlan input -> String
(Int -> MigrationPlan input -> ShowS)
-> (MigrationPlan input -> String)
-> ([MigrationPlan input] -> ShowS)
-> Show (MigrationPlan input)
forall input. Show input => Int -> MigrationPlan input -> ShowS
forall input. Show input => [MigrationPlan input] -> ShowS
forall input. Show input => MigrationPlan input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MigrationPlan input] -> ShowS
$cshowList :: forall input. Show input => [MigrationPlan input] -> ShowS
show :: MigrationPlan input -> String
$cshow :: forall input. Show input => MigrationPlan input -> String
showsPrec :: Int -> MigrationPlan input -> ShowS
$cshowsPrec :: forall input. Show input => Int -> MigrationPlan input -> ShowS
Show)

-- | Creates a migration plan for the given categorized UTxO set and reward
--   withdrawal amount.
--
-- See 'MigrationPlan'.
--
createPlan
    :: TxConstraints
    -> CategorizedUTxO input
    -> RewardWithdrawal
    -> MigrationPlan input
createPlan :: TxConstraints
-> CategorizedUTxO input -> RewardWithdrawal -> MigrationPlan input
createPlan TxConstraints
constraints =
    [Selection input]
-> CategorizedUTxO input -> RewardWithdrawal -> MigrationPlan input
forall input.
[Selection input]
-> CategorizedUTxO input -> RewardWithdrawal -> MigrationPlan input
run []
  where
    run :: [Selection input]
-> CategorizedUTxO input -> RewardWithdrawal -> MigrationPlan input
run ![Selection input]
selections !CategorizedUTxO input
utxo !RewardWithdrawal
reward =
        case TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
forall input.
TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
createSelection TxConstraints
constraints CategorizedUTxO input
utxo RewardWithdrawal
reward of
            Just (CategorizedUTxO input
utxo', Selection input
selection) ->
                [Selection input]
-> CategorizedUTxO input -> RewardWithdrawal -> MigrationPlan input
run (Selection input
selection Selection input -> [Selection input] -> [Selection input]
forall a. a -> [a] -> [a]
: [Selection input]
selections) CategorizedUTxO input
utxo' (Coin -> RewardWithdrawal
RewardWithdrawal (Coin -> RewardWithdrawal) -> Coin -> RewardWithdrawal
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin Natural
0)
            Maybe (CategorizedUTxO input, Selection input)
Nothing -> MigrationPlan :: forall input.
[Selection input]
-> CategorizedUTxO input -> Coin -> MigrationPlan input
MigrationPlan
                { [Selection input]
selections :: [Selection input]
$sel:selections:MigrationPlan :: [Selection input]
selections
                , $sel:unselected:MigrationPlan :: CategorizedUTxO input
unselected = CategorizedUTxO input
utxo
                , $sel:totalFee:MigrationPlan :: Coin
totalFee = (Selection input -> Coin) -> [Selection input] -> Coin
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (((Coin -> Const Coin Coin)
 -> Selection input -> Const Coin (Selection input))
-> Selection input -> Coin
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "fee"
  ((Coin -> Const Coin Coin)
   -> Selection input -> Const Coin (Selection input))
(Coin -> Const Coin Coin)
-> Selection input -> Const Coin (Selection input)
#fee) [Selection input]
selections
                }

-- | Creates an individual selection for inclusion in a migration plan.
--
-- A selection is the basis for an individual transaction.
--
-- Returns 'Nothing' if it was not possible to create a selection with the UTxO
-- entries that remain.
--
createSelection
    :: TxConstraints
    -> CategorizedUTxO input
    -> RewardWithdrawal
    -> Maybe (CategorizedUTxO input, Selection input)
createSelection :: TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
createSelection TxConstraints
constraints CategorizedUTxO input
utxo RewardWithdrawal
rewardWithdrawal =
    TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
forall input.
TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
initializeSelection TxConstraints
constraints CategorizedUTxO input
utxo RewardWithdrawal
rewardWithdrawal
    Maybe (CategorizedUTxO input, Selection input)
-> ((CategorizedUTxO input, Selection input)
    -> (CategorizedUTxO input, Selection input))
-> Maybe (CategorizedUTxO input, Selection input)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
forall input.
TxConstraints
-> (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendSelectionUntilFull TxConstraints
constraints

-- | Initializes a selection with a single entry.
--
-- Returns 'Nothing' if it was not possible to initialize a selection with the
-- UTxO entries that remain.
--
initializeSelection
    :: TxConstraints
    -> CategorizedUTxO input
    -> RewardWithdrawal
    -> Maybe (CategorizedUTxO input, Selection input)
initializeSelection :: TxConstraints
-> CategorizedUTxO input
-> RewardWithdrawal
-> Maybe (CategorizedUTxO input, Selection input)
initializeSelection TxConstraints
constraints CategorizedUTxO input
utxoAtStart RewardWithdrawal
reward =
    ((input, TokenBundle), CategorizedUTxO input)
-> Maybe (CategorizedUTxO input, Selection input)
forall input a.
((input, TokenBundle), a) -> Maybe (a, Selection input)
initializeWith (((input, TokenBundle), CategorizedUTxO input)
 -> Maybe (CategorizedUTxO input, Selection input))
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
-> Maybe (CategorizedUTxO input, Selection input)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CategorizedUTxO input
utxoAtStart CategorizedUTxO input
-> UTxOEntryCategory
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall input.
CategorizedUTxO input
-> UTxOEntryCategory
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
`select` UTxOEntryCategory
Supporter
  where
    initializeWith :: ((input, TokenBundle), a) -> Maybe (a, Selection input)
initializeWith ((input, TokenBundle)
entry, a
utxo) =
        case TxConstraints
-> RewardWithdrawal
-> NonEmpty (input, TokenBundle)
-> Either SelectionError (Selection input)
forall input.
TxConstraints
-> RewardWithdrawal
-> NonEmpty (input, TokenBundle)
-> Either SelectionError (Selection input)
Selection.create TxConstraints
constraints RewardWithdrawal
reward [(input, TokenBundle)
Item (NonEmpty (input, TokenBundle))
entry] of
            Right Selection input
selection -> (a, Selection input) -> Maybe (a, Selection input)
forall a. a -> Maybe a
Just (a
utxo, Selection input
selection)
            Left SelectionError
_ -> Maybe (a, Selection input)
forall a. Maybe a
Nothing

-- | Extends a selection repeatedly, until the selection is full.
--
-- This function terminates when the selection cannot be extended further
-- (because doing so would cause it to exceed the size limit of a transaction),
-- or when there are no more UTxO entries available for selection.
--
-- Priority is given to selecting "freerider" entries: entries that cannot pay
-- for themselves. A "supporter" entry is only added to the selection if there
-- is not enough ada to pay for a "freerider" entry.
--
extendSelectionUntilFull
    :: TxConstraints
    -> (CategorizedUTxO input, Selection input)
    -> (CategorizedUTxO input, Selection input)
extendSelectionUntilFull :: TxConstraints
-> (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendSelectionUntilFull TxConstraints
constraints = (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
forall input.
(CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithFreerider
  where
    extendWithFreerider :: (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithFreerider (!CategorizedUTxO input
utxo, !Selection input
selection) =
        case UTxOEntryCategory
-> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall input.
UTxOEntryCategory
-> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
extendWith UTxOEntryCategory
Freerider TxConstraints
constraints (CategorizedUTxO input
utxo, Selection input
selection) of
            Right (CategorizedUTxO input
utxo', Selection input
selection') ->
                (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithFreerider (CategorizedUTxO input
utxo', Selection input
selection')
            Left ExtendSelectionError
ExtendSelectionAdaInsufficient ->
                (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithSupporter (CategorizedUTxO input
utxo, Selection input
selection)
            Left ExtendSelectionError
ExtendSelectionEntriesExhausted ->
                (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithSupporter (CategorizedUTxO input
utxo, Selection input
selection)
            Left ExtendSelectionError
ExtendSelectionFull ->
                (CategorizedUTxO input
utxo, Selection input
selection)

    extendWithSupporter :: (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithSupporter (!CategorizedUTxO input
utxo, !Selection input
selection) =
        case UTxOEntryCategory
-> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall input.
UTxOEntryCategory
-> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
extendWith UTxOEntryCategory
Supporter TxConstraints
constraints (CategorizedUTxO input
utxo, Selection input
selection) of
            Right (CategorizedUTxO input
utxo', Selection input
selection') ->
                (CategorizedUTxO input, Selection input)
-> (CategorizedUTxO input, Selection input)
extendWithFreerider (CategorizedUTxO input
utxo', Selection input
selection')
            Left ExtendSelectionError
ExtendSelectionAdaInsufficient ->
                (CategorizedUTxO input
utxo, Selection input
selection)
            Left ExtendSelectionError
ExtendSelectionEntriesExhausted ->
                (CategorizedUTxO input
utxo, Selection input
selection)
            Left ExtendSelectionError
ExtendSelectionFull ->
                (CategorizedUTxO input
utxo, Selection input
selection)

data ExtendSelectionError
    = ExtendSelectionAdaInsufficient
    | ExtendSelectionEntriesExhausted
    | ExtendSelectionFull

extendWith
    :: UTxOEntryCategory
    -> TxConstraints
    -> (CategorizedUTxO input, Selection input)
    -> Either ExtendSelectionError (CategorizedUTxO input, Selection input)
extendWith :: UTxOEntryCategory
-> TxConstraints
-> (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
extendWith UTxOEntryCategory
category TxConstraints
constraints (CategorizedUTxO input
utxo, Selection input
selection) =
    case CategorizedUTxO input
utxo CategorizedUTxO input
-> UTxOEntryCategory
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall input.
CategorizedUTxO input
-> UTxOEntryCategory
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
`select` UTxOEntryCategory
category of
        Just ((input, TokenBundle)
entry, CategorizedUTxO input
utxo') ->
            case TxConstraints
-> Selection input
-> (input, TokenBundle)
-> Either SelectionError (Selection input)
forall input.
TxConstraints
-> Selection input
-> (input, TokenBundle)
-> Either SelectionError (Selection input)
Selection.extend TxConstraints
constraints Selection input
selection (input, TokenBundle)
entry of
                Right Selection input
selection' ->
                    (CategorizedUTxO input, Selection input)
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall a b. b -> Either a b
Right (CategorizedUTxO input
utxo', Selection input
selection')
                Left SelectionError
SelectionAdaInsufficient ->
                    ExtendSelectionError
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall a b. a -> Either a b
Left ExtendSelectionError
ExtendSelectionAdaInsufficient
                Left SelectionFull {} ->
                    ExtendSelectionError
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall a b. a -> Either a b
Left ExtendSelectionError
ExtendSelectionFull
        Maybe ((input, TokenBundle), CategorizedUTxO input)
Nothing ->
            ExtendSelectionError
-> Either
     ExtendSelectionError (CategorizedUTxO input, Selection input)
forall a b. a -> Either a b
Left ExtendSelectionError
ExtendSelectionEntriesExhausted

select
    :: CategorizedUTxO input
    -> UTxOEntryCategory
    -> Maybe ((input, TokenBundle), CategorizedUTxO input)
select :: CategorizedUTxO input
-> UTxOEntryCategory
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
select CategorizedUTxO input
utxo = \case
    UTxOEntryCategory
Supporter -> Maybe ((input, TokenBundle), CategorizedUTxO input)
selectSupporter
    UTxOEntryCategory
Freerider -> Maybe ((input, TokenBundle), CategorizedUTxO input)
selectFreerider
    UTxOEntryCategory
Ignorable -> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall a. Maybe a
selectIgnorable
  where
    selectSupporter :: Maybe ((input, TokenBundle), CategorizedUTxO input)
selectSupporter = case CategorizedUTxO input -> [(input, TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
supporters CategorizedUTxO input
utxo of
        (input, TokenBundle)
entry : [(input, TokenBundle)]
remaining -> ((input, TokenBundle), CategorizedUTxO input)
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall a. a -> Maybe a
Just ((input, TokenBundle)
entry, CategorizedUTxO input
utxo {$sel:supporters:CategorizedUTxO :: [(input, TokenBundle)]
supporters = [(input, TokenBundle)]
remaining})
        [] -> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall a. Maybe a
Nothing
    selectFreerider :: Maybe ((input, TokenBundle), CategorizedUTxO input)
selectFreerider = case CategorizedUTxO input -> [(input, TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
freeriders CategorizedUTxO input
utxo of
        (input, TokenBundle)
entry : [(input, TokenBundle)]
remaining -> ((input, TokenBundle), CategorizedUTxO input)
-> Maybe ((input, TokenBundle), CategorizedUTxO input)
forall a. a -> Maybe a
Just ((input, TokenBundle)
entry, CategorizedUTxO input
utxo {$sel:freeriders:CategorizedUTxO :: [(input, TokenBundle)]
freeriders = [(input, TokenBundle)]
remaining})
        [] ->  Maybe ((input, TokenBundle), CategorizedUTxO input)
forall a. Maybe a
Nothing
    selectIgnorable :: Maybe a
selectIgnorable =
        -- We never select an entry that should be ignored:
        Maybe a
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- Categorization of UTxO entries
--------------------------------------------------------------------------------

data UTxOEntryCategory
    = Supporter
    -- ^ A coin or bundle that is capable of paying for its own marginal fee
    -- and the base transaction fee.
    | Freerider
    -- ^ A coin or bundle that is not capable of paying for itself.
    | Ignorable
    -- ^ A coin that should not be added to a selection, because its value is
    -- lower than the marginal fee for an input.
    deriving (UTxOEntryCategory -> UTxOEntryCategory -> Bool
(UTxOEntryCategory -> UTxOEntryCategory -> Bool)
-> (UTxOEntryCategory -> UTxOEntryCategory -> Bool)
-> Eq UTxOEntryCategory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UTxOEntryCategory -> UTxOEntryCategory -> Bool
$c/= :: UTxOEntryCategory -> UTxOEntryCategory -> Bool
== :: UTxOEntryCategory -> UTxOEntryCategory -> Bool
$c== :: UTxOEntryCategory -> UTxOEntryCategory -> Bool
Eq, Int -> UTxOEntryCategory -> ShowS
[UTxOEntryCategory] -> ShowS
UTxOEntryCategory -> String
(Int -> UTxOEntryCategory -> ShowS)
-> (UTxOEntryCategory -> String)
-> ([UTxOEntryCategory] -> ShowS)
-> Show UTxOEntryCategory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UTxOEntryCategory] -> ShowS
$cshowList :: [UTxOEntryCategory] -> ShowS
show :: UTxOEntryCategory -> String
$cshow :: UTxOEntryCategory -> String
showsPrec :: Int -> UTxOEntryCategory -> ShowS
$cshowsPrec :: Int -> UTxOEntryCategory -> ShowS
Show)

data CategorizedUTxO input = CategorizedUTxO
    { CategorizedUTxO input -> [(input, TokenBundle)]
supporters :: ![(input, TokenBundle)]
    , CategorizedUTxO input -> [(input, TokenBundle)]
freeriders :: ![(input, TokenBundle)]
    , CategorizedUTxO input -> [(input, TokenBundle)]
ignorables :: ![(input, TokenBundle)]
    }
    deriving (CategorizedUTxO input -> CategorizedUTxO input -> Bool
(CategorizedUTxO input -> CategorizedUTxO input -> Bool)
-> (CategorizedUTxO input -> CategorizedUTxO input -> Bool)
-> Eq (CategorizedUTxO input)
forall input.
Eq input =>
CategorizedUTxO input -> CategorizedUTxO input -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CategorizedUTxO input -> CategorizedUTxO input -> Bool
$c/= :: forall input.
Eq input =>
CategorizedUTxO input -> CategorizedUTxO input -> Bool
== :: CategorizedUTxO input -> CategorizedUTxO input -> Bool
$c== :: forall input.
Eq input =>
CategorizedUTxO input -> CategorizedUTxO input -> Bool
Eq, Int -> CategorizedUTxO input -> ShowS
[CategorizedUTxO input] -> ShowS
CategorizedUTxO input -> String
(Int -> CategorizedUTxO input -> ShowS)
-> (CategorizedUTxO input -> String)
-> ([CategorizedUTxO input] -> ShowS)
-> Show (CategorizedUTxO input)
forall input. Show input => Int -> CategorizedUTxO input -> ShowS
forall input. Show input => [CategorizedUTxO input] -> ShowS
forall input. Show input => CategorizedUTxO input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CategorizedUTxO input] -> ShowS
$cshowList :: forall input. Show input => [CategorizedUTxO input] -> ShowS
show :: CategorizedUTxO input -> String
$cshow :: forall input. Show input => CategorizedUTxO input -> String
showsPrec :: Int -> CategorizedUTxO input -> ShowS
$cshowsPrec :: forall input. Show input => Int -> CategorizedUTxO input -> ShowS
Show)

categorizeUTxO
    :: TxConstraints
    -> UTxO
    -> CategorizedUTxO (TxIn, TxOut)
categorizeUTxO :: TxConstraints -> UTxO -> CategorizedUTxO (TxIn, TxOut)
categorizeUTxO TxConstraints
constraints (UTxO Map TxIn TxOut
u) = TxConstraints
-> [((TxIn, TxOut), TokenBundle)] -> CategorizedUTxO (TxIn, TxOut)
forall input.
TxConstraints -> [(input, TokenBundle)] -> CategorizedUTxO input
categorizeUTxOEntries TxConstraints
constraints ([((TxIn, TxOut), TokenBundle)] -> CategorizedUTxO (TxIn, TxOut))
-> [((TxIn, TxOut), TokenBundle)] -> CategorizedUTxO (TxIn, TxOut)
forall a b. (a -> b) -> a -> b
$
    (\(TxIn
i, TxOut
o) -> ((TxIn
i, TxOut
o), ((TokenBundle -> Const TokenBundle TokenBundle)
 -> TxOut -> Const TokenBundle TxOut)
-> TxOut -> TokenBundle
forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view IsLabel
  "tokens"
  ((TokenBundle -> Const TokenBundle TokenBundle)
   -> TxOut -> Const TokenBundle TxOut)
(TokenBundle -> Const TokenBundle TokenBundle)
-> TxOut -> Const TokenBundle TxOut
#tokens TxOut
o)) ((TxIn, TxOut) -> ((TxIn, TxOut), TokenBundle))
-> [(TxIn, TxOut)] -> [((TxIn, TxOut), TokenBundle)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn TxOut -> [(TxIn, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn TxOut
u

categorizeUTxOEntries
    :: forall input. TxConstraints
    -> [(input, TokenBundle)]
    -> CategorizedUTxO input
categorizeUTxOEntries :: TxConstraints -> [(input, TokenBundle)] -> CategorizedUTxO input
categorizeUTxOEntries TxConstraints
constraints [(input, TokenBundle)]
uncategorizedEntries = CategorizedUTxO :: forall input.
[(input, TokenBundle)]
-> [(input, TokenBundle)]
-> [(input, TokenBundle)]
-> CategorizedUTxO input
CategorizedUTxO
    { $sel:supporters:CategorizedUTxO :: [(input, TokenBundle)]
supporters = UTxOEntryCategory -> [(input, TokenBundle)]
entriesMatching UTxOEntryCategory
Supporter
    , $sel:freeriders:CategorizedUTxO :: [(input, TokenBundle)]
freeriders = UTxOEntryCategory -> [(input, TokenBundle)]
entriesMatching UTxOEntryCategory
Freerider
    , $sel:ignorables:CategorizedUTxO :: [(input, TokenBundle)]
ignorables = UTxOEntryCategory -> [(input, TokenBundle)]
entriesMatching UTxOEntryCategory
Ignorable
    }
  where
    categorizedEntries :: [(input, (TokenBundle, UTxOEntryCategory))]
    categorizedEntries :: [(input, (TokenBundle, UTxOEntryCategory))]
categorizedEntries = [(input, TokenBundle)]
uncategorizedEntries
        [(input, TokenBundle)]
-> ((input, TokenBundle)
    -> (input, (TokenBundle, UTxOEntryCategory)))
-> [(input, (TokenBundle, UTxOEntryCategory))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(input
i, TokenBundle
b) -> (input
i, (TokenBundle
b, TxConstraints -> TokenBundle -> UTxOEntryCategory
categorizeUTxOEntry TxConstraints
constraints TokenBundle
b)))

    entriesMatching :: UTxOEntryCategory -> [(input, TokenBundle)]
    entriesMatching :: UTxOEntryCategory -> [(input, TokenBundle)]
entriesMatching UTxOEntryCategory
category =
        ((TokenBundle, UTxOEntryCategory) -> TokenBundle)
-> (input, (TokenBundle, UTxOEntryCategory))
-> (input, TokenBundle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TokenBundle, UTxOEntryCategory) -> TokenBundle
forall a b. (a, b) -> a
fst ((input, (TokenBundle, UTxOEntryCategory)) -> (input, TokenBundle))
-> [(input, (TokenBundle, UTxOEntryCategory))]
-> [(input, TokenBundle)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((input, (TokenBundle, UTxOEntryCategory)) -> Bool)
-> [(input, (TokenBundle, UTxOEntryCategory))]
-> [(input, (TokenBundle, UTxOEntryCategory))]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((UTxOEntryCategory -> UTxOEntryCategory -> Bool
forall a. Eq a => a -> a -> Bool
== UTxOEntryCategory
category) (UTxOEntryCategory -> Bool)
-> ((input, (TokenBundle, UTxOEntryCategory)) -> UTxOEntryCategory)
-> (input, (TokenBundle, UTxOEntryCategory))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenBundle, UTxOEntryCategory) -> UTxOEntryCategory
forall a b. (a, b) -> b
snd ((TokenBundle, UTxOEntryCategory) -> UTxOEntryCategory)
-> ((input, (TokenBundle, UTxOEntryCategory))
    -> (TokenBundle, UTxOEntryCategory))
-> (input, (TokenBundle, UTxOEntryCategory))
-> UTxOEntryCategory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (input, (TokenBundle, UTxOEntryCategory))
-> (TokenBundle, UTxOEntryCategory)
forall a b. (a, b) -> b
snd) [(input, (TokenBundle, UTxOEntryCategory))]
categorizedEntries

categorizeUTxOEntry
    :: TxConstraints
    -> TokenBundle
    -> UTxOEntryCategory
categorizeUTxOEntry :: TxConstraints -> TokenBundle -> UTxOEntryCategory
categorizeUTxOEntry TxConstraints
constraints TokenBundle
b
    | Just Coin
c <- TokenBundle -> Maybe Coin
TokenBundle.toCoin TokenBundle
b, Coin -> Bool
coinIsIgnorable Coin
c =
        UTxOEntryCategory
Ignorable
    | Bool
bundleIsSupporter =
        UTxOEntryCategory
Supporter
    | Bool
otherwise =
        UTxOEntryCategory
Freerider
  where
    bundleIsSupporter :: Bool
    bundleIsSupporter :: Bool
bundleIsSupporter = Either SelectionError (Selection ()) -> Bool
forall a b. Either a b -> Bool
isRight (Either SelectionError (Selection ()) -> Bool)
-> Either SelectionError (Selection ()) -> Bool
forall a b. (a -> b) -> a -> b
$
        TxConstraints
-> RewardWithdrawal
-> NonEmpty ((), TokenBundle)
-> Either SelectionError (Selection ())
forall input.
TxConstraints
-> RewardWithdrawal
-> NonEmpty (input, TokenBundle)
-> Either SelectionError (Selection input)
Selection.create TxConstraints
constraints (Coin -> RewardWithdrawal
RewardWithdrawal (Coin -> RewardWithdrawal) -> Coin -> RewardWithdrawal
forall a b. (a -> b) -> a -> b
$ Natural -> Coin
Coin Natural
0) [((), TokenBundle
b)]

    coinIsIgnorable :: Coin -> Bool
    coinIsIgnorable :: Coin -> Bool
coinIsIgnorable Coin
c = Coin
c Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= TxConstraints -> Coin
txInputCost TxConstraints
constraints

uncategorizeUTxO :: CategorizedUTxO (TxIn, TxOut) -> UTxO
uncategorizeUTxO :: CategorizedUTxO (TxIn, TxOut) -> UTxO
uncategorizeUTxO = Map TxIn TxOut -> UTxO
UTxO (Map TxIn TxOut -> UTxO)
-> (CategorizedUTxO (TxIn, TxOut) -> Map TxIn TxOut)
-> CategorizedUTxO (TxIn, TxOut)
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut)] -> Map TxIn TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut)] -> Map TxIn TxOut)
-> (CategorizedUTxO (TxIn, TxOut) -> [(TxIn, TxOut)])
-> CategorizedUTxO (TxIn, TxOut)
-> Map TxIn TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((TxIn, TxOut), TokenBundle) -> (TxIn, TxOut))
-> [((TxIn, TxOut), TokenBundle)] -> [(TxIn, TxOut)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxIn, TxOut), TokenBundle) -> (TxIn, TxOut)
forall a b. (a, b) -> a
fst ([((TxIn, TxOut), TokenBundle)] -> [(TxIn, TxOut)])
-> (CategorizedUTxO (TxIn, TxOut)
    -> [((TxIn, TxOut), TokenBundle)])
-> CategorizedUTxO (TxIn, TxOut)
-> [(TxIn, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CategorizedUTxO (TxIn, TxOut) -> [((TxIn, TxOut), TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
uncategorizeUTxOEntries

uncategorizeUTxOEntries :: CategorizedUTxO input -> [(input, TokenBundle)]
uncategorizeUTxOEntries :: CategorizedUTxO input -> [(input, TokenBundle)]
uncategorizeUTxOEntries CategorizedUTxO input
utxo = [[(input, TokenBundle)]] -> [(input, TokenBundle)]
forall a. Monoid a => [a] -> a
mconcat
    [ CategorizedUTxO input -> [(input, TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
supporters CategorizedUTxO input
utxo
    , CategorizedUTxO input -> [(input, TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
freeriders CategorizedUTxO input
utxo
    , CategorizedUTxO input -> [(input, TokenBundle)]
forall input. CategorizedUTxO input -> [(input, TokenBundle)]
ignorables CategorizedUTxO input
utxo
    ]