{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Generate a Simple Tx with 1 inout, 1 output, and 1 DRep related Cert
module Test.Cardano.Ledger.Constrained.Trace.DrepCertTx where

import Cardano.Ledger.Coin (Coin (..), CompactForm)
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov,
  EraGov,
  GovActionId,
  GovActionState,
  PulsingSnapshot (..),
  computeDRepDistr,
  curPParamsGovStateL,
  finishDRepPulser,
  newEpochStateDRepPulsingStateL,
  proposalsActionsMap,
  proposalsDeposits,
  proposalsGovStateL,
 )
import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..), ConwayTxCert (..))
import Cardano.Ledger.Core
import Cardano.Ledger.DRep hiding (drepDeposit)
import Cardano.Ledger.EpochBoundary (ssStakeMarkPoolDistrL)
import Cardano.Ledger.Shelley.LedgerState (
  CertState (..),
  DState (..),
  EpochState (..),
  IncrementalStake (..),
  LedgerState (..),
  NewEpochState (..),
  UTxOState (..),
  VState (..),
  allObligations,
  esLStateL,
  esSnapshotsL,
  lsUTxOStateL,
  nesEsL,
  utxosGovStateL,
 )
import qualified Cardano.Ledger.UMap as UMap
import Data.Foldable (toList)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.Set as Set
import qualified Debug.Trace as Debug
import Lens.Micro
import Test.Cardano.Ledger.Constrained.Ast (RootTarget (..), (^$))
import Test.Cardano.Ledger.Constrained.Classes (TxF (..), TxOutF (..))
import Test.Cardano.Ledger.Constrained.Combinators (itemFromSet)
import Test.Cardano.Ledger.Constrained.Preds.Tx (hashBody)
import Test.Cardano.Ledger.Constrained.Trace.Actions (
  certsAction,
  feesAction,
  inputsAction,
  outputsAction,
 )
import Test.Cardano.Ledger.Constrained.Trace.SimpleTx (
  completeTxBody,
  plutusFreeCredential,
  simpleTxBody,
 )
import Test.Cardano.Ledger.Constrained.Trace.TraceMonad (
  TraceM,
  epochProp,
  getTarget,
  getTerm,
  liftGen,
  mockChainProp,
  setVar,
  showPulserState,
  stepProp,
 )
import Test.Cardano.Ledger.Constrained.Vars
import Test.Cardano.Ledger.Generic.Fields (TxBodyField (..))
import Test.Cardano.Ledger.Generic.MockChain (MockBlock (..), MockChainState (..))
import Test.Cardano.Ledger.Generic.PrettyCore (pcNewEpochState, pcTxCert, ppList)
import Test.Cardano.Ledger.Generic.Proof (
  ConwayEra,
  Proof (..),
  Reflect (..),
  TxCertWit (..),
  whichTxCert,
 )
import Test.Cardano.Ledger.Generic.Updaters (newTxBody)
import Test.Tasty
import Test.Tasty.QuickCheck

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

-- | Fix the first Outputs field in a [TxBodyField], by applying the delta Coin to the first Output in that Outputs field
--   This is used to compensate for certificates which make deposits, and this Coin must come from somewhere, so it is
--   added (subtracted if the Coin is negative) from the first TxOut.
--   In rare occurrences, it is possible that 'delta' might be too negative to subtract from the input
--   in that case discard the trace. Note that in traces of length 150. this happens less than 1% of the time.
fixOutput :: EraTxOut era => Coin -> [TxBodyField era] -> TraceM era [TxBodyField era]
fixOutput :: forall era.
EraTxOut era =>
Coin -> [TxBodyField era] -> TraceM era [TxBodyField era]
fixOutput Coin
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
fixOutput delta :: Coin
delta@(Coin Integer
n) (Outputs' (TxOut era
txout : [TxOut era]
more) : [TxBodyField era]
others) =
  case TxOut era
txout forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL of
    Coin Integer
m ->
      if Integer
n forall a. Num a => a -> a -> a
+ Integer
m forall a. Ord a => a -> a -> Bool
< Integer
0
        then forall a. a
