{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Shelley.Rules.IncrementalStake (
  incrStakeComputationTest,
  incrStakeComparisonTest,
  stakeDistr,
  aggregateUtxoCoinByCredential,
) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..), Ptr, StakeReference (StakeRefBase, StakeRefPtr))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  UTxOState (..),
  curPParamsEpochStateL,
 )
import Cardano.Ledger.Shelley.State
import qualified Cardano.Ledger.UMap as UM
import Control.SetAlgebra (dom, eval, (▷), (◁))
import Data.Foldable (fold)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy
import qualified Data.VMap as VMap
import Lens.Micro hiding (ix)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..))
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN, ChainState (..))
import Test.Cardano.Ledger.Shelley.Rules.TestChain (
  TestingLedger,
  forAllChainTrace,
  ledgerTraceFromBlock,
  longTraceLen,
  traceLen,
 )
import Test.Cardano.Ledger.Shelley.Utils (
  ChainProperty,
 )
import Test.Cardano.Ledger.TerseTools (tersemapdiffs)
import Test.Control.State.Transition.Trace (
  SourceSignalTarget (..),
  sourceSignalTargets,
 )
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (
  Property,
  conjoin,
  counterexample,
  (===),
 )
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)

incrStakeComputationTest ::
  forall era ledger.
  ( EraGen era
  , EraStake era
  , InstantStake era ~ ShelleyInstantStake era
  , TestingLedger era ledger
  , ChainProperty era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  ) =>
  TestTree
