{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- Copyright: © 2018-2024 Intersect MBO
-- License: Apache-2.0
--
-- Provides functionality for __adjusting__ coin selections in order to pay for
-- transaction __fees__.
--
module Cardano.CoinSelection.Fee
    (
      -- * Fundamental Types
      Fee (..)
    , FeeEstimator (..)

      -- * Fee Adjustment
    , adjustForFee
    , FeeOptions (..)
    , FeeBalancingPolicy (..)
    , FeeAdjustmentError (..)

      -- * Dust Processing
    , DustThreshold (..)
    , isDust
    , coalesceDust

      -- # Internal Functions
    , calculateFee
    , distributeFee
    , reduceChangeOutputs
    , splitCoin

    ) where

import Prelude hiding ( round )

import Cardano.CoinSelection
    ( CoinMap (..)
    , CoinMapEntry (..)
    , CoinSelection (..)
    , coinMapFromList
    , coinMapRandomEntry
    , sumChange
    , sumInputs
    , sumOutputs
    )
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Except ( ExceptT (..), except, throwE )
import Control.Monad.Trans.State ( StateT (..), evalStateT )
import Crypto.Random.Types ( MonadRandom )
import Data.Bifunctor ( first )
import Data.Function ( (&) )
import Data.List.NonEmpty ( NonEmpty ((:|)) )
import Data.Maybe ( fromMaybe )
import Data.Ord ( Down (..), comparing )
import Data.Ratio ( (%) )
import GHC.Generics ( Generic )
import Internal.Coin ( Coin )
import Internal.Invariant ( invariant )
import Internal.Rounding ( RoundingDirection (..), round )
import Quiet ( Quiet (Quiet) )

import qualified Data.Foldable as F
import qualified Data.List.NonEmpty as NE
import qualified Internal.Coin as C

--------------------------------------------------------------------------------
-- Fundamental Types
--------------------------------------------------------------------------------

-- | Represents a non-negative fee to be paid on a transaction.
--
-- @since 1.0.0
newtype Fee = Fee { Fee -> Coin
unFee :: Coin }
    deriving newtype (Semigroup Fee
Fee
Semigroup Fee =>
Fee -> (Fee -> Fee -> Fee) -> ([Fee] -> Fee) -> Monoid Fee
[Fee] -> Fee
Fee -> Fee -> Fee
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Fee
mempty :: Fee
$cmappend :: Fee -> Fee -> Fee
mappend :: Fee -> Fee -> Fee
$cmconcat :: [Fee] -> Fee
mconcat :: [Fee] -> Fee
Monoid, NonEmpty Fee -> Fee
Fee -> Fee -> Fee
(Fee -> Fee -> Fee)
-> (NonEmpty Fee -> Fee)
-> (forall b. Integral b => b -> Fee -> Fee)
-> Semigroup Fee
forall b. Integral b => b -> Fee -> Fee
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Fee -> Fee -> Fee
<> :: Fee -> Fee -> Fee
$csconcat :: NonEmpty Fee -> Fee
sconcat :: NonEmpty Fee -> Fee
$cstimes :: forall b. Integral b => b -> Fee -> Fee
stimes :: forall b. Integral b => b -> Fee -> Fee
Semigroup)
    deriving stock (Fee -> Fee -> Bool
(Fee -> Fee -> Bool) -> (Fee -> Fee -> Bool) -> Eq Fee
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fee -> Fee -> Bool
== :: Fee -> Fee -> Bool
$c/= :: Fee -> Fee -> Bool
/= :: Fee -> Fee -> Bool
Eq, (forall x. Fee -> Rep Fee x)
-> (forall x. Rep Fee x -> Fee) -> Generic Fee
forall x. Rep Fee x -> Fee
forall x. Fee -> Rep Fee x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Fee -> Rep Fee x
from :: forall x. Fee -> Rep Fee x
$cto :: forall x. Rep Fee x -> Fee
to :: forall x. Rep Fee x -> Fee
Generic, Eq Fee
Eq Fee =>
(Fee -> Fee -> Ordering)
-> (Fee -> Fee -> Bool)
-> (Fee -> Fee -> Bool)
-> (Fee -> Fee -> Bool)
-> (Fee -> Fee -> Bool)
-> (Fee -> Fee -> Fee)
-> (Fee -> Fee -> Fee)
-> Ord Fee
Fee -> Fee -> Bool
Fee -> Fee -> Ordering
Fee -> Fee -> Fee
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fee -> Fee -> Ordering
compare :: Fee -> Fee -> Ordering
$c< :: Fee -> Fee -> Bool
< :: Fee -> Fee -> Bool
$c<= :: Fee -> Fee -> Bool
<= :: Fee -> Fee -> Bool
$c> :: Fee -> Fee -> Bool
> :: Fee -> Fee -> Bool
$c>= :: Fee -> Fee -> Bool
>= :: Fee -> Fee -> Bool
$cmax :: Fee -> Fee -> Fee
max :: Fee -> Fee -> Fee
$cmin :: Fee -> Fee -> Fee
min :: Fee -> Fee -> Fee
Ord)
    deriving Int -> Fee -> ShowS
[Fee] -> ShowS
Fee -> String
(Int -> Fee -> ShowS)
-> (Fee -> String) -> ([Fee] -> ShowS) -> Show Fee
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fee -> ShowS
showsPrec :: Int -> Fee -> ShowS
$cshow :: Fee -> String
show :: Fee -> String
$cshowList :: [Fee] -> ShowS
showList :: [Fee] -> ShowS
Show via (Quiet Fee)

-- | Defines the /maximum/ size of a __dust coin__.
--
-- Functions that accept a 'DustThreshold' argument will generally exclude
-- values that are /less than or equal to/ this threshold from the 'change'
-- sets of generated selections, /coalescing/ such coins together into larger
-- coins that /exceed/ the threshold.
--
-- Specifying a dust threshold of __/n/__ causes all coins that are less than
-- or equal to __/n/__ to be treated as dust and coalesced together.
--
-- Specifying a dust threshold of __0__ completely /disables/ dust elimination
-- with the exception of zero-valued coins, which will always be eliminated.
--
-- See 'coalesceDust'.
--
-- @since 1.0.0
newtype DustThreshold = DustThreshold { DustThreshold -> Coin
unDustThreshold :: Coin }
    deriving stock (DustThreshold -> DustThreshold -> Bool
(DustThreshold -> DustThreshold -> Bool)
-> (DustThreshold -> DustThreshold -> Bool) -> Eq DustThreshold
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DustThreshold -> DustThreshold -> Bool
== :: DustThreshold -> DustThreshold -> Bool
$c/= :: DustThreshold -> DustThreshold -> Bool
/= :: DustThreshold -> DustThreshold -> Bool
Eq, (forall x. DustThreshold -> Rep DustThreshold x)
-> (forall x. Rep DustThreshold x -> DustThreshold)
-> Generic DustThreshold
forall x. Rep DustThreshold x -> DustThreshold
forall x. DustThreshold -> Rep DustThreshold x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DustThreshold -> Rep DustThreshold x
from :: forall x. DustThreshold -> Rep DustThreshold x
$cto :: forall x. Rep DustThreshold x -> DustThreshold
to :: forall x. Rep DustThreshold x -> DustThreshold
Generic, Eq DustThreshold
Eq DustThreshold =>
(DustThreshold -> DustThreshold -> Ordering)
-> (DustThreshold -> DustThreshold -> Bool)
-> (DustThreshold -> DustThreshold -> Bool)
-> (DustThreshold -> DustThreshold -> Bool)
-> (DustThreshold -> DustThreshold -> Bool)
-> (DustThreshold -> DustThreshold -> DustThreshold)
-> (DustThreshold -> DustThreshold -> DustThreshold)
-> Ord DustThreshold
DustThreshold -> DustThreshold -> Bool
DustThreshold -> DustThreshold -> Ordering
DustThreshold -> DustThreshold -> DustThreshold
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DustThreshold -> DustThreshold -> Ordering
compare :: DustThreshold -> DustThreshold -> Ordering
$c< :: DustThreshold -> DustThreshold -> Bool
< :: DustThreshold -> DustThreshold -> Bool
$c<= :: DustThreshold -> DustThreshold -> Bool
<= :: DustThreshold -> DustThreshold -> Bool
$c> :: DustThreshold -> DustThreshold -> Bool
> :: DustThreshold -> DustThreshold -> Bool
$c>= :: DustThreshold -> DustThreshold -> Bool
>= :: DustThreshold -> DustThreshold -> Bool
$cmax :: DustThreshold -> DustThreshold -> DustThreshold
max :: DustThreshold -> DustThreshold -> DustThreshold
$cmin :: DustThreshold -> DustThreshold -> DustThreshold
min :: DustThreshold -> DustThreshold -> DustThreshold
Ord)
    deriving Int -> DustThreshold -> ShowS
[DustThreshold] -> ShowS
DustThreshold -> String
(Int -> DustThreshold -> ShowS)
-> (DustThreshold -> String)
-> ([DustThreshold] -> ShowS)
-> Show DustThreshold
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DustThreshold -> ShowS
showsPrec :: Int -> DustThreshold -> ShowS
$cshow :: DustThreshold -> String
show :: DustThreshold -> String
$cshowList :: [DustThreshold] -> ShowS
showList :: [DustThreshold] -> ShowS
Show via (Quiet DustThreshold)

-- | Returns 'True' if and only if the given 'Coin' is a __dust coin__
--   according to the given 'DustThreshold'.
--
-- A coin is considered to be a dust coin if it is /less than or equal to/
-- the threshold.
--
-- See 'DustThreshold'.
--
-- @since 1.0.1
isDust :: DustThreshold -> Coin -> Bool
isDust :: DustThreshold -> Coin -> Bool
isDust (DustThreshold Coin
dt) Coin
c = Coin
c Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
dt

-- | Provides a function capable of __estimating__ the transaction fee required
--   for a given coin selection, according to the rules of a particular
--   blockchain.
--
-- The fee estimate should be a function of the __current__ memberships of the
-- 'inputs', 'outputs', and 'change' sets.
--
-- Depending on the rules of the blockchain under consideration, the fee
-- estimate may take either (or both) of the following factors into account:
--
--   - the number of entries in each set;
--   - the coin value of each set member.
--
-- A fee estimate may differ from the final fee required for a selection, as
-- fees are generally paid for by /adjusting/ a given selection to make a /new/
-- selection. See 'adjustForFee' for more details of this process.
--
-- @since 1.0.0
newtype FeeEstimator i o = FeeEstimator
    { forall i o. FeeEstimator i o -> CoinSelection i o -> Fee
estimateFee :: CoinSelection i o -> Fee
    } deriving (forall x. FeeEstimator i o -> Rep (FeeEstimator i o) x)
-> (forall x. Rep (FeeEstimator i o) x -> FeeEstimator i o)
-> Generic (FeeEstimator i o)
forall x. Rep (FeeEstimator i o) x -> FeeEstimator i o
forall x. FeeEstimator i o -> Rep (FeeEstimator i o) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i o x. Rep (FeeEstimator i o) x -> FeeEstimator i o
forall i o x. FeeEstimator i o -> Rep (FeeEstimator i o) x
$cfrom :: forall i o x. FeeEstimator i o -> Rep (FeeEstimator i o) x
from :: forall x. FeeEstimator i o -> Rep (FeeEstimator i o) x
$cto :: forall i o x. Rep (FeeEstimator i o) x -> FeeEstimator i o
to :: forall x. Rep (FeeEstimator i o) x -> FeeEstimator i o
Generic

--------------------------------------------------------------------------------
-- Fee Adjustment
--------------------------------------------------------------------------------

-- | Provides options for fee adjustment.
--
-- @since 1.0.0
data FeeOptions i o = FeeOptions
    { forall i o. FeeOptions i o -> FeeEstimator i o
feeEstimator
        :: FeeEstimator i o
        -- ^ Estimate fees based on selected inputs and requested outputs.

    , forall i o. FeeOptions i o -> DustThreshold
dustThreshold
        :: DustThreshold
        -- ^ The threshold to use for dust elimination. Specifying a threshold
        -- of zero will disable dust elimination. See 'DustThreshold' for more
        -- details.

    , forall i o. FeeOptions i o -> FeeBalancingPolicy
feeBalancingPolicy
        :: FeeBalancingPolicy
        -- ^ Which fee balancing policy to use.
    } deriving (forall x. FeeOptions i o -> Rep (FeeOptions i o) x)
-> (forall x. Rep (FeeOptions i o) x -> FeeOptions i o)
-> Generic (FeeOptions i o)
forall x. Rep (FeeOptions i o) x -> FeeOptions i o
forall x. FeeOptions i o -> Rep (FeeOptions i o) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i o x. Rep (FeeOptions i o) x -> FeeOptions i o
forall i o x. FeeOptions i o -> Rep (FeeOptions i o) x
$cfrom :: forall i o x. FeeOptions i o -> Rep (FeeOptions i o) x
from :: forall x. FeeOptions i o -> Rep (FeeOptions i o) x
$cto :: forall i o x. Rep (FeeOptions i o) x -> FeeOptions i o
to :: forall x. Rep (FeeOptions i o) x -> FeeOptions i o
Generic

-- | A choice of fee balancing policies for use when adjusting a coin selection.
--
-- == Background
--
-- A coin selection __'s'__ is said to have a /perfectly-balanced/ fee when it
-- satisfies the following property:
--
-- >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s
--
-- Conversely, a selection is said to have an /unbalanced/ fee when it
-- satisfies the following property:
--
-- >>> sumInputs s > sumOutputs s + sumChange s + estimateFee s
--
-- In other words, if a coin selection has an /unbalanced/ fee, the /effective/
-- fee is greater than the minimum fee /actually required/ by the blockchain.
--
-- == Balanced Fees vs Minimal Fees
--
-- Some blockchains /require /that fees are always /perfectly-balanced/.
--
-- However, for blockchains that allow /unbalanced/ fees, it is sometimes
-- possible to /save money/ by generating a coin selection with an unbalanced
-- fee. This may seem counterintuitive at first, but consider an individual
-- change output __/c/__ of value __/v/__. If the /marginal fee/ __/f/__
-- associated with __/c/__ is greater than its value __/v/__, then we will
-- /save money/ by __not__ including __/c/__ within 'change'.
--
-- There are two policy choices available for handling change values with
-- marginal fees greater than their value:
--
--   - For blockchains that __allow__ transactions with /unbalanced/ fees,
--     specifying the 'RequireMinimalFee' policy will allow money to be saved by
--     /excluding/ change outputs that have a marginal fee greater than
--     their value.
--
--   - For blockchains that do __not__ allow transactions with /unbalanced/
--     fees, specifying the 'RequireBalancedFee' policy will always generate
--     selections with fees that are perfectly-balanced, even if the resulting
--     fees are higher than could be achieved by allowing unbalanced fees.
--
data FeeBalancingPolicy
    = RequireBalancedFee
        -- ^ Generate selections with fees that are perfectly balanced, with the
        -- trade-off of allowing slightly higher fees.
    | RequireMinimalFee
        -- ^ Generate selections with the lowest fees possible, with the
        -- trade-off of allowing slightly imbalanced fees.
    deriving ((forall x. FeeBalancingPolicy -> Rep FeeBalancingPolicy x)
-> (forall x. Rep FeeBalancingPolicy x -> FeeBalancingPolicy)
-> Generic FeeBalancingPolicy
forall x. Rep FeeBalancingPolicy x -> FeeBalancingPolicy
forall x. FeeBalancingPolicy -> Rep FeeBalancingPolicy x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FeeBalancingPolicy -> Rep FeeBalancingPolicy x
from :: forall x. FeeBalancingPolicy -> Rep FeeBalancingPolicy x
$cto :: forall x. Rep FeeBalancingPolicy x -> FeeBalancingPolicy
to :: forall x. Rep FeeBalancingPolicy x -> FeeBalancingPolicy
Generic, Int -> FeeBalancingPolicy -> ShowS
[FeeBalancingPolicy] -> ShowS
FeeBalancingPolicy -> String
(Int -> FeeBalancingPolicy -> ShowS)
-> (FeeBalancingPolicy -> String)
-> ([FeeBalancingPolicy] -> ShowS)
-> Show FeeBalancingPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FeeBalancingPolicy -> ShowS
showsPrec :: Int -> FeeBalancingPolicy -> ShowS
$cshow :: FeeBalancingPolicy -> String
show :: FeeBalancingPolicy -> String
$cshowList :: [FeeBalancingPolicy] -> ShowS
showList :: [FeeBalancingPolicy] -> ShowS
Show, FeeBalancingPolicy -> FeeBalancingPolicy -> Bool
(FeeBalancingPolicy -> FeeBalancingPolicy -> Bool)
-> (FeeBalancingPolicy -> FeeBalancingPolicy -> Bool)
-> Eq FeeBalancingPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FeeBalancingPolicy -> FeeBalancingPolicy -> Bool
== :: FeeBalancingPolicy -> FeeBalancingPolicy -> Bool
$c/= :: FeeBalancingPolicy -> FeeBalancingPolicy -> Bool
/= :: FeeBalancingPolicy -> FeeBalancingPolicy -> Bool
Eq)

-- | Represents the set of possible failures that can occur when adjusting a
--   'CoinSelection' with the 'adjustForFee' function.
--
data FeeAdjustmentError i o
    = CannotCoverFee Fee
    -- ^ Indicates that the given map of additional inputs was exhausted while
    --   attempting to select extra inputs to cover the required fee.
    --
    -- Records the shortfall (__/f/__ − __/s/__) between the required fee
    -- __/f/__ and the total value __/s/__ of currently-selected inputs.

    | CoinSelectionUnderfunded (CoinSelection i o)
    -- ^ Indicates that the given coin selection is __underfunded__: the total
    -- value of 'inputs' is less than the total value of 'outputs', as
    -- calculated by the 'CoinSelection.coinMapValue' function.
    deriving (Int -> FeeAdjustmentError i o -> ShowS
[FeeAdjustmentError i o] -> ShowS
FeeAdjustmentError i o -> String
(Int -> FeeAdjustmentError i o -> ShowS)
-> (FeeAdjustmentError i o -> String)
-> ([FeeAdjustmentError i o] -> ShowS)
-> Show (FeeAdjustmentError i o)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall i o.
(Show i, Show o) =>
Int -> FeeAdjustmentError i o -> ShowS
forall i o. (Show i, Show o) => [FeeAdjustmentError i o] -> ShowS
forall i o. (Show i, Show o) => FeeAdjustmentError i o -> String
$cshowsPrec :: forall i o.
(Show i, Show o) =>
Int -> FeeAdjustmentError i o -> ShowS
showsPrec :: Int -> FeeAdjustmentError i o -> ShowS
$cshow :: forall i o. (Show i, Show o) => FeeAdjustmentError i o -> String
show :: FeeAdjustmentError i o -> String
$cshowList :: forall i o. (Show i, Show o) => [FeeAdjustmentError i o] -> ShowS
showList :: [FeeAdjustmentError i o] -> ShowS
Show, FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
(FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool)
-> (FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool)
-> Eq (FeeAdjustmentError i o)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall i o.
(Eq i, Eq o) =>
FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
$c== :: forall i o.
(Eq i, Eq o) =>
FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
== :: FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
$c/= :: forall i o.
(Eq i, Eq o) =>
FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
/= :: FeeAdjustmentError i o -> FeeAdjustmentError i o -> Bool
Eq)

-- | Adjusts the given 'CoinSelection' in order to pay for a __transaction__
--   __fee__, required in order to publish the selection as a transaction on
--   a blockchain.
--
-- == Background
--
-- Implementations of 'Cardano.CoinSelection.CoinSelectionAlgorithm' generally
-- produce coin selections that are /exactly balanced/, satisfying the
-- following equality:
--
-- >>> sumInputs s = sumOutputs s + sumChange s
--
-- In order to pay for a transaction fee, the above equality must be
-- transformed into an /inequality/:
--
-- >>> sumInputs s > sumOutputs s + sumChange s
--
-- The difference between these two sides represents value to be paid /by the/
-- /originator/ of the transaction, in the form of a fee:
--
-- >>> sumInputs s = sumOutputs s + sumChange s + fee
--
-- == The Adjustment Process
--
-- In order to generate a fee that is acceptable to the network, this function
-- adjusts the 'change' and 'inputs' of the given 'CoinSelection', consulting
-- the 'FeeEstimator' as a guide for how much the current selection would cost
-- to publish as a transaction on the network.
--
-- == Methods of Adjustment
--
-- There are two methods of adjustment possible:
--
--  1. The __'change'__ set can be /reduced/, either by:
--
--      a. completely removing a change value from the set; or by
--
--      b. reducing a change value to a lower value.
--
--  2. The __'inputs'__ set can be /augmented/, by selecting additional inputs
--     from the specified 'CoinMap' argument.
--
-- == Dealing with Dust Values
--
-- If, at any point, a change value is generated that is less than or equal
-- to the 'DustThreshold', this function will eliminate that change value
-- from the 'change' set, redistributing the eliminated value over the remaining
-- change values, ensuring that the total value of all 'change' is preserved.
--
-- See 'coalesceDust' for more details.
--
-- == Termination
--
-- Since adjusting a selection can affect the fee estimate produced by
-- 'estimateFee', the process of adjustment is an /iterative/ process.
--
-- The termination post-condition depends on the choice of
-- 'FeeBalancingPolicy':
--
--   - If 'RequireBalancedFee' is specified, this function terminates
--     only when it has generated a 'CoinSelection' __'s'__ that satisfies the
--     following property:
--
--         >>> sumInputs s = sumOutputs s + sumChange s + estimateFee s
--
--   - If 'RequireMinimalFee' policy is specified, the above /equality/
--     is relaxed to the following /inequality/:
--
--         >>> sumInputs s ≥ sumOutputs s + sumChange s + estimateFee s
--
-- See 'FeeBalancingPolicy' for more details.
--
-- @since 1.0.0
adjustForFee
    :: (Ord i, MonadRandom m)
    => FeeOptions i o
    -> CoinMap i
    -> CoinSelection i o
    -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
adjustForFee :: forall i (m :: * -> *) o.
(Ord i, MonadRandom m) =>
FeeOptions i o
-> CoinMap i
-> CoinSelection i o
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
adjustForFee FeeOptions i o
unsafeOpt CoinMap i
utxo CoinSelection i o
coinSel = do
    let opt :: FeeOptions i o
opt = String
-> FeeOptions i o -> (FeeOptions i o -> Bool) -> FeeOptions i o
forall a. String -> a -> (a -> Bool) -> a
invariant
            String
"adjustForFee: fee must be non-null" FeeOptions i o
unsafeOpt (Bool -> Bool
not (Bool -> Bool)
-> (FeeOptions i o -> Bool) -> FeeOptions i o -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FeeOptions i o -> Bool
nullFee)
    FeeOptions i o
-> CoinMap i
-> CoinSelection i o
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
forall i o (m :: * -> *).
(Ord i, MonadRandom m) =>
FeeOptions i o
-> CoinMap i
-> CoinSelection i o
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
senderPaysFee FeeOptions i o
opt CoinMap i
utxo CoinSelection i o
coinSel
  where
    nullFee :: FeeOptions i o -> Bool
nullFee FeeOptions i o
opt = FeeEstimator i o -> CoinSelection i o -> Fee
forall i o. FeeEstimator i o -> CoinSelection i o -> Fee
estimateFee (FeeOptions i o -> FeeEstimator i o
forall i o. FeeOptions i o -> FeeEstimator i o
feeEstimator FeeOptions i o
opt) CoinSelection i o
coinSel Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Coin -> Fee
Fee Coin
C.zero

--------------------------------------------------------------------------------
-- Internal Functions
--------------------------------------------------------------------------------

-- Calculates the current fee associated with a given 'CoinSelection'.
--
-- If the result is less than zero, returns 'Nothing'.
--
calculateFee :: CoinSelection i o -> Maybe Fee
calculateFee :: forall i o. CoinSelection i o -> Maybe Fee
calculateFee CoinSelection i o
s = Coin -> Fee
Fee (Coin -> Fee) -> Maybe Coin -> Maybe Fee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumInputs CoinSelection i o
s Coin -> Coin -> Maybe Coin
`C.sub` (CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumOutputs CoinSelection i o
s Coin -> Coin -> Coin
`C.add` CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumChange CoinSelection i o
s)

-- The sender pays fee in this scenario, so fees are removed from the change
-- outputs, and new inputs are selected if necessary.
--
senderPaysFee
    :: forall i o m . (Ord i, MonadRandom m)
    => FeeOptions i o
    -> CoinMap i
    -> CoinSelection i o
    -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
senderPaysFee :: forall i o (m :: * -> *).
(Ord i, MonadRandom m) =>
FeeOptions i o
-> CoinMap i
-> CoinSelection i o
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
senderPaysFee FeeOptions i o
opts CoinMap i
utxo CoinSelection i o
sel =
    StateT
  (CoinMap i)
  (ExceptT (FeeAdjustmentError i o) m)
  (CoinSelection i o)
-> CoinMap i
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (CoinSelection i o
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o)
go CoinSelection i o
sel) CoinMap i
utxo
  where
    go
        :: CoinSelection i o
        -> StateT
            (CoinMap i)
            (ExceptT (FeeAdjustmentError i o) m)
            (CoinSelection i o)
    go :: CoinSelection i o
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o)
go coinSel :: CoinSelection i o
coinSel@(CoinSelection CoinMap i
inps CoinMap o
outs [Coin]
chgs) = do
        -- Substract fee from change outputs, proportionally to their value.
        (CoinSelection i o
coinSel', Fee
remFee) <- ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee)
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o, Fee)
forall (m :: * -> *) a. Monad m => m a -> StateT (CoinMap i) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee)
 -> StateT
      (CoinMap i)
      (ExceptT (FeeAdjustmentError i o) m)
      (CoinSelection i o, Fee))
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee)
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o, Fee)
forall a b. (a -> b) -> a -> b
$ Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
 -> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee))
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
-> ExceptT (FeeAdjustmentError i o) m (CoinSelection i o, Fee)
forall a b. (a -> b) -> a -> b
$ FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall i o.
FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
reduceChangeOutputs FeeOptions i o
opts CoinSelection i o
coinSel

        -- Should the change cover the fee, we're (almost) good. By removing
        -- change outputs, we make them smaller and may reduce the size of the
        -- transaction, and the fee. Thus, we end up paying slightly more than
        -- the upper bound. We could do some binary search and try to
        -- re-distribute excess across changes until fee becomes bigger.
        if Fee
