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

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

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Plutus.Context (
  EraPlutusContext (..),
  EraPlutusTxInfo (..),
  LedgerTxInfo (..),
 )
import Cardano.Ledger.BaseTypes (Globals (..), Inject (..), Network (..), ProtVer (..))
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Dijkstra.Core (
  ConwayEraTxBody,
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  Value,
  eraProtVerLow,
 )
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 (Arbitrary (..), Spec, describe, prop, shouldBeLeft)
import Test.Cardano.Ledger.Core.Utils (testGlobals)
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()

spec ::
  forall era.
  ( EraPlutusTxInfo PlutusV4 era
  , Inject (DijkstraContextError era) (ContextError era)
  , ConwayEraTxBody era
  , EraTx era
  , Arbitrary (Value era)
  ) =>
  Spec
spec :: forall 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 (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.
ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> UTxO era
-> Tx TopTx 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 $
          toPlutusTxInfo SPlutusV4 ledgerTxInfo `shouldBeLeft` inject (PointerPresentInOutput @era [txOut])