{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Babbage.Examples (
  ledgerExamples,
  exampleBabbageNewEpochState,
  exampleCollateralOutput,
) where

import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..))
import Cardano.Ledger.Alonzo.Translation ()
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..), TxBody (..))
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Mary.Value (MaryValue (..))
import Cardano.Ledger.Plutus.Data (
  Datum (..),
  dataToBinaryData,
 )
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.API (
  ApplyTxError (..),
  Network (..),
  NewEpochState (..),
  ProposedPPUpdates (..),
  RewardAccount (..),
  TxId (..),
  Update (..),
 )
import Cardano.Ledger.Shelley.Rules (ShelleyDelegsPredFailure (..), ShelleyLedgerPredFailure (..))
import Cardano.Ledger.TxIn (mkTxInPartial)
import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
import Test.Cardano.Ledger.Alonzo.Examples (exampleDatum, exampleTx, mkLedgerExamples)
import Test.Cardano.Ledger.Babbage.Era
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
import Test.Cardano.Ledger.Mary.Examples (exampleMultiAssetValue)
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples (..),
  exampleCerts,
  exampleNewEpochState,
  examplePayKey,
  exampleStakeKey,
  keyToCredential,
  mkKeyHash,
 )

ledgerExamples :: LedgerExamples BabbageEra
ledgerExamples :: LedgerExamples BabbageEra
ledgerExamples =
  ApplyTxError BabbageEra
-> NewEpochState BabbageEra
-> Tx BabbageEra
-> TranslationContext BabbageEra
-> LedgerExamples BabbageEra
forall era.
AlonzoEraPParams era =>
ApplyTxError era
-> NewEpochState era
-> Tx era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
    ( NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
-> ApplyTxError BabbageEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
 -> ApplyTxError BabbageEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
-> ApplyTxError BabbageEra
forall a b. (a -> b) -> a -> b
$
        PredicateFailure (EraRule "LEDGER" BabbageEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" BabbageEra)
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra)))
-> PredicateFailure (EraRule "LEDGER" BabbageEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" BabbageEra))
forall a b. (a -> b) -> a -> b
$
          PredicateFailure (EraRule "DELEGS" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure (PredicateFailure (EraRule "DELEGS" BabbageEra)
 -> ShelleyLedgerPredFailure BabbageEra)
-> PredicateFailure (EraRule "DELEGS" BabbageEra)
-> ShelleyLedgerPredFailure BabbageEra
forall a b. (a -> b) -> a -> b
$
            forall era. KeyHash 'StakePool -> ShelleyDelegsPredFailure era
DelegateeNotRegisteredDELEG @BabbageEra (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    )
    NewEpochState BabbageEra
forall era.
(BabbageEraTest era, Value era ~ MaryValue) =>
NewEpochState era
exampleBabbageNewEpochState
    Tx BabbageEra
exampleTxBabbage
    TranslationContext BabbageEra
NoGenesis BabbageEra
forall era. NoGenesis era
NoGenesis

exampleBabbageNewEpochState ::
  ( BabbageEraTest era
  , Value era ~ MaryValue
  ) =>
  NewEpochState era
exampleBabbageNewEpochState :: forall era.
(BabbageEraTest era, Value era ~ MaryValue) =>
NewEpochState era
exampleBabbageNewEpochState =
  Value era -> PParams era -> PParams era -> NewEpochState era
forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era)) =>
Value era -> PParams era -> PParams era -> NewEpochState era
exampleNewEpochState
    (Int -> MaryValue
exampleMultiAssetValue Int
1)
    PParams era
forall era. EraPParams era => PParams era
emptyPParams
    (PParams era
forall era. EraPParams era => PParams era
emptyPParams PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (CoinPerByte -> Identity CoinPerByte)
-> PParams era -> Identity (PParams era)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams era) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams era -> Identity (PParams era))
-> CoinPerByte -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
1))

exampleTxBabbage :: Tx BabbageEra
exampleTxBabbage :: Tx BabbageEra
exampleTxBabbage = TxBody BabbageEra -> PlutusPurpose AsIx BabbageEra -> Tx BabbageEra
forall era.
(AlonzoEraTx era, EraPlutusTxInfo 'PlutusV1 era,
 TxAuxData era ~ AlonzoTxAuxData era, Script era ~ AlonzoScript era,
 NativeScript era ~ Timelock era) =>
