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

module Test.Cardano.Ledger.Conway.Translation.TranslatableGen where

import Cardano.Ledger.Alonzo.Plutus.Context (SupportedLanguage (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Plutus (Data (..), ExUnits, Language (..), plutusLanguage)
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (fromList)
import qualified Data.Set as Set
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (TranslatableGen (..))
import qualified Test.Cardano.Ledger.Babbage.Translation.TranslatableGen as BabbageTranslatableGen (
  genTx,
  genTxOut,
  utxoWithTx,
 )
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Arbitrary ()

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

genTxBody :: SupportedLanguage ConwayEra -> Gen (TxBody TopTx ConwayEra)
genTxBody :: SupportedLanguage ConwayEra -> Gen (TxBody TopTx ConwayEra)
genTxBody l :: SupportedLanguage ConwayEra
l@(SupportedLanguage SLanguage l
slang) = do
  let lang :: Language
lang = SLanguage l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage SLanguage l
slang
      genTxOuts :: Gen (StrictSeq (BabbageTxOut ConwayEra))
genTxOuts =
        [BabbageTxOut ConwayEra] -> StrictSeq (BabbageTxOut ConwayEra)
forall a. [a] -> StrictSeq a
fromList
          ([BabbageTxOut ConwayEra] -> StrictSeq (BabbageTxOut ConwayEra))
-> Gen [BabbageTxOut ConwayEra]
-> Gen (StrictSeq (BabbageTxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BabbageTxOut ConwayEra) -> Gen [BabbageTxOut ConwayEra]
forall a. Gen a -> Gen [a]
listOf1
            (SupportedLanguage ConwayEra -> Gen (TxOut ConwayEra)
forall era.
(BabbageEraTxOut era, Arbitrary (Value era),
 Arbitrary (Script era)) =>
SupportedLanguage era -> Gen (TxOut era)
BabbageTranslatableGen.genTxOut SupportedLanguage ConwayEra
l)
      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)
      offPrePlutusV3 :: Int -> Int
offPrePlutusV3 Int
freq = if Language
lang Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3 then Int
freq else Int
0
      genDelegatee :: Gen Delegatee
genDelegatee =
        [(Int, Gen Delegatee)] -> Gen Delegatee
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
33, KeyHash StakePool -> Delegatee
DelegStake (KeyHash StakePool -> Delegatee)
-> Gen (KeyHash StakePool) -> Gen Delegatee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (KeyHash StakePool)
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int -> Int
offPrePlutusV3 Int
33, DRep -> Delegatee
DelegVote (DRep -> Delegatee) -> Gen DRep -> Gen Delegatee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DRep
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int -> Int
offPrePlutusV3 Int
33, KeyHash StakePool -> DRep -> Delegatee
DelegStakeVote (KeyHash StakePool -> DRep -> Delegatee)
-> Gen (KeyHash StakePool) -> Gen (DRep -> Delegatee)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (KeyHash StakePool)
forall a. Arbitrary a => Gen a
arbitrary Gen (DRep -> Delegatee) -> Gen DRep -> Gen Delegatee
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DRep
forall a. Arbitrary a => Gen a
arbitrary)
          ]
      genDelegCert :: Gen ConwayDelegCert
genDelegCert =
        [(Int, Gen ConwayDelegCert)] -> Gen ConwayDelegCert
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
25, Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert (Credential Staking -> StrictMaybe Coin -> ConwayDelegCert)
-> Gen (Credential Staking)
-> Gen (StrictMaybe Coin -> ConwayDelegCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Credential Staking)
forall a. Arbitrary a => Gen a
arbitrary Gen (StrictMaybe Coin -> ConwayDelegCert)
-> Gen (StrictMaybe Coin) -> Gen ConwayDelegCert
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe Coin)
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
25, Credential Staking -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert (Credential Staking -> StrictMaybe Coin -> ConwayDelegCert)
-> Gen (Credential Staking)
-> Gen (StrictMaybe Coin -> ConwayDelegCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Credential Staking)
forall a. Arbitrary a => Gen a
arbitrary Gen (StrictMaybe Coin -> ConwayDelegCert)
-> Gen (StrictMaybe Coin) -> Gen ConwayDelegCert
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictMaybe Coin)
forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
25, Credential Staking -> Delegatee -> ConwayDelegCert
ConwayDelegCert (Credential Staking -> Delegatee -> ConwayDelegCert)
-> Gen (Credential Staking) -> Gen (Delegatee -> ConwayDelegCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Credential Staking)
forall a. Arbitrary a => Gen a
arbitrary Gen (Delegatee -> ConwayDelegCert)
-> Gen Delegatee -> Gen ConwayDelegCert
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Delegatee
genDelegatee)
          , (Int -> Int
offPrePlutusV3 Int
25, Credential Staking -> Delegatee -> Coin -> ConwayDelegCert
ConwayRegDelegCert (Credential Staking -> Delegatee -> Coin -> ConwayDelegCert)
-> Gen (Credential Staking)
-> Gen (Delegatee -> Coin -> ConwayDelegCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Credential Staking)
forall a. Arbitrary a => Gen a
arbitrary Gen (Delegatee -> Coin -> ConwayDelegCert)
-> Gen Delegatee -> Gen (Coin -> ConwayDelegCert)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Delegatee
genDelegatee Gen (Coin -> ConwayDelegCert) -> Gen Coin -> Gen ConwayDelegCert
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Coin
forall a. Arbitrary a => Gen a
arbitrary)
          ]
      genTxCerts :: Gen (StrictSeq (ConwayTxCert ConwayEra))
