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

-- | The example transactions in this module are not valid transactions. We
-- don't care, we are only interested in serialisation, not validation.
module Test.Cardano.Ledger.Mary.Examples (
  ledgerExamples,
  exampleMaryBasedTx,
  exampleMultiAsset,
  exampleMultiAssetValue,
) where

import Cardano.Ledger.Allegra.Scripts (AllegraEraScript)
import Cardano.Ledger.Coin
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Mary (ApplyTxError (MaryApplyTxError), MaryEra)
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Value
import Cardano.Ledger.Shelley.Rules (
  ShelleyDelegPredFailure (DelegateeNotRegisteredDELEG),
  ShelleyDelegsPredFailure (DelplFailure),
  ShelleyDelplPredFailure (DelegFailure),
  ShelleyLedgerPredFailure (DelegsFailure),
 )
import qualified Data.Map.Strict as Map (singleton)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable (Typeable)
import Lens.Micro
import Test.Cardano.Ledger.Allegra.Examples (
  exampleAllegraBasedTx,
 )
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples,
  addShelleyBasedTopTxExampleFee,
  addShelleyToBabbageExampleProposedPUpdates,
  addShelleyToBabbageTxCerts,
  addShelleyToConwayTxCerts,
  examplePayKey,
  exampleStakeKey,
  mkKeyHash,
  mkScriptHash,
  mkShelleyBasedLedgerExamples,
 )

ledgerExamples :: LedgerExamples MaryEra
ledgerExamples :: LedgerExamples MaryEra
ledgerExamples =
  ApplyTxError MaryEra
-> Value MaryEra
-> Tx TopTx MaryEra
-> TranslationContext MaryEra
-> LedgerExamples MaryEra
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era,
 Default (StashedAVVMAddresses era), AtMostEra "Mary" era) =>
ApplyTxError era
-> Value era
-> Tx TopTx era
-> TranslationContext era
-> LedgerExamples era
mkShelleyBasedLedgerExamples
    ( NonEmpty (ShelleyLedgerPredFailure MaryEra) -> ApplyTxError MaryEra
MaryApplyTxError (NonEmpty (ShelleyLedgerPredFailure MaryEra)
 -> ApplyTxError MaryEra)
-> (ShelleyDelegPredFailure MaryEra
    -> NonEmpty (ShelleyLedgerPredFailure MaryEra))
-> ShelleyDelegPredFailure MaryEra
-> ApplyTxError MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerPredFailure MaryEra
-> NonEmpty (ShelleyLedgerPredFailure MaryEra)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyLedgerPredFailure MaryEra
 -> NonEmpty (ShelleyLedgerPredFailure MaryEra))
-> (ShelleyDelegPredFailure MaryEra
    -> ShelleyLedgerPredFailure MaryEra)