discard
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall era. [TxOut era] -> TxBodyField era
Outputs' ((TxOut era
txout forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Coin
delta) forall a. a -> [a] -> [a]
: [TxOut era]
more)) forall a. a -> [a] -> [a]
: [TxBodyField era]
others)
fixOutput Coin
delta (TxBodyField era
x : [TxBodyField era]
xs) = (TxBodyField era
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
EraTxOut era =>
Coin -> [TxBodyField era] -> TraceM era [TxBodyField era]
fixOutput Coin
delta [TxBodyField era]
xs

-- | Compute a valid Cert, and the change in the stored Deposits from that Cert.
drepCert :: Reflect era => Proof era -> TraceM era (Coin, [TxBodyField era])
drepCert :: forall era.
Reflect era =>
Proof era -> TraceM era (Coin, [TxBodyField era])
drepCert Proof era
proof = case forall era. Proof era -> TxCertWit era
whichTxCert Proof era
proof of
  TxCertWit era
TxCertShelleyToBabbage -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, [])
  TxCertWit era
TxCertConwayToConway -> do
    Map ScriptHash (IsValid, ScriptF era)
plutusmap <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Reflect era =>
Term era (Map ScriptHash (IsValid, ScriptF era))
plutusUniv
    Set (Credential 'DRepRole)
drepCreds <- forall a. (a -> Bool) -> Set a -> Set a
Set.filter (forall a (kr :: KeyRole). Map ScriptHash a -> Credential kr -> Bool
plutusFreeCredential Map ScriptHash (IsValid, ScriptF era)
plutusmap) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. Term era a -> TraceM era a
getTerm forall era. Era era => Term era (Set (Credential 'DRepRole))
voteUniv
    (Credential 'DRepRole
cred, Set (Credential 'DRepRole)
_) <- forall a era. Gen a -> TraceM era a
liftGen (forall a. [String] -> Set a -> Gen (a, Set a)
itemFromSet [] Set (Credential 'DRepRole)
drepCreds)
    Maybe DRepState
mdrepstate <- forall era r a. RootTarget era r a -> TraceM era a
getTarget (forall a b era. String -> (a -> b) -> RootTarget era Void (a -> b)
Constr String
"mapMember" (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
cred) forall era a t. Target era (a -> t) -> Term era a -> Target era t
^$ forall era.
Era era =>
Term era (Map (Credential 'DRepRole) DRepState)
currentDRepState)
    deposit :: Coin
deposit@(Coin Integer
m) <- forall era a. Term era a -> TraceM era a
getTerm (forall era. ConwayEraPParams era => Proof era -> Term era Coin
drepDeposit Proof era
proof)
    case Maybe DRepState
mdrepstate of
      Maybe DRepState
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Coin
Coin (-Integer
m), [forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. ConwayGovCert -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> ConwayGovCert
ConwayRegDRep Credential 'DRepRole
cred Coin
deposit forall a. StrictMaybe a
SNothing]])
      Just (DRepState EpochNo
_expiry StrictMaybe Anchor
_manchor Coin
_dep Set (Credential 'Staking)
_delegs) ->
        forall a era. Gen a -> TraceM era a
liftGen forall a b. (a -> b) -> a -> b
$
          forall a. HasCallStack => [Gen a] -> Gen a
oneof
            [ forall (f :: * -> *) a. Applicative f => a -> f a
pure (Coin
deposit, [forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. ConwayGovCert -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ Credential 'DRepRole -> Coin -> ConwayGovCert
ConwayUnRegDRep Credential 'DRepRole
cred Coin
deposit]])
            , do
                StrictMaybe Anchor
mAnchor <- forall a. Arbitrary a => Gen a
arbitrary
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Coin
Coin Integer
0, [forall era. [TxCert era] -> TxBodyField era
Certs' [forall era. ConwayGovCert -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ Credential 'DRepRole -> StrictMaybe Anchor -> ConwayGovCert
ConwayUpdateDRep Credential 'DRepRole
cred StrictMaybe Anchor
mAnchor]])
            ]

drepCertTx :: Reflect era => Coin -> Proof era -> TraceM era (TxF era)
drepCertTx :: forall era.
Reflect era =>
Coin -> Proof era -> TraceM era (TxF era)
drepCertTx Coin
maxFeeEstimate Proof era
proof = do
  [TxBodyField era]
simplefields <- forall era.
Reflect era =>
Proof era -> Coin -> TraceM era [TxBodyField era]
simpleTxBody Proof era
proof Coin
maxFeeEstimate
  (Coin
deltadeposit, [TxBodyField era]
certfields) <- forall era.
Reflect era =>
Proof era -> TraceM era (Coin, [TxBodyField era])
drepCert Proof era
proof
  TxBody era
txb <- do
    [TxBodyField era]
fields2 <- forall era.
EraTxOut era =>
Coin -> [TxBodyField era] -> TraceM era [TxBodyField era]
fixOutput Coin
deltadeposit [TxBodyField era]
simplefields
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody Proof era
proof ([TxBodyField era]
fields2 forall a. [a] -> [a] -> [a]
++ [TxBodyField era]
certfields))
  Tx era
tx <- forall era.
Reflect era =>
Proof era -> Coin -> TxBody era -> TraceM era (Tx era)
completeTxBody Proof era
proof Coin
maxFeeEstimate TxBody era
txb
  forall era t. Term era t -> t -> TraceM era ()
setVar forall era. Reflect era => Term era (TxF era)
txterm (forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
tx)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
tx)

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

--   appropriate for a SimpleTx with DRepCerts.
--   Changes to the Env are done by side effects in the TraceM mondad.
applyDRepCertActions :: Reflect era => Proof era -> Tx era -> TraceM era ()
applyDRepCertActions :: forall era. Reflect era => Proof era -> Tx era -> TraceM era ()
applyDRepCertActions Proof era
proof Tx era
tx = do
  let txb :: TxBody era
txb = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      feeCoin :: Coin
feeCoin = TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
      txbcerts :: StrictSeq (TxCert era)
txbcerts = TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
  forall era. Era era => Proof era -> Set TxIn -> TraceM era ()
inputsAction Proof era
proof (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
  forall era.
Reflect era =>
Proof era -> TxBody era -> [TxOutF era] -> TraceM era ()
outputsAction Proof era
proof TxBody era
txb (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL)))
  forall era. Era era => Coin -> TraceM era ()