remFee Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Coin -> Fee
Fee Coin
C.zero
        then CoinSelection i o
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o)
forall a.
a -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoinSelection i o
coinSel'
        else do
            -- Otherwise, we need an extra entries from the available utxo to
            -- cover what's left. Note that this entry may increase our change
            -- because we may not consume it entirely. So we will just split
            -- the extra change across all changes possibly increasing the
            -- number of change outputs (if there was none, or if increasing a
            -- change value causes an overflow).
            --
            -- Because selecting a new input increases the fee, we need to
            -- re-run the algorithm with this new elements and using the initial
            -- change plus the extra change brought up by this entry and see if
            -- we can now correctly cover fee.
            [CoinMapEntry i]
inps' <- Fee
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
forall (m :: * -> *) i o.
MonadRandom m =>
Fee
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
coverRemainingFee Fee
remFee
            let extraChange :: [Coin]
extraChange = Coin -> [Coin] -> [Coin]
splitCoin ([CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
inps') [Coin]
chgs
            CoinSelection i o
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o)
go (CoinSelection i o
 -> StateT
      (CoinMap i)
      (ExceptT (FeeAdjustmentError i o) m)
      (CoinSelection i o))
-> CoinSelection i o
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (CoinSelection i o)
forall a b. (a -> b) -> a -> b
$ CoinMap i -> CoinMap o -> [Coin] -> CoinSelection i o
forall i o. CoinMap i -> CoinMap o -> [Coin] -> CoinSelection i o
CoinSelection (CoinMap i
inps CoinMap i -> CoinMap i -> CoinMap i
forall a. Semigroup a => a -> a -> a
<> [CoinMapEntry i] -> CoinMap i
forall a. Ord a => [CoinMapEntry a] -> CoinMap a
coinMapFromList [CoinMapEntry i]
inps') CoinMap o
outs [Coin]
extraChange

-- A short and simple version of the 'random' fee policy to cover for the fee
-- in the case where existing set of change is not enough.
--
coverRemainingFee
    :: MonadRandom m
    => Fee
    -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
coverRemainingFee :: forall (m :: * -> *) i o.
MonadRandom m =>
Fee
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
coverRemainingFee (Fee Coin
fee) = [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
go [] where
    go :: [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
go [CoinMapEntry i]
acc
        | [CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
acc Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
fee =
            [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
forall a.
a -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return [CoinMapEntry i]
acc
        | Bool
otherwise = do
            -- We ignore the size of the fee, and just pick randomly
            (CoinMap i
 -> ExceptT
      (FeeAdjustmentError i o) m (Maybe (CoinMapEntry i), CoinMap i))
-> StateT
     (CoinMap i)
     (ExceptT (FeeAdjustmentError i o) m)
     (Maybe (CoinMapEntry i))
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (m (Maybe (CoinMapEntry i), CoinMap i)
-> ExceptT
     (FeeAdjustmentError i o) m (Maybe (CoinMapEntry i), CoinMap i)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (FeeAdjustmentError i o) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe (CoinMapEntry i), CoinMap i)
 -> ExceptT
      (FeeAdjustmentError i o) m (Maybe (CoinMapEntry i), CoinMap i))
-> (CoinMap i -> m (Maybe (CoinMapEntry i), CoinMap i))
-> CoinMap i
-> ExceptT
     (FeeAdjustmentError i o) m (Maybe (CoinMapEntry i), CoinMap i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoinMap i -> m (Maybe (CoinMapEntry i), CoinMap i)
forall {f :: * -> *} {a}.
MonadRandom f =>
CoinMap a -> f (Maybe (CoinMapEntry a), CoinMap a)
selectRandomEntry) StateT
  (CoinMap i)
  (ExceptT (FeeAdjustmentError i o) m)
  (Maybe (CoinMapEntry i))
-> (Maybe (CoinMapEntry i)
    -> StateT
         (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i])
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
forall a b.
StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) a
-> (a -> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) b)
-> StateT (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just CoinMapEntry i
entry ->
                    [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
go (CoinMapEntry i
entry CoinMapEntry i -> [CoinMapEntry i] -> [CoinMapEntry i]
forall a. a -> [a] -> [a]
: [CoinMapEntry i]
acc)
                Maybe (CoinMapEntry i)
Nothing ->
                    ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
forall (m :: * -> *) a. Monad m => m a -> StateT (CoinMap i) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i]
 -> StateT
      (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i])
-> ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i]
-> StateT
     (CoinMap i) (ExceptT (FeeAdjustmentError i o) m) [CoinMapEntry i]
forall a b. (a -> b) -> a -> b
$ FeeAdjustmentError i o
-> ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i]
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (FeeAdjustmentError i o
 -> ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i])