TxBody era -> PlutusPurpose AsIx era -> Tx era
exampleTx TxBody BabbageEra
exampleTxBodyBabbage (AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx BabbageEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx BabbageEra)
-> AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx BabbageEra
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)

exampleTxBodyBabbage :: TxBody BabbageEra
exampleTxBodyBabbage :: TxBody BabbageEra
exampleTxBodyBabbage =
  Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut BabbageEra))
-> StrictMaybe (Sized (TxOut BabbageEra))
-> StrictMaybe Coin
-> StrictSeq (TxCert BabbageEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update BabbageEra)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> TxBody BabbageEra
BabbageTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
1)) Integer
0]) -- spending inputs
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
2)) Integer
1]) -- collateral inputs
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
1)) Integer
3]) -- reference inputs
    ( [Sized (BabbageTxOut BabbageEra)]
-> StrictSeq (Sized (BabbageTxOut BabbageEra))
forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ Version
-> BabbageTxOut BabbageEra -> Sized (BabbageTxOut BabbageEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @BabbageEra) (BabbageTxOut BabbageEra -> Sized (BabbageTxOut BabbageEra))
-> BabbageTxOut BabbageEra -> Sized (BabbageTxOut BabbageEra)
forall a b. (a -> b) -> a -> b
$
            Addr
-> Value BabbageEra
-> Datum BabbageEra
-> StrictMaybe (Script BabbageEra)
-> BabbageTxOut BabbageEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
              (KeyPair 'Payment -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyPair 'Payment
examplePayKey KeyPair 'Staking
exampleStakeKey)
              (Int -> MaryValue
exampleMultiAssetValue Int
2)
              (BinaryData BabbageEra -> Datum BabbageEra
forall era. BinaryData era -> Datum era
Datum (BinaryData BabbageEra -> Datum BabbageEra)
-> BinaryData BabbageEra -> Datum BabbageEra
forall a b. (a -> b) -> a -> b
$ Data BabbageEra -> BinaryData BabbageEra
forall era. Data era -> BinaryData era
dataToBinaryData Data BabbageEra
forall era. Era era => Data era
exampleDatum) -- inline datum
              (Script BabbageEra -> StrictMaybe (Script BabbageEra)
forall a. a -> StrictMaybe a
SJust (Script BabbageEra -> StrictMaybe (Script BabbageEra))
-> Script BabbageEra -> StrictMaybe (Script BabbageEra)
forall a b. (a -> b) -> a -> b
$ forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV2 Natural
3) -- reference script
        ]
    )
    (Sized (TxOut BabbageEra) -> StrictMaybe (Sized (TxOut BabbageEra))
forall a. a -> StrictMaybe a
SJust (Sized (TxOut BabbageEra)
 -> StrictMaybe (Sized (TxOut BabbageEra)))
-> Sized (TxOut BabbageEra)
-> StrictMaybe (Sized (TxOut BabbageEra))
forall a b. (a -> b) -> a -> b
$ Version
-> BabbageTxOut BabbageEra -> Sized (BabbageTxOut BabbageEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @BabbageEra) BabbageTxOut BabbageEra
forall era.
(BabbageEraTxOut era, Value era ~ MaryValue) =>
BabbageTxOut era
exampleCollateralOutput) -- collateral return
    (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Coin -> StrictMaybe Coin) -> Coin -> StrictMaybe Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