feesAction Coin
feeCoin
  forall (t :: * -> *) era.
(Foldable t, Era era) =>
Proof era -> t (TxCert era) -> TraceM era ()
certsAction Proof era
proof StrictSeq (TxCert era)
txbcerts

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

-- | Generate a Tx that can be made into a Trace, because it applies the
--   necessary Actions to update the Env. The Env must contain the Vars that
--   are updated by 'applyDRepCertActions' . It is best to intialize the whole
--   LedgerState to do this.
drepCertTxForTrace :: Reflect era => Coin -> Proof era -> TraceM era (Tx era)
drepCertTxForTrace :: forall era. Reflect era => Coin -> Proof era -> TraceM era (Tx era)
drepCertTxForTrace Coin
maxFeeEstimate Proof era
proof = do
  TxF Proof era
_ Tx era
tx <- forall era.
Reflect era =>
Coin -> Proof era -> TraceM era (TxF era)
drepCertTx Coin
maxFeeEstimate Proof era
proof
  forall era. Reflect era => Proof era -> Tx era -> TraceM era ()
applyDRepCertActions Proof era
proof Tx era
tx
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx

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

drepTree :: TestTree
drepTree :: TestTree
drepTree =
  String -> [TestTree] -> TestTree
testGroup
    String
"DRep property Debug.traces"
    [ forall a. Testable a => String -> a -> TestTree
testProperty
        String
"All Tx are valid on traces of length 150."
        forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
20
        forall a b. (a -> b) -> a -> b
$ forall era.
(Reflect era, STS (MOCKCHAIN era)) =>
Proof era
-> Int
-> (Proof era -> TraceM era (Tx era))
-> (Trace (MOCKCHAIN era) -> Property)
-> Property
mockChainProp Proof ConwayEra
Conway Int
150 (forall era. Reflect era => Coin -> Proof era -> TraceM era (Tx era)
drepCertTxForTrace @ConwayEra (Integer -> Coin
Coin Integer
100000))
        forall a b. (a -> b) -> a -> b
$ forall era.
(MockChainState era
 -> MockBlock era -> MockChainState era -> Property)
-> Trace (MOCKCHAIN era) -> Property
stepProp (forall era.
Reflect era =>
Proof era
-> MockChainState era
-> MockBlock era
-> MockChainState era
-> Property
allValidSignals Proof ConwayEra
Conway)
    , forall a. Testable a => String -> a -> TestTree
testProperty
        String
"Bruteforce = Pulsed, in every epoch, on traces of length 150"
        forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
5
        forall a b. (a -> b) -> a -> b
$ forall era.
(Reflect era, STS (MOCKCHAIN era)) =>
Proof era
-> Int
-> (Proof era -> TraceM era (Tx era))
-> (Trace (MOCKCHAIN era) -> Property)
-> Property
mockChainProp Proof ConwayEra
Conway Int
150 (forall era. Reflect era => Coin -> Proof era -> TraceM era (Tx era)
drepCertTxForTrace (Integer -> Coin
Coin Integer
60000))
        forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraGov era =>
(MockChainState era -> MockChainState era -> Property)
-> Trace (MOCKCHAIN era) -> Property
epochProp forall era.
ConwayEraGov era =>
MockChainState era -> MockChainState era -> Property
pulserWorks
    ]