-> FeeAdjustmentError i o
-> ExceptT (FeeAdjustmentError i o) m [CoinMapEntry i]
forall a b. (a -> b) -> a -> b
$ Fee -> FeeAdjustmentError i o
forall i o. Fee -> FeeAdjustmentError i o
CannotCoverFee (Fee -> FeeAdjustmentError i o) -> Fee -> FeeAdjustmentError i o
forall a b. (a -> b) -> a -> b
$ Coin -> Fee
Fee (Coin -> Fee) -> Coin -> Fee
forall a b. (a -> b) -> a -> b
$
                        Coin
fee Coin -> Coin -> Coin
`C.distance` ([CoinMapEntry i] -> Coin
forall i. [CoinMapEntry i] -> Coin
sumEntries [CoinMapEntry i]
acc)
    selectRandomEntry :: CoinMap a -> f (Maybe (CoinMapEntry a), CoinMap a)
selectRandomEntry CoinMap a
m =
        (Maybe (CoinMapEntry a), CoinMap a)
-> ((CoinMapEntry a, CoinMap a)
    -> (Maybe (CoinMapEntry a), CoinMap a))
-> Maybe (CoinMapEntry a, CoinMap a)
-> (Maybe (CoinMapEntry a), CoinMap a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (CoinMapEntry a)
forall a. Maybe a
Nothing, CoinMap a
m) ((CoinMapEntry a -> Maybe (CoinMapEntry a))
-> (CoinMapEntry a, CoinMap a)
-> (Maybe (CoinMapEntry a), CoinMap a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CoinMapEntry a -> Maybe (CoinMapEntry a)
forall a. a -> Maybe a
Just) (Maybe (CoinMapEntry a, CoinMap a)
 -> (Maybe (CoinMapEntry a), CoinMap a))
-> f (Maybe (CoinMapEntry a, CoinMap a))
-> f (Maybe (CoinMapEntry a), CoinMap a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoinMap a -> f (Maybe (CoinMapEntry a, CoinMap a))
forall (m :: * -> *) a.
MonadRandom m =>
CoinMap a -> m (Maybe (CoinMapEntry a, CoinMap a))
coinMapRandomEntry CoinMap a
m

-- Pays for the given fee by subtracting it from the given list of change
-- outputs, so that each change output is reduced by a portion of the fee
-- that's in proportion to its relative size.
--
-- == Basic Examples
--
-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 4) (Coin <$> [2, 2, 2, 2])
-- [Coin 1, Coin 1, Coin 1, Coin 1]
--
-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [2, 4, 8, 16])
-- [Coin 1, Coin 2, Coin 4, Coin 8]
--
-- == Handling Dust
--
-- Any dust outputs in the resulting list are coalesced according to the given
-- dust threshold: (See 'coalesceDust'.)
--
-- >>> reduceChangeOutputs (DustThreshold 1) (Fee 4) (Coin <$> [2, 2, 2, 2])
-- [Coin 4]
--
-- == Handling Insufficient Change
--
-- If there's not enough change to pay for the fee, or if there's only just
-- enough to pay for it exactly, this function returns the /empty list/:
--
-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [10])
-- []
--
-- >>> reduceChangeOutputs (DustThreshold 0) (Fee 15) (Coin <$> [1, 2, 4, 8])
-- []
--
reduceChangeOutputs
    :: FeeOptions i o
    -> CoinSelection i o
    -> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