8675309) -- collateral tot
    StrictSeq (TxCert BabbageEra)
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
StrictSeq (TxCert era)
exampleCerts
    ( Map RewardAccount Coin -> Withdrawals
Withdrawals (Map RewardAccount Coin -> Withdrawals)
-> Map RewardAccount Coin -> Withdrawals
forall a b. (a -> b) -> a -> b
$
        RewardAccount -> Coin -> Map RewardAccount Coin
forall k a. k -> a -> Map k a
Map.singleton
          (Network -> Credential 'Staking -> RewardAccount
RewardAccount Network
Testnet (KeyPair 'Staking -> Credential 'Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair 'Staking
exampleStakeKey))
          (Integer -> Coin
Coin Integer
100)
    )
    (Integer -> Coin
Coin Integer
999) -- txfee
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
2)) (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (Word64 -> SlotNo
SlotNo Word64
4))) -- txvldt
    ( Update BabbageEra -> StrictMaybe (Update BabbageEra)
forall a. a -> StrictMaybe a
SJust (Update BabbageEra -> StrictMaybe (Update BabbageEra))
-> Update BabbageEra -> StrictMaybe (Update BabbageEra)
forall a b. (a -> b) -> a -> b
$
        ProposedPPUpdates BabbageEra -> EpochNo -> Update BabbageEra
forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update
          ( Map (KeyHash 'Genesis) (PParamsUpdate BabbageEra)
-> ProposedPPUpdates BabbageEra
forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates (Map (KeyHash 'Genesis) (PParamsUpdate BabbageEra)
 -> ProposedPPUpdates BabbageEra)
-> Map (KeyHash 'Genesis) (PParamsUpdate BabbageEra)
-> ProposedPPUpdates BabbageEra
forall a b. (a -> b) -> a -> b
$
              KeyHash 'Genesis
-> PParamsUpdate BabbageEra
-> Map (KeyHash 'Genesis) (PParamsUpdate BabbageEra)
forall k a. k -> a -> Map k a
Map.singleton
                (Int -> KeyHash 'Genesis
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
                (PParamsUpdate BabbageEra
forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate PParamsUpdate BabbageEra
-> (PParamsUpdate BabbageEra -> PParamsUpdate BabbageEra)
-> PParamsUpdate BabbageEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe Word16 -> Identity (StrictMaybe Word16))
-> PParamsUpdate BabbageEra -> Identity (PParamsUpdate BabbageEra)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
Lens' (PParamsUpdate BabbageEra) (StrictMaybe Word16)
ppuMaxBHSizeL ((StrictMaybe Word16 -> Identity (StrictMaybe Word16))
 -> PParamsUpdate BabbageEra -> Identity (PParamsUpdate BabbageEra))
-> StrictMaybe Word16
-> PParamsUpdate BabbageEra
-> PParamsUpdate BabbageEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16 -> StrictMaybe Word16
forall a. a -> StrictMaybe a
SJust Word16
4000)
          )
          (Word64 -> EpochNo
EpochNo Word64
0)
    ) -- txUpdates
    (KeyHash 'Witness -> Set (KeyHash 'Witness)
forall a. a -> Set a
Set.singleton (KeyHash 'Witness -> Set (KeyHash 'Witness))
-> KeyHash 'Witness -> Set (KeyHash 'Witness)
forall a b. (a -> b) -> a -> b
$ Int -> KeyHash 'Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
212) -- reqSignerHashes
    MultiAsset
exampleMultiAsset -- mint
    (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash)
-> ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a b. (a -> b) -> a -> b
$ Int -> ScriptIntegrityHash
forall a. Int -> SafeHash a
mkDummySafeHash Int
42) -- scriptIntegrityHash
    (TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust (TxAuxDataHash -> StrictMaybe TxAuxDataHash)
-> (SafeHash EraIndependentTxAuxData -> TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData
-> StrictMaybe TxAuxDataHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash (SafeHash EraIndependentTxAuxData -> StrictMaybe TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData -> StrictMaybe TxAuxDataHash
forall a b. (a -> b) -> a -> b
$ Int -> SafeHash EraIndependentTxAuxData
forall a. Int -> SafeHash a
mkDummySafeHash Int
42) -- adHash
    (Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet) -- txnetworkid
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
exampleMultiAssetValue Int
3

exampleCollateralOutput ::
  ( BabbageEraTxOut era
  , Value era ~ MaryValue
  ) =>
  BabbageTxOut era
exampleCollateralOutput :: forall era.
(BabbageEraTxOut era, Value era ~ MaryValue) =>
BabbageTxOut era
exampleCollateralOutput =
  Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
    (KeyPair 'Payment -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyPair 'Payment
examplePayKey KeyPair 'Staking
exampleStakeKey)
    (Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
8675309) MultiAsset
forall a. Monoid a => a
mempty)
    Datum era
forall era. Datum era
NoDatum
    StrictMaybe (Script era)
forall a. StrictMaybe a
SNothing