main :: IO ()
main :: IO ()
main = TestTree -> IO ()
defaultMain TestTree
drepTree

-- =================================================
-- Example functions that can be lifted to
-- Trace (MOCKCHAIN era) -> Property
-- using 'stepProp', 'deltaProp', 'preserveProp', and 'epochProp'
-- this lifted value is then passed to 'mockChainProp' to make a Property

getpp :: EraGov era => NewEpochState era -> PParams era
getpp :: forall era. EraGov era => NewEpochState era -> PParams era
getpp NewEpochState era
nes = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL)

getProposals ::
  ConwayEraGov era => NewEpochState era -> Map.Map GovActionId (GovActionState era)
getProposals :: forall era.
ConwayEraGov era =>
NewEpochState era -> Map GovActionId (GovActionState era)
getProposals NewEpochState era
nes =
  forall era. Proposals era -> Map GovActionId (GovActionState era)
proposalsActionsMap
    (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL))

allValidSignals ::
  Reflect era => Proof era -> MockChainState era -> MockBlock era -> MockChainState era -> Property
allValidSignals :: forall era.
Reflect era =>
Proof era
-> MockChainState era
-> MockBlock era
-> MockChainState era
-> Property
allValidSignals Proof era
p (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
slot Int
count) (MockBlock KeyHash 'StakePool
_ SlotNo
_ StrictSeq (Tx era)
_txs) MockChainState era
_stateN =
  forall prop. Testable prop => String -> prop -> Property
counterexample
    (String
"\nCount " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" Slot " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SlotNo
slot forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall era. Reflect era => Proof era -> NewEpochState era -> PDoc
pcNewEpochState Proof era
p NewEpochState era
nes))
    (forall prop. Testable prop => prop -> Property
property Bool
True)

pulserWorks :: ConwayEraGov era => MockChainState era -> MockChainState era -> Property
pulserWorks :: forall era.
ConwayEraGov era =>
MockChainState era -> MockChainState era -> Property
pulserWorks MockChainState era
mcsfirst MockChainState era
mcslast =
  forall prop. Testable prop => String -> prop -> Property
counterexample
    ( String
"\nFirst "
        forall a. [a] -> [a] -> [a]
++ forall era. ConwayEraGov era => MockChainState era -> String
showPulserState MockChainState era
mcsfirst
        forall a. [a] -> [a] -> [a]
++ String
"\nLast "
        forall a. [a] -> [a] -> [a]
++ forall era. ConwayEraGov era => MockChainState era -> String
showPulserState MockChainState era
mcslast
    )
    (forall era.
ConwayEraGov era =>
NewEpochState era -> Map DRep (CompactForm Coin)
bruteForceDRepDistr (forall era. MockChainState era -> NewEpochState era
mcsTickNes MockChainState era
mcsfirst) forall a. (Eq a, Show a) => a -> a -> Property
=== forall era.
ConwayEraGov era =>
NewEpochState era -> Map DRep (CompactForm Coin)
extractPulsingDRepDistr (forall era. MockChainState era -> NewEpochState era
mcsNes MockChainState era
mcslast))

bruteForceDRepDistr ::
  forall era.
  ConwayEraGov era =>
  NewEpochState era ->
  Map.Map DRep (CompactForm Coin)
bruteForceDRepDistr :: forall era.
ConwayEraGov era =>
NewEpochState era -> Map DRep (CompactForm Coin)
bruteForceDRepDistr NewEpochState era
nes =
  forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'Staking) (CompactForm Coin)
