{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Test.Cardano.Ledger.Era (
EraTest (..),
registerTestAccount,
accountsFromUMap,
) where
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Plutus (CostModels)
import Cardano.Ledger.State
import Cardano.Ledger.UMap
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (def)
import Data.Functor.Identity
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Typeable
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.TreeDiff ()
class
(
EraTx era
, EraTxOut era
, EraTxBody era
, EraTxAuxData era
, EraTxWits era
, EraScript era
, EraPParams era
, EraBlockBody era
, EraTxCert era
,
EraCertState era
, EraGov era
, EraStake era
, EraUTxO era
, EraAccounts era
,
Arbitrary (Tx era)
, Arbitrary (TxOut era)
, Arbitrary (TxBody era)
, Arbitrary (TxAuxData era)
, Arbitrary (TxWits era)
, Arbitrary (Script era)
, Arbitrary (PParamsHKD Identity era)
, Arbitrary (PParamsHKD StrictMaybe era)
, Arbitrary (TxCert era)
, Arbitrary (Value era)
,
Arbitrary (CertState era)
, Arbitrary (GovState era)
, Arbitrary (InstantStake era)
, Arbitrary (Accounts era)
, Arbitrary (AccountState era)
,
ToExpr (Tx era)
, ToExpr (TxOut era)
, ToExpr (TxBody era)
, ToExpr (TxAuxData era)
, ToExpr (TxWits era)
, ToExpr (Script era)
, ToExpr (PParamsHKD Identity era)
, ToExpr (PParamsHKD StrictMaybe era)
, ToExpr (TxCert era)
, ToExpr (Value era)
,
ToExpr (CertState era)
, ToExpr (GovState era)
, ToExpr (InstantStake era)
, ToExpr (Accounts era)
, ToExpr (AccountState era)
,
Eq (TranslationContext era)
, Show (TranslationContext era)
, Typeable (TranslationContext era)
, ToJSON (TranslationContext era)
, FromJSON (TranslationContext era)
, Arbitrary (TranslationContext era)
) =>
EraTest era
where
zeroCostModels :: CostModels
mkTestAccountState ::
HasCallStack =>
Maybe Ptr ->
CompactForm Coin ->
Maybe (KeyHash 'StakePool) ->
Maybe DRep ->
AccountState era
accountsFromAccountsMap :: Map.Map (Credential 'Staking) (AccountState era) -> Accounts era
accountsToUMap :: Accounts era -> UMap
registerTestAccount ::
(HasCallStack, EraTest era) =>
Credential 'Staking ->
Maybe Ptr ->
CompactForm Coin ->
Maybe (KeyHash 'StakePool) ->
Maybe DRep ->
Accounts era ->
Accounts era
registerTestAccount :: forall era.
(HasCallStack, EraTest era) =>
Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
registerTestAccount Credential 'Staking
cred Maybe Ptr
mPtr CompactForm Coin
deposit Maybe (KeyHash 'StakePool)
mStakePool Maybe DRep
mDRep =
Credential 'Staking
-> AccountState era -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Credential 'Staking
-> AccountState era -> Accounts era -> Accounts era
addAccountState Credential 'Staking
cred (Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
forall era.
(EraTest era, HasCallStack) =>
Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> AccountState era
mkTestAccountState Maybe Ptr
mPtr CompactForm Coin
deposit Maybe (KeyHash 'StakePool)
mStakePool Maybe DRep
mDRep)
accountsFromUMap :: (EraTest era, HasCallStack) => UMap -> Accounts era
accountsFromUMap :: forall era. (EraTest era, HasCallStack) => UMap -> Accounts era
accountsFromUMap UMap
umap =
(Credential 'Staking -> UMElem -> Accounts era -> Accounts era)
-> Accounts era -> Map (Credential 'Staking) UMElem -> Accounts era
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' Credential 'Staking -> UMElem -> Accounts era -> Accounts era
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
EraTest era) =>
Credential 'Staking -> UMElem -> Accounts era -> Accounts era
register Accounts era
forall a. Default a => a
def (UMap -> Map (Credential 'Staking) UMElem
umElems UMap
umap)
where
register :: Credential 'Staking -> UMElem -> Accounts era -> Accounts era
register Credential 'Staking
cred (UMElem StrictMaybe RDPair
mRD Set Ptr
ptrSet StrictMaybe (KeyHash 'StakePool)
smStakePool StrictMaybe DRep
smDRep) =
case StrictMaybe RDPair
mRD of
StrictMaybe RDPair
SNothing -> [Char] -> Accounts era -> Accounts era
forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid UMap state: missing RDPair"
SJust RDPair {CompactForm Coin
rdReward :: CompactForm Coin
rdReward :: RDPair -> CompactForm Coin
rdReward, CompactForm Coin
rdDeposit :: CompactForm Coin
rdDeposit :: RDPair -> CompactForm Coin
rdDeposit} ->
let mPtr :: Maybe Ptr
mPtr =
case Set Ptr -> [Ptr]
forall a. Set a -> [a]
Set.toList Set Ptr
ptrSet of
[] -> Maybe Ptr
forall a. Maybe a
Nothing
[Ptr
ptr] -> Ptr -> Maybe Ptr
forall a. a -> Maybe a
Just Ptr
ptr
[Ptr]
ptrs -> [Char] -> Maybe Ptr
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe Ptr) -> [Char] -> Maybe Ptr
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid UMap state: Can't have more than one pointer: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Ptr] -> [Char]
forall a. Show a => a -> [Char]
show [Ptr]
ptrs
mStakePool :: Maybe (KeyHash 'StakePool)
mStakePool = StrictMaybe (KeyHash 'StakePool) -> Maybe (KeyHash 'StakePool)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe (KeyHash 'StakePool)
smStakePool
mDRep :: Maybe DRep
mDRep = StrictMaybe DRep -> Maybe DRep
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe DRep
smDRep
in Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Map (Credential 'Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts (Credential 'Staking
-> CompactForm Coin -> Map (Credential 'Staking) (CompactForm Coin)
forall k a. k -> a -> Map k a
Map.singleton Credential 'Staking
cred CompactForm Coin
rdReward)
(Accounts era -> Accounts era)
-> (Accounts era -> Accounts era) -> Accounts era -> Accounts era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
forall era.
(HasCallStack, EraTest era) =>
Credential 'Staking
-> Maybe Ptr
-> CompactForm Coin
-> Maybe (KeyHash 'StakePool)
-> Maybe DRep
-> Accounts era
-> Accounts era
registerTestAccount Credential 'Staking
cred Maybe Ptr
mPtr CompactForm Coin
rdDeposit Maybe (KeyHash 'StakePool)
mStakePool Maybe DRep
mDRep