{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Dijkstra.ImpTest (
  module Test.Cardano.Ledger.Conway.ImpTest,
  DijkstraEraImp,
  impDijkstraSatisfyNativeScript,
  fixupSubTransactions,
  balanceSubTransactions,
  switchTxToLegacyMode,
  switchTxToPhase2InvalidLegacyMode,
  mkTopTxWithSubTxs,
  mkTopTxWithDistinctSubTxs,
  distinctSubTxs,
  traverseSubTxs,
  withPostFixupSubTxs,
  submitFailingSubTx,
  submitFailingMempoolTx,
  expectMempoolRejection,
  voteSubTx,
  declareTreasurySubTx,
) where

import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov (..),
  GovActionId,
  Vote,
  Voter,
  VotingProcedure (..),
  VotingProcedures (..),
  committeeMembersL,
 )
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential
import Cardano.Ledger.Dijkstra (ApplyTxError, DijkstraEra, DijkstraEraForecast)
import Cardano.Ledger.Dijkstra.BlockBody (DijkstraEraBlockBody)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules
import Cardano.Ledger.Dijkstra.Scripts (
  DijkstraNativeScript,
  evalDijkstraNativeScript,
  pattern RequireGuard,
 )
import Cardano.Ledger.Dijkstra.UTxO
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.API (mkStAnnTx)
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.State
import Cardano.Ledger.Tools (ensureMinCoinTxOut)
import Cardano.Ledger.Val
import Control.Monad.State (gets)
import Data.Foldable
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as Map
import qualified Data.OMap.Strict as OMap
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Dijkstra.Era
import Test.Cardano.Ledger.Dijkstra.Examples (exampleDijkstraGenesis)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsWithDatum, alwaysSucceedsWithDatum)

instance ShelleyEraImp DijkstraEra where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (Genesis DijkstraEra)
initGenesis = DijkstraGenesis -> m DijkstraGenesis
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DijkstraGenesis
exampleDijkstraGenesis

  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState DijkstraEra)
initNewEpochState = (NewEpochState (PreviousEra DijkstraEra)
 -> NewEpochState (PreviousEra DijkstraEra))
-> m (NewEpochState DijkstraEra)
forall era g s (m :: * -> *).
(MonadState s m, HasKeyPairs s, HasStatefulGen g m, MonadFail m,
 ShelleyEraImp era, ShelleyEraImp (PreviousEra era),
 TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState ((NewEpochState (PreviousEra DijkstraEra)
  -> NewEpochState (PreviousEra DijkstraEra))
 -> m (NewEpochState DijkstraEra))
-> (NewEpochState (PreviousEra DijkstraEra)
    -> NewEpochState (PreviousEra DijkstraEra))
-> m (NewEpochState DijkstraEra)
forall a b. (a -> b) -> a -> b
$ \NewEpochState (PreviousEra DijkstraEra)
nes ->
    NewEpochState (PreviousEra DijkstraEra)
NewEpochState ConwayEra
nes
      NewEpochState ConwayEra
-> (NewEpochState ConwayEra -> NewEpochState ConwayEra)
-> NewEpochState ConwayEra
forall a b. a -> (a -> b) -> b
& (EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState ConwayEra -> Identity (EpochState ConwayEra))
 -> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra))
-> ((StrictMaybe (Committee ConwayEra)
     -> Identity (StrictMaybe (Committee ConwayEra)))
    -> EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> Identity (StrictMaybe (Committee ConwayEra)))
-> NewEpochState ConwayEra
-> Identity (NewEpochState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState ConwayEra -> Identity (GovState ConwayEra))
-> EpochState ConwayEra -> Identity (EpochState ConwayEra)
(ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
-> EpochState ConwayEra -> Identity (EpochState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL ((ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
 -> EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> ((StrictMaybe (Committee ConwayEra)
     -> Identity (StrictMaybe (Committee ConwayEra)))
    -> ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> Identity (StrictMaybe (Committee ConwayEra)))
-> EpochState ConwayEra
-> Identity (EpochState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee ConwayEra)
 -> Identity (StrictMaybe (Committee ConwayEra)))
-> GovState ConwayEra -> Identity (GovState ConwayEra)
(StrictMaybe (Committee ConwayEra)
 -> Identity (StrictMaybe (Committee ConwayEra)))
-> ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState ConwayEra) (StrictMaybe (Committee ConwayEra))
committeeGovStateL ((StrictMaybe (Committee ConwayEra)
  -> Identity (StrictMaybe (Committee ConwayEra)))
 -> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> StrictMaybe (Committee ConwayEra))
-> NewEpochState ConwayEra
-> NewEpochState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Committee ConwayEra -> Committee ConwayEra)
-> StrictMaybe (Committee ConwayEra)
-> StrictMaybe (Committee ConwayEra)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Committee ConwayEra -> Committee ConwayEra
forall {era}. Committee era -> Committee era
updateCommitteeExpiry
    where
      updateCommitteeExpiry :: Committee era -> Committee era
updateCommitteeExpiry =
        (Map (Credential ColdCommitteeRole) EpochNo
 -> Identity (Map (Credential ColdCommitteeRole) EpochNo))
-> Committee era -> Identity (Committee era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential ColdCommitteeRole) EpochNo
 -> f (Map (Credential ColdCommitteeRole) EpochNo))
-> Committee era -> f (Committee era)
committeeMembersL
          ((Map (Credential ColdCommitteeRole) EpochNo
  -> Identity (Map (Credential ColdCommitteeRole) EpochNo))
 -> Committee era -> Identity (Committee era))
-> (Map (Credential ColdCommitteeRole) EpochNo
    -> Map (Credential ColdCommitteeRole) EpochNo)
-> Committee era
-> Committee era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (EpochNo -> EpochNo)
-> Map (Credential ColdCommitteeRole) EpochNo
-> Map (Credential ColdCommitteeRole) EpochNo
forall a b.
(a -> b)
-> Map (Credential ColdCommitteeRole) a
-> Map (Credential ColdCommitteeRole) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochNo -> EpochNo -> EpochNo
forall a b. a -> b -> a
const (EpochNo -> EpochNo -> EpochNo) -> EpochNo -> EpochNo -> EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval (forall era. Era era => EpochNo
impEraStartEpochNo @DijkstraEra) (Word32 -> EpochInterval
EpochInterval Word32
15))

  impSatisfyNativeScript :: forall (l :: TxLevel).
Set (KeyHash Witness)
-> TxBody l DijkstraEra
-> NativeScript DijkstraEra
-> ImpTestM
     DijkstraEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyNativeScript = Set (KeyHash Witness)
