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

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

import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript, AsIx (..), PlutusPurpose)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..))
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..))
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus (Data (..), ExUnits, Language (..), SLanguage (..))
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (fromList)
import qualified Data.Set as Set
import Test.Cardano.Data.Arbitrary (genOSet)
import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen (
  TranslatableGen (..),
  TxInfoLanguage (..),
 )
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 = forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ ConwayPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers
  tgTx :: Language -> Gen (Tx ConwayEra)
tgTx Language
l = forall era.
(TranslatableGen era, Arbitrary (TxAuxData era),
 Arbitrary (Script era), AlonzoEraScript era,
 AlonzoTxWits era ~ TxWits era) =>
Gen (TxBody era) -> Gen (AlonzoTx era)
BabbageTranslatableGen.genTx @ConwayEra (Language -> Gen (ConwayTxBody ConwayEra)
genTxBody Language
l)
  tgUtxo :: Language -> Tx ConwayEra -> Gen (UTxO ConwayEra)
tgUtxo = forall era.
(EraTx era, Arbitrary (Value era), Arbitrary (Script era),
 TxOut era ~ BabbageTxOut era) =>
Language -> Tx era -> Gen (UTxO era)
BabbageTranslatableGen.utxoWithTx @ConwayEra
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage ConwayEra
mkTxInfoLanguage Language
PlutusV1 = forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> TxInfoLanguage era
TxInfoLanguage SLanguage 'PlutusV1
SPlutusV1
  mkTxInfoLanguage Language
PlutusV2 = forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> TxInfoLanguage era
TxInfoLanguage SLanguage 'PlutusV2
SPlutusV2
  mkTxInfoLanguage Language
PlutusV3 = forall (l :: Language) era.
EraPlutusTxInfo l era =>
SLanguage l -> TxInfoLanguage era
TxInfoLanguage SLanguage 'PlutusV3
SPlutusV3

genTxBody :: Language -> Gen (ConwayTxBody ConwayEra)
genTxBody :: Language -> Gen (ConwayTxBody ConwayEra)
genTxBody Language
l = do
  let genTxOuts :: Gen (StrictSeq (Sized (BabbageTxOut ConwayEra)))
genTxOuts =
        forall a. [a] -> StrictSeq a
fromList
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1
            ( forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerLow @ConwayEra)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(EraTxOut era, Arbitrary (Value era), Arbitrary (Script era)) =>
Language -> Gen (BabbageTxOut era)
BabbageTranslatableGen.genTxOut @ConwayEra Language
l
            )
  let genTxIns :: Gen (Set TxIn)
genTxIns = forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 (forall a. Arbitrary a => Gen a
arbitrary :: Gen TxIn)
      offPrePlutusV3 :: Int -> Int
offPrePlutusV3 Int
freq = if Language
l forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3 then Int
freq else Int
0
      genDelegatee :: Gen Delegatee
genDelegatee =
        forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
33, KeyHash 'StakePool -> Delegatee
DelegStake forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
          , (Int -> Int
offPrePlutusV3 Int
33, DRep -> Delegatee
DelegVote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
          , (Int -> Int
offPrePlutusV3 Int
33, KeyHash 'StakePool -> DRep -> Delegatee
DelegStakeVote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary)
          ]
      genDelegCert :: Gen ConwayDelegCert
genDelegCert =
        forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
25, StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
25, StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary)
          , (Int
25, StakeCredential -> Delegatee -> ConwayDelegCert
ConwayDelegCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Delegatee
genDelegatee)
          , (Int -> Int
offPrePlutusV3 Int
25, StakeCredential -> Delegatee -> Coin -> ConwayDelegCert
ConwayRegDelegCert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Delegatee
genDelegatee forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary)
          ]
      genTxCerts :: Gen (OSet (ConwayTxCert ConwayEra))
genTxCerts =
        forall a. Ord a => Gen a -> Gen (OSet a)
genOSet forall a b. (a -> b) -> a -> b
$
          forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
            [ (Int
33, forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ConwayDelegCert
genDelegCert)
            , (Int
33, forall era. PoolCert -> ConwayTxCert era
ConwayTxCertPool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
            , (Int -> Int
offPrePlutusV3 Int
33, forall era. ConwayGovCert -> ConwayTxCert era
ConwayTxCertGov forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
l of
          Language
PlutusV3 -> forall a. Arbitrary a => Gen a
arbitrary
          Language
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d
  forall era.
ConwayEraTxBody era =>
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> OSet (ConwayTxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> VotingProcedures era
-> OSet (ProposalProcedure era)
-> StrictMaybe Coin
-> Coin
-> ConwayTxBody era
ConwayTxBody
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Set TxIn)
genTxIns
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictSeq (Sized (BabbageTxOut ConwayEra)))
genTxOuts
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (OSet (ConwayTxCert ConwayEra))
genTxCerts
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Int -> Int) -> Gen a -> Gen a
scale (forall a. Integral a => a -> a -> a
`div` Int
15) forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Int -> Int) -> Gen a -> Gen a
scale (forall a. Integral a => a -> a -> a
`div` Int
15) forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => a -> Gen a
genForPlutusV3 (forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures forall a. Monoid a => a
mempty)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => a -> Gen a
genForPlutusV3 forall a. Monoid a => a
mempty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => a -> Gen a
genForPlutusV3 forall a. Monoid a => a
mempty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => a -> Gen a
genForPlutusV3 forall a. Monoid a => a
mempty

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
  Data era
d <- forall a. Arbitrary a => Gen a
arbitrary :: Gen (Data era)
  ExUnits
eu <- forall a. Arbitrary a => Gen a
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
  forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
elements [forall k a. k -> a -> Map k a
Map.singleton (forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
ConwaySpending forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data era
d, ExUnits
eu), forall k a. Map k a
Map.empty]