reduceChangeOutputs :: forall i o.
FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
reduceChangeOutputs FeeOptions i o
opts CoinSelection i o
s = do
    -- The original requested fee amount
    let Fee Coin
phi_original = FeeEstimator i o -> CoinSelection i o -> Fee
forall i o. FeeEstimator i o -> CoinSelection i o -> Fee
estimateFee (FeeOptions i o -> FeeEstimator i o
forall i o. FeeOptions i o -> FeeEstimator i o
feeEstimator FeeOptions i o
opts) CoinSelection i o
s
    -- The initial amount left for fee (i.e. inputs - outputs)
    let m_delta_original :: Maybe Coin
m_delta_original = CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumInputs CoinSelection i o
s Coin -> Coin -> Maybe Coin
`C.sub` (CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumOutputs CoinSelection i o
s Coin -> Coin -> Coin
`C.add` CoinSelection i o -> Coin
forall i o. CoinSelection i o -> Coin
sumChange CoinSelection i o
s)
    case Maybe Coin
m_delta_original of
        -- selection is now balanced, nothing to do.
        Just Coin
delta_original | Coin
phi_original Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
delta_original -> do
            (CoinSelection i o, Fee)
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall a. a -> Either (FeeAdjustmentError i o) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoinSelection i o
s, Coin -> Fee
Fee Coin
C.zero)

        -- some fee left to pay, but we've depleted all change outputs
        Just Coin
