{-# 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 (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.Crypto
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 Conway where
  tgRedeemers :: Gen (Redeemers Conway)
tgRedeemers = forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ ConwayPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers
  tgTx :: Language -> Gen (Tx Conway)
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 @Conway (forall c. Crypto c => Language -> Gen (ConwayTxBody (ConwayEra c))
genTxBody Language
l)
  tgUtxo :: Language -> Tx Conway -> Gen (UTxO Conway)
tgUtxo = forall era.
(EraTx era, Arbitrary (Value era), Arbitrary (Script era),
 TxOut era ~ BabbageTxOut era) =>
Language -> Tx era -> Gen (UTxO era)
BabbageTranslatableGen.utxoWithTx @Conway
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage Conway
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 :: forall c. Crypto c => Language -> Gen (ConwayTxBody (ConwayEra c))
genTxBody :: forall c. Crypto c => Language -> Gen (ConwayTxBody (ConwayEra c))
genTxBody Language
l = do
  let genTxOuts :: Gen (StrictSeq (Sized (BabbageTxOut (ConwayEra c))))
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 @Conway)
                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 c) Language
l
            )
  let genTxIns :: Gen (Set (TxIn c))
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 c))
      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 c)
genDelegatee =
        forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
33, forall c. KeyHash 'StakePool c -> Delegatee c
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, forall c. DRep c -> Delegatee c
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, forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
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 c)
genDelegCert =
        forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
25, forall c.
StakeCredential c -> StrictMaybe Coin -> ConwayDelegCert c
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, forall c.
StakeCredential c -> StrictMaybe Coin -> ConwayDelegCert c
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, forall c. StakeCredential c -> Delegatee c -> ConwayDelegCert c
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 c)
genDelegatee)
          , (Int -> Int
offPrePlutusV3 Int
25, forall c.
StakeCredential c -> Delegatee c -> Coin -> ConwayDelegCert c
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 c)
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 c)))
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 (EraCrypto era) -> ConwayTxCert era
ConwayTxCertDeleg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ConwayDelegCert c)
genDelegCert)
            , (Int
33, forall era. PoolCert (EraCrypto era) -> 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 (EraCrypto era) -> 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 (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> OSet (ConwayTxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> Set (KeyHash 'Witness (EraCrypto era))
-> MultiAsset (EraCrypto era)
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> 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 c))
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 c))))
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 c)))
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 (EraCrypto era))
  (Map (GovActionId (EraCrypto era)) (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 (EraCrypto era)) -> 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]