{-# LANGUAGE BangPatterns #-}
{-# 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.Crypto.Hash.Class (Hash)
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.Crypto (Crypto (..), HASH)
import Cardano.Ledger.DRep hiding (drepDeposit)
import Cardano.Ledger.EpochBoundary (ssStakeMarkPoolDistrL)
import Cardano.Ledger.Hashes (EraIndependentTxBody)
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.EraClass
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 StandardCrypto) (IsValid, ScriptF era)
plutusmap <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Reflect era =>
Term era (Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era))
plutusUniv
    Set (Credential 'DRepRole StandardCrypto)
drepCreds <- forall a. (a -> Bool) -> Set a -> Set a
Set.filter (forall c a (kr :: KeyRole).
Map (ScriptHash c) a -> Credential kr c -> Bool
plutusFreeCredential Map (ScriptHash StandardCrypto) (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 (EraCrypto era)))
voteUniv
    (Credential 'DRepRole StandardCrypto
cred, Set (Credential 'DRepRole StandardCrypto)
_) <- forall a era. Gen a -> TraceM era a
liftGen (forall a. [String] -> Set a -> Gen (a, Set a)
itemFromSet [] Set (Credential 'DRepRole StandardCrypto)
drepCreds)
    Maybe (DRepState StandardCrypto)
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 StandardCrypto
cred) forall era a t. Target era (a -> t) -> Term era a -> Target era t
^$ forall era.
Era era =>
Term
  era
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
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 StandardCrypto)
mdrepstate of
      Maybe (DRepState StandardCrypto)
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 (EraCrypto era) -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ forall c.
Credential 'DRepRole c
-> Coin -> StrictMaybe (Anchor c) -> ConwayGovCert c
ConwayRegDRep Credential 'DRepRole StandardCrypto
cred Coin
deposit forall a. StrictMaybe a
SNothing]])
      Just (DRepState EpochNo
_expiry StrictMaybe (Anchor StandardCrypto)
_manchor Coin
_dep Set (Credential 'Staking StandardCrypto)
_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 (EraCrypto era) -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ forall c. Credential 'DRepRole c -> Coin -> ConwayGovCert c
ConwayUnRegDRep Credential 'DRepRole StandardCrypto
cred Coin
deposit]])
            , do
                StrictMaybe (Anchor StandardCrypto)
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 (EraCrypto era) -> ConwayTxCert era
ConwayTxCertGov forall a b. (a -> b) -> a -> b
$ forall c.
Credential 'DRepRole c -> StrictMaybe (Anchor c) -> ConwayGovCert c
ConwayUpdateDRep Credential 'DRepRole StandardCrypto
cred StrictMaybe (Anchor StandardCrypto)
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 (EraCrypto era)) -> 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 (EraCrypto era)))
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 StandardCrypto)
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 StandardCrypto)
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 StandardCrypto)
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 (EraCrypto era)) (GovActionState era)
getProposals :: forall era.
ConwayEraGov era =>
NewEpochState era
-> Map (GovActionId (EraCrypto era)) (GovActionState era)
getProposals NewEpochState era
nes =
  forall era.
Proposals era
-> Map (GovActionId (EraCrypto era)) (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 (EraCrypto era)
_ 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 (EraCrypto era)) (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 (EraCrypto era)) (CompactForm Coin)
extractPulsingDRepDistr (forall era. MockChainState era -> NewEpochState era
mcsNes MockChainState era
mcslast))

bruteForceDRepDistr ::
  forall era.
  ConwayEraGov era =>
  NewEpochState era ->
  Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
bruteForceDRepDistr :: forall era.
ConwayEraGov era =>
NewEpochState era -> Map (DRep (EraCrypto era)) (CompactForm Coin)
bruteForceDRepDistr NewEpochState era
nes =
  forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall c.
Map (Credential 'Staking c) (CompactForm Coin)
-> Map (Credential 'DRepRole c) (DRepState c)
-> Map (Credential 'Staking c) (CompactForm Coin)
-> PoolDistr c
-> Map (DRep c) (CompactForm Coin)
-> Map (Credential 'Staking c) (UMElem c)
-> (Map (DRep c) (CompactForm Coin), PoolDistr c)
computeDRepDistr Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
incstk Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
propDeps PoolDistr (EraCrypto era)
poolD forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ forall c. UMap c -> Map (Credential 'Staking c) (UMElem c)
UMap.umElems UMap (EraCrypto era)
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 (EraCrypto era)) (CompactForm Coin)
propDeps = forall era.
Proposals era
-> Map (Credential 'Staking (EraCrypto era)) (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 (EraCrypto era)
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 (EraCrypto era))
esSnapshotsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (SnapShots c) (PoolDistr c)
ssStakeMarkPoolDistrL
    cs :: CertState era
cs = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ls
    IStake Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
incstk Map Ptr (CompactForm Coin)
_ = forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr (forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ls)
    umap :: UMap (EraCrypto era)
umap = forall era. DState era -> UMap (EraCrypto era)
dsUnified (forall era. CertState era -> DState era
certDState CertState era
cs)
    dreps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps = forall era.
VState era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
vsDReps (forall era. CertState era -> VState era
certVState CertState era
cs)

extractPulsingDRepDistr ::
  ConwayEraGov era =>
  NewEpochState era ->
  Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
extractPulsingDRepDistr :: forall era.
ConwayEraGov era =>
NewEpochState era -> Map (DRep (EraCrypto era)) (CompactForm Coin)
extractPulsingDRepDistr NewEpochState era
nes =
  (forall era.
PulsingSnapshot era
-> Map (DRep (EraCrypto era)) (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 (EraCrypto era)) EraIndependentTxBody
hashTx :: forall era.
EraTx era =>
Proof era
-> Tx era -> Hash (HASH (EraCrypto era)) EraIndependentTxBody
hashTx Proof era
proof Tx era
tx = forall era.
Proof era
-> TxBody era -> Hash (EraCrypto era) 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