delta_original | Coin
phi_original Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
delta_original Bool -> Bool -> Bool
&& [Coin] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CoinSelection i o -> [Coin]
forall i o. CoinSelection i o -> [Coin]
change CoinSelection i o
s) -> do
            let remainder :: Coin
remainder = Coin
phi_original Coin -> Coin -> Coin
`C.distance` Coin
delta_original
            (CoinSelection i o, Fee)
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall a. a -> Either (FeeAdjustmentError i o) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoinSelection i o
s, Coin -> Fee
Fee Coin
remainder)

        -- some fee left to pay, and we've haven't depleted all change yet
        Just Coin
delta_original | Coin
phi_original Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
delta_original Bool -> Bool -> Bool
&& Bool -> Bool
not ([Coin] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CoinSelection i o -> [Coin]
forall i o. CoinSelection i o -> [Coin]
change CoinSelection i o
s)) -> do
            let remainder :: Coin
remainder = Coin
phi_original Coin -> Coin -> Coin
`C.distance` Coin
delta_original
            let chgs' :: [Coin]
chgs' = Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin)
distributeFee (Coin -> Fee
Fee Coin
remainder) ([Coin] -> NonEmpty Coin
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (CoinSelection i o -> [Coin]
forall i o. CoinSelection i o -> [Coin]
change CoinSelection i o
s))
                      NonEmpty (Fee, Coin)
