{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Dijkstra.ImpTest (
  module Test.Cardano.Ledger.Conway.ImpTest,
  exampleDijkstraGenesis,
  DijkstraEraImp,
  impDijkstraSatisfyNativeScript,
) where

import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Compactible
import Cardano.Ledger.Conway.Governance (ConwayEraGov (..), committeeMembersL)
import Cardano.Ledger.Conway.Rules (
  ConwayCertPredFailure (..),
  ConwayCertsPredFailure (..),
  ConwayDelegPredFailure (..),
  PredicateFailure,
 )
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential
import Cardano.Ledger.Dijkstra (ApplyTxError, DijkstraEra)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..))
import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams (..))
import Cardano.Ledger.Dijkstra.Rules (
  DijkstraLedgerPredFailure (..),
  DijkstraMempoolPredFailure,
  DijkstraUtxoPredFailure,
 )
import Cardano.Ledger.Dijkstra.Scripts (
  DijkstraNativeScript,
  evalDijkstraNativeScript,
  pattern RequireGuard,
 )
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..))
import Cardano.Ledger.Plutus (SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
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 Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
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.Imp.Common

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, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx TopTx era -> ImpTestM era (Tx TopTx era)
babbageFixupTx
  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

instance BabbageEraImp DijkstraEra

instance ConwayEraImp DijkstraEra

class
  ( ConwayEraImp era
  , DijkstraEraTest era
  , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era
  , InjectRuleFailure "MEMPOOL" DijkstraMempoolPredFailure era
  , InjectRuleFailure "MEMPOOL" DijkstraUtxoPredFailure era
  , Inject (NonEmpty (PredicateFailure (EraRule "MEMPOOL" era))) (ApplyTxError era)
  ) =>
  DijkstraEraImp era

instance DijkstraEraImp DijkstraEra

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

instance InjectRuleFailure "CERTS" 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
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" 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
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" ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "DELEG" DijkstraEra
injectFailure (Shelley.StakeKeyAlreadyRegisteredDELEG Credential Staking
c) = Credential Staking -> ConwayDelegPredFailure DijkstraEra
forall era. Credential Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential Staking
c
  injectFailure (Shelley.StakeKeyNotRegisteredDELEG Credential Staking
c) = Credential Staking -> ConwayDelegPredFailure DijkstraEra
forall era. Credential Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential Staking
c
  injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG Coin
c) = Coin -> ConwayDelegPredFailure DijkstraEra
forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
c
  injectFailure ShelleyDelegPredFailure DijkstraEra
_ = [Char] -> ConwayDelegPredFailure DijkstraEra
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot inject ShelleyDelegPredFailure into DijkstraEra"

exampleDijkstraGenesis :: DijkstraGenesis
exampleDijkstraGenesis :: DijkstraGenesis
exampleDijkstraGenesis =
  DijkstraGenesis
    { dgUpgradePParams :: UpgradeDijkstraPParams Identity DijkstraEra
dgUpgradePParams =
        UpgradeDijkstraPParams
          { udppMaxRefScriptSizePerBlock :: HKD Identity Word32
udppMaxRefScriptSizePerBlock = Word32
1024 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 -- 1MiB
          , udppMaxRefScriptSizePerTx :: HKD Identity Word32
udppMaxRefScriptSizePerTx = Word32
200 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 -- 200KiB
          , udppRefScriptCostStride :: HKD Identity (NonZero Word32)
udppRefScriptCostStride = forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @25_600 -- 25 KiB
          , udppRefScriptCostMultiplier :: HKD Identity PositiveInterval
udppRefScriptCostMultiplier = Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (HKD Identity PositiveInterval)
 -> HKD Identity PositiveInterval)
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe PositiveInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
1.2
          }
    }

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