{-# 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 ..])