-> (NonEmpty (Fee, Coin) -> NonEmpty Coin) -> NonEmpty Coin
forall a b. a -> (a -> b) -> b
& ((Fee, Coin) -> Coin) -> NonEmpty (Fee, Coin) -> NonEmpty Coin
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Fee, Coin) -> Coin
payFee
                      NonEmpty Coin -> (NonEmpty Coin -> [Coin]) -> [Coin]
forall a b. a -> (a -> b) -> b
& DustThreshold -> NonEmpty Coin -> [Coin]
coalesceDust (FeeOptions i o -> DustThreshold
forall i o. FeeOptions i o -> DustThreshold
dustThreshold FeeOptions i o
opts)
            FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall i o.
FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
reduceChangeOutputs FeeOptions i o
opts (CoinSelection i o
s { change = chgs' })

        -- The current selection has a higher fee than necessary. This typically
        -- occurs if, after reducing an output to pay for the predicted fee, the
        -- required fee turns out to be less than originally predicted.
        -- The outcome depends on whether or not the node allows transactions
        -- to be unbalanced.
        Just Coin
delta_original | Coin
delta_original Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
phi_original -> do
            let extraChg :: Coin
extraChg = Coin
delta_original Coin -> Coin -> Coin
`C.distance` Coin
phi_original
            let sDangling :: CoinSelection i o
sDangling = CoinSelection i o
s { change = splitCoin extraChg (change s) }
            let Fee Coin
phi_dangling = FeeEstimator i o -> CoinSelection i o -> Fee
forall i o. FeeEstimator i o -> CoinSelection i o -> Fee
estimateFee (FeeOptions i o -> FeeEstimator i o
forall i o. FeeOptions i o -> FeeEstimator i o
feeEstimator FeeOptions i o
opts) CoinSelection i o
sDangling
            -- We have `delta_dangling = phi_original` by construction of sDangling.
            --
            -- Proof:
            --
            -- delta_dangling = Σi_dangling - (Σo_dangling + Σc_dangling)
            --            = Σi_original - (Σo_original + Σc_original + extraChg)
            --            = Σi_original - (Σo_original + Σc_original) - extraChg
            --            = delta_original - extraChg
            --            = delta_original - (delta_original - phi_original)
            --            = phi_original
            let delta_dangling :: Coin
delta_dangling = Coin
phi_original
            case Coin
phi_dangling Coin -> Coin -> Maybe Coin
`C.sub` Coin
delta_dangling of
                -- we've left too much, but adding a change output would be more
                -- expensive than not having it. Here we have two choices:
                --
                -- a) If the node allows unbalanced transaction, we can stop
                --    here and do nothing. We'll leave slightly more than what's
                --    needed for fees, but having an extra change output isn't
                --    worth it anyway.
                --
                -- b) If we __must__ balance the transaction, then we can choose
                --    to pay the extra cost by adding the change output and
                --    continue trying to balance the transaction (likely, by
                --    selecting another input).
                Just Coin
remainder | Coin
phi_dangling Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
delta_original ->
                    case FeeOptions i o -> FeeBalancingPolicy
forall i o. FeeOptions i o -> FeeBalancingPolicy
feeBalancingPolicy FeeOptions i o
opts of
                        FeeBalancingPolicy
RequireMinimalFee ->
                            (CoinSelection i o, Fee)
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall a. a -> Either (FeeAdjustmentError i o) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoinSelection i o
s, Coin -> Fee
Fee Coin
C.zero)
                        FeeBalancingPolicy
RequireBalancedFee ->
                            (CoinSelection i o, Fee)
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall a. a -> Either (FeeAdjustmentError i o) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoinSelection i o
sDangling, Coin -> Fee
Fee Coin
remainder)

                -- If however, adding the dangling change doesn't cost more than
                -- not having it, we might as well add it to get the money and
                -- continue balancing!
                Maybe Coin
_otherwise ->
                    FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall i o.
FeeOptions i o
-> CoinSelection i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
reduceChangeOutputs FeeOptions i o
opts CoinSelection i o
sDangling

        -- The only way to end-up here is if the user has provided an invalid
        -- selection where outputs are trying to spend more than inputs. This is
        -- simply forbidden.
        Maybe Coin
_Nothing ->
            FeeAdjustmentError i o
-> Either (FeeAdjustmentError i o) (CoinSelection i o, Fee)
forall a b. a -> Either a b
Left (CoinSelection i o -> FeeAdjustmentError i o
forall i o. CoinSelection i o -> FeeAdjustmentError i o
CoinSelectionUnderfunded CoinSelection i o
s)

-- Distribute the given fee over the given list of coins, so that each coin
-- is allocated a __fraction__ of the fee in proportion to its relative size.
--
-- == Pre-condition
--
-- Every coin in the given list must be __non-zero__ in value.
--
-- == Examples
--
-- >>> distributeFee (Fee 2) [(Coin 1), (Coin 1)]
-- [(Fee 1, Coin 1), (Fee 1, Coin 1)]
--
-- >>> distributeFee (Fee 4) [(Coin 1), (Coin 1)]
-- [(Fee 2, Coin 1), (Fee 2, Coin 1)]
--
-- >>> distributeFee (Fee 7) [(Coin 1), (Coin 2), (Coin 4)]
-- [(Fee 1, Coin 1), (Fee 2, Coin 2), (Fee 4, Coin 4)]
--
-- >>> distributeFee (Fee 14) [(Coin 1), (Coin 2), (Coin 4)]
-- [(Fee 2, Coin 1), (Fee 4, Coin 2), (Fee 8, Coin 4)]
--
distributeFee :: Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin)
distributeFee :: Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin)
distributeFee (Fee Coin
feeTotal) NonEmpty Coin
coinsUnsafe =
    NonEmpty Fee -> NonEmpty Coin -> NonEmpty (Fee, Coin)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Fee
feesRounded NonEmpty Coin
coins
  where
    -- A list of coins that are non-zero in value.
    coins :: NonEmpty Coin
    coins :: NonEmpty Coin