-> TxBody l DijkstraEra
-> NativeScript DijkstraEra
-> ImpTestM
     DijkstraEra (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
(DijkstraEraImp era,
 NativeScript era ~ DijkstraNativeScript era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impDijkstraSatisfyNativeScript

  modifyPParams :: (PParams DijkstraEra -> PParams DijkstraEra)
-> ImpTestM DijkstraEra ()
modifyPParams = (PParams DijkstraEra -> PParams DijkstraEra)
-> ImpTestM DijkstraEra ()
forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams

  fixupTx :: HasCallStack =>
Tx TopTx DijkstraEra -> ImpTestM DijkstraEra (Tx TopTx DijkstraEra)
fixupTx = Tx TopTx DijkstraEra -> ImpTestM DijkstraEra (Tx TopTx DijkstraEra)
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
dijkstraFixupTx
  expectTxSuccess :: HasCallStack => Tx TopTx DijkstraEra -> ImpTestM DijkstraEra ()
expectTxSuccess = Tx TopTx DijkstraEra -> ImpTestM DijkstraEra ()
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era ()
impBabbageExpectTxSuccess
  modifyImpInitProtVer :: ShelleyEraImp DijkstraEra =>
Version
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
modifyImpInitProtVer = Version
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall era.
ConwayEraImp era =>
Version
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
conwayModifyImpInitProtVer
  genRegTxCert :: Credential Staking -> ImpTestM DijkstraEra (TxCert DijkstraEra)
genRegTxCert = Credential Staking -> ImpTestM DijkstraEra (TxCert DijkstraEra)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
dijkstraGenRegTxCert
  genUnRegTxCert :: Credential Staking -> ImpTestM DijkstraEra (TxCert DijkstraEra)
genUnRegTxCert = Credential Staking -> ImpTestM DijkstraEra (TxCert DijkstraEra)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
dijkstraGenUnRegTxCert
  delegStakeTxCert :: Credential Staking -> KeyHash StakePool -> TxCert DijkstraEra
delegStakeTxCert = Credential Staking -> KeyHash StakePool -> TxCert DijkstraEra
forall era.
ConwayEraTxCert era =>
Credential Staking -> KeyHash StakePool -> TxCert era
conwayDelegStakeTxCert

instance AllegraEraImp DijkstraEra

instance MaryEraImp DijkstraEra

instance AlonzoEraImp DijkstraEra where
  scriptTestContexts :: Map ScriptHash ScriptTestContext
scriptTestContexts =
    SLanguage 'PlutusV1 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1
      Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV2 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV2
SPlutusV2
      Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV3 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV3
SPlutusV3
      Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV4 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV4
SPlutusV4

instance BabbageEraImp DijkstraEra

instance ConwayEraImp DijkstraEra

class
  ( ConwayEraImp era
  , DijkstraEraTest era
  , DijkstraEraForecast era
  , DijkstraEraBlockBody era
  , InjectRuleFailure "BBODY" DijkstraBbodyPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraLedgerPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraPoolPredFailure era
  , InjectRuleFailure "LEDGER" EntitiesPredFailure era
  , InjectRuleFailure "LEDGER" SubEntitiesPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraUtxowPredFailure era
  , InjectRuleFailure "MEMPOOL" DijkstraMempoolPredFailure era
  , InjectRuleFailure "MEMPOOL" DijkstraUtxoPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraSubUtxoPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraGovPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraSubGovPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraSubUtxowPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraSubDelegPredFailure era
  , InjectRuleFailure "LEDGER" DijkstraSubLedgerPredFailure era
  , Inject (NonEmpty (Conway.PredicateFailure (EraRule "MEMPOOL" era))) (ApplyTxError era)
  ) =>
  DijkstraEraImp era

instance DijkstraEraImp DijkstraEra

-- Partial implementation used for checking predicate failures
instance InjectRuleFailure "LEDGER" Shelley.ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "ENTITIES" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
EntitiesPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "ENTITIES" era)
-> DijkstraLedgerPredFailure era
DijkstraEntitiesFailure (EntitiesPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> EntitiesPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"ENTITIES"

instance InjectRuleFailure "ENTITIES" Shelley.ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "ENTITIES" DijkstraEra
injectFailure = PredicateFailure (EraRule "CERTS" DijkstraEra)
-> EntitiesPredFailure DijkstraEra
ConwayCertsPredFailure DijkstraEra
-> EntitiesPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "CERTS" era) -> EntitiesPredFailure era
CertsFailure (ConwayCertsPredFailure DijkstraEra
 -> EntitiesPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayCertsPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> EntitiesPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"CERTS"

instance InjectRuleFailure "CERTS" Shelley.ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERTS" DijkstraEra
injectFailure = PredicateFailure (EraRule "CERT" DijkstraEra)
-> ConwayCertsPredFailure DijkstraEra
ConwayCertPredFailure DijkstraEra
-> ConwayCertsPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
Conway.CertFailure (ConwayCertPredFailure DijkstraEra
 -> ConwayCertsPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayCertPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> ConwayCertsPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERT" DijkstraEra
ShelleyDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERT" Shelley.ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERT" DijkstraEra
injectFailure = PredicateFailure (EraRule "DELEG" DijkstraEra)
-> ConwayCertPredFailure DijkstraEra
ConwayDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "DELEG" era) -> ConwayCertPredFailure era
Conway.DelegFailure (ConwayDelegPredFailure DijkstraEra
 -> ConwayCertPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayDelegPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "DELEG" DijkstraEra
ShelleyDelegPredFailure DijkstraEra
-> ConwayDelegPredFailure DijkstraEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "DELEG" Shelley.ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "DELEG" DijkstraEra
injectFailure (Shelley.DelegAccountAlreadyRegistered AccountAlreadyRegistered DijkstraEra
c) = AccountAlreadyRegistered DijkstraEra
-> ConwayDelegPredFailure DijkstraEra
forall era.
AccountAlreadyRegistered era -> ConwayDelegPredFailure era
Conway.DelegAccountAlreadyRegistered AccountAlreadyRegistered DijkstraEra
c
  injectFailure (Shelley.StakeKeyNotRegisteredDELEG Credential Staking
c) = Credential Staking -> ConwayDelegPredFailure DijkstraEra
forall era. Credential Staking -> ConwayDelegPredFailure era
Conway.StakeKeyNotRegisteredDELEG Credential Staking
c
  injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG Coin
c) = Coin -> ConwayDelegPredFailure DijkstraEra
forall era. Coin -> ConwayDelegPredFailure era
Conway.StakeKeyHasNonZeroAccountBalanceDELEG Coin
c
  injectFailure ShelleyDelegPredFailure DijkstraEra
_ = [Char] -> ConwayDelegPredFailure DijkstraEra
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot inject ShelleyDelegPredFailure into DijkstraEra"

instance InjectRuleFailure "LEDGER" DijkstraSubUtxowPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxowPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGERS" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
DijkstraSubLedgersPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGERS" era)
-> DijkstraLedgerPredFailure era
DijkstraSubLedgersFailure (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubUtxowPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubUtxowPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGERS"

instance InjectRuleFailure "SUBLEDGERS" DijkstraSubUtxowPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxowPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGERS" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGER" DijkstraEra)
-> DijkstraSubLedgersPredFailure DijkstraEra
DijkstraSubLedgerPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGER" era)
-> DijkstraSubLedgersPredFailure era
SubLedgerFailure (DijkstraSubLedgerPredFailure DijkstraEra
 -> DijkstraSubLedgersPredFailure DijkstraEra)
-> (DijkstraSubUtxowPredFailure DijkstraEra
    -> DijkstraSubLedgerPredFailure DijkstraEra)
-> DijkstraSubUtxowPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGER"

instance InjectRuleFailure "LEDGER" DijkstraSubUtxoPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxoPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGERS" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
DijkstraSubLedgersPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGERS" era)
-> DijkstraLedgerPredFailure era
DijkstraSubLedgersFailure (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubUtxoPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubUtxoPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGERS"

instance InjectRuleFailure "SUBLEDGERS" DijkstraSubUtxoPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxoPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGERS" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGER" DijkstraEra)
-> DijkstraSubLedgersPredFailure DijkstraEra
DijkstraSubLedgerPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGER" era)
-> DijkstraSubLedgersPredFailure era
SubLedgerFailure (DijkstraSubLedgerPredFailure DijkstraEra
 -> DijkstraSubLedgersPredFailure DijkstraEra)
-> (DijkstraSubUtxoPredFailure DijkstraEra
    -> DijkstraSubLedgerPredFailure DijkstraEra)
-> DijkstraSubUtxoPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGER"

instance InjectRuleFailure "SUBLEDGER" DijkstraSubUtxoPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxoPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBUTXOW" DijkstraEra)
-> DijkstraSubLedgerPredFailure DijkstraEra
DijkstraSubUtxowPredFailure DijkstraEra
-> DijkstraSubLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBUTXOW" era)
-> DijkstraSubLedgerPredFailure era
SubUtxowFailure (DijkstraSubUtxowPredFailure DijkstraEra
 -> DijkstraSubLedgerPredFailure DijkstraEra)
-> (DijkstraSubUtxoPredFailure DijkstraEra
    -> DijkstraSubUtxowPredFailure DijkstraEra)
-> DijkstraSubUtxoPredFailure DijkstraEra
-> DijkstraSubLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBUTXOW"

instance InjectRuleFailure "LEDGER" DijkstraSubGovPredFailure DijkstraEra where
  injectFailure :: DijkstraSubGovPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGERS" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
DijkstraSubLedgersPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGERS" era)
-> DijkstraLedgerPredFailure era
DijkstraSubLedgersFailure (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubGovPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubGovPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGERS"

instance InjectRuleFailure "SUBLEDGERS" DijkstraSubGovPredFailure DijkstraEra where
  injectFailure :: DijkstraSubGovPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGERS" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGER" DijkstraEra)
-> DijkstraSubLedgersPredFailure DijkstraEra
DijkstraSubLedgerPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGER" era)
-> DijkstraSubLedgersPredFailure era
SubLedgerFailure (DijkstraSubLedgerPredFailure DijkstraEra
 -> DijkstraSubLedgersPredFailure DijkstraEra)
-> (DijkstraSubGovPredFailure DijkstraEra
    -> DijkstraSubLedgerPredFailure DijkstraEra)
-> DijkstraSubGovPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGER"

instance InjectRuleFailure "LEDGER" DijkstraSubDelegPredFailure DijkstraEra where
  injectFailure :: DijkstraSubDelegPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGERS" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
DijkstraSubLedgersPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGERS" era)
-> DijkstraLedgerPredFailure era
DijkstraSubLedgersFailure (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubDelegPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubDelegPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGERS"

instance InjectRuleFailure "SUBLEDGERS" DijkstraSubDelegPredFailure DijkstraEra where
  injectFailure :: DijkstraSubDelegPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGERS" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGER" DijkstraEra)
-> DijkstraSubLedgersPredFailure DijkstraEra
DijkstraSubLedgerPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGER" era)
-> DijkstraSubLedgersPredFailure era
SubLedgerFailure (DijkstraSubLedgerPredFailure DijkstraEra
 -> DijkstraSubLedgersPredFailure DijkstraEra)
-> (DijkstraSubDelegPredFailure DijkstraEra
    -> DijkstraSubLedgerPredFailure DijkstraEra)
-> DijkstraSubDelegPredFailure DijkstraEra
-> DijkstraSubLedgersPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGER"

instance InjectRuleFailure "SUBLEDGER" DijkstraSubDelegPredFailure DijkstraEra where
  injectFailure :: DijkstraSubDelegPredFailure DijkstraEra
-> EraRuleFailure "SUBLEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBENTITIES" DijkstraEra)
-> DijkstraSubLedgerPredFailure DijkstraEra
SubEntitiesPredFailure DijkstraEra
-> DijkstraSubLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBENTITIES" era)
-> DijkstraSubLedgerPredFailure era
SubEntitiesFailure (SubEntitiesPredFailure DijkstraEra
 -> DijkstraSubLedgerPredFailure DijkstraEra)
-> (DijkstraSubDelegPredFailure DijkstraEra
    -> SubEntitiesPredFailure DijkstraEra)
-> DijkstraSubDelegPredFailure DijkstraEra
-> DijkstraSubLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBENTITIES"

instance InjectRuleFailure "SUBENTITIES" DijkstraSubDelegPredFailure DijkstraEra where
  injectFailure :: DijkstraSubDelegPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBCERTS" DijkstraEra)
-> SubEntitiesPredFailure DijkstraEra
DijkstraSubCertsPredFailure DijkstraEra
-> SubEntitiesPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure (DijkstraSubCertsPredFailure DijkstraEra
 -> SubEntitiesPredFailure DijkstraEra)
-> (DijkstraSubDelegPredFailure DijkstraEra
    -> DijkstraSubCertsPredFailure DijkstraEra)
-> DijkstraSubDelegPredFailure DijkstraEra
-> SubEntitiesPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBCERTS"

instance InjectRuleFailure "SUBCERTS" DijkstraSubDelegPredFailure DijkstraEra where
  injectFailure :: DijkstraSubDelegPredFailure DijkstraEra
-> EraRuleFailure "SUBCERTS" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBCERT" DijkstraEra)
-> DijkstraSubCertsPredFailure DijkstraEra
DijkstraSubCertPredFailure DijkstraEra
-> DijkstraSubCertsPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBCERT" era)
-> DijkstraSubCertsPredFailure era
SubCertFailure (DijkstraSubCertPredFailure DijkstraEra
 -> DijkstraSubCertsPredFailure DijkstraEra)
-> (DijkstraSubDelegPredFailure DijkstraEra
    -> DijkstraSubCertPredFailure DijkstraEra)
-> DijkstraSubDelegPredFailure DijkstraEra
-> DijkstraSubCertsPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBCERT"

instance InjectRuleFailure "LEDGER" DijkstraSubLedgerPredFailure DijkstraEra where
  injectFailure :: DijkstraSubLedgerPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBLEDGERS" DijkstraEra)
-> DijkstraLedgerPredFailure DijkstraEra
DijkstraSubLedgersPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBLEDGERS" era)
-> DijkstraLedgerPredFailure era
DijkstraSubLedgersFailure (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubLedgerPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubLedgerPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBLEDGERS"

-- | A top level transaction that nests the given sub-transactions and
-- is otherwise empty.
mkTopTxWithSubTxs :: DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs :: forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Tx SubTx era]
subTxs =
  TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OMap TxId (Tx SubTx era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx SubTx era] -> OMap TxId (Tx SubTx era)
forall (f :: * -> *) k v.
(Foldable f, HasOKey k v) =>
f v -> OMap k v
OMap.fromFoldable [Tx SubTx era]
subTxs

mkTopTxWithDistinctSubTxs :: DijkstraEraImp era => [Tx SubTx era] -> ImpTestM era (Tx TopTx era)
mkTopTxWithDistinctSubTxs :: forall era.
DijkstraEraImp era =>
[Tx SubTx era] -> ImpTestM era (Tx TopTx era)
mkTopTxWithDistinctSubTxs [Tx SubTx era]
subTxs = [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs ([Tx SubTx era] -> Tx TopTx era)
-> ImpM (LedgerSpec era) [Tx SubTx era]
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tx SubTx era] -> ImpM (LedgerSpec era) [Tx SubTx era]
forall era.
DijkstraEraImp era =>
[Tx SubTx era] -> ImpTestM era [Tx SubTx era]
distinctSubTxs [Tx SubTx era]
subTxs

-- | Give each sub-transaction a fresh input, so that otherwise identical
-- sub-transactions get distinct transaction ids
distinctSubTxs :: DijkstraEraImp era => [Tx SubTx era] -> ImpTestM era [Tx SubTx era]
distinctSubTxs :: forall era.
DijkstraEraImp era =>
[Tx SubTx era] -> ImpTestM era [Tx SubTx era]
distinctSubTxs = (Tx SubTx era -> ImpM (LedgerSpec era) (Tx SubTx era))
-> [Tx SubTx era] -> ImpM (LedgerSpec era) [Tx SubTx era]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tx SubTx era -> ImpM (LedgerSpec era) (Tx SubTx era)
forall {era} {era} {l :: TxLevel}.
(Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era), EraTx era,
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era)) =>
Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addFreshInput
  where
    addFreshInput :: Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addFreshInput Tx l era