incrStakeComputationTest :: forall era ledger.
(EraGen era, EraStake era,
 InstantStake era ~ ShelleyInstantStake era,
 TestingLedger era ledger, ChainProperty era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
TestTree
incrStakeComputationTest =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"instant stake calculation" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    forall era prop.
(EraGen era, EraGov era, EraStake era, Testable prop,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace @era Word64
longTraceLen Constants
defaultConstants ((Trace (CHAIN era) -> Property) -> Property)
-> (Trace (CHAIN era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN era)
tr -> do
      let ssts :: [SourceSignalTarget (CHAIN era)]
ssts = Trace (CHAIN era) -> [SourceSignalTarget (CHAIN era)]
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN era)
tr

      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property)
-> ([[Property]] -> [Property]) -> [[Property]] -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Property]] -> [Property]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Property]] -> Property) -> [[Property]] -> Property
forall a b. (a -> b) -> a -> b
$
        [ -- preservation properties
          (SourceSignalTarget (CHAIN era) -> Property)
-> [SourceSignalTarget (CHAIN era)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (forall era ledger.
(ChainProperty era, InstantStake era ~ ShelleyInstantStake era,
 TestingLedger era ledger) =>
SourceSignalTarget (CHAIN era) -> Property
incrStakeComp @era @ledger) [SourceSignalTarget (CHAIN era)]
ssts
        ]

incrStakeComp ::
  forall era ledger.
  ( ChainProperty era
  , InstantStake era ~ ShelleyInstantStake era
  , TestingLedger era ledger
  ) =>
  SourceSignalTarget (CHAIN era) ->
  Property
incrStakeComp :: forall era ledger.
(ChainProperty era, InstantStake era ~ ShelleyInstantStake era,
 TestingLedger era ledger) =>
SourceSignalTarget (CHAIN era) -> Property
incrStakeComp SourceSignalTarget {source :: forall a. SourceSignalTarget a -> State a
source = State (CHAIN era)
chainSt, signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal (CHAIN era)
block} =
  [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
    (SourceSignalTarget ledger -> Property)
-> [SourceSignalTarget ledger] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map SourceSignalTarget ledger -> Property
checkIncrStakeComp ([SourceSignalTarget ledger] -> [Property])
-> [SourceSignalTarget ledger] -> [Property]
forall a b. (a -> b) -> a -> b
$
      Trace ledger -> [SourceSignalTarget ledger]
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace ledger
ledgerTr
  where
    (ChainState era
_, Trace ledger
ledgerTr) = forall era ledger.
(ChainProperty era, TestingLedger era ledger) =>
ChainState era
-> Block (BHeader MockCrypto) era -> (ChainState era, Trace ledger)
ledgerTraceFromBlock @era @ledger State (CHAIN era)
ChainState era
chainSt Block (BHeader MockCrypto) era
Signal (CHAIN era)
block
    checkIncrStakeComp :: SourceSignalTarget ledger -> Property
    checkIncrStakeComp :: SourceSignalTarget ledger -> Property
checkIncrStakeComp
      SourceSignalTarget
        { source :: forall a. SourceSignalTarget a -> State a
source = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO era
u, utxosInstantStake :: forall era. UTxOState era -> InstantStake era
utxosInstantStake = InstantStake era
is} CertState era
dp
        , signal :: forall a. SourceSignalTarget a -> Signal a
signal = Signal ledger
tx
        , target :: forall a. SourceSignalTarget a -> State a
target = LedgerState UTxOState {utxosUtxo :: forall era. UTxOState era -> UTxO era
utxosUtxo = UTxO era
u', utxosInstantStake :: forall era. UTxOState era -> InstantStake era
utxosInstantStake = InstantStake era
is'} CertState era
dp'
        } =
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
          ( [TestName] -> TestName
unlines
              [ TestName
"\nDetails:"
              , TestName
"\ntx"
              , Tx era -> TestName
forall a. Show a => a -> TestName
show Tx era
Signal ledger
tx
              , TestName
"size original utxo"
              , Int -> TestName
forall a. Show a => a -> TestName
show (Map TxIn (TxOut era) -> Int
forall k a. Map k a -> Int
Map.size (Map TxIn (TxOut era) -> Int) -> Map TxIn (TxOut era) -> Int
forall a b. (a -> b) -> a -> b
$ UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
u)
              , TestName
"original utxo"
              , UTxO era -> TestName
forall a. Show a => a -> TestName
show UTxO era
u
              , TestName
"original instantStake"
              , ShelleyInstantStake era -> TestName
forall a. Show a => a -> TestName
show InstantStake era
ShelleyInstantStake era
is
              , TestName
"final utxo"
              , UTxO era -> TestName
forall a. Show a => a -> TestName
show UTxO era
u'
              , TestName
"final instantStake"
              , ShelleyInstantStake era -> TestName
forall a. Show a => a -> TestName
show InstantStake era
ShelleyInstantStake era
is'
              , TestName
"original ptrs"
              , Map Ptr (Credential 'Staking) -> TestName
forall a. Show a => a -> TestName
show Map Ptr (Credential 'Staking)
ptrs
              , TestName
"final ptrs"
              , Map Ptr (Credential 'Staking) -> TestName
forall a. Show a => a -> TestName
show Map Ptr (Credential 'Staking)
ptrs'
              ]
          )
          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Coin
utxoBalanace Coin -> Coin -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
instantStakeBalanace
        where
          utxoBalanace :: Coin
utxoBalanace = UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO era
u'
          instantStakeBalanace :: CompactForm Coin
instantStakeBalanace = Map (Credential 'Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential 'Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
forall era.
ShelleyInstantStake era
-> Map (Credential 'Staking) (CompactForm Coin)
sisCredentialStake InstantStake era
ShelleyInstantStake era
is') CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> Map Ptr (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map Ptr m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
forall era. ShelleyInstantStake era -> Map Ptr (CompactForm Coin)
sisPtrStake InstantStake era
ShelleyInstantStake era
is')
          ptrs :: Map Ptr (Credential 'Staking)
ptrs = DState era -> Map Ptr (Credential 'Staking)
forall era. DState era -> Map Ptr (Credential 'Staking)
ptrsMap (DState era -> Map Ptr (Credential 'Staking))
-> DState era -> Map Ptr (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ CertState era
dp 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
          ptrs' :: Map Ptr (Credential 'Staking)
ptrs' = DState era -> Map Ptr (Credential 'Staking)
forall era. DState era -> Map Ptr (Credential 'Staking)
ptrsMap (DState era -> Map Ptr (Credential 'Staking))
-> DState era -> Map Ptr (Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ CertState era
dp' 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

incrStakeComparisonTest ::
  forall era.
  ( EraGen era
  , EraGov era
  , EraStake era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  ) =>
  Proxy era ->
  TestTree
incrStakeComparisonTest :: forall era.
(EraGen era, EraGov era, EraStake era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
Proxy era -> TestTree
incrStakeComparisonTest Proxy era
Proxy =
  TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"Incremental stake distribution at epoch boundaries agrees" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    Word64 -> Constants -> (Trace (CHAIN era) -> Property) -> Property
forall era prop.
(EraGen era, EraGov era, EraStake era, Testable prop,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
Word64 -> Constants -> (Trace (CHAIN era) -> prop) -> Property
forAllChainTrace Word64
traceLen Constants
defaultConstants ((Trace (CHAIN era) -> Property) -> Property)
-> (Trace (CHAIN era) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Trace (CHAIN era)
tr ->
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
        (SourceSignalTarget (CHAIN era) -> Property)
-> [SourceSignalTarget (CHAIN era)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (\(SourceSignalTarget State (CHAIN era)
_ State (CHAIN era)
target Signal (CHAIN era)
_) -> forall era.
(EraGov era, EraTxOut era, EraStake era, EraCertState era) =>
EpochState era -> Property
checkIncrementalStake @era ((NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs (NewEpochState era -> EpochState era)
-> (ChainState era -> NewEpochState era)
-> ChainState era
-> EpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes) State (CHAIN era)
ChainState era
target)) ([SourceSignalTarget (CHAIN era)] -> [Property])
-> [SourceSignalTarget (CHAIN era)] -> [Property]
forall a b. (a -> b) -> a -> b
$
          (SourceSignalTarget (CHAIN era) -> Bool)
-> [SourceSignalTarget (CHAIN era)]
-> [SourceSignalTarget (CHAIN era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SourceSignalTarget (CHAIN era) -> Bool)
-> SourceSignalTarget (CHAIN era)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSignalTarget (CHAIN era) -> Bool
forall {a} {era}.
(State a ~ ChainState era) =>
SourceSignalTarget a -> Bool
sameEpoch) (Trace (CHAIN era) -> [SourceSignalTarget (CHAIN era)]
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN era)
tr)
  where
    sameEpoch :: SourceSignalTarget a -> Bool
sameEpoch SourceSignalTarget {State a
source :: forall a. SourceSignalTarget a -> State a
source :: State a
source, State a
target :: forall a. SourceSignalTarget a -> State a
target :: State a
target} = ChainState era -> EpochNo
forall {era}. ChainState era -> EpochNo
epoch State a
ChainState era
source EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== ChainState era -> EpochNo
forall {era}. ChainState era -> EpochNo
epoch State a
ChainState era
target
    epoch :: ChainState era -> EpochNo
epoch = NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
nesEL (NewEpochState era -> EpochNo)
-> (ChainState era -> NewEpochState era)
-> ChainState era
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> NewEpochState era
forall era. ChainState era -> NewEpochState era
chainNes

checkIncrementalStake ::
  forall era.
  (EraGov era, EraTxOut era, EraStake era, EraCertState era) =>
  EpochState era ->
  Property
checkIncrementalStake :: forall era.
(EraGov era, EraTxOut era, EraStake era, EraCertState era) =>
EpochState era -> Property
checkIncrementalStake EpochState era
es =
  let
    LedgerState (UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
_ InstantStake era
instantStake Coin
_) CertState era
certState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    dstate :: DState era
dstate = 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
    pstate :: PState era
pstate = CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    stake :: SnapShot
stake = forall era.
EraTxOut era =>
UTxO era -> DState era -> PState era -> SnapShot
stakeDistr @era UTxO era
utxo DState era
dstate PState era
pstate
    snapShot :: SnapShot
snapShot = InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake DState era
dstate PState era
pstate
    _pp :: PParams era
_pp = EpochState era
es EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
   in
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
      ( TestName
"\nIncremental stake distribution does not match old style stake distribution"
          TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName -> Stake -> Stake -> TestName
tersediffincremental TestName
"differences: Old vs Incremental" (SnapShot -> Stake
ssStake SnapShot
stake) (SnapShot -> Stake
ssStake SnapShot
snapShot)
      )
      (SnapShot
stake SnapShot -> SnapShot -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SnapShot
snapShot)

tersediffincremental :: String -> Stake -> Stake -> String
tersediffincremental :: TestName -> Stake -> Stake -> TestName
tersediffincremental TestName
message (Stake VMap VB VP (Credential 'Staking) (CompactForm Coin)
a) (Stake VMap VB VP (Credential 'Staking) (CompactForm Coin)
c) =
  TestName
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> TestName
forall a b.
(Terse a, Terse b, Ord a, Eq b) =>
TestName -> Map a b -> Map a b -> TestName
tersemapdiffs (TestName
message TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"hashes") (VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
mp VMap VB VP (Credential 'Staking) (CompactForm Coin)
a) (VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
mp VMap VB VP (Credential 'Staking) (CompactForm Coin)
c)
  where
    mp :: VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
mp = (CompactForm Coin -> Coin)
-> Map (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Map (Credential 'Staking) (CompactForm Coin)
 -> Map (Credential 'Staking) Coin)
-> (VMap VB VP (Credential 'Staking) (CompactForm Coin)
    -> Map (Credential 'Staking) (CompactForm Coin))
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap

-- | Compute the current Stake Distribution. This was called at the Epoch boundary in the Snap Rule.
--   Now it is called in the tests to see that its incremental analog 'incrementalStakeDistr' agrees.
stakeDistr ::
  forall era.
  EraTxOut era =>
  UTxO era ->
  DState era ->
  PState era ->
  SnapShot
stakeDistr :: forall era.
EraTxOut era =>
UTxO era -> DState era -> PState era -> SnapShot
stakeDistr UTxO era
u DState era
ds PState era
ps =
  Stake
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> VMap VB VB (KeyHash 'StakePool) PoolParams
-> SnapShot
SnapShot
    (VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
Stake (VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake)
-> VMap VB VP (Credential 'Staking) (CompactForm Coin) -> Stake
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking) (CompactForm Coin)
-> VMap VB VP (Credential 'Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap (HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
UM.compactCoinOrError (Coin -> CompactForm Coin)
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) (CompactForm Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp (Map (Credential 'Staking) Coin)
-> Map (Credential 'Staking) Coin
forall s t. Embed s t => Exp t -> s
eval (Map (Credential 'Staking) (KeyHash 'StakePool)
-> Exp (Sett (Credential 'Staking) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (Credential 'Staking) (KeyHash 'StakePool)
activeDelegs Exp (Sett (Credential 'Staking) ())
-> Map (Credential 'Staking) Coin
-> Exp (Map (Credential 'Staking) Coin)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (Credential 'Staking) Coin
stakeRelation)))
    (Map (Credential 'Staking) (KeyHash 'StakePool)
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (Credential 'Staking) (KeyHash 'StakePool)
delegs)
    (Map (KeyHash 'StakePool) PoolParams
-> VMap VB VB (KeyHash 'StakePool) PoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap Map (KeyHash 'StakePool) PoolParams
poolParams)
  where
    rewards' :: Map.Map (Credential 'Staking) Coin
    rewards' :: Map (Credential 'Staking) Coin
rewards' = UMap -> Map (Credential 'Staking) Coin
UM.rewardMap (DState era -> UMap
forall era. DState era -> UMap
dsUnified DState era
ds)
    delegs :: Map.Map (Credential 'Staking) (KeyHash 'StakePool)
    delegs :: Map (Credential 'Staking) (KeyHash 'StakePool)
delegs = UMap -> Map (Credential 'Staking) (KeyHash 'StakePool)
UM.sPoolMap (DState era -> UMap
forall era. DState era -> UMap
dsUnified DState era
ds)
    ptrs' :: Map Ptr (Credential 'Staking)
ptrs' = DState era -> Map Ptr (Credential 'Staking)
forall era. DState era -> Map Ptr (Credential 'Staking)
ptrsMap DState era
ds
    PState {psStakePoolParams :: forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = Map (KeyHash 'StakePool) PoolParams
poolParams} = PState era
ps
    stakeRelation :: Map (Credential 'Staking) Coin
    stakeRelation :: Map (Credential 'Staking) Coin
stakeRelation = Map Ptr (Credential 'Staking)
-> UTxO era
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
forall era.
EraTxOut era =>
Map Ptr (Credential 'Staking)
-> UTxO era
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
aggregateUtxoCoinByCredential Map Ptr (Credential 'Staking)
ptrs' UTxO era
u Map (Credential 'Staking) Coin
rewards'
    activeDelegs :: Map.Map (Credential 'Staking) (KeyHash 'StakePool)
    activeDelegs :: Map (Credential 'Staking) (KeyHash 'StakePool)
activeDelegs = Exp (Map (Credential 'Staking) (KeyHash 'StakePool))
-> Map (Credential 'Staking) (KeyHash 'StakePool)
forall s t. Embed s t => Exp t -> s
eval ((Map (Credential 'Staking) Coin
-> Exp (Sett (Credential 'Staking) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (Credential 'Staking) Coin
rewards' Exp (Sett (Credential 'Staking) ())
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Exp (Map (Credential 'Staking) (KeyHash 'StakePool))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (Credential 'Staking) (KeyHash 'StakePool)
delegs) Exp (Map (Credential 'Staking) (KeyHash 'StakePool))
-> Exp (Sett (KeyHash 'StakePool) ())
-> Exp (Map (Credential 'Staking) (KeyHash 'StakePool))
forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
▷ Map (KeyHash 'StakePool) PoolParams
-> Exp (Sett (KeyHash 'StakePool) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'StakePool) PoolParams
poolParams)

-- | Sum up all the Coin for each staking Credential. This function has an
--   incremental analog. See 'incrementalAggregateUtxoCoinByCredential'
aggregateUtxoCoinByCredential ::
  forall era.
  EraTxOut era =>
  Map Ptr (Credential 'Staking) ->
  UTxO era ->
  Map (Credential 'Staking) Coin ->
  Map (Credential 'Staking) Coin
aggregateUtxoCoinByCredential :: forall era.
EraTxOut era =>
Map Ptr (Credential 'Staking)
-> UTxO era
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
aggregateUtxoCoinByCredential Map Ptr (Credential 'Staking)
ptrs (UTxO Map TxIn (TxOut era)
u) Map (Credential 'Staking) Coin
initial =
  (Map (Credential 'Staking) Coin
 -> TxOut era -> Map (Credential 'Staking) Coin)
-> Map (Credential 'Staking) Coin
-> Map TxIn (TxOut era)
-> Map (Credential 'Staking) Coin
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map (Credential 'Staking) Coin
-> TxOut era -> Map (Credential 'Staking) Coin
accum Map (Credential 'Staking) Coin
initial Map TxIn (TxOut era)
u
  where
    accum :: Map (Credential 'Staking) Coin
-> TxOut era -> Map (Credential 'Staking) Coin
accum Map (Credential 'Staking) Coin
ans TxOut era
out =
      let c :: Coin
c = TxOut era
out TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
       in case TxOut era
out TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL of
            Addr Network
_ PaymentCredential
_ (StakeRefPtr Ptr
p)
              | Just Credential 'Staking
cred <- Ptr -> Map Ptr (Credential 'Staking) -> Maybe (Credential 'Staking)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ptr
p Map Ptr (Credential 'Staking)
ptrs -> (Coin -> Coin -> Coin)
-> Credential 'Staking
-> Coin
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>) Credential 'Staking
cred Coin
c Map (Credential 'Staking) Coin
ans
            Addr Network
_ PaymentCredential
_ (StakeRefBase Credential 'Staking
hk) -> (Coin -> Coin -> Coin)
-> Credential 'Staking
-> Coin
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
(<>) Credential 'Staking
hk Coin
c Map (Credential 'Staking) Coin
ans
            Addr
_other -> Map (Credential 'Staking) Coin
ans