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

module Test.Cardano.Ledger.Dijkstra.Examples (
  ledgerExamples,
) where

import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (mkSized)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
import Cardano.Ledger.Conway.Rules (ConwayDELEG, ConwayDelegPredFailure (..))
import Cardano.Ledger.Dijkstra (DijkstraEra)
import Cardano.Ledger.Dijkstra.Rules (DijkstraLEDGER)
import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..))
import Cardano.Ledger.Dijkstra.TxBody (TxBody (..))
import Cardano.Ledger.Dijkstra.TxCert
import Cardano.Ledger.Mary.Value (MaryValue (..))
import Cardano.Ledger.Plutus.Data (
  Datum (..),
  dataToBinaryData,
 )
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.API (
  ApplyTxError (..),
  Credential (..),
  RewardAccount (..),
  TxId (..),
 )
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.TxIn (mkTxInPartial)
import Control.State.Transition.Extended (Embed (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
import Test.Cardano.Ledger.Alonzo.Examples (
  exampleDatum,
  exampleTx,
  mkLedgerExamples,
 )
import Test.Cardano.Ledger.Babbage.Examples (exampleBabbageNewEpochState, exampleCollateralOutput)
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
import Test.Cardano.Ledger.Dijkstra.Era ()
import Test.Cardano.Ledger.Dijkstra.ImpTest (exampleDijkstraGenesis)
import Test.Cardano.Ledger.Mary.Examples (exampleMultiAssetValue)
import Test.Cardano.Ledger.Shelley.Examples (
  LedgerExamples (..),
  examplePayKey,
  exampleStakeKey,
  exampleStakePoolParams,
  keyToCredential,
  mkKeyHash,
  mkScriptHash,
 )

ledgerExamples :: LedgerExamples DijkstraEra
ledgerExamples :: LedgerExamples DijkstraEra
ledgerExamples =
  ApplyTxError DijkstraEra
-> NewEpochState DijkstraEra
-> Tx TopTx DijkstraEra
-> TranslationContext DijkstraEra
-> LedgerExamples DijkstraEra
forall era.
AlonzoEraPParams era =>
ApplyTxError era
-> NewEpochState era
-> Tx TopTx era
-> TranslationContext era
-> LedgerExamples era
mkLedgerExamples
    ( NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra))
-> ApplyTxError DijkstraEra
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra))
 -> ApplyTxError DijkstraEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra))
-> ApplyTxError DijkstraEra
forall a b. (a -> b) -> a -> b
$
        PredicateFailure (EraRule "LEDGER" DijkstraEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" DijkstraEra)
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra)))
-> PredicateFailure (EraRule "LEDGER" DijkstraEra)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" DijkstraEra))
forall a b. (a -> b) -> a -> b
$
          forall sub super.
Embed sub super =>
PredicateFailure sub -> PredicateFailure super
wrapFailed @(ConwayDELEG DijkstraEra) @(DijkstraLEDGER DijkstraEra) (PredicateFailure (ConwayDELEG DijkstraEra)
 -> PredicateFailure (DijkstraLEDGER DijkstraEra))
-> PredicateFailure (ConwayDELEG DijkstraEra)
-> PredicateFailure (DijkstraLEDGER DijkstraEra)
forall a b. (a -> b) -> a -> b
$
            forall era. KeyHash StakePool -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG @DijkstraEra (Int -> KeyHash StakePool
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
1)
    )
    NewEpochState DijkstraEra
forall era.
(BabbageEraTest era, Value era ~ MaryValue) =>
NewEpochState era
exampleBabbageNewEpochState
    Tx TopTx DijkstraEra
exampleTxDijkstra
    TranslationContext DijkstraEra
DijkstraGenesis
exampleDijkstraGenesis

exampleTxDijkstra :: Tx TopTx DijkstraEra
exampleTxDijkstra :: Tx TopTx DijkstraEra
exampleTxDijkstra =
  TxBody TopTx DijkstraEra
-> PlutusPurpose AsIx DijkstraEra
-> NativeScript DijkstraEra
-> Tx TopTx DijkstraEra
forall era.
(AlonzoEraTx era, EraPlutusTxInfo 'PlutusV1 era,
 TxAuxData era ~ AlonzoTxAuxData era,
 Script era ~ AlonzoScript era) =>
TxBody TopTx era
-> PlutusPurpose AsIx era -> NativeScript era -> Tx TopTx era
exampleTx
    TxBody TopTx DijkstraEra
