{-# 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,
  exampleMaryTx,
  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 qualified Cardano.Ledger.Shelley.Rules as Shelley
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
Shelley.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
Shelley.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
Shelley.DelegFailure (ShelleyDelegPredFailure MaryEra -> ApplyTxError MaryEra)
-> ShelleyDelegPredFailure MaryEra -> ApplyTxError MaryEra
forall a b. (a -> b) -> a -> b
$
        forall era. KeyHash StakePool -> ShelleyDelegPredFailure era
Shelley.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

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"