{-# 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 (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.Crypto
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 Babbage where
  tgRedeemers :: Gen (Redeemers Babbage)
tgRedeemers = forall era.
(AlonzoEraScript era,
 PlutusPurpose AsIx era ~ AlonzoPlutusPurpose AsIx era) =>
Gen (Redeemers era)
genRedeemers
  tgTx :: Language -> Gen (Tx Babbage)
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 @Babbage (forall c.
Crypto c =>
Language -> Gen (BabbageTxBody (BabbageEra c))
genTxBody Language
l)
  tgUtxo :: Language -> Tx Babbage -> Gen (UTxO Babbage)
tgUtxo = forall era.
(EraTx era, Arbitrary (Value era), Arbitrary (Script era),
 TxOut era ~ BabbageTxOut era) =>
Language -> Tx era -> Gen (UTxO era)
utxoWithTx @Babbage
  mkTxInfoLanguage :: HasCallStack => Language -> TxInfoLanguage Babbage
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 @Babbage

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 (EraCrypto era))
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 (EraCrypto era)))
allInputsTxBodyF
  [BabbageTxOut era]
outs <- forall a. Int -> Gen a -> Gen [a]
vectorOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length Set (TxIn (EraCrypto era))
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 (EraCrypto era)) (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 (EraCrypto era))
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 (EraCrypto era)
addr <- forall c. Crypto c => Gen (Addr c)
genNonByronAddr @(EraCrypto era)
  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 (EraCrypto era) -> Datum era
DatumHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Arbitrary a => Gen a
arbitrary :: Gen (DataHash (EraCrypto era)))]
    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 (EraCrypto era)
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut Addr (EraCrypto era)
addr Value era
value Datum era
datum StrictMaybe (Script era)
script

genTxBody :: forall c. Crypto c => Language -> Gen (BabbageTxBody (BabbageEra c))
genTxBody :: forall c.
Crypto c =>
Language -> Gen (BabbageTxBody (BabbageEra c))
genTxBody Language
l = do
  let genTxOuts :: Gen (StrictSeq (Sized (BabbageTxOut (BabbageEra 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 @Babbage) 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 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))
  forall era.
BabbageEraTxBody era =>
Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> StrictSeq (Sized (TxOut era))
-> StrictMaybe (Sized (TxOut era))
-> StrictMaybe Coin
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness (EraCrypto era))
-> MultiAsset (EraCrypto era)
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> StrictMaybe Network
-> BabbageTxBody era
BabbageTxBody
    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
<*> ( 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 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
<*> 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 :: forall c. Crypto c => Gen (Addr c)
genNonByronAddr :: forall c. Crypto c => Gen (Addr c)
genNonByronAddr =
  forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
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, forall c. StakeCredential c -> StakeReference c
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 forall c. StakeReference c
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 (EraCrypto era))
-> Set (BootstrapWitness (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)) (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 (EraCrypto era)) -> 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]