exampleTxBodyDijkstra
    (AsIx Word32 TxIn -> DijkstraPlutusPurpose AsIx DijkstraEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> DijkstraPlutusPurpose f era
DijkstraSpending (AsIx Word32 TxIn -> DijkstraPlutusPurpose AsIx DijkstraEra)
-> AsIx Word32 TxIn -> DijkstraPlutusPurpose AsIx DijkstraEra
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
0)
    (forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf @DijkstraEra StrictSeq (NativeScript DijkstraEra)
StrictSeq (DijkstraNativeScript DijkstraEra)
forall a. Monoid a => a
mempty)

exampleTxBodyDijkstra :: TxBody TopTx DijkstraEra
exampleTxBodyDijkstra :: TxBody TopTx DijkstraEra
exampleTxBodyDijkstra =
  (EncCBOR (Tx SubTx DijkstraEra), Eq (Tx SubTx DijkstraEra),
 NFData (Tx SubTx DijkstraEra), Show (Tx SubTx DijkstraEra),
 DecCBOR (Annotator (Tx SubTx DijkstraEra)),
 HasOKey TxId (Tx SubTx DijkstraEra)) =>
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut DijkstraEra))
-> StrictMaybe (Sized (TxOut DijkstraEra))
-> StrictMaybe Coin
-> OSet (TxCert DijkstraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> OSet (Credential Guard)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> VotingProcedures DijkstraEra
-> OSet (ProposalProcedure DijkstraEra)
-> StrictMaybe Coin
-> Coin
-> OMap TxId (Tx SubTx DijkstraEra)
-> TxBody TopTx DijkstraEra
Set TxIn
-> Set TxIn
-> Set TxIn
-> StrictSeq (Sized (TxOut DijkstraEra))
-> StrictMaybe (Sized (TxOut DijkstraEra))
-> StrictMaybe Coin
-> OSet (TxCert DijkstraEra)
-> Withdrawals
-> Coin
-> ValidityInterval
-> OSet (Credential Guard)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> VotingProcedures DijkstraEra
-> OSet (ProposalProcedure DijkstraEra)
-> StrictMaybe Coin
-> Coin
-> OMap TxId (Tx SubTx DijkstraEra)
-> TxBody TopTx DijkstraEra
DijkstraTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
1)) Integer
0]) -- spending inputs
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
2)) Integer
1]) -- collateral inputs
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial (SafeHash EraIndependentTxBody -> TxId
TxId (Int -> SafeHash EraIndependentTxBody
forall a. Int -> SafeHash a
mkDummySafeHash Int
1)) Integer
3]) -- reference inputs
    ( [Sized (BabbageTxOut DijkstraEra)]
-> StrictSeq (Sized (BabbageTxOut DijkstraEra))
forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ Version
-> BabbageTxOut DijkstraEra -> Sized (BabbageTxOut DijkstraEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @DijkstraEra) (BabbageTxOut DijkstraEra -> Sized (BabbageTxOut DijkstraEra))
-> BabbageTxOut DijkstraEra -> Sized (BabbageTxOut DijkstraEra)
forall a b. (a -> b) -> a -> b
$
            Addr
-> Value DijkstraEra
-> Datum DijkstraEra
-> StrictMaybe (Script DijkstraEra)
-> BabbageTxOut DijkstraEra
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
BabbageTxOut
              (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)
              (BinaryData DijkstraEra -> Datum DijkstraEra
forall era. BinaryData era -> Datum era
Datum (BinaryData DijkstraEra -> Datum DijkstraEra)
-> BinaryData DijkstraEra -> Datum DijkstraEra
forall a b. (a -> b) -> a -> b
$ Data DijkstraEra -> BinaryData DijkstraEra
forall era. Data era -> BinaryData era
dataToBinaryData Data DijkstraEra
forall era. Era era => Data era
exampleDatum) -- inline datum
              (Script DijkstraEra -> StrictMaybe (Script DijkstraEra)
forall a. a -> StrictMaybe a
SJust (Script DijkstraEra -> StrictMaybe (Script DijkstraEra))
-> Script DijkstraEra -> StrictMaybe (Script DijkstraEra)
forall a b. (a -> b) -> a -> b
$ forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV2 Natural
3) -- reference script
        ]
    )
    (Sized (TxOut DijkstraEra)
-> StrictMaybe (Sized (TxOut DijkstraEra))
forall a. a -> StrictMaybe a
SJust (Sized (TxOut DijkstraEra)
 -> StrictMaybe (Sized (TxOut DijkstraEra)))
-> Sized (TxOut DijkstraEra)
-> StrictMaybe (Sized (TxOut DijkstraEra))
forall a b. (a -> b) -> a -> b
$ Version
-> BabbageTxOut DijkstraEra -> Sized (BabbageTxOut DijkstraEra)
forall a. EncCBOR a => Version -> a -> Sized a
mkSized (forall era. Era era => Version
eraProtVerHigh @DijkstraEra) BabbageTxOut DijkstraEra
forall era.
(BabbageEraTxOut era, Value era ~ MaryValue) =>
BabbageTxOut era
exampleCollateralOutput) -- collateral return
    (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Coin -> StrictMaybe Coin) -> Coin -> StrictMaybe Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
