{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.Examples (
  ledgerExamples,
  exampleConwayCerts,
) where

import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Conway.Rules (ConwayDELEG, ConwayDelegPredFailure (..), ConwayLEDGER)
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Conway.TxBody (TxBody (..))
import Cardano.Ledger.Conway.TxCert
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 (..),
  RewardAccount (..),
  TxId (..),
 )
import Cardano.Ledger.TxIn (mkTxInPartial)
import Control.State.Transition.Extended (Embed (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
import Test.Cardano.Ledger.Alonzo.Examples (
  exampleDatum,
  exampleTx,
  mkLedgerExamples,
 )
import Test.Cardano.Ledger.Babbage.Examples (exampleBabbageNewEpochState, exampleCollateralOutput)
import Test.Cardano.Ledger.Conway.Era ()
import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis)
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 (..),
  examplePayKey,
  examplePoolParams,
  exampleStakeKey,
  keyToCredential,
  mkKeyHash,
 )

ledgerExamples :: LedgerExamples ConwayEra
ledgerExamples :: LedgerExamples ConwayEra
ledgerExamples =
  ApplyTxError ConwayEra
-> NewEpochState ConwayEra
-> Tx ConwayEra
-> TranslationContext ConwayEra
-> LedgerExamples ConwayEra
forall era.
AlonzoEraPParams era =>
ApplyTxError era
-> NewEpochState era
-> Tx era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
    ( NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
-> ApplyTxError ConwayEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
 -> ApplyTxError ConwayEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
-> ApplyTxError ConwayEra
forall a b. (a -> b) -> a -> b
$
        PredicateFailure (EraRule "LEDGER" ConwayEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" ConwayEra)
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra)))
-> PredicateFailure (EraRule "LEDGER" ConwayEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" ConwayEra))
forall a b. (a -> b) -> a -> b
$
          forall sub super.
Embed sub super =>
PredicateFailure sub -> PredicateFailure super
wrapFailed @(ConwayDELEG ConwayEra) @(ConwayLEDGER ConwayEra) (PredicateFailure (ConwayDELEG ConwayEra)
 -> PredicateFailure (ConwayLEDGER ConwayEra))
-> PredicateFailure (ConwayDELEG ConwayEra)
-> PredicateFailure (ConwayLEDGER ConwayEra)
forall a b. (a -> b) -> a -> b
$
            forall era. KeyHash 'StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG @ConwayEra (Int -> KeyHash 'StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    )
    NewEpochState ConwayEra
forall era.
(BabbageEraTest era, Value era ~ MaryValue) =>
NewEpochState era
exampleBabbageNewEpochState
    Tx ConwayEra
exampleTxConway
    TranslationContext ConwayEra
ConwayGenesis
exampleConwayGenesis

exampleTxConway :: Tx ConwayEra
exampleTxConway :: Tx ConwayEra
exampleTxConway = TxBody ConwayEra -> PlutusPurpose AsIx ConwayEra -> Tx ConwayEra
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 ConwayEra
exampleTxBodyConway (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
ConwaySpending (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra)
-> AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)

exampleTxBodyConway :: TxBody ConwayEra
exampleTxBodyConway :: TxBody ConwayEra
exampleTxBodyConway =
  Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut ConwayEra))
-> StrictMaybe (Sized (TxOut ConwayEra))
-> StrictMaybe Coin
-> OSet (TxCert ConwayEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> VotingProcedures ConwayEra
-> OSet (ProposalProcedure ConwayEra)
-> StrictMaybe Coin
-> Coin
-> TxBody ConwayEra
ConwayTxBody
    ([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 ConwayEra)]
-> StrictSeq (Sized (BabbageTxOut ConwayEra))
forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ Version -> BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @ConwayEra) (BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra))
-> BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra)
forall a b. (a -> b) -> a -> b
$
            Addr
-> Value ConwayEra
-> Datum ConwayEra
-> StrictMaybe (Script ConwayEra)
-> BabbageTxOut ConwayEra
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 ConwayEra -> Datum ConwayEra
forall era. BinaryData era -> Datum era
Datum (BinaryData ConwayEra -> Datum ConwayEra)
-> BinaryData ConwayEra -> Datum ConwayEra
forall a b. (a -> b) -> a -> b
$ Data ConwayEra -> BinaryData ConwayEra
forall era. Data era -> BinaryData era
dataToBinaryData Data ConwayEra
forall era. Era era => Data era
exampleDatum) -- inline datum
              (Script ConwayEra -> StrictMaybe (Script ConwayEra)
forall a. a -> StrictMaybe a
SJust (Script ConwayEra -> StrictMaybe (Script ConwayEra))
-> Script ConwayEra -> StrictMaybe (Script ConwayEra)
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 ConwayEra) -> StrictMaybe (Sized (TxOut ConwayEra))
forall a. a -> StrictMaybe a
SJust (Sized (TxOut ConwayEra) -> StrictMaybe (Sized (TxOut ConwayEra)))
-> Sized (TxOut ConwayEra) -> StrictMaybe (Sized (TxOut ConwayEra))
forall a b. (a -> b) -> a -> b
$ Version -> BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @ConwayEra) BabbageTxOut ConwayEra
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
    OSet (TxCert ConwayEra)
OSet (ConwayTxCert ConwayEra)
forall era. OSet (ConwayTxCert era)
exampleConwayCerts
    ( 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
    (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
    (Map Voter (Map GovActionId (VotingProcedure ConwayEra))
-> VotingProcedures ConwayEra
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures Map Voter (Map GovActionId (VotingProcedure ConwayEra))
forall a. Monoid a => a
mempty)
    OSet (ProposalProcedure ConwayEra)
forall a. Monoid a => a
mempty
    (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
867530900000) -- current treasury value
    Coin
forall a. Monoid a => a
mempty
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
exampleMultiAssetValue Int
3

exampleConwayCerts :: OSet.OSet (ConwayTxCert era)
exampleConwayCerts :: forall era. OSet (ConwayTxCert era)
exampleConwayCerts =
  [ConwayTxCert era] -> OSet (ConwayTxCert era)
forall a. Ord a => [a] -> OSet a
OSet.fromList -- TODO add all possible certificates
    [PoolCert -> ConwayTxCert era
forall era. PoolCert -> ConwayTxCert era
ConwayTxCertPool (PoolParams -> PoolCert
RegPool PoolParams
examplePoolParams)]

exampleConwayGenesis :: ConwayGenesis
exampleConwayGenesis :: ConwayGenesis
exampleConwayGenesis = ConwayGenesis
expectedConwayGenesis