{-# 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.Genesis
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
  ( -- Core
    EraTx era
  , EraTxOut era
  , EraTxBody era
  , EraTxAuxData era
  , EraTxWits era
  , EraScript era
  , EraPParams era
  , EraBlockBody era
  , EraTxCert era
  , -- State
    EraCertState era
  , EraGov era
  , EraStake era
  , EraUTxO era
  , EraAccounts era
  , EraGenesis era
  , -- Arbitrary Core
    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 State
    Arbitrary (CertState era)
  , Arbitrary (GovState era)
  , Arbitrary (InstantStake era)
  , Arbitrary (Accounts era)
  , Arbitrary (AccountState era)
  , -- ToExpr Core
    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 State
    ToExpr (CertState era)
  , ToExpr (GovState era)
  , ToExpr (InstantStake era)
  , ToExpr (Accounts era)
  , ToExpr (AccountState era)
  , -- TranslationContext
    Eq (TranslationContext era)
  , Show (TranslationContext era)
  , Typeable (TranslationContext era)
  , ToJSON (TranslationContext era)
  , FromJSON (TranslationContext era)
  , Arbitrary (TranslationContext era)
  ) =>
  EraTest era
  where
  zeroCostModels :: CostModels

  -- | This is a helper function that allows for creation of an `AccountState` in era agnostic
  -- fashion. There is no equivalent function outside of testing since arguments required for
  -- creation of `AccountState` varies between eras and we can get away with such function in
  -- testing because we allow for such function to be partial.
  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

-- | This is a helper function that uses `mkTestAccountState` to register an account.
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)

-- This is a temporary converter, which is used to test some functionality until UMap is completely removed
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