{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Shelley.AdaPots (
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
  Produced (..),
  Consumed (..),
  consumedTxBody,
  producedTxBody,
  sumAdaPots,
) where

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.LedgerState.Types (
  EpochState (..),
  LedgerState (..),
  UTxOState (..),
  lsCertStateL,
  lsUTxOStateL,
  utxosGovStateL,
 )
import Cardano.Ledger.Shelley.TxBody (unWithdrawals)
import Cardano.Ledger.State
import Cardano.Ledger.UMap (sumRewardsUView)
import Control.DeepSeq (NFData)
import Data.Foldable (fold)
import GHC.Generics (Generic)
import Lens.Micro ((^.))

data AdaPots = AdaPots
  { AdaPots -> Coin
treasuryAdaPot :: Coin
  , AdaPots -> Coin
reservesAdaPot :: Coin
  , AdaPots -> Coin
rewardsAdaPot :: Coin
  , AdaPots -> Coin
utxoAdaPot :: Coin
  , AdaPots -> Coin
feesAdaPot :: Coin
  , AdaPots -> Obligations
obligationsPot :: Obligations
  }
  deriving (Int -> AdaPots -> ShowS
[AdaPots] -> ShowS
AdaPots -> String
(Int -> AdaPots -> ShowS)
-> (AdaPots -> String) -> ([AdaPots] -> ShowS) -> Show AdaPots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AdaPots -> ShowS
showsPrec :: Int -> AdaPots -> ShowS
$cshow :: AdaPots -> String
show :: AdaPots -> String
$cshowList :: [AdaPots] -> ShowS
showList :: [AdaPots] -> ShowS
Show, AdaPots -> AdaPots -> Bool
(AdaPots -> AdaPots -> Bool)
-> (AdaPots -> AdaPots -> Bool) -> Eq AdaPots
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdaPots -> AdaPots -> Bool
== :: AdaPots -> AdaPots -> Bool
$c/= :: AdaPots -> AdaPots -> Bool
/= :: AdaPots -> AdaPots -> Bool
Eq, (forall x. AdaPots -> Rep AdaPots x)
-> (forall x. Rep AdaPots x -> AdaPots) -> Generic AdaPots
forall x. Rep AdaPots x -> AdaPots
forall x. AdaPots -> Rep AdaPots x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AdaPots -> Rep AdaPots x
from :: forall x. AdaPots -> Rep AdaPots x
$cto :: forall x. Rep AdaPots x -> AdaPots
to :: forall x. Rep AdaPots x -> AdaPots
Generic)

instance NFData AdaPots

-- | Calculate the total ada pots in the epoch state
totalAdaPotsES ::
  ( EraTxOut era
  , EraGov era
  , EraCertState era
  ) =>
  EpochState era ->
  AdaPots
totalAdaPotsES :: forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES (EpochState (ChainAccountState {Coin
casTreasury :: Coin
casTreasury :: ChainAccountState -> Coin
casTreasury, Coin
casReserves :: Coin
casReserves :: ChainAccountState -> Coin
casReserves}) LedgerState era
ls SnapShots
_ NonMyopic
_) =
  AdaPots
    { treasuryAdaPot :: Coin
treasuryAdaPot = Coin
casTreasury
    , reservesAdaPot :: Coin
reservesAdaPot = Coin
casReserves
    , rewardsAdaPot :: Coin
rewardsAdaPot = Coin
rewards_
    , utxoAdaPot :: Coin
utxoAdaPot = Coin
coins
    , feesAdaPot :: Coin
feesAdaPot = Coin
fees_
    , obligationsPot :: Obligations
obligationsPot = CertState era -> Obligations
forall era. EraCertState era => CertState era -> Obligations
obligationCertState CertState era
certState Obligations -> Obligations -> Obligations
forall a. Semigroup a => a -> a -> a
<> Obligations
govStateObligations
    }
  where
    UTxOState UTxO era
u Coin
_ Coin
fees_ GovState era
_ InstantStake era
_ Coin
_ = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    certState :: CertState era
certState = LedgerState era
ls LedgerState era
-> Getting (CertState era) (LedgerState era) (CertState era)
-> CertState era
forall s a. s -> Getting a s a -> a
^. Getting (CertState era) (LedgerState era) (CertState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
    rewards_ :: Coin
rewards_ = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ UView (Credential 'Staking) RDPair -> CompactForm Coin
forall k. UView k RDPair -> CompactForm Coin
sumRewardsUView (DState era -> UView (Credential 'Staking) RDPair
forall era. DState era -> UView (Credential 'Staking) RDPair
rewards (DState era -> UView (Credential 'Staking) RDPair)
-> DState era -> UView (Credential 'Staking) RDPair
forall a b. (a -> b) -> a -> b
$ CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
    coins :: Coin
coins = UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO era
u
    govStateObligations :: Obligations
govStateObligations = GovState era -> Obligations
forall era. EraGov era => GovState era -> Obligations
obligationGovState (LedgerState era
ls LedgerState era
-> Getting (GovState era) (LedgerState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. (UTxOState era -> Const (GovState era) (UTxOState era))
-> LedgerState era -> Const (GovState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const (GovState era) (UTxOState era))
 -> LedgerState era -> Const (GovState era) (LedgerState era))
-> ((GovState era -> Const (GovState era) (GovState era))
    -> UTxOState era -> Const (GovState era) (UTxOState era))
-> Getting (GovState era) (LedgerState era) (GovState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const (GovState era) (GovState era))
-> UTxOState era -> Const (GovState era) (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL)

sumAdaPots :: AdaPots -> Coin
sumAdaPots :: AdaPots -> Coin
sumAdaPots
  AdaPots
    { Coin
treasuryAdaPot :: AdaPots -> Coin
treasuryAdaPot :: Coin
treasuryAdaPot
    , Coin
reservesAdaPot :: AdaPots -> Coin
reservesAdaPot :: Coin
reservesAdaPot
    , Coin
rewardsAdaPot :: AdaPots -> Coin
rewardsAdaPot :: Coin
rewardsAdaPot
    , Coin
utxoAdaPot :: AdaPots -> Coin
utxoAdaPot :: Coin
utxoAdaPot
    , Coin
feesAdaPot :: AdaPots -> Coin
feesAdaPot :: Coin
feesAdaPot
    , Obligations
obligationsPot :: AdaPots -> Obligations
obligationsPot :: Obligations
obligationsPot
    } =
    Coin
treasuryAdaPot
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
reservesAdaPot
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
rewardsAdaPot
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
utxoAdaPot
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
feesAdaPot
      Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Obligations -> Coin
sumObligation Obligations
obligationsPot

-- | Calculate the total ada in the epoch state
totalAdaES :: (EraTxOut era, EraGov era, EraCertState era) => EpochState era -> Coin
totalAdaES :: forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> Coin
totalAdaES = AdaPots -> Coin
sumAdaPots (AdaPots -> Coin)
-> (EpochState era -> AdaPots) -> EpochState era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochState era -> AdaPots
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES

-- =============================================
-- Produced and Consumed are specialized AdaPots
-- relative to the actions of a TxBody

-- | Itemizing what is consumed by a transaction
data Consumed = Consumed
  {Consumed -> Coin
conInputs :: !Coin, Consumed -> Coin
conRefunds :: !Coin, Consumed -> Coin
conWithdrawals :: !Coin}

instance Show Consumed where
  show :: Consumed -> String
show (Consumed (Coin Integer
i) (Coin Integer
r) (Coin Integer
w)) =
    String
"Consumed(Inputs "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", Refunds "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
r
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", Withdrawals "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
w
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") = "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w)

-- | Itemizing what is Produced by a transaction
data Produced = Produced
  { Produced -> Coin
proOutputs :: !Coin
  , Produced -> Coin
proFees :: !Coin
  , Produced -> Coin
proDeposits :: !Coin
  }

instance Show Produced where
  show :: Produced -> String
show (Produced (Coin Integer
out) (Coin Integer
f) (Coin Integer
d)) =
    String
"Produced(Outputs "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
out
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", Fees "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
f
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", Deposits "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
d
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") = "
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Integer
out Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
f Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d)

-- =========================

-- | Compute the Coin part of what is consumed by a TxBody, itemized as a 'Consume'
consumedTxBody ::
  (EraTxBody era, EraCertState era) =>
  TxBody era ->
  PParams era ->
  CertState era ->
  UTxO era ->
  Consumed
consumedTxBody :: forall era.
(EraTxBody era, EraCertState era) =>
TxBody era -> PParams era -> CertState era -> UTxO era -> Consumed
consumedTxBody TxBody era
txBody PParams era
pp CertState era
dpstate UTxO era
utxo =
  Consumed
    { conInputs :: Coin
conInputs =
        UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO (UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
    , conRefunds :: Coin
conRefunds = PParams era -> CertState era -> TxBody era -> Coin
forall era.
(EraCertState era, EraTxBody era) =>
PParams era -> CertState era -> TxBody era -> Coin
certsTotalRefundsTxBody PParams era
pp CertState era
dpstate TxBody era
txBody
    , conWithdrawals :: Coin
conWithdrawals = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map RewardAccount Coin -> Coin)
-> (Withdrawals -> Map RewardAccount Coin) -> Withdrawals -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals (Withdrawals -> Coin) -> Withdrawals -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
    }

-- | Compute the Coin part of what is produced by a TxBody, itemized as a 'Produced'
producedTxBody ::
  (EraTxBody era, EraCertState era) =>
  TxBody era ->
  PParams era ->
  CertState era ->
  Produced
producedTxBody :: forall era.
(EraTxBody era, EraCertState era) =>
TxBody era -> PParams era -> CertState era -> Produced
producedTxBody TxBody era
txBody PParams era
pp CertState era
dpstate =
  Produced
    { proOutputs :: Coin
proOutputs = UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO (TxBody era -> UTxO era
forall era. EraTxBody era => TxBody era -> UTxO era
txouts TxBody era
txBody)
    , proFees :: Coin
proFees = TxBody era
txBody TxBody era -> Getting Coin (TxBody era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxBody era) Coin
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL
    , proDeposits :: Coin
proDeposits = PParams era -> CertState era -> TxBody era -> Coin
forall era.
(EraCertState era, EraTxBody era) =>
PParams era -> CertState era -> TxBody era -> Coin
certsTotalDepositsTxBody PParams era
pp CertState era
dpstate TxBody era
txBody
    }