{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.Translation.TranslatableGen (
  genTx,
  genTxOut,
  utxoWithTx,
) where

import Cardano.Ledger.Alonzo.Plutus.Context (SupportedLanguage (..))
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), ExUnits (..))
import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits, Redeemers (..))
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.TxBody ()
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Plutus.Data (Data (..), Datum (..))
import Cardano.Ledger.Plutus.Language (SLanguage (..))
import Cardano.Ledger.State (UTxO (..))
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict
import Data.Sequence.Strict (fromList)
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Alonzo.Arbitrary (genScripts)
import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (TranslatableGen (..))
import Test.Cardano.Ledger.Babbage.Arbitrary ()
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.QuickCheck (
  Arbitrary,
  Gen,
  arbitrary,
  elements,
  frequency,
  listOf1,
  oneof,
  scale,
  vectorOf,
 )

instance TranslatableGen BabbageEra where
  tgRedeemers :: Gen (Redeemers BabbageEra)
tgRedeemers = Gen (Redeemers BabbageEra)
forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers
  tgTx :: SupportedLanguage BabbageEra -> Gen (Tx TopTx BabbageEra)
tgTx SupportedLanguage BabbageEra
l = forall era.
(TranslatableGen era, AlonzoEraTx era, Arbitrary (TxAuxData era),
 AlonzoTxWits era ~ TxWits era) =>
