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

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

import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ApplyTxError (ConwayApplyTxError), 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.TxCert
import Cardano.Ledger.Mary.Value (MaryValue (..))
import Cardano.Ledger.Plutus.Data (
  Datum (..),
  dataToBinaryData,
 )
import Cardano.Ledger.Plutus.Language (Language (..), plutusBinary)
import Control.State.Transition.Extended (Embed (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import Lens.Micro
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
import Test.Cardano.Ledger.Alonzo.Examples (
  exampleDatum,
  mkAlonzoBasedLedgerExamples,
 )
import Test.Cardano.Ledger.Babbage.Examples (
  exampleBabbageBasedTxBody,
  exampleBabbageNewEpochState,
  mkBabbageBasedExampleTx,
 )
import Test.Cardano.Ledger.Conway.Era ()
import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis)
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Mary.Examples (exampleMultiAssetValue)
import Test.Cardano.Ledger.Plutus (alwaysSucceedsPlutus)
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples (..),
  examplePayKey,
  exampleStakeKey,
  exampleStakePoolParams,
  mkKeyHash,
 )

ledgerExamples :: LedgerExamples ConwayEra
ledgerExamples :: LedgerExamples ConwayEra
ledgerExamples =
  ApplyTxError ConwayEra
-> NewEpochState ConwayEra
-> Tx TopTx ConwayEra
-> TranslationContext ConwayEra
-> LedgerExamples ConwayEra
forall era.
AlonzoEraPParams era =>
ApplyTxError era
-> NewEpochState era
-> Tx TopTx era
-> TranslationContext era
-> LedgerExamples era
mkAlonzoBasedLedgerExamples
    ( NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
ConwayApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra)
 -> ApplyTxError ConwayEra)
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
-> ApplyTxError ConwayEra
forall a b. (a -> b) -> a -> b
$
        ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure ConwayEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConwayLedgerPredFailure ConwayEra
 -> NonEmpty (ConwayLedgerPredFailure ConwayEra))
-> ConwayLedgerPredFailure ConwayEra
-> NonEmpty (ConwayLedgerPredFailure 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
    ( TxBody TopTx ConwayEra
-> PlutusPurpose AsIx ConwayEra -> Tx TopTx ConwayEra
forall era.
(AlonzoEraTx era, AlonzoEraTxAuxData era,
 EraPlutusTxInfo 'PlutusV1 era, EraPlutusTxInfo 'PlutusV2 era,
 EraPlutusTxInfo 'PlutusV3 era) =>
TxBody TopTx era -> PlutusPurpose AsIx era -> Tx TopTx era
mkConwayBasedExampleTx
        (StrictSeq (TxCert ConwayEra) -> TxBody TopTx ConwayEra
forall era.
(ConwayEraTxBody era, EraPlutusTxInfo 'PlutusV1 era,
 EraPlutusTxInfo 'PlutusV2 era, EraPlutusTxInfo 'PlutusV3 era,
 Value era ~ MaryValue) =>
StrictSeq (TxCert era) -> TxBody TopTx era
exampleConwayBasedTxBody StrictSeq (TxCert ConwayEra)
StrictSeq (ConwayTxCert ConwayEra)
forall era. StrictSeq (ConwayTxCert era)
exampleConwayCerts)
        (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)
    )
    TranslationContext ConwayEra
ConwayGenesis
exampleConwayGenesis

mkConwayBasedExampleTx ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraTxAuxData era
  , EraPlutusTxInfo 'PlutusV1 era
  , EraPlutusTxInfo 'PlutusV2 era
  , EraPlutusTxInfo 'PlutusV3 era
  ) =>
  TxBody TopTx era ->
  PlutusPurpose AsIx era ->
  Tx TopTx era
mkConwayBasedExampleTx :: forall era.
(AlonzoEraTx era, AlonzoEraTxAuxData era,
 EraPlutusTxInfo 'PlutusV1 era, EraPlutusTxInfo 'PlutusV2 era,
 EraPlutusTxInfo 'PlutusV3 era) =>
TxBody TopTx era -> PlutusPurpose AsIx era -> Tx TopTx era
mkConwayBasedExampleTx TxBody TopTx era
txBody PlutusPurpose AsIx era
scriptPurpose =
  TxBody TopTx era -> PlutusPurpose AsIx era -> Tx TopTx era
forall era.
(AlonzoEraTx era, AlonzoEraTxAuxData era,
 EraPlutusTxInfo 'PlutusV1 era, EraPlutusTxInfo 'PlutusV2 era) =>
TxBody TopTx era -> PlutusPurpose AsIx era -> Tx TopTx era
mkBabbageBasedExampleTx
    TxBody TopTx era
txBody
    PlutusPurpose AsIx era
scriptPurpose
    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL
      ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ ( TxWits era
forall era. EraTxWits era => TxWits era
mkBasicTxWits
              TxWits era -> (TxWits era -> TxWits era) -> TxWits era
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL
                ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> TxWits era -> Identity (TxWits era))
-> Map ScriptHash (Script era) -> TxWits era -> TxWits era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptHash -> Script era -> Map ScriptHash (Script era)
forall k a. k -> a -> Map k a
Map.singleton
                  (forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV3 Natural
3)
                  (forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV3 Natural
3)
          )
    Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL
      ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> (StrictMaybe (TxAuxData era) -> StrictMaybe (TxAuxData era))
-> Tx TopTx era
-> Tx TopTx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (TxAuxData era -> TxAuxData era)
-> StrictMaybe (TxAuxData era) -> StrictMaybe (TxAuxData era)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \TxAuxData era
auxData ->
            TxAuxData era
auxData
              TxAuxData era -> (TxAuxData era -> TxAuxData era) -> TxAuxData era
forall a b. a -> (a -> b) -> b
& (Map Language (NonEmpty PlutusBinary)
 -> Identity (Map Language (NonEmpty PlutusBinary)))
-> TxAuxData era -> Identity (TxAuxData era)
forall era.
AlonzoEraTxAuxData era =>
Lens' (TxAuxData era) (Map Language (NonEmpty PlutusBinary))
Lens' (TxAuxData era) (Map Language (NonEmpty PlutusBinary))
plutusScriptsTxAuxDataL
                ((Map Language (NonEmpty PlutusBinary)
  -> Identity (Map Language (NonEmpty PlutusBinary)))
 -> TxAuxData era -> Identity (TxAuxData era))
-> Map Language (NonEmpty PlutusBinary)
-> TxAuxData era
-> TxAuxData era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Language
-> NonEmpty PlutusBinary -> Map Language (NonEmpty PlutusBinary)
forall k a. k -> a -> Map k a
Map.singleton Language
PlutusV3 (PlutusBinary -> NonEmpty PlutusBinary
forall a. a -> NonEmpty a
NE.singleton (Plutus 'PlutusV3 -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary (forall (l :: Language). Natural -> Plutus l
alwaysSucceedsPlutus @'PlutusV3 Natural
3)))
        )