subTx = do
      input <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      pure $ subTx & bodyTxL . inputsTxBodyL <>~ [input]

-- | Apply an effectful modification to every sub-transaction of a top
-- level transaction.
--
-- Sub-transactions are keyed by their transaction id, so a modification
-- that makes two of them equal keeps only the first.
traverseSubTxs ::
  ( Applicative m
  , EraTx era
  , DijkstraEraTxBody era
  ) =>
  (Tx SubTx era -> m (Tx SubTx era)) ->
  Tx TopTx era ->
  m (Tx TopTx era)
traverseSubTxs :: forall (m :: * -> *) era.
(Applicative m, EraTx era, DijkstraEraTxBody era) =>
(Tx SubTx era -> m (Tx SubTx era))
-> Tx TopTx era -> m (Tx TopTx era)
traverseSubTxs Tx SubTx era -> m (Tx SubTx era)
f Tx TopTx era
tx =
  [Tx SubTx era] -> Tx TopTx era
replaceSubTxs ([Tx SubTx era] -> Tx TopTx era)
-> m [Tx SubTx era] -> m (Tx TopTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tx SubTx era -> m (Tx SubTx era))
-> [Tx SubTx era] -> m [Tx SubTx era]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tx SubTx era -> m (Tx SubTx era)
f (OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (Tx TopTx era
tx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL))
  where
    replaceSubTxs :: [Tx SubTx era] -> Tx TopTx era