Gen (TxBody TopTx era) -> Gen (Tx TopTx era)
genTx @BabbageEra (TxBody TopTx BabbageEra -> TxBody TopTx BabbageEra
forall (l :: TxLevel) (t :: TxLevel -> * -> *) era.
(Typeable l, HasEraTxLevel t era,
 STxLevel l era ~ STxTopLevel l era) =>
t TopTx era -> t l era
asSTxTopLevel (TxBody TopTx BabbageEra -> TxBody TopTx BabbageEra)
-> Gen (TxBody TopTx BabbageEra) -> Gen (TxBody TopTx BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SupportedLanguage BabbageEra -> Gen (TxBody TopTx BabbageEra)
genTxBody SupportedLanguage BabbageEra
l)
  tgUtxo :: SupportedLanguage BabbageEra
-> Tx TopTx BabbageEra -> Gen (UTxO BabbageEra)
tgUtxo = forall era.
(EraTx era, BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Tx TopTx era -> Gen (UTxO era)
utxoWithTx @BabbageEra

utxoWithTx ::
  forall era.
  ( EraTx era
  , BabbageEraTxOut era
  , Arbitrary (Value era)
  , Arbitrary (Script era)
  ) =>
  SupportedLanguage era ->
  Tx TopTx era ->
  Gen (UTxO era)
utxoWithTx :: forall era.
(EraTx era, BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Tx TopTx era -> Gen (UTxO era)
utxoWithTx SupportedLanguage era
l Tx TopTx era
tx = do
  let allIns :: Set TxIn
allIns = Tx TopTx era
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era.
EraTxBody era =>
SimpleGetter (TxBody TopTx era) (Set TxIn)
SimpleGetter (TxBody TopTx era) (Set TxIn)
allInputsTxBodyF
  outs <- Int -> Gen (TxOut era) -> Gen [TxOut era]
forall a. Int -> Gen a -> Gen [a]
vectorOf (Set TxIn -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Set TxIn
allIns) (forall era.
(BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Gen (TxOut era)
genTxOut @era SupportedLanguage era
l)
  pure $ UTxO (Map.fromList $ Set.toList allIns `zip` outs)

genTx ::
  forall era.
  ( TranslatableGen era
  , AlonzoEraTx era
  , Arbitrary (TxAuxData era)
  , AlonzoTxWits era ~ TxWits era
  ) =>
  Gen (TxBody TopTx era) ->
  Gen (Tx TopTx era)
genTx :: forall era.
(TranslatableGen era, AlonzoEraTx era, Arbitrary (TxAuxData era),
 AlonzoTxWits era ~ TxWits era) =>
Gen (TxBody TopTx era) -> Gen (Tx TopTx era)
genTx Gen (TxBody TopTx era)
txbGen = do
  txb <- Gen (TxBody TopTx era)
txbGen
  wits <- genTxWits @era
  isValid <- arbitrary
  auxData <- arbitrary
  pure $
    mkBasicTx txb
      & witsTxL .~ wits
      & isValidTxL .~ isValid
      & auxDataTxL .~ auxData

genTxOut ::
  forall era.
  ( BabbageEraTxOut era
  , Arbitrary (Value era)
  , Arbitrary (Script era)
  ) =>
  SupportedLanguage era ->
  Gen (TxOut era)
genTxOut :: forall era.
(BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Gen (TxOut era)
genTxOut (SupportedLanguage SLanguage l
slang) = do
  addr <- Gen Addr
genNonByronAddr
  value <- scale (`div` 15) arbitrary
  script <- case slang of
    SLanguage l
SPlutusV1 -> StrictMaybe (Script era) -> Gen (StrictMaybe (Script era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (Script era)
forall a. StrictMaybe a
SNothing
    SLanguage l
_ -> Gen (StrictMaybe (Script era))
forall a. Arbitrary a => Gen a
arbitrary
  datum <- case slang of
    SLanguage l
SPlutusV1 -> [Gen (Datum era)] -> Gen (Datum era)
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Datum era -> Gen (Datum era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Datum era
forall era. Datum era
NoDatum, DataHash -> Datum era
forall era. DataHash -> Datum era
DatumHash (DataHash -> Datum era) -> Gen DataHash -> Gen (Datum era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen DataHash
forall a. Arbitrary a => Gen a
arbitrary :: Gen DataHash)]
    SLanguage l
_ -> Gen (Datum era)
forall a. Arbitrary a => Gen a
arbitrary
  pure $
    mkBasicTxOut addr value
      & datumTxOutL .~ datum
      & referenceScriptTxOutL .~ script

genTxBody :: SupportedLanguage BabbageEra -> Gen (TxBody TopTx BabbageEra)
genTxBody :: SupportedLanguage BabbageEra -> Gen (TxBody TopTx BabbageEra)
genTxBody l :: SupportedLanguage BabbageEra
l@(SupportedLanguage SLanguage l
slang) = do
  let genTxOuts :: Gen (StrictSeq (BabbageTxOut BabbageEra))
genTxOuts = [BabbageTxOut BabbageEra] -> StrictSeq (BabbageTxOut BabbageEra)
forall a. [a] -> StrictSeq a
fromList ([BabbageTxOut BabbageEra] -> StrictSeq (BabbageTxOut BabbageEra))
-> Gen [BabbageTxOut BabbageEra]
-> Gen (StrictSeq (BabbageTxOut BabbageEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut BabbageEra) -> Gen [BabbageTxOut BabbageEra]
forall a. Gen a -> Gen [a]
listOf1 (forall era.
(BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Gen (TxOut era)
genTxOut @BabbageEra SupportedLanguage BabbageEra
l)
  let genTxIns :: Gen (Set TxIn)
genTxIns = [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList ([TxIn] -> Set TxIn) -> Gen [TxIn] -> Gen (Set TxIn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn -> Gen [TxIn]
forall a. Gen a -> Gen [a]
listOf1 (Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary :: Gen TxIn)
  txIns <- Gen (Set TxIn)
genTxIns
  collIns <- arbitrary
  refIns <- case slang of
    SLanguage l
SPlutusV1 -> Set TxIn -> Gen (Set TxIn)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set TxIn
forall a. Set a
Set.empty
    SLanguage l
_ -> Gen (Set TxIn)
forall a. Arbitrary a => Gen a
arbitrary
  txOuts <- genTxOuts
  collReturn <- arbitrary
  totColl <- arbitrary
  certs <- arbitrary
  withdrawals <- arbitrary
  fee <- arbitrary
  vldt <- arbitrary
  update <- scale (`div` 15) arbitrary
  reqSignerHashes <- arbitrary
  mint <- scale (`div` 15) arbitrary
  scriptIntegrityHash <- arbitrary
  adHash <- arbitrary
  txNetworkId <- arbitrary
  pure $
    mkBasicTxBody
      & inputsTxBodyL .~ txIns
      & collateralInputsTxBodyL .~ collIns
      & referenceInputsTxBodyL .~ refIns
      & outputsTxBodyL .~ txOuts
      & collateralReturnTxBodyL .~ collReturn
      & totalCollateralTxBodyL .~ totColl
      & certsTxBodyL .~ certs
      & withdrawalsTxBodyL .~ withdrawals
      & feeTxBodyL .~ fee
      & vldtTxBodyL .~ vldt
      & updateTxBodyL .~ update
      & reqSignerHashesTxBodyL .~ reqSignerHashes
      & mintTxBodyL .~ mint
      & scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
      & auxDataHashTxBodyL .~ adHash
      & networkIdTxBodyL .~ txNetworkId

genNonByronAddr :: Gen Addr
genNonByronAddr :: Gen Addr
genNonByronAddr =
  Network -> Credential Payment -> StakeReference -> Addr
Addr
    (Network -> Credential Payment -> StakeReference -> Addr)
-> Gen Network
-> Gen (Credential Payment -> StakeReference -> Addr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Network
forall a. Arbitrary a => Gen a
arbitrary
    Gen (Credential Payment -> StakeReference -> Addr)
-> Gen (Credential Payment) -> Gen (StakeReference -> Addr)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Credential Payment)
forall a. Arbitrary a => Gen a
arbitrary
    Gen (StakeReference -> Addr) -> Gen StakeReference -> Gen Addr
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Int, Gen StakeReference)] -> Gen StakeReference
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
85, Credential Staking -> StakeReference
StakeRefBase (Credential Staking -> StakeReference)
-> Gen (Credential Staking) -> Gen StakeReference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Credential Staking)
forall a. Arbitrary a => Gen a
arbitrary)
      , (Int
15, StakeReference -> Gen StakeReference
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StakeReference
StakeRefNull)
      ]

genTxWits ::
  ( TranslatableGen era
  , AlonzoEraTxWits era
  ) =>
  Gen (TxWits era)
genTxWits :: forall era.
(TranslatableGen era, AlonzoEraTxWits era) =>
Gen (TxWits era)
genTxWits = do
  addrWits <- Gen (Set (WitVKey Witness))
forall a. Arbitrary a => Gen a
arbitrary
  bootAddrWits <- arbitrary
  scripts <- genScripts
  datums <- arbitrary
  redeemers <- tgRedeemers
  pure $
    mkBasicTxWits
      & addrTxWitsL .~ addrWits
      & bootAddrTxWitsL .~ bootAddrWits
      & scriptTxWitsL .~ scripts
      & datsTxWitsL .~ datums
      & rdmrsTxWitsL .~ redeemers

genRedeemers ::
  forall era.
  (AlonzoEraScript era, PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
  Gen (Redeemers era)
genRedeemers :: forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers = do
  d <- Gen (Data era)
forall a. Arbitrary a => Gen a
arbitrary :: Gen (Data era)
  eu <- arbitrary :: Gen ExUnits
  -- We provide `RdrmPtr Spend 0` as the only valid reedemer, because
  -- for any other redeemer type, we would have to modify the body of the transaction
  -- in order for the translation to succeed
  Redeemers <$> elements [Map.singleton (AlonzoSpending $ AsIx 0) (d, eu), Map.empty]