-> ShelleyDelegPredFailure MaryEra
-> NonEmpty (ShelleyLedgerPredFailure MaryEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELEGS" MaryEra)
-> ShelleyLedgerPredFailure MaryEra
ShelleyDelegsPredFailure MaryEra
-> ShelleyLedgerPredFailure MaryEra
forall era.
PredicateFailure (EraRule "DELEGS" era)
-> ShelleyLedgerPredFailure era
DelegsFailure (ShelleyDelegsPredFailure MaryEra
 -> ShelleyLedgerPredFailure MaryEra)
-> (ShelleyDelegPredFailure MaryEra
    -> ShelleyDelegsPredFailure MaryEra)
-> ShelleyDelegPredFailure MaryEra
-> ShelleyLedgerPredFailure MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELPL" MaryEra)
-> ShelleyDelegsPredFailure MaryEra
ShelleyDelplPredFailure MaryEra -> ShelleyDelegsPredFailure MaryEra
forall era.
PredicateFailure (EraRule "DELPL" era)
-> ShelleyDelegsPredFailure era
DelplFailure (ShelleyDelplPredFailure MaryEra
 -> ShelleyDelegsPredFailure MaryEra)
-> (ShelleyDelegPredFailure MaryEra
    -> ShelleyDelplPredFailure MaryEra)
-> ShelleyDelegPredFailure MaryEra
-> ShelleyDelegsPredFailure MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFailure (EraRule "DELEG" MaryEra)
-> ShelleyDelplPredFailure MaryEra
ShelleyDelegPredFailure MaryEra -> ShelleyDelplPredFailure MaryEra
forall era.
PredicateFailure (EraRule "DELEG" era)
-> ShelleyDelplPredFailure era
DelegFailure (ShelleyDelegPredFailure MaryEra -> ApplyTxError MaryEra)
-> ShelleyDelegPredFailure MaryEra -> ApplyTxError MaryEra
forall a b. (a -> b) -> a -> b
$
        forall era. KeyHash StakePool -> ShelleyDelegPredFailure era
DelegateeNotRegisteredDELEG @MaryEra (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    )
    (Int -> MaryValue
exampleMultiAssetValue Int
1)
    Tx TopTx MaryEra
exampleMaryTx
    TranslationContext MaryEra
NoGenesis MaryEra
forall era. NoGenesis era
NoGenesis
  where
    exampleMaryTx :: Tx TopTx MaryEra
    exampleMaryTx :: Tx TopTx MaryEra
exampleMaryTx =
      Tx TopTx MaryEra
forall era (l :: TxLevel).
(EraTx era, MaryEraTxBody era, Value era ~ MaryValue,
 AllegraEraTxAuxData era, AllegraEraScript era, Typeable l) =>
Tx l era
exampleMaryBasedTx
        Tx TopTx MaryEra
-> (Tx TopTx MaryEra -> Tx TopTx MaryEra) -> Tx TopTx MaryEra
forall a b. a -> (a -> b) -> b
& Tx TopTx MaryEra -> Tx TopTx MaryEra
forall era. EraTx era => Tx TopTx era -> Tx TopTx era
addShelleyBasedTopTxExampleFee
        Tx TopTx MaryEra
-> (Tx TopTx MaryEra -> Tx TopTx MaryEra) -> Tx TopTx MaryEra
forall a b. a -> (a -> b) -> b
& Tx TopTx MaryEra -> Tx TopTx MaryEra
forall era.
(EraTx era, ShelleyEraTxBody era) =>
Tx TopTx era -> Tx TopTx era
addShelleyToBabbageExampleProposedPUpdates
        Tx TopTx MaryEra
-> (Tx TopTx MaryEra -> Tx TopTx MaryEra) -> Tx TopTx MaryEra
forall a b. a -> (a -> b) -> b
& Tx TopTx MaryEra -> Tx TopTx MaryEra
forall era (l :: TxLevel).
(EraTx era, ShelleyEraTxCert era, AtMostEra "Babbage" era) =>
Tx l era -> Tx l era
addShelleyToBabbageTxCerts
        Tx TopTx MaryEra
-> (Tx TopTx MaryEra -> Tx TopTx MaryEra) -> Tx TopTx MaryEra
forall a b. a -> (a -> b) -> b
& Tx TopTx MaryEra -> Tx TopTx MaryEra
forall era (l :: TxLevel).
(EraTx era, ShelleyEraTxCert era) =>
Tx l era -> Tx l era
addShelleyToConwayTxCerts

-- Complete transaction which is compatible with any era starting with Mary.
-- This transaction forms the basis on which future era transactions will be
-- at the very least based on.
exampleMaryBasedTx ::
  forall era l.
  ( EraTx era
  , MaryEraTxBody era
  , Value era ~ MaryValue
  , AllegraEraTxAuxData era
  , AllegraEraScript era
  , Typeable l
  ) =>
  Tx l era
exampleMaryBasedTx :: forall era (l :: TxLevel).
(EraTx era, MaryEraTxBody era, Value era ~ MaryValue,
 AllegraEraTxAuxData era, AllegraEraScript era, Typeable l) =>
Tx l era
exampleMaryBasedTx =
  Tx l era
forall era (l :: TxLevel).
(EraTx era, AllegraEraTxAuxData era, AllegraEraScript era,
 AllegraEraTxBody era, Typeable l) =>
Tx l era
exampleAllegraBasedTx
    Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody l era -> Identity (TxBody l 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)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxOut era) -> Tx l era -> Tx l 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) (Value era -> TxOut era) -> Value era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Int -> MaryValue
exampleMultiAssetValue Int
1
        ]
    Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((MultiAsset -> Identity MultiAsset)
    -> TxBody l era -> Identity (TxBody l era))
-> (MultiAsset -> Identity MultiAsset)
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiAsset -> Identity MultiAsset)
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> Tx l era -> Identity (Tx l era))
-> MultiAsset -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> MultiAsset
exampleMultiAsset Int
1

exampleMultiAssetValue :: Int -> MaryValue
exampleMultiAssetValue :: Int -> MaryValue
exampleMultiAssetValue Int
x = Coin -> MultiAsset -> MaryValue
MaryValue (Integer -> Coin
Coin Integer
100) (MultiAsset -> MaryValue) -> MultiAsset -> MaryValue
forall a b. (a -> b) -> a -> b
$ Int -> MultiAsset
exampleMultiAsset Int
x

exampleMultiAsset :: Int -> MultiAsset
exampleMultiAsset :: Int -> MultiAsset
exampleMultiAsset Int
x =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton PolicyID
policyId (Map AssetName Integer -> Map PolicyID (Map AssetName Integer))
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall a b. (a -> b) -> a -> b
$ AssetName -> Integer -> Map AssetName Integer
forall k a. k -> a -> Map k a
Map.singleton AssetName
couttsCoin Integer
1000)
  where
    policyId :: PolicyID
policyId = ScriptHash -> PolicyID
PolicyID (ScriptHash -> PolicyID) -> ScriptHash -> PolicyID
forall a b. (a -> b) -> a -> b
$ Int -> ScriptHash
mkScriptHash Int
x
    couttsCoin :: AssetName
    couttsCoin :: AssetName
couttsCoin = ShortByteString -> AssetName
AssetName ShortByteString
"couttsCoin"