exampleConwayBasedTxBody ::
  forall era.
  ( ConwayEraTxBody era
  , EraPlutusTxInfo PlutusV1 era
  , EraPlutusTxInfo PlutusV2 era
  , EraPlutusTxInfo PlutusV3 era
  , Value era ~ MaryValue
  ) =>
  StrictSeq.StrictSeq (TxCert era) ->
  TxBody TopTx era
exampleConwayBasedTxBody :: forall era.
(ConwayEraTxBody era, EraPlutusTxInfo 'PlutusV1 era,
 EraPlutusTxInfo 'PlutusV2 era, EraPlutusTxInfo 'PlutusV3 era,
 Value era ~ MaryValue) =>
StrictSeq (TxCert era) -> TxBody TopTx era
exampleConwayBasedTxBody StrictSeq (TxCert era)
certs = StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall era.
(ConwayEraTxBody era, Value era ~ MaryValue,
 EraPlutusTxInfo 'PlutusV3 era) =>
StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
mkConwayBasedExampleTxBody StrictSeq (TxCert era)
certs TxBody TopTx era
forall era.
(BabbageEraTxBody era, EraPlutusTxInfo 'PlutusV1 era,
 EraPlutusTxInfo 'PlutusV2 era, Value era ~ MaryValue) =>
TxBody TopTx era
exampleBabbageBasedTxBody

mkConwayBasedExampleTxBody ::
  forall era.
  ( ConwayEraTxBody era
  , Value era ~ MaryValue
  , EraPlutusTxInfo PlutusV3 era
  ) =>
  StrictSeq.StrictSeq (TxCert era) ->
  TxBody TopTx era ->
  TxBody TopTx era
mkConwayBasedExampleTxBody :: forall era.
(ConwayEraTxBody era, Value era ~ MaryValue,
 EraPlutusTxInfo 'PlutusV3 era) =>
StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
mkConwayBasedExampleTxBody StrictSeq (TxCert era)
certs TxBody TopTx era
txBody =
  TxBody TopTx era
txBody
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL
      ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
            (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)
            TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Datum era -> Identity (Datum era))
-> TxOut era -> Identity (TxOut era)
forall era. BabbageEraTxOut era => Lens' (TxOut era) (Datum era)
Lens' (TxOut era) (Datum era)
datumTxOutL ((Datum era -> Identity (Datum era))
 -> TxOut era -> Identity (TxOut era))
-> Datum era -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BinaryData era -> Datum era
forall era. BinaryData era -> Datum era
Datum (Data era -> BinaryData era
forall era. Data era -> BinaryData era
dataToBinaryData Data era
forall era. Era era => Data era
exampleDatum)
            TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Script era -> StrictMaybe (Script era)
forall a. a -> StrictMaybe a
SJust (forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV3 Natural
3)
        ]
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxCert era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxCert era)
certs
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL ((VotingProcedures era -> Identity (VotingProcedures era))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> VotingProcedures era -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures Map Voter (Map GovActionId (VotingProcedure era))
forall a. Monoid a => a
mempty
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (OSet (ProposalProcedure era)
 -> Identity (OSet (ProposalProcedure era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (OSet (ProposalProcedure era))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
  -> Identity (OSet (ProposalProcedure era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> OSet (ProposalProcedure era)
-> TxBody TopTx era
-> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ OSet (ProposalProcedure era)
forall a. Monoid a => a
mempty
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Coin)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictMaybe Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Integer -> Coin
Coin Integer
867530900000)
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Coin -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
forall a. Monoid a => a
mempty

exampleConwayCerts :: StrictSeq.StrictSeq (ConwayTxCert era)
exampleConwayCerts :: forall era. StrictSeq (ConwayTxCert era)
exampleConwayCerts =
  -- TODO add all possible certificates
  [ConwayTxCert era] -> StrictSeq (ConwayTxCert era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
    [ PoolCert -> ConwayTxCert era
forall era. PoolCert -> ConwayTxCert era
ConwayTxCertPool (StakePoolParams -> PoolCert
RegPool StakePoolParams
exampleStakePoolParams)
    ]

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