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

module Test.Cardano.Ledger.Mary.Examples (
  ledgerExamples,
  exampleMaryBasedShelleyTxBody,
  exampleMaryBasedTxBody,
  exampleMultiAssetValue,
) where

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 Lens.Micro
import Test.Cardano.Ledger.Allegra.Examples (
  exampleAllegraBasedShelleyTxBody,
  exampleAllegraBasedTxBody,
  mkAllegraBasedExampleTx,
 )
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples,
  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)
    (TxBody TopTx MaryEra -> Tx TopTx MaryEra
forall era.
(EraTx era, AllegraEraTxAuxData era, AllegraEraScript era) =>
TxBody TopTx era -> Tx TopTx era
mkAllegraBasedExampleTx TxBody TopTx MaryEra
forall era.
(MaryEraTxBody era, ShelleyEraTxBody era, Value era ~ MaryValue) =>
TxBody TopTx era
exampleMaryBasedShelleyTxBody)
    TranslationContext MaryEra
NoGenesis MaryEra
forall era. NoGenesis era
NoGenesis

exampleMaryBasedShelleyTxBody ::
  forall era.
  ( MaryEraTxBody era
  , ShelleyEraTxBody era
  , Value era ~ MaryValue
  ) =>
  TxBody TopTx era
exampleMaryBasedShelleyTxBody :: forall era.
(MaryEraTxBody era, ShelleyEraTxBody era, Value era ~ MaryValue) =>
TxBody TopTx era
exampleMaryBasedShelleyTxBody =
  TxBody TopTx era -> TxBody TopTx era
forall era.
MaryEraTxBody era =>
TxBody TopTx era -> TxBody TopTx era
mkMaryBasedExampleTxBody (Value era -> TxBody TopTx era
forall era.
(AllegraEraTxBody era, ShelleyEraTxBody era) =>
Value era -> TxBody TopTx era
exampleAllegraBasedShelleyTxBody (Int -> MaryValue
exampleMultiAssetValue Int
1))

exampleMaryBasedTxBody ::
  forall era.
  ( MaryEraTxBody era
  , Value era ~ MaryValue
  ) =>
  TxBody TopTx era
exampleMaryBasedTxBody :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
TxBody TopTx era
exampleMaryBasedTxBody =
  TxBody TopTx era -> TxBody TopTx era
forall era.
MaryEraTxBody era =>
TxBody TopTx era -> TxBody TopTx era
mkMaryBasedExampleTxBody (Value era -> TxBody TopTx era
forall era. AllegraEraTxBody era => Value era -> TxBody TopTx era
exampleAllegraBasedTxBody (Int -> MaryValue
exampleMultiAssetValue Int
1))

mkMaryBasedExampleTxBody ::
  forall era.
  MaryEraTxBody era =>
  TxBody TopTx era ->
  TxBody TopTx era
mkMaryBasedExampleTxBody :: forall era.
MaryEraTxBody era =>
TxBody TopTx era -> TxBody TopTx era
mkMaryBasedExampleTxBody 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
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> MultiAsset -> TxBody TopTx era -> TxBody TopTx 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"