coins =
        String -> NonEmpty Coin -> (NonEmpty Coin -> Bool) -> NonEmpty Coin
forall a. String -> a -> (a -> Bool) -> a
invariant String
"distributeFee: all coins must be non-zero in value."
        NonEmpty Coin
coinsUnsafe (Coin
C.zero Coin -> NonEmpty Coin -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`F.notElem`)

    -- A list of rounded fee portions, where each fee portion deviates from the
    -- ideal unrounded portion by as small an amount as possible.
    feesRounded :: NonEmpty Fee
    feesRounded :: NonEmpty Fee
feesRounded
        -- 1. Start with the list of ideal unrounded fee portions for each coin:
        = NonEmpty Rational
feesUnrounded
        -- 2. Attach an index to each fee portion, so that we can remember the
        --    original order:
        NonEmpty Rational
-> (NonEmpty Rational -> NonEmpty (Int, Rational))
-> NonEmpty (Int, Rational)
forall a b. a -> (a -> b) -> b
& NonEmpty Int -> NonEmpty Rational -> NonEmpty (Int, Rational)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Int
indices
        -- 3. Sort the fees into descending order of their fractional parts:
        NonEmpty (Int, Rational)
-> (NonEmpty (Int, Rational) -> NonEmpty (Int, Rational))
-> NonEmpty (Int, Rational)
forall a b. a -> (a -> b) -> b
& ((Int, Rational) -> (Int, Rational) -> Ordering)
-> NonEmpty (Int, Rational) -> NonEmpty (Int, Rational)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (((Int, Rational) -> Down Rational)
-> (Int, Rational) -> (Int, Rational) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Rational -> Down Rational
forall a. a -> Down a
Down (Rational -> Down Rational)
-> ((Int, Rational) -> Rational)
-> (Int, Rational)
-> Down Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational
fractionalPart (Rational -> Rational)
-> ((Int, Rational) -> Rational) -> (Int, Rational) -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Rational) -> Rational
forall a b. (a, b) -> b
snd))
        -- 4. Apply pre-computed roundings to each fee portion:
        --    * portions with the greatest fractional parts are rounded up;
        --    * portions with the smallest fractional parts are rounded down.
        NonEmpty (Int, Rational)
-> (NonEmpty (Int, Rational) -> NonEmpty (Int, Integer))
-> NonEmpty (Int, Integer)
forall a b. a -> (a -> b) -> b
& (RoundingDirection -> (Int, Rational) -> (Int, Integer))
-> NonEmpty RoundingDirection
-> NonEmpty (Int, Rational)
-> NonEmpty (Int, Integer)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith (\RoundingDirection
roundDir (Int
i, Rational
f) -> (Int
i, RoundingDirection -> Rational -> Integer
forall a b. (RealFrac a, Integral b) => RoundingDirection -> a -> b
round RoundingDirection
roundDir Rational
f)) NonEmpty RoundingDirection
feeRoundings
        -- 5. Restore the original order:
        NonEmpty (Int, Integer)
-> (NonEmpty (Int, Integer) -> NonEmpty (Int, Integer))
-> NonEmpty (Int, Integer)
forall a b. a -> (a -> b) -> b
& ((Int, Integer) -> (Int, Integer) -> Ordering)
-> NonEmpty (Int, Integer) -> NonEmpty (Int, Integer)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (((Int, Integer) -> Int)
-> (Int, Integer) -> (Int, Integer) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Integer) -> Int
forall a b. (a, b) -> a
fst)
        -- 6. Strip away the indices:
        NonEmpty (Int, Integer)
-> (NonEmpty (Int, Integer) -> NonEmpty Integer)
-> NonEmpty Integer
forall a b. a -> (a -> b) -> b
& ((Int, Integer) -> Integer)
-> NonEmpty (Int, Integer) -> NonEmpty Integer
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Integer) -> Integer
forall a b. (a, b) -> b
snd
        -- 7. Transform results into fees:
        NonEmpty Integer
-> (NonEmpty Integer -> NonEmpty Fee) -> NonEmpty Fee
forall a b. a -> (a -> b) -> b
& (Integer -> Fee) -> NonEmpty Integer -> NonEmpty Fee
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coin -> Fee
Fee (Coin -> Fee) -> (Integer -> Coin) -> Integer -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Maybe Coin -> Coin
forall a. a -> Maybe a -> a
fromMaybe Coin
C.zero (Maybe Coin -> Coin) -> (Integer -> Maybe Coin) -> Integer -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => i -> Maybe Coin
C.coinFromIntegral @Integer)
      where
        indices :: NonEmpty Int
        indices :: NonEmpty Int
indices = Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 ..]

    -- A list of rounding directions, one per fee portion.
    --
    -- Since the ideal fee portion for each coin is a rational value, we must
    -- therefore round each rational value either /up/ or /down/ to produce a
    -- final integer result.
    --
    -- However, we can't take the simple approach of either rounding /all/ fee
    -- portions down or rounding /all/ fee portions up, as this could cause the
    -- sum of fee portions to either undershoot or overshoot the original fee.
    --
    -- So in order to hit the fee exactly, we must round /some/ of the portions
    -- up, and /some/ of the portions down.
    --
    -- Fortunately, we can calculate exactly how many fee portions must be
    -- rounded up, by first rounding /all/ portions down, and then computing
    -- the /shortfall/ between the sum of the rounded-down portions and the
    -- original fee.
    --
    -- We return a list where all values of 'RoundUp' occur in a contiguous
    -- section at the start of the list, of the following form:
    --
    --     [RoundUp, RoundUp, ..., RoundDown, RoundDown, ...]
    --
    feeRoundings :: NonEmpty RoundingDirection
    feeRoundings :: NonEmpty RoundingDirection
feeRoundings =
        Int
-> (NonEmpty RoundingDirection -> NonEmpty RoundingDirection)
-> NonEmpty RoundingDirection
-> NonEmpty RoundingDirection
forall a. Int -> (a -> a) -> a -> a
applyN Int
feeShortfall (RoundingDirection
-> NonEmpty RoundingDirection -> NonEmpty RoundingDirection
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons RoundingDirection
RoundUp) (RoundingDirection -> NonEmpty RoundingDirection
forall a. a -> NonEmpty a
NE.repeat RoundingDirection
RoundDown)
      where
         -- The part of the total fee that we'd lose if we were to take the
         -- simple approach of rounding all ideal fee portions /down/.
        feeShortfall :: Int
feeShortfall
            = Coin -> Int
forall i. Integral i => Coin -> i
C.coinToIntegral Coin
feeTotal
            Int -> Int -> Int
forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer (NonEmpty Integer -> Integer
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
F.sum (NonEmpty Integer -> Integer) -> NonEmpty Integer -> Integer
forall a b. (a -> b) -> a -> b
$ RoundingDirection -> Rational -> Integer
forall a b. (RealFrac a, Integral b) => RoundingDirection -> a -> b
round RoundingDirection
RoundDown (Rational -> Integer) -> NonEmpty Rational -> NonEmpty Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Rational
feesUnrounded)

    -- A list of ideal unrounded fee portions, with one fee portion per coin.
    --
    -- A coin's ideal fee portion is the rational portion of the total fee that
    -- corresponds to that coin's relative size when compared to other coins.
    feesUnrounded :: NonEmpty Rational
    feesUnrounded :: NonEmpty Rational