-> PoolDistr
-> Map DRep (CompactForm Coin)
-> Map (Credential 'Staking) UMElem
-> (Map DRep (CompactForm Coin), PoolDistr)
computeDRepDistr Map (Credential 'Staking) (CompactForm Coin)
incstk Map (Credential 'DRepRole) DRepState
dreps Map (Credential 'Staking) (CompactForm Coin)
propDeps PoolDistr
poolD forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ UMap -> Map (Credential 'Staking) UMElem
UMap.umElems UMap
umap
  where
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes)
    propDeps :: Map (Credential 'Staking) (CompactForm Coin)
propDeps = forall era.
Proposals era -> Map (Credential 'Staking) (CompactForm Coin)
proposalsDeposits forall a b. (a -> b) -> a -> b
$ LedgerState era
ls forall s a. s -> Getting a s a -> a
^. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL
    poolD :: PoolDistr
poolD = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) SnapShots
esSnapshotsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SnapShots PoolDistr
ssStakeMarkPoolDistrL
    cs :: CertState era
cs = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    IStake Map (Credential 'Staking) (CompactForm Coin)
incstk Map Ptr (CompactForm Coin)
_ = forall era. UTxOState era -> IncrementalStake
utxosStakeDistr (forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls)
    umap :: UMap
umap = forall era. DState era -> UMap
dsUnified (forall era. CertState era -> DState era
certDState CertState era
cs)
    dreps :: Map (Credential 'DRepRole) DRepState
dreps = forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps (forall era. CertState era -> VState era
certVState CertState era
cs)

extractPulsingDRepDistr ::
  ConwayEraGov era =>
  NewEpochState era ->
  Map.Map DRep (CompactForm Coin)
extractPulsingDRepDistr :: forall era.
ConwayEraGov era =>
NewEpochState era -> Map DRep (CompactForm Coin)
extractPulsingDRepDistr NewEpochState era
nes =
  (forall era. PulsingSnapshot era -> Map DRep (CompactForm Coin)
psDRepDistr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser) (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL)

-- ===============================================
-- helper functions

showCerts :: Proof era -> [TxCert era] -> String
showCerts :: forall era. Proof era -> [TxCert era] -> String
showCerts Proof era
proof [TxCert era]
cs = forall a. Show a => a -> String
show (forall x ann. (x -> Doc ann) -> [x] -> Doc ann
ppList (forall era. Proof era -> TxCert era -> PDoc
pcTxCert Proof era
proof) [TxCert era]
cs)

certsOf :: EraTx era => Tx era -> [TxCert era]
certsOf :: forall era. EraTx era => Tx era -> [TxCert era]
certsOf Tx era
tx = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Tx era
tx forall s a. s -> Getting a s a -> a
^. (forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL))

hashTx :: EraTx era => Proof era -> Tx era -> Hash HASH EraIndependentTxBody
hashTx :: forall era.
EraTx era =>
Proof era -> Tx era -> Hash HASH EraIndependentTxBody
hashTx Proof era
proof Tx era
tx = forall era.
Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
hashBody Proof era
proof (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)

showMap :: (Show k, Show v) => String -> Map.Map k v -> String
showMap :: forall k v. (Show k, Show v) => String -> Map k v -> String
showMap String
msg Map k v
m = [String] -> String
unlines (String
msg forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show (forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m))

traceMap :: (Show k, Show v) => String -> Map.Map k v -> a -> a
traceMap :: forall k v a. (Show k, Show v) => String -> Map k v -> a -> a
traceMap String
s Map k v
m a
x = forall a. String -> a -> a
Debug.trace (forall k v. (Show k, Show v) => String -> Map k v -> String
showMap String
s Map k v
m) a
x

showPotObl :: ConwayEraGov era => NewEpochState era -> String
showPotObl :: forall era. ConwayEraGov era => NewEpochState era -> String
showPotObl NewEpochState era
nes =
  String
"\nPOT "
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall era. UTxOState era -> Coin
utxosDeposited UTxOState era
us)
    forall a. [a] -> [a] -> [a]
++ String
"\nAll "
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall era.
EraGov era =>
CertState era -> GovState era -> Obligations
allObligations CertState era
certSt (UTxOState era
us forall s a. s -> Getting a s a -> a
^. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL))
  where
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    ls :: LedgerState era
ls = forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    us :: UTxOState era
us = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls
    certSt :: CertState era
certSt = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls