{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Dijkstra.TxInfoSpec (spec) where

import Cardano.Ledger.Alonzo.Plutus.Context (
  EraPlutusContext (..),
  EraPlutusTxInfo (..),
  LedgerTxInfo (..),
  PlutusTxInfoResult (..),
  SupportedLanguage (..),
 )
import Cardano.Ledger.Alonzo.Scripts (AsPurpose (..))
import Cardano.Ledger.BaseTypes (Globals (..), Inject (..), Network (..), ProtVer (..))
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.State (UTxO (..))
import Cardano.Ledger.Dijkstra.TxInfo (DijkstraContextError (..))
import Cardano.Ledger.Plutus (Language (..), SLanguage (..))
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Utils (testGlobals)
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()

spec ::
  forall era.
  ( EraPlutusTxInfo PlutusV1 era
  , EraPlutusTxInfo PlutusV2 era
  , EraPlutusTxInfo PlutusV3 era
  , EraPlutusTxInfo PlutusV4 era
  , Inject (DijkstraContextError era) (ContextError era)
  , ConwayEraTxBody era
  , EraTx era
  , Arbitrary (Value era)
  ) =>
  Spec
spec :: forall era.
(EraPlutusTxInfo 'PlutusV1 era, EraPlutusTxInfo 'PlutusV2 era,
 EraPlutusTxInfo 'PlutusV3 era, EraPlutusTxInfo 'PlutusV4 era,
 Inject (DijkstraContextError era) (ContextError era),
 ConwayEraTxBody era, EraTx era, Arbitrary (Value era)) =>
Spec
spec = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV4" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Gen Expectation -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Fails translation when Ptr present in outputs" (Gen Expectation -> Spec) -> Gen Expectation -> Spec
forall a b. (a -> b) -> a -> b
$ do
      paymentCred <- Gen (Credential Payment)
forall a. Arbitrary a => Gen a
arbitrary
      ptr <- arbitrary
      val <- arbitrary
      let
        txOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet Credential Payment
paymentCred (Ptr -> StakeReference
StakeRefPtr Ptr
ptr)) Value era
val
      txIn <- arbitrary
      paymentCred2 <- arbitrary
      stakeRef <- arbitrary
      let
        utxo =
          Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO
            [ (TxIn
txIn, Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet Credential Payment
paymentCred2 StakeReference
stakeRef) Value era
val)
            ]
        tx =
          forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
mkBasicTx @era @TopTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
            TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
        ledgerTxInfo =
          forall era (level :: TxLevel).
ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> UTxO era
-> Tx level era
-> LedgerTxInfo era
LedgerTxInfo @era
            (Version -> Nat -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Nat
0)
            (Globals -> EpochInfo (Either Text)
epochInfo Globals
testGlobals)
            (Globals -> SystemStart
systemStart Globals
testGlobals)
            UTxO era
utxo
            Tx TopTx era
tx
      pure $
        (($ SpendingPurpose AsPurpose) <$> unPlutusTxInfoResult (toPlutusTxInfo SPlutusV4 ledgerTxInfo))
          `shouldBeLeft` inject (PointerPresentInOutput @era [txOut])
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV1-V3" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let plutusV1toV3 :: [SupportedLanguage era]
        plutusV1toV3 :: [SupportedLanguage era]
plutusV1toV3 =
          [ SLanguage 'PlutusV1 -> SupportedLanguage era
forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> SupportedLanguage era
SupportedLanguage SLanguage 'PlutusV1
SPlutusV1
          , SLanguage 'PlutusV2 -> SupportedLanguage era
forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> SupportedLanguage era
SupportedLanguage SLanguage 'PlutusV2
SPlutusV2
          , SLanguage 'PlutusV3 -> SupportedLanguage era
forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> SupportedLanguage era
SupportedLanguage SLanguage 'PlutusV3
SPlutusV3
          ]
    [SupportedLanguage era] -> (SupportedLanguage era -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SupportedLanguage era]
plutusV1toV3 ((SupportedLanguage era -> Spec) -> Spec)
-> (SupportedLanguage era -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \(SupportedLanguage SLanguage l
slang) -> do
      String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SubTxIsNotSupported" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
        let
          tx :: Tx SubTx era
tx = forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
mkBasicTx @era @SubTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          ledgerTxInfo :: LedgerTxInfo era
ledgerTxInfo =
            forall era (level :: TxLevel).
ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> UTxO era
-> Tx level era
-> LedgerTxInfo era
LedgerTxInfo @era
              (Version -> Nat -> ProtVer
ProtVer (forall era. Era era => Version
eraProtVerLow @era) Nat
0)
              (Globals -> EpochInfo (Either Text)
epochInfo Globals
testGlobals)
              (Globals -> SystemStart
systemStart Globals
testGlobals)
              UTxO era
forall a. Monoid a => a
mempty
              Tx SubTx era
tx
          txInfoResult :: Either
  (ContextError era) (Either (ContextError era) (PlutusTxInfo l))
txInfoResult =
            ((PlutusPurpose AsPurpose era
 -> Either (ContextError era) (PlutusTxInfo l))
-> PlutusPurpose AsPurpose era
-> Either (ContextError era) (PlutusTxInfo l)
forall a b. (a -> b) -> a -> b
$ AsPurpose Word32 TxIn -> PlutusPurpose AsPurpose era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose AsPurpose Word32 TxIn
forall ix it. AsPurpose ix it
AsPurpose)
              ((PlutusPurpose AsPurpose era
  -> Either (ContextError era) (PlutusTxInfo l))
 -> Either (ContextError era) (PlutusTxInfo l))
-> Either
     (ContextError era)
     (PlutusPurpose AsPurpose era
      -> Either (ContextError era) (PlutusTxInfo l))
-> Either
     (ContextError era) (Either (ContextError era) (PlutusTxInfo l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlutusTxInfoResult l era
-> Either
     (ContextError era)
     (PlutusPurpose AsPurpose era
      -> Either (ContextError era) (PlutusTxInfo l))
forall (l :: Language) era.
PlutusTxInfoResult l era
-> Either
     (ContextError era)
     (PlutusPurpose AsPurpose era
      -> Either (ContextError era) (PlutusTxInfo l))
unPlutusTxInfoResult (SLanguage l -> LedgerTxInfo era -> PlutusTxInfoResult l era
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l -> LedgerTxInfo era -> PlutusTxInfoResult l era
forall (proxy :: Language -> *).
proxy l -> LedgerTxInfo era -> PlutusTxInfoResult l era
toPlutusTxInfo SLanguage l
slang LedgerTxInfo era
ledgerTxInfo)
        Either
  (ContextError era) (Either (ContextError era) (PlutusTxInfo l))
txInfoResult Either
  (ContextError era) (Either (ContextError era) (PlutusTxInfo l))
-> ContextError era -> Expectation
forall a b.
(HasCallStack, Show a, Eq a, Show b) =>
Either a b -> a -> Expectation
`shouldBeLeft` DijkstraContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (forall era. TxId -> DijkstraContextError era
SubTxIsNotSupported @era (Tx SubTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx SubTx era
tx))