replaceSubTxs [Tx SubTx era]
subTxs =
      Tx TopTx era
tx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OMap TxId (Tx SubTx era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx SubTx era] -> OMap TxId (Tx SubTx era)
forall (f :: * -> *) k v.
(Foldable f, HasOKey k v) =>
f v -> OMap k v
OMap.fromFoldable [Tx SubTx era]
subTxs

-- | Apply a modification to every sub-transaction, after the given
-- fixup `f` has run, in order to provoke a failure that `f` otherwise
-- repairs.
--
-- The top level transaction is signed again afterwards, since
-- sub-transactions are part of its body and modifying one invalidates
-- its witnesses.
withPostFixupSubTxs ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  (Tx SubTx era -> ImpTestM era (Tx SubTx era)) ->
  ImpTestM era a ->
  ImpTestM era a
withPostFixupSubTxs :: forall era a.
(HasCallStack, DijkstraEraImp era) =>
(Tx SubTx era -> ImpTestM era (Tx SubTx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixupSubTxs Tx SubTx era -> ImpTestM era (Tx SubTx era)
f = (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
forall era a.
(Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup ((Tx TopTx era -> ImpTestM era (Tx TopTx era))
 -> ImpTestM era a -> ImpTestM era a)
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era a
-> ImpTestM era a
forall a b. (a -> b) -> a -> b
$ (Tx SubTx era -> ImpTestM era (Tx SubTx era))
-> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) era.
(Applicative m, EraTx era, DijkstraEraTxBody era) =>
(Tx SubTx era -> m (Tx SubTx era))
-> Tx TopTx era -> m (Tx TopTx era)
traverseSubTxs Tx SubTx era -> ImpTestM era (Tx SubTx era)
f (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> Tx TopTx era
-> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
rederiveAddrTxWits

-- | Submit a sub-transaction, nested in an otherwise empty top level
-- transaction, that is expected to be rejected with exactly the given
-- predicate failures.
submitFailingSubTx ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  Tx SubTx era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingSubTx :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx SubTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingSubTx Tx SubTx era
subTx = Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx (Tx TopTx era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
 -> ImpTestM era ())
-> Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs [Item [Tx SubTx era]
Tx SubTx era
subTx]

-- | Submit a transaction through the mempool that is expected to be rejected
-- with exactly the given predicate failures.
submitFailingMempoolTx ::
  (HasCallStack, DijkstraEraImp era) =>
  Tx TopTx era ->
  NonEmpty (DijkstraMempoolPredFailure era) ->
  ImpTestM era ()
submitFailingMempoolTx :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era
-> NonEmpty (DijkstraMempoolPredFailure era) -> ImpTestM era ()
submitFailingMempoolTx Tx TopTx era
tx NonEmpty (DijkstraMempoolPredFailure era)
expectedFailures = do
  result <- Tx TopTx era
-> ImpTestM
     era (Either (ApplyTxError era) (MempoolState era, ValidatedTx era))
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> ImpTestM
     era (Either (ApplyTxError era) (MempoolState era, ValidatedTx era))
trySubmitMempoolTx Tx TopTx era
tx
  expectMempoolRejection result expectedFailures

-- | Expect the result of a mempool submission to be a rejection with exactly
-- the given predicate failures.
expectMempoolRejection ::
  (HasCallStack, DijkstraEraImp era) =>
  Either (ApplyTxError era) a ->
  NonEmpty (DijkstraMempoolPredFailure era) ->
  ImpTestM era ()
expectMempoolRejection :: forall era a.
(HasCallStack, DijkstraEraImp era) =>
Either (ApplyTxError era) a
-> NonEmpty (DijkstraMempoolPredFailure era) -> ImpTestM era ()
expectMempoolRejection Either (ApplyTxError era) a
result NonEmpty (DijkstraMempoolPredFailure era)
expectedFailures = case Either (ApplyTxError era) a
result of
  Left ApplyTxError era
applyTxError ->
    ApplyTxError era
applyTxError ApplyTxError era -> ApplyTxError era -> ImpTestM era ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` NonEmpty (EraRuleFailure "MEMPOOL" era) -> ApplyTxError era
forall t s. Inject t s => t -> s
inject (forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"MEMPOOL" (DijkstraMempoolPredFailure era -> EraRuleFailure "MEMPOOL" era)
-> NonEmpty (DijkstraMempoolPredFailure era)
-> NonEmpty (EraRuleFailure "MEMPOOL" era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (DijkstraMempoolPredFailure era)
expectedFailures)
  Right a
_ ->
    [Char] -> ImpTestM era ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
assertFailure ([Char] -> ImpTestM era ()) -> [Char] -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a mempool rejection with: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> NonEmpty (DijkstraMempoolPredFailure era) -> [Char]
forall a. Show a => a -> [Char]
show NonEmpty (DijkstraMempoolPredFailure era)
expectedFailures

-- | A sub-transaction that casts a single vote.
voteSubTx :: DijkstraEraImp era => Vote -> Voter -> GovActionId -> Tx SubTx era
voteSubTx :: forall era.
DijkstraEraImp era =>
Vote -> Voter -> GovActionId -> Tx SubTx era
voteSubTx Vote
vote Voter
voter GovActionId
govActionId =
  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$
    TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
      TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
        ((VotingProcedures era -> Identity (VotingProcedures era))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> VotingProcedures era -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
          ( Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton Voter
voter (Map GovActionId (VotingProcedure era)
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> (VotingProcedure era -> Map GovActionId (VotingProcedure era))
-> VotingProcedure era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
govActionId (VotingProcedure era
 -> Map Voter (Map GovActionId (VotingProcedure era)))
-> VotingProcedure era
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$
              VotingProcedure {vProcVote :: Vote
vProcVote = Vote
vote, vProcAnchor :: StrictMaybe Anchor
vProcAnchor = StrictMaybe Anchor
forall a. StrictMaybe a
SNothing}
          )

-- | A sub-transaction that declares the given value as the current treasury value.
declareTreasurySubTx :: DijkstraEraImp era => Coin -> Tx SubTx era
declareTreasurySubTx :: forall era. DijkstraEraImp era => Coin -> Tx SubTx era
declareTreasurySubTx Coin
declaredTreasury =
  TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Coin)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe Coin -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
declaredTreasury

impDijkstraSatisfyNativeScript ::
  ( DijkstraEraImp era
  , NativeScript era ~ DijkstraNativeScript era
  ) =>
  Set.Set (KeyHash Witness) ->
  TxBody l era ->
  NativeScript era ->
  ImpTestM era (Maybe (Map.Map (KeyHash Witness) (KeyPair Witness)))
impDijkstraSatisfyNativeScript :: forall era (l :: TxLevel).
(DijkstraEraImp era,
 NativeScript era ~ DijkstraNativeScript era) =>
Set (KeyHash Witness)
-> TxBody l era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impDijkstraSatisfyNativeScript Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody NativeScript era
script = do
  let vi :: ValidityInterval
vi = TxBody l era
txBody TxBody l era
-> Getting ValidityInterval (TxBody l era) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. Getting ValidityInterval (TxBody l era) ValidityInterval
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL
  let guards :: OSet (Credential Guard)
guards = TxBody l era
txBody TxBody l era
-> Getting
     (OSet (Credential Guard)) (TxBody l era) (OSet (Credential Guard))
-> OSet (Credential Guard)
forall s a. s -> Getting a s a -> a
^. Getting
  (OSet (Credential Guard)) (TxBody l era) (OSet (Credential Guard))
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL
  case NativeScript era
script of
    RequireSignature KeyHash Witness
keyHash -> KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era.
KeyHash Witness
-> Set (KeyHash Witness)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfySignature KeyHash Witness
keyHash Set (KeyHash Witness)
providedVKeyHashes
    RequireAllOf StrictSeq (NativeScript era)
ss -> Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody (StrictSeq (DijkstraNativeScript era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript era)
StrictSeq (DijkstraNativeScript era)
ss) StrictSeq (NativeScript era)
ss
    RequireAnyOf StrictSeq (NativeScript era)
ss -> do
      m <- [(Int, ImpM (LedgerSpec era) Int)] -> ImpM (LedgerSpec era) Int
forall (m :: * -> *) a. MonadGen m => [(Int, m a)] -> m a
frequency [(Int
9, Int -> ImpM (LedgerSpec era) Int
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1), (Int
1, (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, StrictSeq (DijkstraNativeScript era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (NativeScript era)
StrictSeq (DijkstraNativeScript era)
ss))]
      impSatisfyMNativeScripts providedVKeyHashes txBody m ss
    RequireMOf Int
m StrictSeq (NativeScript era)
ss -> Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall era (l :: TxLevel).
ShelleyEraImp era =>
Set (KeyHash Witness)
-> TxBody l era
-> Int
-> StrictSeq (NativeScript era)
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
impSatisfyMNativeScripts Set (KeyHash Witness)
providedVKeyHashes TxBody l era
txBody Int
m StrictSeq (NativeScript era)
ss
    lock :: NativeScript era
lock@(RequireTimeStart SlotNo
_)
      | Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
forall era.
(DijkstraEraScript era,
 NativeScript era ~ DijkstraNativeScript era) =>
Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
evalDijkstraNativeScript Set (KeyHash Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi OSet (Credential Guard)
guards NativeScript era
lock -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      | Bool
otherwise -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    lock :: NativeScript era
lock@(RequireTimeExpire SlotNo
_)
      | Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
forall era.
(DijkstraEraScript era,
 NativeScript era ~ DijkstraNativeScript era) =>
Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
evalDijkstraNativeScript Set (KeyHash Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi OSet (Credential Guard)
guards NativeScript era
lock -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      | Bool
otherwise -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    -- TODO: actual satisfy the native scripts by updating the transaction's guards
    ns :: NativeScript era
ns@(RequireGuard Credential Guard
_)
      | Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
forall era.
(DijkstraEraScript era,
 NativeScript era ~ DijkstraNativeScript era) =>
Set (KeyHash Witness)
-> ValidityInterval
-> OSet (Credential Guard)
-> NativeScript era
-> Bool
evalDijkstraNativeScript Set (KeyHash Witness)
forall a. Monoid a => a
mempty ValidityInterval
vi OSet (Credential Guard)
guards NativeScript era
ns -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Map (KeyHash Witness) (KeyPair Witness))
 -> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness))))
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a b. (a -> b) -> a -> b
$ Map (KeyHash Witness) (KeyPair Witness)
-> Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. a -> Maybe a
Just Map (KeyHash Witness) (KeyPair Witness)
forall a. Monoid a => a
mempty
      | Bool
otherwise -> Maybe (Map (KeyHash Witness) (KeyPair Witness))
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map (KeyHash Witness) (KeyPair Witness))
forall a. Maybe a
Nothing
    NativeScript era
_ -> [Char]
-> ImpTestM era (Maybe (Map (KeyHash Witness) (KeyPair Witness)))
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: All NativeScripts should have been accounted for"

dijkstraGenRegTxCert ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential Staking ->
  ImpTestM era (TxCert era)
dijkstraGenRegTxCert :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
dijkstraGenRegTxCert Credential Staking
stakingCredential =
  Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert Credential Staking
stakingCredential
    (Coin -> TxCert era)
-> ImpM (LedgerSpec era) Coin -> ImpM (LedgerSpec era) (TxCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)

dijkstraGenUnRegTxCert ::
  forall era.
  ( ShelleyEraImp era
  , ConwayEraTxCert era
  ) =>
  Credential Staking ->
  ImpTestM era (TxCert era)
dijkstraGenUnRegTxCert :: forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential Staking -> ImpTestM era (TxCert era)
dijkstraGenUnRegTxCert Credential Staking
stakingCredential = do
  accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  deposit <- case lookupAccountState stakingCredential accounts of
    Maybe (AccountState era)
Nothing -> SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
 -> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
    Just AccountState era
accountState -> Coin -> ImpM (LedgerSpec era) Coin
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState 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)
depositAccountStateL))
  pure $ UnRegDepositTxCert stakingCredential deposit

switchTxToLegacyMode ::
  DijkstraEraImp era =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
switchTxToLegacyMode :: forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToLegacyMode Tx TopTx era
tx = do
  txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus 'PlutusV3 -> ScriptHash)
-> Plutus 'PlutusV3
-> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ImpTestM era TxIn)
-> Plutus 'PlutusV3 -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage 'PlutusV3
SPlutusV3
  pure $ tx & bodyTxL . inputsTxBodyL <>~ [txIn]

switchTxToPhase2InvalidLegacyMode ::
  DijkstraEraImp era =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
switchTxToPhase2InvalidLegacyMode :: forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
switchTxToPhase2InvalidLegacyMode Tx TopTx era
tx = do
  txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (ScriptHash -> ImpTestM era TxIn)
-> (Plutus 'PlutusV3 -> ScriptHash)
-> Plutus 'PlutusV3
-> ImpTestM era TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ImpTestM era TxIn)
-> Plutus 'PlutusV3 -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage 'PlutusV3
SPlutusV3
  pure $ tx & bodyTxL . inputsTxBodyL <>~ [txIn]

dijkstraFixupTx ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
dijkstraFixupTx :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
dijkstraFixupTx Tx TopTx era
tx = do
  -- add top-level Plutus script witnesses so legacy detection sees them
  fixedUp <- Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInputForSubTxs (Tx TopTx era -> ImpTestM era (Tx TopTx era))
-> ImpTestM era (Tx TopTx era) -> ImpTestM era (Tx TopTx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tx TopTx era -> ImpTestM era (Tx TopTx era)
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupSubTransactions Tx TopTx era
tx
  isLegacy <- detectLegacyMode fixedUp
  balancedInLegacy <- if isLegacy then balanceSubTransactions fixedUp else pure fixedUp
  babbageFixupTx balancedInLegacy

detectLegacyMode ::
  DijkstraEraImp era =>
  Tx TopTx era ->
  ImpTestM era Bool
detectLegacyMode :: forall era. DijkstraEraImp era => Tx TopTx era -> ImpTestM era Bool
detectLegacyMode Tx TopTx era
tx = do
  Globals {systemStart, epochInfo} <- (ImpTestState era -> Globals) -> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ImpTestState era
-> Getting Globals (ImpTestState era) Globals -> Globals
forall s a. s -> Getting a s a -> a
^. Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL)
  pp <- getsNES $ nesEsL . curPParamsEpochStateL
  utxo <- getUTxO
  let stAnnTx = EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> StAnnTxCache era
-> Tx TopTx era
-> StAnnTx TopTx era
forall era.
ApplyTx era =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> StAnnTxCache era
-> Tx TopTx era
-> StAnnTx TopTx era
mkStAnnTx EpochInfo (Either Text)
epochInfo SystemStart
systemStart PParams era
pp UTxO era
utxo StAnnTxCache era
forall a. Monoid a => a
mempty Tx TopTx era
tx
  pure $ stAnnTx ^. plutusLegacyModeStAnnTxG

-- | Add a collateral input to the top-level transaction when a
-- sub-transaction needs a Plutus script.
--
-- Collateral is validated across the whole batch but the inherited
-- `addCollateralInput` step only inspects the top-level transaction's
-- own script needs. This step covers the sub-transactions. Both skip
-- when a collateral input is already present, so at most one collateral
-- input is added for the whole batch, and neither step overrides
-- collateral that a test set itself.
addCollateralInputForSubTxs ::
  DijkstraEraImp era =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
addCollateralInputForSubTxs :: forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
addCollateralInputForSubTxs Tx TopTx era
tx
  | Bool -> Bool
not (Set TxIn -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Tx TopTx era
tx Tx TopTx era
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
 -> Tx TopTx era -> Const (Set TxIn) (Tx TopTx era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era))
-> Getting (Set TxIn) (Tx TopTx era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody TopTx era -> Const (Set TxIn) (TxBody TopTx era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody TopTx era) (Set TxIn)
Lens' (TxBody TopTx era) (Set TxIn)
collateralInputsTxBodyL)) = Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx TopTx era
tx
  | Bool
otherwise = do
      subTxContexts <-
        (Tx SubTx era
 -> ImpM
      (LedgerSpec era)
      [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)])
-> [Tx SubTx era]
-> ImpM
     (LedgerSpec era)
     [[(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Tx SubTx era
-> ImpM
     (LedgerSpec era)
     [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era
-> ImpTestM
     era [(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]
impGetPlutusContexts ([Tx SubTx era]
 -> ImpM
      (LedgerSpec era)
      [[(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]])
-> (OMap TxId (Tx SubTx era) -> [Tx SubTx era])
-> OMap TxId (Tx SubTx era)
-> ImpM
     (LedgerSpec era)
     [[(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (OMap TxId (Tx SubTx era)
 -> ImpM
      (LedgerSpec era)
      [[(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]])
-> OMap TxId (Tx SubTx era)
-> ImpM
     (LedgerSpec era)
     [[(PlutusPurpose AsIxItem era, ScriptHash, ScriptTestContext)]]
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
tx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL
      if all null subTxContexts
        then pure tx
        else impAnn "addCollateralInputForSubTxs" $ do
          collateralInput <- makeCollateralInput
          pure $ tx & bodyTxL . collateralInputsTxBodyL %~ Set.insert collateralInput

fixupSubTransactions ::
  ( HasCallStack
  , DijkstraEraImp era
  ) =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
fixupSubTransactions :: forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
fixupSubTransactions Tx TopTx era
tx = [Char]
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a t. NFData a => [Char] -> ImpM t a -> ImpM t a
impAnn [Char]
"fixupSubTransactions" (ImpM (LedgerSpec era) (Tx TopTx era)
 -> ImpM (LedgerSpec era) (Tx TopTx era))
-> ImpM (LedgerSpec era) (Tx TopTx era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ do
  fixedup <-
    (Tx SubTx era -> ImpM (LedgerSpec era) (Tx SubTx era))
-> [Tx SubTx era] -> ImpM (LedgerSpec era) [Tx SubTx era]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
      Tx SubTx era -> ImpM (LedgerSpec era) (Tx SubTx era)
forall {l :: TxLevel}. Tx l era -> ImpM (LedgerSpec era) (Tx l era)
fixupSubTransaction
      (OMap TxId (Tx SubTx era) -> [Tx SubTx era]
forall k v. Ord k => OMap k v -> [v]
OMap.elems (Tx TopTx era
tx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL))
  pure $ tx & bodyTxL . subTransactionsTxBodyL .~ OMap.fromFoldable fixedup
  where
    fixupSubTransaction :: Tx l era -> ImpM (LedgerSpec era) (Tx l era)
fixupSubTransaction =
      Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall {era} {era} {l :: TxLevel}.
(PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era), EraTx era,
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era)) =>
Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addSubTxIn
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
ShelleyEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
addNativeScriptTxWits
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (m :: * -> *) (l :: TxLevel).
(EraTx era, Applicative m) =>
Tx l era -> m (Tx l era)
fixupAuxDataHash
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupScriptWits
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupOutputDatums
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, AlonzoEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
fixupDatums
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(ShelleyEraImp era, HasCallStack) =>
Tx l era -> ImpTestM era (Tx l era)
fixupTxOuts
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall {era} {l :: TxLevel}.
(PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AlonzoEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era)) =>
Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addMissingRedeemers
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
fixupPPHash
        (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> (Tx l era -> ImpM (LedgerSpec era) (Tx l era))
-> Tx l era
-> ImpM (LedgerSpec era) (Tx l era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits
    addMissingRedeemers :: Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addMissingRedeemers Tx l era
subTx = do
      let originalRedeemers :: Redeemers era
originalRedeemers = Tx l era
subTx Tx l era
-> Getting (Redeemers era) (Tx l era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Redeemers era) (TxWits era))
-> Tx l era -> Const (Redeemers era) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Redeemers era) (TxWits era))
 -> Tx l era -> Const (Redeemers era) (Tx l era))
-> ((Redeemers era -> Const (Redeemers era) (Redeemers era))
    -> TxWits era -> Const (Redeemers era) (TxWits era))
-> Getting (Redeemers era) (Tx l era) (Redeemers era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Const (Redeemers era) (Redeemers era))
-> TxWits era -> Const (Redeemers era) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
      withMaxRedeemers <- Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall era (l :: TxLevel).
AlonzoEraImp era =>
Tx l era -> ImpTestM era (Tx l era)
txWithMaxRedeemers Tx l era
subTx
      pure $ withMaxRedeemers & witsTxL . rdmrsTxWitsL %~ (originalRedeemers <>)
    addSubTxIn :: Tx l era -> ImpM (LedgerSpec era) (Tx l era)
addSubTxIn Tx l era
subTx
      | Bool -> Bool
not (Set TxIn -> Bool
forall a. Set a -> Bool
Set.null (Tx l era
subTx Tx l era -> Getting (Set TxIn) (Tx l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody l era -> Const (Set TxIn) (TxBody l era))
-> Tx l era -> Const (Set TxIn) (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Const (Set TxIn) (TxBody l era))
 -> Tx l era -> Const (Set TxIn) (Tx l era))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody l era -> Const (Set TxIn) (TxBody l era))
-> Getting (Set TxIn) (Tx l era) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody l era -> Const (Set TxIn) (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL)) = Tx l era -> ImpM (LedgerSpec era) (Tx l era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx l era
subTx
      | Bool
otherwise = do
          addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddrNoPtr_
          -- restore default fixup behaviour temporarily,
          -- to make sure it isn't affected by any higher-level fixup modifications
          newTxIn <- withFixup fixupTx $ sendCoinTo addr (Coin 1_000_000)
          pure $ subTx & bodyTxL . inputsTxBodyL .~ Set.singleton newTxIn

balanceSubTransactions ::
  DijkstraEraImp era =>
  Tx TopTx era ->
  ImpTestM era (Tx TopTx era)
balanceSubTransactions :: forall era.
DijkstraEraImp era =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
balanceSubTransactions Tx TopTx era
topTx = do
  pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  pools <- Map.keysSet <$> getsNES (nesEsL . epochStateStakePoolsL)
  utxo <- getUTxO
  let
    subTransactions = Tx TopTx era
topTx Tx TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era
 -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era
  -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
 -> Tx TopTx era -> Const (OMap TxId (Tx SubTx era)) (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era
    -> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era))
-> Getting
     (OMap TxId (Tx SubTx era))
     (Tx TopTx era)
     (OMap TxId (Tx SubTx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era)
 -> Const (OMap TxId (Tx SubTx era)) (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era
-> Const (OMap TxId (Tx SubTx era)) (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL
    subsCerts = (Tx SubTx era -> StrictSeq (TxCert era))
-> OMap TxId (Tx SubTx era) -> StrictSeq (TxCert era)
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (Tx SubTx era
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Tx SubTx era -> Const (StrictSeq (TxCert era)) (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era
  -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
 -> Tx SubTx era -> Const (StrictSeq (TxCert era)) (Tx SubTx era))
-> ((StrictSeq (TxCert era)
     -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
    -> TxBody SubTx era
    -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era)
 -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
-> TxBody SubTx era
-> Const (StrictSeq (TxCert era)) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL) OMap TxId (Tx SubTx era)
subTransactions
    subsConsumed = MaryValue -> Coin
forall t. Val t => t -> Coin
coin (MaryValue -> Coin) -> MaryValue -> Coin
forall a b. (a -> b) -> a -> b
$ (Tx SubTx era -> MaryValue)
-> OMap TxId (Tx SubTx era) -> MaryValue
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (PParams era -> UTxO era -> TxBody SubTx era -> Value era
forall era (l :: TxLevel).
EraUTxO era =>
PParams era -> UTxO era -> TxBody l era -> Value era
dijkstraConsumed PParams era
pp UTxO era
utxo (TxBody SubTx era -> MaryValue)
-> (Tx SubTx era -> TxBody SubTx era) -> Tx SubTx era -> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx SubTx era
-> Getting (TxBody SubTx era) (Tx SubTx era) (TxBody SubTx era)
-> TxBody SubTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody SubTx era) (Tx SubTx era) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL)) OMap TxId (Tx SubTx era)
subTransactions
    subsProduced =
      (Tx SubTx era -> Coin) -> OMap TxId (Tx SubTx era) -> Coin
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (MaryValue -> Coin
forall t. Val t => t -> Coin
coin (MaryValue -> Coin)
-> (Tx SubTx era -> MaryValue) -> Tx SubTx era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams era -> TxBody SubTx era -> MaryValue
forall era (l :: TxLevel).
(DijkstraEraTxBody era, Value era ~ MaryValue) =>
PParams era -> TxBody l era -> MaryValue
localProducedValue PParams era
pp (TxBody SubTx era -> MaryValue)
-> (Tx SubTx era -> TxBody SubTx era) -> Tx SubTx era -> MaryValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx SubTx era
-> Getting (TxBody SubTx era) (Tx SubTx era) (TxBody SubTx era)
-> TxBody SubTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody SubTx era) (Tx SubTx era) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL)) OMap TxId (Tx SubTx era)
subTransactions
        Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> PParams era
-> (KeyHash StakePool -> Bool) -> StrictSeq (TxCert era) -> Coin
forall era (f :: * -> *).
(EraTxCert era, Foldable f) =>
PParams era
-> (KeyHash StakePool -> Bool) -> f (TxCert era) -> Coin
forall (f :: * -> *).
Foldable f =>
PParams era
-> (KeyHash StakePool -> Bool) -> f (TxCert era) -> Coin
getTotalDepositsTxCerts PParams era
pp (KeyHash StakePool -> Set (KeyHash StakePool) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash StakePool)
pools) StrictSeq (TxCert era)
subsCerts
  balancer <- mkBalancerSubTx subsConsumed subsProduced
  case balancer of
    Maybe (Tx SubTx era)
Nothing -> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx TopTx era
topTx
    Just Tx SubTx era
b -> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era))
-> Tx TopTx era -> ImpM (LedgerSpec era) (Tx TopTx era)
forall a b. (a -> b) -> a -> b
$ Tx TopTx era
topTx Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> (OMap TxId (Tx SubTx era) -> OMap TxId (Tx SubTx era))
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (OMap TxId (Tx SubTx era)
-> Tx SubTx era -> OMap TxId (Tx SubTx era)
forall k v. HasOKey k v => OMap k v -> v -> OMap k v
OMap.|> Tx SubTx era
b)

mkBalancerSubTx ::
  DijkstraEraImp era =>
  -- | Cumulated consumed value by all sub-transactions
  Coin ->
  -- | Cumulated produced value by all sub-transactions
  Coin ->
  ImpTestM era (Maybe (Tx SubTx era))
mkBalancerSubTx :: forall era.
DijkstraEraImp era =>
Coin -> Coin -> ImpTestM era (Maybe (Tx SubTx era))
mkBalancerSubTx Coin
consumed Coin
produced = do
  pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
 -> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
    -> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  case consumed `compare` produced of
    Ordering
EQ -> Maybe (Tx SubTx era)
-> ImpM (LedgerSpec era) (Maybe (Tx SubTx era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Tx SubTx era)
forall a. Maybe a
Nothing
    Ordering
ord -> do
      addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddrNoPtr_
      let
        (surplus, shortfall) = case ord of
          Ordering
GT -> (Coin
consumed Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
produced, Coin
forall a. Monoid a => a
mempty)
          Ordering
LT -> (Coin
forall a. Monoid a => a
mempty, Coin
produced Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
consumed)
        -- a buffer to make both the input UTxO and the change output satisfy minCoin. It's added on both sides, so it cancels out.
        minChangeCoin = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty) TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
        inputCoin = Coin
minChangeCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
shortfall
        changeCoin = Coin
minChangeCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
surplus
        changeOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
changeCoin)
      newTxIn <- withFixup fixupTx $ sendCoinTo addr inputCoin
      let subTx =
            TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
newTxIn]
              Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictSeq (TxOut era) -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
changeOut]
      Just <$> updateAddrTxWits subTx