genTxCerts =
        [ConwayTxCert ConwayEra] -> StrictSeq (ConwayTxCert ConwayEra)
forall a. [a] -> StrictSeq a
fromList
          ([ConwayTxCert ConwayEra] -> StrictSeq (ConwayTxCert ConwayEra))
-> Gen [ConwayTxCert ConwayEra]
-> Gen (StrictSeq (ConwayTxCert ConwayEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ConwayTxCert ConwayEra) -> Gen [ConwayTxCert ConwayEra]
forall a. Gen a -> Gen [a]
listOf1
            ( [(Int, Gen (ConwayTxCert ConwayEra))]
-> Gen (ConwayTxCert ConwayEra)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
                [ (Int
33, ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> Gen ConwayDelegCert -> Gen (ConwayTxCert ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ConwayDelegCert
genDelegCert)
                , (Int
33, PoolCert -> ConwayTxCert ConwayEra
forall era. PoolCert -> ConwayTxCert era
ConwayTxCertPool (PoolCert -> ConwayTxCert ConwayEra)
-> Gen PoolCert -> Gen (ConwayTxCert ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen PoolCert
forall a. Arbitrary a => Gen a
arbitrary)
                , (Int -> Int
offPrePlutusV3 Int
33, ConwayGovCert -> ConwayTxCert ConwayEra
forall era. ConwayGovCert -> ConwayTxCert era
ConwayTxCertGov (ConwayGovCert -> ConwayTxCert ConwayEra)
-> Gen ConwayGovCert -> Gen (ConwayTxCert ConwayEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ConwayGovCert
forall a. Arbitrary a => Gen a
arbitrary)
                ]
            )
      genForPlutusV3 :: Arbitrary a => a -> Gen a
      genForPlutusV3 :: forall a. Arbitrary a => a -> Gen a
genForPlutusV3 a
d =
        case Language
lang of
          Language
PlutusV3 -> Gen a
forall a. Arbitrary a => Gen a
arbitrary
          Language
_ -> a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
  txIns <- Gen (Set TxIn)
genTxIns
  collIns <- arbitrary
  refIns <- arbitrary
  txOuts <- genTxOuts
  collReturn <- arbitrary
  totColl <- arbitrary
  certs <- genTxCerts
  withdrawals <- arbitrary
  fee <- arbitrary
  vldt <- scale (`div` 15) arbitrary
  reqSignerHashes <- arbitrary
  mint <- scale (`div` 15) arbitrary
  scriptIntegrityHash <- arbitrary
  adHash <- arbitrary
  txNetworkId <- arbitrary
  votingProcedures <- genForPlutusV3 (VotingProcedures mempty)
  proposalProcedures <- genForPlutusV3 mempty
  currentTreasuryValue <- genForPlutusV3 mempty
  treasuryDonation <- genForPlutusV3 mempty
  pure $
    mkBasicTxBody
      & inputsTxBodyL .~ txIns
      & collateralInputsTxBodyL .~ collIns
      & referenceInputsTxBodyL .~ refIns
      & outputsTxBodyL .~ txOuts
      & collateralReturnTxBodyL .~ collReturn
      & totalCollateralTxBodyL .~ totColl
      & certsTxBodyL .~ certs
      & withdrawalsTxBodyL .~ withdrawals
      & feeTxBodyL .~ fee
      & vldtTxBodyL .~ vldt
      & reqSignerHashesTxBodyL .~ reqSignerHashes
      & mintTxBodyL .~ mint
      & scriptIntegrityHashTxBodyL .~ scriptIntegrityHash
      & auxDataHashTxBodyL .~ adHash
      & networkIdTxBodyL .~ txNetworkId
      & votingProceduresTxBodyL .~ votingProcedures
      & proposalProceduresTxBodyL .~ proposalProcedures
      & currentTreasuryValueTxBodyL .~ currentTreasuryValue
      & treasuryDonationTxBodyL .~ treasuryDonation

genRedeemers ::
  forall era.
  (AlonzoEraScript era, PlutusPurpose AsIx era ~ ConwayPlutusPurpose AsIx era) =>
  Gen (Redeemers era)
genRedeemers :: forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ ConwayPlutusPurpose 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 (ConwaySpending $ AsIx 0) (d, eu), Map.empty]