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

module Test.Cardano.Ledger.Allegra.Examples (
  ledgerExamples,
  exampleAllegraTxBody,
  exampleAllegraTxAuxData,
) where

import Cardano.Ledger.Allegra
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts
import Cardano.Ledger.Allegra.TxAuxData
import Cardano.Ledger.Allegra.TxBody
import Cardano.Ledger.Coin
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Shelley.PParams (Update (..))
import Cardano.Ledger.Shelley.Scripts
import Cardano.Slotting.Slot
import Data.Proxy
import qualified Data.Sequence.Strict as StrictSeq
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples,
  exampleAuxDataMap,
  exampleCerts,
  exampleCoin,
  examplePayKey,
  exampleProposedPPUpdates,
  exampleStakeKey,
  exampleTxIns,
  exampleWithdrawals,
  mkKeyHash,
  mkLedgerExamples,
  mkWitnessesPreAlonzo,
 )

ledgerExamples :: LedgerExamples AllegraEra
ledgerExamples :: LedgerExamples AllegraEra
ledgerExamples =
  (TxBody TopTx AllegraEra -> [KeyPair Witness] -> TxWits AllegraEra)
-> Value AllegraEra
-> TxBody TopTx AllegraEra
-> TxAuxData AllegraEra
-> TranslationContext AllegraEra
-> LedgerExamples AllegraEra
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 PredicateFailure (EraRule "DELEGS" era)
 ~ ShelleyDelegsPredFailure era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ ShelleyLedgerPredFailure era,
 Default (StashedAVVMAddresses era), AtMostEra "Mary" era) =>
(TxBody TopTx era -> [KeyPair Witness] -> TxWits era)
-> Value era
-> TxBody TopTx era
-> TxAuxData era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
    (Proxy AllegraEra
-> TxBody TopTx AllegraEra
-> [KeyPair Witness]
-> ShelleyTxWits AllegraEra
forall era.
EraTx era =>
Proxy era
-> TxBody TopTx era -> [KeyPair Witness] -> ShelleyTxWits era
mkWitnessesPreAlonzo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @AllegraEra))
    Value AllegraEra
Coin
exampleCoin
    (Value AllegraEra -> TxBody TopTx AllegraEra
forall era.
(AllegraEraTxBody era, ShelleyEraTxBody era) =>
Value era -> TxBody TopTx era
exampleAllegraTxBody Value AllegraEra
Coin
exampleCoin)
    AllegraTxAuxData AllegraEra
TxAuxData AllegraEra
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
AllegraTxAuxData era
exampleAllegraTxAuxData
    TranslationContext AllegraEra
NoGenesis AllegraEra
forall era. NoGenesis era
NoGenesis

exampleAllegraTxBody ::
  forall era.
  ( AllegraEraTxBody era
  , ShelleyEraTxBody era
  ) =>
  Value era ->
  TxBody TopTx era
exampleAllegraTxBody :: forall era.
(AllegraEraTxBody era, ShelleyEraTxBody era) =>
Value era -> TxBody TopTx era
exampleAllegraTxBody Value era
value =
  TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
exampleTxIns
    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 s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
StrictSeq.singleton (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) Value era
value)
    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)
forall era.
(ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
StrictSeq (TxCert era)
exampleCerts
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Withdrawals -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Withdrawals
exampleWithdrawals
    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. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx era) Coin
feeTxBodyL ((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
.~ Integer -> Coin
Coin Integer
3
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
AllegraEraTxBody era =>
Lens' (TxBody l era) ValidityInterval
forall (l :: TxLevel). Lens' (TxBody l era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> ValidityInterval -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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))
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Update era) -> Identity (StrictMaybe (Update era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
ShelleyEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (Update era))
Lens' (TxBody TopTx era) (StrictMaybe (Update era))
updateTxBodyL ((StrictMaybe (Update era) -> Identity (StrictMaybe (Update era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictMaybe (Update era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Update era -> StrictMaybe (Update era)
forall a. a -> StrictMaybe a
SJust (ProposedPPUpdates era -> EpochNo -> Update era
forall era. ProposedPPUpdates era -> EpochNo -> Update era
Update ProposedPPUpdates era
forall era. EraPParams era => ProposedPPUpdates era
exampleProposedPPUpdates (Word64 -> EpochNo
EpochNo Word64
0))
    TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictMaybe TxAuxDataHash
-> TxBody TopTx era
-> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust TxAuxDataHash
auxiliaryDataHash
  where
    -- Dummy hash to decouple from the auxiliary data in 'exampleTx'.
    auxiliaryDataHash :: TxAuxDataHash
    auxiliaryDataHash :: TxAuxDataHash
auxiliaryDataHash =
      SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash (SafeHash EraIndependentTxAuxData -> TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData -> TxAuxDataHash
forall a b. (a -> b) -> a -> b
$ Int -> SafeHash EraIndependentTxAuxData
forall a. Int -> SafeHash a
mkDummySafeHash Int
30

exampleTimelock :: AllegraEraScript era => NativeScript era
exampleTimelock :: forall era. AllegraEraScript era => NativeScript era
exampleTimelock =
  Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
2 (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
    [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
          [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
            [ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
0)
            , SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (Word64 -> SlotNo
SlotNo Word64
9)
            ]
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
          [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
            [ KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
0)
            , KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
            ]
      , KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (Int -> KeyHash Witness
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
100)
      ]

exampleAllegraTxAuxData ::
  (AllegraEraScript era, NativeScript era ~ Timelock era) => AllegraTxAuxData era
exampleAllegraTxAuxData :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
AllegraTxAuxData era
exampleAllegraTxAuxData = Map Word64 Metadatum
-> StrictSeq (NativeScript era) -> AllegraTxAuxData era
forall era.
(Era era, EncCBOR (NativeScript era)) =>
Map Word64 Metadatum
-> StrictSeq (NativeScript era) -> AllegraTxAuxData era
AllegraTxAuxData Map Word64 Metadatum
exampleAuxDataMap ([Timelock era] -> StrictSeq (Timelock era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Timelock era
NativeScript era
forall era. AllegraEraScript era => NativeScript era
exampleTimelock])