{-# 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.Address (Addr (..))
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), ExUnits (..))
import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..))
import Cardano.Ledger.Alonzo.TxWits
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.TxBody (BabbageTxBody (..), BabbageTxOut (..))
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Credential (StakeReference (..))
import Cardano.Ledger.Plutus.Data (Data (..), Datum (..))
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (UTxO (..))
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 (..),
  TxInfoLanguage (..),
 )
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 = forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers
  tgTx :: Language -> Gen (Tx BabbageEra)
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)
genTx @BabbageEra (Language -> Gen (BabbageTxBody BabbageEra)
genTxBody Language
l)
  tgUtxo :: Language -> Tx BabbageEra -> Gen (UTxO BabbageEra)
tgUtxo = forall era.
(EraTx era, Arbitrary (Value era), Arbitrary (Script era),
 TxOut era ~ BabbageTxOut era) =>
Language -> Tx era -> Gen (UTxO era)
utxoWithTx @BabbageEra
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage BabbageEra
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
lang =
    forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Language " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Language
lang forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported in " forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @BabbageEra

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

genTx ::
  forall era.
  ( TranslatableGen era
  , Arbitrary (TxAuxData era)
  , Arbitrary (Script era)
  , AlonzoEraScript era
  , AlonzoTxWits era ~ TxWits era
  ) =>
  Gen (TxBody era) ->
  Gen (AlonzoTx era)
genTx :: forall era.
(TranslatableGen era, Arbitrary (TxAuxData era),
 Arbitrary (Script era), AlonzoEraScript era,
 AlonzoTxWits era ~ TxWits era) =>
Gen (TxBody era) -> Gen (AlonzoTx era)
genTx Gen (TxBody era)
txbGen =
  forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxBody era)
txbGen
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era.
(TranslatableGen era, Arbitrary (Script era),
 AlonzoEraScript era) =>
Gen (AlonzoTxWits era)
genTxWits @era
    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

genTxOut ::
  forall era.
  ( EraTxOut era
  , Arbitrary (Value era)
  , Arbitrary (Script era)
  ) =>
  Language ->
  Gen (BabbageTxOut era)
genTxOut :: forall era.
(EraTxOut era, Arbitrary (Value era), Arbitrary (Script era)) =>
Language -> Gen (BabbageTxOut era)
genTxOut Language
l = do
  Addr
addr <- Gen Addr
genNonByronAddr
  Value era
value <- 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
  StrictMaybe (Script era)
script <- case Language
l of
    Language
PlutusV1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
    Language
_ -> forall a. Arbitrary a => Gen a
arbitrary
  Datum era
datum <- case Language
l of
    Language
PlutusV1 -> forall a. HasCallStack => [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall era. Datum era
NoDatum, forall era. DataHash -> Datum era
DatumHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Arbitrary a => Gen a
arbitrary :: Gen DataHash)]
    Language
_ -> forall a. Arbitrary a => Gen a
arbitrary
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Addr
addr Value era
value Datum era
datum StrictMaybe (Script era)
script

genTxBody :: Language -> Gen (BabbageTxBody BabbageEra)
genTxBody :: Language -> Gen (BabbageTxBody BabbageEra)
genTxBody Language
l = do
  let genTxOuts :: Gen (StrictSeq (Sized (BabbageTxOut BabbageEra)))
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 @BabbageEra) 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)
genTxOut @BabbageEra 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)
  forall era.
BabbageEraTxBody era =>
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> BabbageTxBody era
BabbageTxBody
    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
<*> ( case Language
l of -- refinputs
            Language
PlutusV1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
Set.empty
            Language
_ -> forall a. Arbitrary a => Gen a
arbitrary
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (StrictSeq (Sized (BabbageTxOut BabbageEra)))
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
<*> 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. (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

genNonByronAddr :: Gen Addr
genNonByronAddr :: Gen Addr
genNonByronAddr =
  Network -> PaymentCredential -> StakeReference -> Addr
Addr
    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
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
85, StakeCredential -> StakeReference
StakeRefBase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
      , (Int
15, forall (f :: * -> *) a. Applicative f => a -> f a
pure StakeReference
StakeRefNull)
      ]

genTxWits ::
  ( TranslatableGen era
  , Arbitrary (Script era)
  , AlonzoEraScript era
  ) =>
  Gen (AlonzoTxWits era)
genTxWits :: forall era.
(TranslatableGen era, Arbitrary (Script era),
 AlonzoEraScript era) =>
Gen (AlonzoTxWits era)
genTxWits =
  forall era.
AlonzoEraScript era =>
Set (WitVKey 'Witness)
-> Set BootstrapWitness
-> Map ScriptHash (Script era)
-> TxDats era
-> Redeemers era
-> AlonzoTxWits era
AlonzoTxWits
    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
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall era.
(EraScript era, Arbitrary (Script era)) =>
Gen (Map ScriptHash (Script era))
genScripts
    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 era. TranslatableGen era => Gen (Redeemers era)
tgRedeemers

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
  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 -> AlonzoPlutusPurpose f era
AlonzoSpending 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]