{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 900
{-# LANGUAGE IncoherentInstances #-}
#endif
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.ImpTest (
  babbageFixupTx,
  impBabbageExpectTxSuccess,
  module Test.Cardano.Ledger.Alonzo.ImpTest,
  produceRefScript,
  produceRefScripts,
) where

import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Collateral (collOuts)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState (
  UTxO (..),
  curPParamsEpochStateL,
  nesEsL,
  utxoL,
 )
import Cardano.Ledger.Tools (ensureMinCoinTxOut, 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.Map.Strict as Map
import Data.Maybe (isNothing)
import qualified Data.Sequence.Strict as SSeq
import GHC.Stack (HasCallStack)
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Babbage.TreeDiff ()
import Test.Cardano.Ledger.Plutus (testingCostModels)

instance ShelleyEraImp BabbageEra where
  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState BabbageEra)
initNewEpochState =
    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
      (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)
-> TxBody BabbageEra
-> NativeScript BabbageEra
-> ImpTestM
     BabbageEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack =>
Tx BabbageEra -> ImpTestM BabbageEra (Tx BabbageEra)
fixupTx = forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
babbageFixupTx
  expectTxSuccess :: HasCallStack => Tx BabbageEra -> ImpTestM BabbageEra ()
expectTxSuccess = forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess

babbageFixupTx ::
  ( HasCallStack
  , AlonzoEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
babbageFixupTx :: forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
babbageFixupTx =
  forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
addCollateralInput
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
fixupCollateralReturn
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupFees
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits

fixupCollateralReturn ::
  ( ShelleyEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupCollateralReturn :: forall era.
(ShelleyEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
fixupCollateralReturn Tx era
tx = 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp)

impBabbageExpectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  , BabbageEraTxBody era
  ) =>
  Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess Tx era
tx = do
  forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
impAlonzoExpectTxSuccess Tx era
tx
  -- Check that the balance of the collateral was returned
  let returns :: [(TxIn, TxOut era)]
returns = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. BabbageEraTxBody era => TxBody era -> UTxO era
collOuts forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
  UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL
  if Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True
    then do
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral return should not be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, forall a. Maybe a -> Bool
isNothing) | (TxIn
txIn, TxOut era
_txOut) <- [(TxIn, TxOut era)]
returns]
    else do
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral return should be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era -> [(TxIn, Maybe (TxOut era) -> Bool)] -> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn
txIn, (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TxOut era
txOut)) | (TxIn
txIn, TxOut era
txOut) <- [(TxIn, TxOut era)]
returns]

instance ShelleyEraImp BabbageEra => MaryEraImp BabbageEra

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

produceRefScript ::
  (ShelleyEraImp era, BabbageEraTxOut era) =>
  Script era ->
  ImpTestM era TxIn
produceRefScript :: forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript Script era
script = do
  TxIn
txIn :| [] <- forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
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
txIn

produceRefScripts ::
  (ShelleyEraImp era, BabbageEraTxOut era) =>
  NonEmpty (Script era) ->
  ImpTestM era (NonEmpty TxIn)
produceRefScripts :: forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
NonEmpty (Script era) -> ImpTestM era (NonEmpty TxIn)
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
addr <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    let txOutZero :: TxOut era
txOutZero =
          forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
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
txId <- forall era. EraTx era => Tx era -> TxId
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
_ -> HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
txId) NonEmpty (Script era)
scripts (Integer
0 forall a. a -> [a] -> NonEmpty a
:| [Integer
1 ..])