feesUnrounded = Coin -> Rational
calculateIdealFee (Coin -> Rational) -> NonEmpty Coin -> NonEmpty Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Coin
coins
      where
        calculateIdealFee :: Coin -> Rational
calculateIdealFee Coin
c
            = Coin -> Integer
forall i. Integral i => Coin -> i
C.coinToIntegral Coin
c
            Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Coin -> Integer
forall i. Integral i => Coin -> i
C.coinToIntegral Coin
feeTotal
            Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Coin -> Integer
forall i. Integral i => Coin -> i
C.coinToIntegral Coin
totalCoinValue

    -- The total value of all coins.
    totalCoinValue :: Coin
    totalCoinValue :: Coin
totalCoinValue = NonEmpty Coin -> Coin
forall m. Monoid m => NonEmpty m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold NonEmpty Coin
coins

-- | From the given list of coins, remove dust coins with a value less than or
--   equal to the given threshold value, redistributing their total value over
--   the coins that remain.
--
-- This function satisfies the following properties:
--
-- >>> sum coins = sum (coalesceDust threshold coins)
-- >>> all (/= Coin 0) (coalesceDust threshold coins)
--
coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin]
coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin]
coalesceDust DustThreshold
threshold NonEmpty Coin
coins =
    Coin -> [Coin] -> [Coin]
splitCoin Coin
valueToDistribute [Coin]
coinsToKeep
  where
    ([Coin]
coinsToRemove, [Coin]
coinsToKeep) = (Coin -> Bool) -> NonEmpty Coin -> ([Coin], [Coin])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition (DustThreshold -> Coin -> Bool
isDust DustThreshold
threshold) NonEmpty Coin
coins
    valueToDistribute :: Coin
valueToDistribute = [Coin] -> Coin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold [Coin]
coinsToRemove

-- Splits up the given coin of value __@v@__, distributing its value over the
-- given coin list of length __@n@__, so that each coin value is increased by
-- an integral amount within unity of __@v/n@__, producing a new list of coin
-- values where the overall total is preserved.
--
-- == Basic Examples
--
-- When it's possible to divide a coin evenly, each coin value is increased by
-- the same integer amount:
--
-- >>> splitCoin (Coin 40) (Coin <$> [1, 1, 1, 1])
-- [Coin 11, Coin 11, Coin 11, Coin 11]
--
-- >>> splitCoin (Coin 40) (Coin <$> [1, 2, 3, 4])
-- [Coin 11, Coin 12, Coin 13, Coin 14]
--
-- == Handling Non-Uniform Increases
--
-- When it's not possible to divide a coin evenly, each integral coin value in
-- the resulting list is always within unity of the ideal unrounded result:
--
-- >>> splitCoin (Coin 2) (Coin <$> [1, 1, 1, 1])
-- [Coin 1, Coin 1, Coin 2, Coin 2]
--
-- >>> splitCoin (Coin 10) (Coin <$> [1, 1, 1, 1])
-- [Coin 3, Coin 3, Coin 4, Coin 4]
--
-- == Handling Empty Lists
--
-- If the given list is empty, this function returns a list with the original
-- given coin as its sole element:
--
-- >>> splitCoin (Coin 10) []
-- [Coin 10]
--
-- == Properties
--
-- The total value is always preserved:
--
-- >>> sum (splitCoin x ys) == x + sum ys
--
splitCoin :: Coin -> [Coin] -> [Coin]
splitCoin :: Coin -> [Coin] -> [Coin]
splitCoin Coin
coinToSplit [Coin]
coinsToIncrease =
    case (Maybe Coin
mIncrement, Maybe Coin
mShortfall) of
        (Just Coin
increment, Just Coin
shortfall) ->
            (Coin -> Coin -> Coin) -> [Coin] -> [Coin] -> [Coin]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Coin -> Coin -> Coin
C.add [Coin]
coinsToIncrease [Coin]
increments
          where
            increments :: [Coin]
increments = (Coin -> Coin -> Coin) -> [Coin] -> [Coin] -> [Coin]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Coin -> Coin -> Coin
C.add [Coin]
majorIncrements [Coin]
minorIncrements
            majorIncrements :: [Coin]
majorIncrements = Coin -> [Coin]
forall a. a -> [a]
repeat Coin
increment
            minorIncrements :: [Coin]
minorIncrements = Int -> Coin -> [Coin]
forall a. Int -> a -> [a]
replicate (Coin -> Int
forall i. Integral i => Coin -> i
C.coinToIntegral Coin
shortfall) Coin
C.one
                [Coin] -> [Coin] -> [Coin]
forall a. Semigroup a => a -> a -> a
<> Coin -> [Coin]
forall a. a -> [a]
repeat Coin
C.zero
        (Maybe Coin, Maybe Coin)
_ | Coin
coinToSplit Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
C.zero ->
            [Coin
coinToSplit]
        (Maybe Coin, Maybe Coin)
_ ->
            []
  where
    mCoinCount :: Int
mCoinCount = [Coin] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Coin]
coinsToIncrease
    mIncrement :: Maybe Coin
mIncrement = Coin
coinToSplit Coin -> Int -> Maybe Coin
forall i. Integral i => Coin -> i -> Maybe Coin
`C.div` Int
mCoinCount
    mShortfall :: Maybe Coin
mShortfall = Coin
coinToSplit Coin -> Int -> Maybe Coin
forall i. Integral i => Coin -> i -> Maybe Coin
`C.mod` Int
mCoinCount

-- Extract the fractional part of a rational number.
--
-- Examples:
--
-- >>> fractionalPart (3 % 2)
-- 1 % 2
--
-- >>> fractionalPart (11 % 10)
-- 1 % 10
--
fractionalPart :: Rational -> Rational
fractionalPart :: Rational -> Rational
fractionalPart = (Integer, Rational) -> Rational
forall a b. (a, b) -> b
snd ((Integer, Rational) -> Rational)
-> (Rational -> (Integer, Rational)) -> Rational -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction @_ @Integer

-- Apply the same function multiple times to a value.
--
applyN :: Int -> (a -> a) -> a -> a
applyN :: forall a. Int -> (a -> a) -> a -> a
applyN Int
n a -> a
f = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id (Int -> (a -> a) -> [a -> a]
forall a. Int -> a -> [a]
replicate Int
n a -> a
f)

-- Find the sum of a list of entries.
--
sumEntries :: [CoinMapEntry i] -> Coin
sumEntries :: forall i. [CoinMapEntry i] -> Coin
sumEntries = [Coin] -> Coin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
F.fold ([Coin] -> Coin)
-> ([CoinMapEntry i] -> [Coin]) -> [CoinMapEntry i] -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoinMapEntry i -> Coin) -> [CoinMapEntry i] -> [Coin]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoinMapEntry i -> Coin
forall a. CoinMapEntry a -> Coin
entryValue

-- | Reduce a coin value by a given fee amount. If fees are too big for
-- a single coin, returns a `Coin 0`.
payFee :: (Fee, Coin) -> Coin
payFee :: (Fee, Coin) -> Coin
payFee (Fee Coin
f, Coin
c) = Coin -> Maybe Coin -> Coin
forall a. a -> Maybe a -> a
fromMaybe Coin
C.zero (Coin
c Coin -> Coin -> Maybe Coin
`C.sub` Coin
f)