8675309) -- collateral tot
    OSet (TxCert DijkstraEra)
OSet (DijkstraTxCert DijkstraEra)
forall era. OSet (DijkstraTxCert era)
exampleDijkstraCerts
    ( Map RewardAccount Coin -> Withdrawals
Withdrawals (Map RewardAccount Coin -> Withdrawals)
-> Map RewardAccount Coin -> Withdrawals
forall a b. (a -> b) -> a -> b
$
        RewardAccount -> Coin -> Map RewardAccount Coin
forall k a. k -> a -> Map k a
Map.singleton
          (Network -> Credential Staking -> RewardAccount
RewardAccount Network
Testnet (KeyPair Staking -> Credential Staking
forall (r :: KeyRole). KeyPair r -> Credential r
keyToCredential KeyPair Staking
exampleStakeKey))
          (Integer -> Coin
Coin Integer
100) -- txwdrls
    )
    (Integer -> Coin
Coin Integer
999) -- txfee
    (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))) -- txvldt
    ([Credential Guard] -> OSet (Credential Guard)
forall a. Ord a => [a] -> OSet a
OSet.fromList [KeyHash Guard -> Credential Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Guard -> Credential Guard)
-> KeyHash Guard -> Credential Guard
forall a b. (a -> b) -> a -> b
$ Int -> KeyHash Guard
forall (discriminator :: KeyRole). Int -> KeyHash discriminator
mkKeyHash Int
212, ScriptHash -> Credential Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Guard) -> ScriptHash -> Credential Guard
forall a b. (a -> b) -> a -> b
$ Int -> ScriptHash
mkScriptHash Int
213]) -- guards
    MultiAsset
exampleMultiAsset -- mint
    (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash)
-> ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a b. (a -> b) -> a -> b
$ Int -> ScriptIntegrityHash
forall a. Int -> SafeHash a
mkDummySafeHash Int
42) -- scriptIntegrityHash
    (TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust (TxAuxDataHash -> StrictMaybe TxAuxDataHash)
-> (SafeHash EraIndependentTxAuxData -> TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData
-> StrictMaybe TxAuxDataHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentTxAuxData -> TxAuxDataHash
TxAuxDataHash (SafeHash EraIndependentTxAuxData -> StrictMaybe TxAuxDataHash)
-> SafeHash EraIndependentTxAuxData -> StrictMaybe TxAuxDataHash
forall a b. (a -> b) -> a -> b
$ Int -> SafeHash EraIndependentTxAuxData
forall a. Int -> SafeHash a
mkDummySafeHash Int
42) -- adHash
    (Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet) -- txnetworkid
    (Map Voter (Map GovActionId (VotingProcedure DijkstraEra))
-> VotingProcedures DijkstraEra
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures Map Voter (Map GovActionId (VotingProcedure DijkstraEra))
forall a. Monoid a => a
mempty)
    OSet (ProposalProcedure DijkstraEra)
forall a. Monoid a => a
mempty
    (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust (Coin -> StrictMaybe Coin) -> Coin -> StrictMaybe Coin
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
867530900000) -- current treasury value
    Coin
forall a. Monoid a => a
mempty
    OMap TxId (Tx SubTx DijkstraEra)
forall a. Monoid a => a
mempty
  where
    MaryValue Coin
_ MultiAsset
exampleMultiAsset = Int -> MaryValue
exampleMultiAssetValue Int
3

exampleDijkstraCerts :: OSet.OSet (DijkstraTxCert era)
exampleDijkstraCerts :: forall era. OSet (DijkstraTxCert era)
exampleDijkstraCerts =
  [DijkstraTxCert era] -> OSet (DijkstraTxCert era)
forall a. Ord a => [a] -> OSet a
OSet.fromList -- TODO should I add the new certs here?
    [ PoolCert -> DijkstraTxCert era
forall era. PoolCert -> DijkstraTxCert era
DijkstraTxCertPool (StakePoolParams -> PoolCert
RegPool StakePoolParams
exampleStakePoolParams)
    ]