{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Babbage.Imp.UtxoSpec (spec) where

import Cardano.Ledger.Babbage.Core (
  BabbageEraTxBody (..),
  BabbageEraTxOut (..),
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  ppProtocolVersionL,
 )
import Cardano.Ledger.BaseTypes (Inject (..), ProtVer (..), natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Plutus (
  Data (..),
  Datum (..),
  SLanguage (..),
  dataToBinaryData,
  hashPlutusScript,
 )
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~))
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Babbage.ImpTest (
  AlonzoEraImp,
  ImpInit,
  LedgerSpec,
  getsPParams,
  submitTx,
  submitTx_,
 )
import Test.Cardano.Ledger.Common (SpecWith, describe, it, when)
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common (mkAddr)
import Test.Cardano.Ledger.Plutus.Examples (inputsOverlapsWithRefInputs)

spec :: forall era. (AlonzoEraImp era, BabbageEraTxBody era) => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era, BabbageEraTxBody era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Reference scripts" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reference inputs can overlap with regular inputs in PlutusV2" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let
        txOut :: TxOut era
txOut =
          Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
            ( ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr
                (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
inputsOverlapsWithRefInputs SLanguage 'PlutusV2
SPlutusV2))
                StakeReference
StakeRefNull
            )
            (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000)
            TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Datum era -> Identity (Datum era))
-> TxOut era -> Identity (TxOut era)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut era) (Datum era)
datumTxOutL ((Datum era -> Identity (Datum era))
 -> TxOut era -> Identity (TxOut era))
-> Datum era -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BinaryData era -> Datum era
forall era. BinaryData era -> Datum era
Datum (Data era -> BinaryData era
forall era. Data era -> BinaryData era
dataToBinaryData (Data era -> BinaryData era)
-> (Data -> Data era) -> Data -> BinaryData era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> BinaryData era) -> Data -> BinaryData era
forall a b. (a -> b) -> a -> b
$ Integer -> Data
PV1.I Integer
0)
      Tx era
tx <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton TxOut era
txOut
      let txIn :: TxIn
txIn = Integer -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Integer
0 :: Integer) Tx era
tx
      Version
majorVer <- ProtVer -> Version
pvMajor (ProtVer -> Version)
-> ImpM (LedgerSpec era) ProtVer -> ImpM (LedgerSpec era) Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' (PParams era) ProtVer -> ImpM (LedgerSpec era) ProtVer
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      Bool -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
majorVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9 Bool -> Bool -> Bool
|| Version
majorVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ @era (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn