{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 900 {-# LANGUAGE IncoherentInstances #-} #endif {-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Ledger.Babbage.ImpTest ( module Test.Cardano.Ledger.Alonzo.ImpTest, produceRefScript, produceRefScripts, ) where import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN) import Cardano.Crypto.Hash (Hash) import Cardano.Crypto.Hash.Blake2b (Blake2b_224) import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Babbage.Core import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..)) import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, nesEsL) import Cardano.Ledger.Tools (setMinCoinTxOut) import Cardano.Ledger.TxIn (TxIn, mkTxInPartial) import Control.Monad (forM) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Sequence.Strict as SSeq import Lens.Micro ((&), (.~), (<>~)) import Test.Cardano.Ledger.Alonzo.ImpTest import Test.Cardano.Ledger.Babbage.TreeDiff () import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Plutus (testingCostModels) instance ( Crypto c , NFData (SigDSIGN (DSIGN c)) , NFData (VerKeyDSIGN (DSIGN c)) , ADDRHASH c ~ Blake2b_224 , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => ShelleyEraImp (BabbageEra c) where initNewEpochState :: forall s (m :: * -> *). (HasKeyPairs s (EraCrypto (BabbageEra c)), MonadState s m, HasStatefulGen (StateGenM s) m) => m (NewEpochState (BabbageEra c)) initNewEpochState = forall era s (m :: * -> *). (MonadState s m, HasKeyPairs s (EraCrypto era), HasStatefulGen (StateGenM s) m, ShelleyEraImp era, ShelleyEraImp (PreviousEra era), TranslateEra era NewEpochState, TranslationError era NewEpochState ~ Void, TranslationContext era ~ Genesis era, EraCrypto era ~ EraCrypto (PreviousEra era)) => (NewEpochState (PreviousEra era) -> NewEpochState (PreviousEra era)) -> m (NewEpochState era) defaultInitNewEpochState (forall era. Lens' (NewEpochState era) (EpochState era) nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraGov era => Lens' (EpochState era) (PParams era) curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels ppCostModelsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t <>~ HasCallStack => [Language] -> CostModels testingCostModels [Language PlutusV2]) impSatisfyNativeScript :: Set (KeyHash 'Witness (EraCrypto (BabbageEra c))) -> NativeScript (BabbageEra c) -> ImpTestM (BabbageEra c) (Maybe (Map (KeyHash 'Witness (EraCrypto (BabbageEra c))) (KeyPair 'Witness (EraCrypto (BabbageEra c))))) impSatisfyNativeScript = forall era. AllegraEraScript era => Set (KeyHash 'Witness (EraCrypto era)) -> NativeScript era -> ImpTestM era (Maybe (Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))) impAllegraSatisfyNativeScript fixupTx :: HasCallStack => Tx (BabbageEra c) -> ImpTestM (BabbageEra c) (Tx (BabbageEra c)) fixupTx = forall era. (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (Tx era) alonzoFixupTx instance ShelleyEraImp (BabbageEra c) => MaryEraImp (BabbageEra c) instance ShelleyEraImp (BabbageEra c) => AlonzoEraImp (BabbageEra c) where scriptTestContexts :: Map (ScriptHash (EraCrypto (BabbageEra c))) ScriptTestContext scriptTestContexts = forall c (l :: Language). (Crypto c, PlutusLanguage l) => SLanguage l -> Map (ScriptHash c) ScriptTestContext plutusTestScripts SLanguage 'PlutusV1 SPlutusV1 forall a. Semigroup a => a -> a -> a <> forall c (l :: Language). (Crypto c, PlutusLanguage l) => SLanguage l -> Map (ScriptHash c) ScriptTestContext plutusTestScripts SLanguage 'PlutusV2 SPlutusV2 produceRefScript :: (ShelleyEraImp era, BabbageEraTxOut era) => Script era -> ImpTestM era (TxIn (EraCrypto era)) produceRefScript :: forall era. (ShelleyEraImp era, BabbageEraTxOut era) => Script era -> ImpTestM era (TxIn (EraCrypto era)) produceRefScript Script era script = do TxIn (EraCrypto era) txIn :| [] <- forall era. (ShelleyEraImp era, BabbageEraTxOut era) => NonEmpty (Script era) -> ImpTestM era (NonEmpty (TxIn (EraCrypto era))) produceRefScripts forall a b. (a -> b) -> a -> b $ Script era script forall a. a -> [a] -> NonEmpty a :| [] forall (f :: * -> *) a. Applicative f => a -> f a pure TxIn (EraCrypto era) txIn produceRefScripts :: (ShelleyEraImp era, BabbageEraTxOut era) => NonEmpty (Script era) -> ImpTestM era (NonEmpty (TxIn (EraCrypto era))) produceRefScripts :: forall era. (ShelleyEraImp era, BabbageEraTxOut era) => NonEmpty (Script era) -> ImpTestM era (NonEmpty (TxIn (EraCrypto era))) produceRefScripts NonEmpty (Script era) scripts = do PParams era pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a getsNES forall a b. (a -> b) -> a -> b $ forall era. Lens' (NewEpochState era) (EpochState era) nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall era. EraGov era => Lens' (EpochState era) (PParams era) curPParamsEpochStateL NonEmpty (TxOut era) txOuts <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM NonEmpty (Script era) scripts forall a b. (a -> b) -> a -> b $ \Script era script -> do Addr (EraCrypto era) addr <- forall s c (m :: * -> *). (HasKeyPairs s c, MonadState s m, HasStatefulGen (StateGenM s) m) => m (Addr c) freshKeyAddr_ let txOutZero :: TxOut era txOutZero = forall era. (EraTxOut era, HasCallStack) => Addr (EraCrypto era) -> Value era -> TxOut era mkBasicTxOut Addr (EraCrypto era) addr forall a. Monoid a => a mempty forall a b. a -> (a -> b) -> b & forall era. BabbageEraTxOut era => Lens' (TxOut era) (StrictMaybe (Script era)) referenceScriptTxOutL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. a -> StrictMaybe a SJust Script era script forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era setMinCoinTxOut PParams era pp TxOut era txOutZero let txBody :: TxBody era txBody = forall era. EraTxBody era => TxBody era mkBasicTxBody forall a b. a -> (a -> b) -> b & forall era. EraTxBody era => Lens' (TxBody era) (StrictSeq (TxOut era)) outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t .~ forall a. [a] -> StrictSeq a SSeq.fromList (forall a. NonEmpty a -> [a] NE.toList NonEmpty (TxOut era) txOuts) TxId (EraCrypto era) txId <- forall era. EraTx era => Tx era -> TxId (EraCrypto era) txIdTx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall era. (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era) submitTx (forall era. EraTx era => TxBody era -> Tx era mkBasicTx TxBody era txBody) forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c NE.zipWith (\Script era _ -> forall c. HasCallStack => TxId c -> Integer -> TxIn c mkTxInPartial TxId (EraCrypto era) txId) NonEmpty (Script era) scripts (Integer 0 forall a. a -> [a] -> NonEmpty a :| [Integer 1 ..])