diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Constants.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Constants.hs index 0ddae876cd3..00a51cdc263 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Constants.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Constants.hs @@ -137,7 +137,7 @@ defaultConstants = Constants , frequencyTxUpdates = 10 , minGenesisUTxOouts = 10 , maxGenesisUTxOouts = 100 - , maxCertsPerTx = 1 + , maxCertsPerTx = 3 , maxTxsPerBlock = 10 , maxNumKeyPairs = 150 , minGenesisOutputVal = 1000000 diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs index d5c6c356d85..408527c045a 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Trace/DCert.hs @@ -28,7 +28,7 @@ import Test.QuickCheck (Gen) import Control.State.Transition (BaseM, Embed, Environment, PredicateFailure, STS, Signal, State, TRC (..), TransitionRule, initialRules, judgmentContext, trans, transitionRules, wrapFailed) -import Control.State.Transition.Trace (TraceOrder (OldestFirst), traceSignals) +import Control.State.Transition.Trace (TraceOrder (OldestFirst), lastState, traceSignals) import qualified Control.State.Transition.Trace.Generator.QuickCheck as QC import GHC.Generics (Generic) import Shelley.Spec.Ledger.BaseTypes (Globals, ShelleyBase) @@ -127,7 +127,7 @@ genDCerts -> Natural -> Natural -> Coin - -> Gen (StrictSeq DCert, [CertCred], Coin, Coin) + -> Gen (StrictSeq DCert, [CertCred], Coin, Coin, DPState) genDCerts ge@( GenEnv KeySpace_ {ksKeyPairsByHash} @@ -142,11 +142,12 @@ genDCerts let env = (slot, txIx, pparams, reserves) st0 = (dpState, 0) - certsCreds <- - catMaybes . traceSignals OldestFirst <$> + certsTrace <- QC.traceFrom @CERTS testGlobals maxCertsPerTx ge env st0 - let (certs, creds) = unzip certsCreds + let certsCreds = catMaybes . traceSignals OldestFirst $ certsTrace + (lastState_, _) = lastState certsTrace + (certs, creds) = unzip certsCreds deRegStakeCreds = filter isDeRegKey certs slotWithTTL = slot + SlotNo (fromIntegral ttl) @@ -155,7 +156,8 @@ genDCerts pure ( StrictSeq.fromList certs , withScriptCreds , totalDeposits pparams (_stPools (_pstate dpState)) certs - , sum (certRefund slotWithTTL <$> deRegStakeCreds) ) + , sum (certRefund slotWithTTL <$> deRegStakeCreds) + , lastState_) where (dval, dmin, lambda) = decayKey pparams diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs index 71a7eb0b3d5..8f36dbff618 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs @@ -101,16 +101,16 @@ genTx ge@(GenEnv KeySpace_ { ksCoreNodes let slotWithTTL = slot + SlotNo (fromIntegral ttl) -- certificates - (certs, certCreds, deposits_, refunds_) + (certs, certCreds, deposits_, refunds_, dpState') <- genDCerts ge pparams dpState slot ttl txIx reserves - if spendingBalance < deposits_ + let balance_ = spendingBalance - deposits_ + refunds_ + if balance_ <= 0 then QC.discard else do -- attempt to make provision for certificate deposits (otherwise discard this generator) - let balance_ = spendingBalance - deposits_ + refunds_ - stakeScripts = Maybe.catMaybes $ map (\case + let stakeScripts = Maybe.catMaybes $ map (\case ScriptCred c -> Just c _ -> Nothing) certCreds genesisWitnesses = foldl (++) [] $ @@ -128,7 +128,7 @@ genTx ge@(GenEnv KeySpace_ { ksCoreNodes --- PParam + AV Updates (update, updateWitnesses) <- - genUpdate constants slot ksCoreNodes ksKeyPairsByStakeHash pparams (utxoSt, dpState) + genUpdate constants slot ksCoreNodes ksKeyPairsByStakeHash pparams (utxoSt, dpState') -- this is the "model" `TxBody` which is used to calculate the fees -- diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/PropertyTests.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/PropertyTests.hs index 67f08f4f5cf..68b798ee269 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/PropertyTests.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/PropertyTests.hs @@ -180,19 +180,15 @@ roundTripAddr = keyPair2 <- snd . mkKeyPairs <$> Gen.word64 Range.constantBounded pure $ toAddr (keyPair1, keyPair2) - minimalPropertyTests :: TestTree minimalPropertyTests = testGroup "Minimal Property Tests" - [ -- TODO @uroboros - -- TQC.testProperty "Chain and Ledger traces cover the relevant cases" relevantCasesAreCovered - --, TQC.testProperty "total amount of Ada is preserved" preservationOfAda - --, - TQC.testProperty "Only valid CHAIN STS signals are generated" onlyValidChainSignalsAreGenerated + [ TQC.testProperty "Chain and Ledger traces cover the relevant cases" relevantCasesAreCovered + , TQC.testProperty "total amount of Ada is preserved" preservationOfAda + , TQC.testProperty "Only valid CHAIN STS signals are generated" onlyValidChainSignalsAreGenerated , testProperty "Roundtrip Addr serialisation Hedghog" roundTripAddr ] - -- | 'TestTree' of property-based testing properties. propertyTests :: TestTree propertyTests = testGroup "Property-Based Testing" diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs index 8ec265318b1..495443584c7 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs @@ -16,8 +16,8 @@ import Cardano.Binary (serialize') import Cardano.Slotting.Slot (EpochSize (..)) import Control.State.Transition.Trace (TraceOrder (OldestFirst), traceLength, traceSignals) -import Control.State.Transition.Trace.Generator.QuickCheck (classifyTraceLength, - forAllTraceFromInitState, onlyValidSignalsAreGeneratedFromInitState) +import Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitState, + onlyValidSignalsAreGeneratedFromInitState, traceFromInitState) import qualified Data.ByteString as BS import Data.Foldable (toList) import qualified Data.Map.Strict as Map @@ -36,7 +36,8 @@ import Shelley.Spec.Ledger.Tx (_body) import Shelley.Spec.Ledger.TxData (pattern Addr, pattern DCertDeleg, pattern DeRegKey, pattern Delegate, pattern Delegation, pattern RegKey, pattern ScriptHashObj, pattern TxOut, Wdrl (..), _certs, _outputs, _txUpdate, _wdrls) -import Test.QuickCheck (Property, checkCoverage, conjoin, cover, property, withMaxSuccess) +import Test.QuickCheck (Property, checkCoverage, conjoin, cover, forAll, property, + withMaxSuccess) import qualified Test.QuickCheck.Gen import qualified Control.State.Transition.Extended @@ -73,83 +74,80 @@ genesisLedgerState genesisLedgerState = Just $ mkGenesisLedgerState (geConstants genEnv) relevantCasesAreCovered :: Property -relevantCasesAreCovered = withMaxSuccess 200 . property $ do +relevantCasesAreCovered = do let tl = 100 GenEnv _ c@(Constants{maxCertsPerTx}) = genEnv - forAllTraceFromInitState @CHAIN testGlobals tl genEnv genesisChainState $ \tr -> do + + forAll (traceFromInitState @CHAIN testGlobals tl genEnv genesisChainState) $ \tr -> do let blockTxs (Block _ (TxSeq txSeq)) = toList txSeq bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) + tl' = traceLength tr certs_ = allCerts txs - checkCoverage $ conjoin [ - classifyTraceLength tl 5 tr - - , cover_ 60 - (traceLength tr <= 3 * length certs_) - "there is at least 1 certificate for every 3 transactions" - - , cover_ 60 - (traceLength tr <= 10 * length (filter isRegKey certs_)) - "there is at least 1 RegKey certificate for every 10 transactions" - - , cover_ 60 - (traceLength tr <= 10 * length (filter isDeRegKey certs_)) - "there is at least 1 DeRegKey certificate for every 10 transactions" - - , cover_ 60 - (traceLength tr <= 10 * length (filter isDelegation certs_)) - "there is at least 1 Delegation certificate for every 10 transactions" - - , cover_ 60 - (traceLength tr <= 20 * length (filter isGenesisDelegation certs_)) - "there is at least 1 Genesis Delegation certificate for every 20 transactions" - - , cover_ 60 - (traceLength tr <= 10 * length (filter isRegPool certs_)) - "there is at least 1 RegPool certificate for every 10 transactions" - - , cover_ 60 - (traceLength tr <= 10 * length (filter isRetirePool certs_)) - "there is at least 1 RetirePool certificate for every 10 transactions" - - , cover_ 60 - (traceLength tr <= 30 * length (filter isInstantaneousRewards certs_)) - "there is at least 1 MIR certificate for every 30 transactions" - - , cover_ 60 - (0.6 >= noCertsRatio (certsByTx txs)) - "at most 60% of transactions have no certificates" - - , cover_ 60 - (0.1 <= maxCertsRatio c (certsByTx txs)) - ("at least 10% of transactions have " <> (show maxCertsPerTx) <> " certificates") - - , cover_ 20 - (0.1 <= txScriptOutputsRatio (map (_outputs . _body) txs)) - "at least 10% of transactions have script TxOuts" - , cover_ 60 - (0.1 <= scriptCredentialCertsRatio certs_) - "at least 10% of `DCertDeleg` certificates have script credentials" - , cover_ 60 - (0.1 <= withdrawalRatio txs) - "at least 10% of transactions have a reward withdrawal" - - , cover_ 60 - (0.98 >= noPPUpdateRatio (ppUpdatesByTx txs)) - "at least 2% of transactions have non-trivial protocol param updates" - - , cover_ 60 - (2 <= epochBoundariesInTrace bs) - "at least 2 epoch changes in trace" - - , cover_ 20 - (5 <= epochBoundariesInTrace bs) - "at least 5 epoch changes in trace" - ] - where - cover_ pc b s = cover pc b s (property ()) - + property $ conjoin $ + [ + checkCoverage $ cover 60 + (tl' < 1 * length certs_) + "there is at least 1 certificate for every 3 transactions" + (property ()) + , checkCoverage $ cover 60 + (tl' < 10 * length (filter isRegKey certs_)) + "there is at least 1 RegKey certificate for every 10 transactions" + (property ()) + , checkCoverage $ cover 60 + (tl' < 10 * length (filter isDeRegKey certs_)) + "there is at least 1 DeRegKey certificate for every 10 transactions" + (property ()) + , checkCoverage $ cover 60 + (traceLength tr < 10 * length (filter isDelegation certs_)) + "there is at least 1 Delegation certificate for every 10 transactions" + (property ()) + , checkCoverage $ cover 60 + (traceLength tr < 20 * length (filter isGenesisDelegation certs_)) + "there is at least 1 Genesis Delegation certificate for every 20 transactions" + (property ()) + , checkCoverage $ cover 60 + (traceLength tr < 10 * length (filter isRetirePool certs_)) + "there is at least 1 RetirePool certificate for every 10 transactions" + (property ()) + , checkCoverage $ cover 60 + (traceLength tr < 30 * length (filter isInstantaneousRewards certs_)) + "there is at least 1 MIR certificate for every 30 transactions" + (property ()) + , checkCoverage $ cover 60 + (0.6 > noCertsRatio (certsByTx txs)) + "at most 60% of transactions have no certificates" + (property ()) + , checkCoverage $ cover 60 + (0.1 < maxCertsRatio c (certsByTx txs)) + ("at least 10% of transactions have " <> (show maxCertsPerTx) <> " certificates") + (property ()) + , checkCoverage $ cover 60 + (traceLength tr < 10 * length (filter isRegPool certs_)) + "there is at least 1 RegPool certificate for every 10 transactions" + (property ()) + , checkCoverage $ cover 20 + (0.1 < txScriptOutputsRatio (map (_outputs . _body) txs)) + "at least 10% of transactions have script TxOuts" + (property ()) + , checkCoverage $ cover 60 + (0.1 < scriptCredentialCertsRatio certs_) + "at least 10% of `DCertDeleg` certificates have script credentials" + (property ()) + , checkCoverage $ cover 60 + (0.1 < withdrawalRatio txs) + "at least 10% of transactions have a reward withdrawal" + (property ()) + , checkCoverage $ cover 60 + (0.98 > noPPUpdateRatio (ppUpdatesByTx txs)) + "at least 2% of transactions have non-trivial protocol param updates" + (property ()) + , checkCoverage $ cover 40 + (2 <= epochBoundariesInTrace bs) + "at least 2 epoch changes in trace" + (property ()) + ] -- | Ratio of certificates with script credentials to the number of certificates -- that could have script credentials. diff --git a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/TestLedger.hs b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/TestLedger.hs index f6a2c26cdb7..6d289c4e2ff 100644 --- a/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/TestLedger.hs +++ b/shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Rules/TestLedger.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -36,30 +38,35 @@ import Data.Word (Word64) import Test.QuickCheck (Property, Testable, conjoin, property, withMaxSuccess, (===)) -import Control.State.Transition.Trace (SourceSignalTarget (..), Trace (..), source, - sourceSignalTargets, target) +import Control.State.Transition.Trace (SourceSignalTarget (..), Trace (..), + TraceOrder (NewestFirst), source, sourceSignalTargets, target, traceSignals) +import qualified Control.State.Transition.Trace as Trace import Control.State.Transition.Trace.Generator.QuickCheck (forAllTraceFromInitState) import Shelley.Spec.Ledger.Coin (pattern Coin) import Shelley.Spec.Ledger.LedgerState (pattern DPState, pattern DState, pattern UTxOState, _deposited, _dstate, _fees, _pstate, _rewards, _stPools, _stkCreds, _utxo) -import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (ledgerPp)) +import Shelley.Spec.Ledger.STS.Deleg (DelegEnv (..)) +import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (..)) +import Shelley.Spec.Ledger.STS.Pool (PoolEnv (..)) import Shelley.Spec.Ledger.Tx (_body) -import Shelley.Spec.Ledger.TxData (_certs, _wdrls) +import Shelley.Spec.Ledger.TxData (Ptr (..), _certs, _wdrls) import Shelley.Spec.Ledger.UTxO (balance) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (DELEG, DELEGS, LEDGER, POOL, StakeCreds, StakePools, UTXO, UTXOW, Wdrl) -import Test.Shelley.Spec.Ledger.Generator.Trace.Ledger (mkGenesisLedgerState) -import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv(geConstants)) +import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv (geConstants)) import qualified Test.Shelley.Spec.Ledger.Generator.Presets as Preset (genEnv) +import Test.Shelley.Spec.Ledger.Generator.Trace.Ledger (mkGenesisLedgerState) import qualified Test.Shelley.Spec.Ledger.Rules.TestDeleg as TestDeleg import qualified Test.Shelley.Spec.Ledger.Rules.TestDelegs as TestDelegs import qualified Test.Shelley.Spec.Ledger.Rules.TestPool as TestPool import qualified Test.Shelley.Spec.Ledger.Rules.TestUtxo as TestUtxo import qualified Test.Shelley.Spec.Ledger.Rules.TestUtxow as TestUtxow -import Test.Shelley.Spec.Ledger.Utils (testGlobals) +import Test.Shelley.Spec.Ledger.Utils (runShelleyBase, testGlobals) + +import Shelley.Spec.Ledger.STS.Pool () ------------------------------ -- Constants for Properties -- @@ -79,25 +86,25 @@ traceLen = 100 rewardZeroAfterRegKey :: Property rewardZeroAfterRegKey = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToDelegTrace tr) in TestDeleg.rewardZeroAfterReg sst credentialRemovedAfterDereg :: Property credentialRemovedAfterDereg = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToDelegTrace tr) in TestDeleg.credentialRemovedAfterDereg sst credentialMappingAfterDelegation :: Property credentialMappingAfterDelegation = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToDelegTrace tr) in TestDeleg.credentialMappingAfterDelegation sst rewardsSumInvariant :: Property rewardsSumInvariant = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToDelegTrace tr) in TestDeleg.rewardsSumInvariant sst rewardsDecreasesByWithdrawals :: Property @@ -205,50 +212,50 @@ requiredMSigSignaturesSubset = registeredPoolIsAdded :: Property registeredPoolIsAdded = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToPoolSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToPoolTrace tr) in TestPool.registeredPoolIsAdded (_traceEnv tr) sst -- | Check that a newly registered pool has a reward of 0. rewardZeroAfterRegPool :: Property rewardZeroAfterRegPool = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToPoolSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToPoolTrace tr) in TestPool.rewardZeroAfterReg sst poolRetireInEpoch :: Property poolRetireInEpoch = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToPoolSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToPoolTrace tr) in TestPool.poolRetireInEpoch (_traceEnv tr) sst -- | Check that a `RetirePool` certificate properly removes a stake pool. poolIsMarkedForRetirement :: Property poolIsMarkedForRetirement = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToPoolSsts (sourceSignalTargets tr) + let sst = sourceSignalTargets (ledgerToPoolTrace tr) in TestPool.poolIsMarkedForRetirement sst +pStateIsInternallyConsistent :: Property +pStateIsInternallyConsistent = + forAllLedgerTrace $ \tr -> + let sst = sourceSignalTargets (ledgerToPoolTrace tr) + in TestPool.pStateIsInternallyConsistent sst + -- | Check that `InstantaneousRewards` certificate entries are added to the -- Instantaneous Rewards map. prop_MIRentriesEndUpInMap :: Property prop_MIRentriesEndUpInMap = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) - in TestDeleg.instantaneousRewardsAdded sst + let sst = sourceSignalTargets (ledgerToDelegTrace tr) + in TestDeleg.instantaneousRewardsAdded sst -- | Check that the coin values in `InstantaneousRewards` certificate entries -- are added to the Instantaneous Rewards map. prop_MIRValuesEndUpInMap :: Property prop_MIRValuesEndUpInMap = forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToDelegSsts (sourceSignalTargets tr) - in TestDeleg.instantaneousRewardsValue sst - -pStateIsInternallyConsistent :: Property -pStateIsInternallyConsistent = - forAllLedgerTrace $ \tr -> - let sst = concatMap ledgerToPoolSsts (sourceSignalTargets tr) - in TestPool.pStateIsInternallyConsistent sst + let sst = sourceSignalTargets (ledgerToDelegTrace tr) + in TestDeleg.instantaneousRewardsValue sst --------------------------- -- Utils -- @@ -262,13 +269,6 @@ forAllLedgerTrace prop = withMaxSuccess (fromIntegral numberOfTests) . property $ forAllTraceFromInitState testGlobals traceLen Preset.genEnv (Just $ mkGenesisLedgerState (geConstants Preset.genEnv)) prop --- | Transform LEDGER `sourceSignalTargets`s to DELEG ones. -ledgerToDelegSsts - :: SourceSignalTarget LEDGER - -> [SourceSignalTarget DELEG] -ledgerToDelegSsts (SourceSignalTarget (_, DPState d _) (_, DPState d' _) tx) = - [SourceSignalTarget d d' cert | cert <- toList ((_certs . _body) tx)] - -- | Transform LEDGER `sourceSignalTargets`s to DELEGS ones. ledgerToDelegsSsts :: SourceSignalTarget LEDGER @@ -277,13 +277,6 @@ ledgerToDelegsSsts (SourceSignalTarget (_, dpSt) (_, dpSt') tx) = ( (_wdrls . _body) tx , SourceSignalTarget dpSt dpSt' ((StrictSeq.getSeq . _certs . _body) tx)) --- | Transform LEDGER `SourceSignalTargets`s to POOL ones. -ledgerToPoolSsts - :: SourceSignalTarget LEDGER - -> [SourceSignalTarget POOL] -ledgerToPoolSsts (SourceSignalTarget (_, DPState _ p) (_, DPState _ p') tx) = - [SourceSignalTarget p p' cert | cert <- toList ((_certs . _body) tx)] - -- | Transform LEDGER to UTXO `SourceSignalTargets`s ledgerToUtxoSsts :: SourceSignalTarget LEDGER @@ -299,3 +292,37 @@ ledgerToUtxowSsts (SourceSignalTarget (utxoSt, delegSt) (utxoSt', _) tx) = ( (_stkCreds . _dstate) delegSt , (_stPools . _pstate) delegSt , SourceSignalTarget utxoSt utxoSt' tx) + +-- | Transform a LEDGER Trace to a POOL Trace by extracting the certificates +-- from the LEDGER transactions and then reconstructing a new POOL trace from +-- those certificates. +ledgerToPoolTrace :: Trace LEDGER -> Trace POOL +ledgerToPoolTrace ledgerTr = + runShelleyBase $ + Trace.closure @POOL poolEnv poolSt0 (certs txs) + where + txs = traceSignals NewestFirst ledgerTr + certs = concatMap (toList . _certs . _body) + + poolEnv = let (LedgerEnv s _ pp _) = _traceEnv ledgerTr in + PoolEnv s pp + poolSt0 = let (_, DPState _ poolSt0_) = _traceInitState ledgerTr in + poolSt0_ + +-- | Transform a LEDGER Trace to a DELEG Trace by extracting the certificates +-- from the LEDGER transactions and then reconstructing a new DELEG trace from +-- those certificates. +ledgerToDelegTrace :: Trace LEDGER -> Trace DELEG +ledgerToDelegTrace ledgerTr = + runShelleyBase $ + Trace.closure @DELEG delegEnv delegSt0 (certs txs) + where + txs = traceSignals NewestFirst ledgerTr + certs = concatMap (toList . _certs . _body) + + delegEnv = let (LedgerEnv s txIx _ reserves) = _traceEnv ledgerTr + dummyCertIx = 0 + ptr = Ptr s txIx dummyCertIx in + DelegEnv s ptr reserves + delegSt0 = let (_, DPState delegSt0_ _) = _traceInitState ledgerTr in + delegSt0_