{-# 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,
) 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 (..), committeeMembersL)
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential
import Cardano.Ledger.Dijkstra (ApplyTxError, DijkstraEra)
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 (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 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
  , InjectRuleFailure "LEDGER" DijkstraLedgerPredFailure 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
  , 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" DijkstraSubUtxoPredFailure DijkstraEra where
  injectFailure :: DijkstraSubUtxoPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure =
    forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"LEDGER" @DijkstraSubLedgersPredFailure
      (DijkstraSubLedgersPredFailure DijkstraEra
 -> DijkstraLedgerPredFailure DijkstraEra)
-> (DijkstraSubUtxoPredFailure DijkstraEra
    -> DijkstraSubLedgersPredFailure DijkstraEra)
-> DijkstraSubUtxoPredFailure DijkstraEra
-> DijkstraLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
. 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
. PredicateFailure (EraRule "SUBUTXO" DijkstraEra)
-> DijkstraSubUtxowPredFailure DijkstraEra
DijkstraSubUtxoPredFailure DijkstraEra
-> DijkstraSubUtxowPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBUTXO" era)
-> DijkstraSubUtxowPredFailure era
SubUtxoFailure

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]

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.
(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

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}.
(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 MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (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).
(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).
(HasCallStack, ShelleyEraImp era) =>
Tx l era -> ImpTestM era (Tx l era)
updateAddrTxWits
    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
freshKeyAddr_
          -- 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 . esLStateL . lsCertStateL . certPStateL . psStakePoolsL)
  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
freshKeyAddr_
      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