{-# 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.BaseTypes (Globals (Globals, networkId), Network)
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.Rules (Identity, LedgerEnv)
import Cardano.Ledger.Shelley.State
import Control.Monad.Reader (MonadReader (ask), ReaderT)
import Control.State.Transition (STS (..))
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 (
  forAllChainTrace,
  ledgerTraceFromBlock,
  longTraceLen,
  traceLen,
 )
import Test.Cardano.Ledger.Shelley.Utils (
  ChainProperty,
  runShelleyBase,
 )
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.
  ( EraGen era
  , EraStake era
  , ShelleyEraAccounts era
  , InstantStake era ~ ShelleyInstantStake era
  , ChainProperty era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity
  , STS (EraRule "LEDGER" era)
  , Signal (EraRule "LEDGER" era) ~ Tx TopTx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  ) =>
  TestTree
incrStakeComputationTest :: forall era.
(EraGen era, EraStake era, ShelleyEraAccounts era,
 InstantStake era ~ ShelleyInstantStake era, ChainProperty era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity,
 STS (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era) ~ Tx TopTx era,
 State (EraRule "LEDGER" era) ~ LedgerState era) =>
TestTree
incrStakeComputationTest =
  String -> Property -> TestTree
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> TestTree
testProperty String
"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
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$ forall era.
(ChainProperty era, InstantStake era ~ ShelleyInstantStake era,
 BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 STS (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era) ~ Tx TopTx era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 ShelleyEraAccounts era) =>
SourceSignalTarget (CHAIN era) -> Property
incrStakeComp @era (SourceSignalTarget (CHAIN era) -> Property)
-> [SourceSignalTarget (CHAIN era)] -> [Property]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trace (CHAIN era) -> [SourceSignalTarget (CHAIN era)]
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (CHAIN era)
tr

incrStakeComp ::
  forall era.
  ( ChainProperty era
  , InstantStake era ~ ShelleyInstantStake era
  , BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , STS (EraRule "LEDGER" era)
  , Signal (EraRule "LEDGER" era) ~ Tx TopTx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , ShelleyEraAccounts era
  ) =>
  SourceSignalTarget (CHAIN era) ->
  Property
incrStakeComp :: forall era.
(ChainProperty era, InstantStake era ~ ShelleyInstantStake era,
 BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 STS (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era) ~ Tx TopTx era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 ShelleyEraAccounts era) =>
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 (EraRule "LEDGER" era) -> Property)
-> [SourceSignalTarget (EraRule "LEDGER" era)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map SourceSignalTarget (EraRule "LEDGER" era) -> Property
checkIncrStakeComp ([SourceSignalTarget (EraRule "LEDGER" era)] -> [Property])
-> [SourceSignalTarget (EraRule "LEDGER" era)] -> [Property]
forall a b. (a -> b) -> a -> b
$
      Trace (EraRule "LEDGER" era)
-> [SourceSignalTarget (EraRule "LEDGER" era)]
forall a. Trace a -> [SourceSignalTarget a]
sourceSignalTargets Trace (EraRule "LEDGER" era)
ledgerTr
  where
    (ChainState era
_, Trace (EraRule "LEDGER" era)
ledgerTr) = forall era.
(ChainProperty era, STS (EraRule "LEDGER" era),
 BaseM (EraRule "LEDGER" era) ~ ReaderT Globals Identity,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 Signal (EraRule "LEDGER" era) ~ Tx TopTx era) =>
ChainState era
-> Block (BHeader MockCrypto) era
-> (ChainState era, Trace (EraRule "LEDGER" era))
ledgerTraceFromBlock @era State (CHAIN era)
ChainState era
chainSt Block (BHeader MockCrypto) era
Signal (CHAIN era)
block
    checkIncrStakeComp :: SourceSignalTarget (EraRule "LEDGER" era) -> Property
    checkIncrStakeComp :: SourceSignalTarget (EraRule "LEDGER" era) -> 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 (EraRule "LEDGER" era)
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'
        } =
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( [String] -> String
unlines
              [ String
"\nDetails:"
              , String
"\ntx"
              , Tx TopTx era -> String
forall a. Show a => a -> String
show Tx TopTx era
Signal (EraRule "LEDGER" era)
tx
              , String
"size original utxo"
              , Int -> String
forall a. Show a => a -> String
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)
              , String
"original utxo"
              , UTxO era -> String
forall a. Show a => a -> String
show UTxO era
u
              , String
"original instantStake"
              , ShelleyInstantStake era -> String
forall a. Show a => a -> String
show InstantStake era
ShelleyInstantStake era
is
              , String
"final utxo"
              , UTxO era -> String
forall a. Show a => a -> String
show UTxO era
u'
              , String
"final instantStake"
              , ShelleyInstantStake era -> String
forall a. Show a => a -> String
show InstantStake era
ShelleyInstantStake era
is'
              , String
"original ptrs"
              , Map Ptr (Credential Staking) -> String
forall a. Show a => a -> String
show Map Ptr (Credential Staking)
ptrs
              , String
"final ptrs"
              , Map Ptr (Credential Staking) -> String
forall a. Show a => a -> String
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 = CertState era
dp CertState era
-> Getting
     (Map Ptr (Credential Staking))
     (CertState era)
     (Map Ptr (Credential Staking))
-> Map Ptr (Credential Staking)
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> CertState era
-> Const (Map Ptr (Credential Staking)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Map Ptr (Credential Staking)) (DState era))
 -> CertState era
 -> Const (Map Ptr (Credential Staking)) (CertState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> Getting
     (Map Ptr (Credential Staking))
     (CertState era)
     (Map Ptr (Credential Staking))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
 -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> DState era -> Const (Map Ptr (Credential Staking)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const (Map Ptr (Credential Staking)) (Accounts era))
 -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> Accounts era
    -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> (Map Ptr (Credential Staking)
    -> Const
         (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> DState era
-> Const (Map Ptr (Credential Staking)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Ptr (Credential Staking)
 -> Const
      (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> Accounts era
-> Const (Map Ptr (Credential Staking)) (Accounts era)
forall era.
ShelleyEraAccounts era =>
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
accountsPtrsMapG
          ptrs' :: Map Ptr (Credential Staking)
ptrs' = CertState era
dp' CertState era
-> Getting
     (Map Ptr (Credential Staking))
     (CertState era)
     (Map Ptr (Credential Staking))
-> Map Ptr (Credential Staking)
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> CertState era
-> Const (Map Ptr (Credential Staking)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Map Ptr (Credential Staking)) (DState era))
 -> CertState era
 -> Const (Map Ptr (Credential Staking)) (CertState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> Getting
     (Map Ptr (Credential Staking))
     (CertState era)
     (Map Ptr (Credential Staking))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
 -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> DState era -> Const (Map Ptr (Credential Staking)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const (Map Ptr (Credential Staking)) (Accounts era))
 -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> Accounts era
    -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> (Map Ptr (Credential Staking)
    -> Const
         (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> DState era
-> Const (Map Ptr (Credential Staking)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Ptr (Credential Staking)
 -> Const
      (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> Accounts era
-> Const (Map Ptr (Credential Staking)) (Accounts era)
forall era.
ShelleyEraAccounts era =>
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
accountsPtrsMapG

incrStakeComparisonTest ::
  forall era.
  ( EraGen era
  , EraGov era
  , EraStake era
  , ShelleyEraAccounts era
  , QC.HasTrace (CHAIN era) (GenEnv MockCrypto era)
  ) =>
  Proxy era ->
  TestTree
incrStakeComparisonTest :: forall era.
(EraGen era, EraGov era, EraStake era, ShelleyEraAccounts era,
 HasTrace (CHAIN era) (GenEnv MockCrypto era)) =>
Proxy era -> TestTree
incrStakeComparisonTest Proxy era
Proxy = do
  let network :: Network
network = ShelleyBase Network -> Network
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase Network -> Network) -> ShelleyBase Network -> Network
forall a b. (a -> b) -> a -> b
$ ReaderT Globals Identity Globals
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Globals Identity Globals
-> (Globals -> ShelleyBase Network) -> ShelleyBase Network
forall a b.
ReaderT Globals Identity a
-> (a -> ReaderT Globals Identity b) -> ReaderT Globals Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Globals {Network
networkId :: Globals -> Network
networkId :: Network
networkId} -> Network -> ShelleyBase Network
forall a. a -> ReaderT Globals Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Network
networkId
  String -> Property -> TestTree
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> TestTree
testProperty String
"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,
 ShelleyEraAccounts era) =>
Network -> EpochState era -> Property
checkIncrementalStake @era Network
network ((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, ShelleyEraAccounts era) =>
  Network ->
  EpochState era ->
  Property
checkIncrementalStake :: forall era.
(EraGov era, EraTxOut era, EraStake era, EraCertState era,
 ShelleyEraAccounts era) =>
Network -> EpochState era -> Property
checkIncrementalStake Network
network 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, ShelleyEraAccounts era) =>
Network -> UTxO era -> DState era -> PState era -> SnapShot
stakeDistr @era Network
network UTxO era
utxo DState era
dstate PState era
pstate
    snapShot :: SnapShot
snapShot = InstantStake era -> DState era -> PState era -> Network -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> Network -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake DState era
dstate PState era
pstate Network
network
    _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
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
      ( String
"\nIncremental stake distribution does not match old style stake distribution"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Stake -> Stake -> String
tersediffincremental String
"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 :: String -> Stake -> Stake -> String
tersediffincremental String
message (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
a) (Stake VMap VB VP (Credential Staking) (CompactForm Coin)
c) =
  String
-> Map (Credential Staking) Coin
-> Map (Credential Staking) Coin
-> String
forall a b.
(Terse a, Terse b, Ord a, Eq b) =>
String -> Map a b -> Map a b -> String
tersemapdiffs (String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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, ShelleyEraAccounts era) =>
  Network ->
  UTxO era ->
  DState era ->
  PState era ->
  SnapShot
stakeDistr :: forall era.
(EraTxOut era, ShelleyEraAccounts era) =>
Network -> UTxO era -> DState era -> PState era -> SnapShot
stakeDistr Network
network UTxO era
u DState era
ds PState era
ps =
  Stake
-> VMap VB VB (Credential Staking) (KeyHash StakePool)
-> VMap VB VB (KeyHash StakePool) StakePoolParams
-> 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 (Map (Credential Staking) (CompactForm Coin)
 -> VMap VB VP (Credential Staking) (CompactForm Coin))
-> Map (Credential Staking) (CompactForm Coin)
-> VMap VB VP (Credential Staking) (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$ Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (KeyHash StakePool)
-> Map (Credential Staking) (CompactForm Coin)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map (Credential Staking) (CompactForm Coin)
stakeRelation Map (Credential Staking) (KeyHash StakePool)
activeDelegs)
    (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) StakePoolParams
-> VMap VB VB (KeyHash StakePool) StakePoolParams
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
Map k v -> VMap kv vv k v
VMap.fromMap (Map (KeyHash StakePool) StakePoolParams
 -> VMap VB VB (KeyHash StakePool) StakePoolParams)
-> Map (KeyHash StakePool) StakePoolParams
-> VMap VB VB (KeyHash StakePool) StakePoolParams
forall a b. (a -> b) -> a -> b
$ (KeyHash StakePool -> StakePoolState -> StakePoolParams)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolParams
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (KeyHash StakePool -> Network -> StakePoolState -> StakePoolParams
`stakePoolStateToStakePoolParams` Network
network) Map (KeyHash StakePool) StakePoolState
poolState)
  where
    accountsMap :: Map (Credential Staking) (AccountState era)
accountsMap = DState era
ds DState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
    rewards' :: Map.Map (Credential Staking) (CompactForm Coin)
    rewards' :: Map (Credential Staking) (CompactForm Coin)
rewards' = (AccountState era -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (CompactForm Coin)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL) Map (Credential Staking) (AccountState era)
accountsMap
    delegs :: Map.Map (Credential Staking) (KeyHash StakePool)
    delegs :: Map (Credential Staking) (KeyHash StakePool)
delegs = (AccountState era -> Maybe (KeyHash StakePool))
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (KeyHash StakePool)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL) Map (Credential Staking) (AccountState era)
accountsMap
    ptrs' :: Map Ptr (Credential Staking)
ptrs' = DState era
ds DState era
-> Getting
     (Map Ptr (Credential Staking))
     (DState era)
     (Map Ptr (Credential Staking))
-> Map Ptr (Credential Staking)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> DState era -> Const (Map Ptr (Credential Staking)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const (Map Ptr (Credential Staking)) (Accounts era))
 -> DState era -> Const (Map Ptr (Credential Staking)) (DState era))
-> ((Map Ptr (Credential Staking)
     -> Const
          (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
    -> Accounts era
    -> Const (Map Ptr (Credential Staking)) (Accounts era))
-> Getting
     (Map Ptr (Credential Staking))
     (DState era)
     (Map Ptr (Credential Staking))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Ptr (Credential Staking)
 -> Const
      (Map Ptr (Credential Staking)) (Map Ptr (Credential Staking)))
-> Accounts era
-> Const (Map Ptr (Credential Staking)) (Accounts era)
forall era.
ShelleyEraAccounts era =>
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
SimpleGetter (Accounts era) (Map Ptr (Credential Staking))
accountsPtrsMapG
    PState {psStakePools :: forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools = Map (KeyHash StakePool) StakePoolState
poolState} = PState era
ps
    stakeRelation :: Map (Credential Staking) (CompactForm Coin)
    stakeRelation :: Map (Credential Staking) (CompactForm Coin)
stakeRelation = Map Ptr (Credential Staking)
-> UTxO era
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
forall era.
EraTxOut era =>
Map Ptr (Credential Staking)
-> UTxO era
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
aggregateUtxoCoinByCredential Map Ptr (Credential Staking)
ptrs' UTxO era
u Map (Credential Staking) (CompactForm Coin)
rewards'
    activeDelegs :: Map.Map (Credential Staking) (KeyHash StakePool)
    activeDelegs :: Map (Credential Staking) (KeyHash StakePool)
activeDelegs = (Credential Staking -> KeyHash StakePool -> Bool)
-> Map (Credential Staking) (KeyHash StakePool)
-> Map (Credential Staking) (KeyHash StakePool)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Credential Staking
k KeyHash StakePool
v -> Credential Staking
-> Map (Credential Staking) (CompactForm Coin) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential Staking
k Map (Credential Staking) (CompactForm Coin)
rewards' Bool -> Bool -> Bool
&& KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash StakePool
v Map (KeyHash StakePool) StakePoolState
poolState) Map (Credential Staking) (KeyHash StakePool)
delegs

-- | 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) (CompactForm Coin) ->
  Map (Credential Staking) (CompactForm Coin)
aggregateUtxoCoinByCredential :: forall era.
EraTxOut era =>
Map Ptr (Credential Staking)
-> UTxO era
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
aggregateUtxoCoinByCredential Map Ptr (Credential Staking)
ptrs (UTxO Map TxIn (TxOut era)
u) Map (Credential Staking) (CompactForm Coin)
initial =
  (Map (Credential Staking) (CompactForm Coin)
 -> TxOut era -> Map (Credential Staking) (CompactForm Coin))
-> Map (Credential Staking) (CompactForm Coin)
-> Map TxIn (TxOut era)
-> Map (Credential Staking) (CompactForm Coin)
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map (Credential Staking) (CompactForm Coin)
-> TxOut era -> Map (Credential Staking) (CompactForm Coin)
accum ((CompactForm Coin -> Bool)
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (CompactForm Coin -> CompactForm Coin -> Bool
forall a. Eq a => a -> a -> Bool
/= CompactForm Coin
forall a. Monoid a => a
mempty) Map (Credential Staking) (CompactForm Coin)
initial) Map TxIn (TxOut era)
u
  where
    accum :: Map (Credential Staking) (CompactForm Coin)
-> TxOut era -> Map (Credential Staking) (CompactForm Coin)
accum Map (Credential Staking) (CompactForm Coin)
ans TxOut era
out =
      let c :: CompactForm Coin
c = TxOut era
out TxOut era
-> Getting (CompactForm Coin) (TxOut era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (TxOut era) (CompactForm Coin)
forall era.
(HasCallStack, EraTxOut era) =>
Lens' (TxOut era) (CompactForm Coin)
Lens' (TxOut era) (CompactForm Coin)
compactCoinTxOutL
       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
_ Credential Payment
_ (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 -> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> Credential Staking
-> CompactForm Coin
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) Credential Staking
cred CompactForm Coin
c Map (Credential Staking) (CompactForm Coin)
ans
            Addr Network
_ Credential Payment
_ (StakeRefBase Credential Staking
hk) -> (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> Credential Staking
-> CompactForm Coin
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>) Credential Staking
hk CompactForm Coin
c Map (Credential Staking) (CompactForm Coin)
ans
            Addr
_other -> Map (Credential Staking) (CompactForm Coin)
ans