{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Test.Cardano.Ledger.Era (
  EraTest (..),
  EraSpec (..),
  ledgerEraTestMain,
  registerTestAccount,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR)
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 Data.Aeson (FromJSON, ToJSON)
import Data.Functor.Identity
import qualified Data.Map.Strict as Map
import Data.Typeable
import GHC.TypeLits (Symbol, symbolVal)
import Test.Cardano.Ledger.Binary.Golden (cborAnnGoldenSpec)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec)
import Test.Cardano.Ledger.Era.Rules
import Test.Cardano.Ledger.TreeDiff ()

class
  ( -- Core
    EraBlockBody era
  , -- State
    EraCertState era
  , EraGov era
  , EraStake era
  , EraUTxO era
  , EraAccounts era
  , EraGenesis era
  , -- Arbitrary Core
    Arbitrary (Tx TopTx era)
  , Arbitrary (TxBody TopTx era)
  , Arbitrary (TxWits era)
  , Arbitrary (TxOut era)
  , Arbitrary (TxAuxData era)
  , Arbitrary (Script era)
  , Arbitrary (PParamsHKD Identity era)
  , Arbitrary (PParamsHKD StrictMaybe era)
  , Arbitrary (TxCert era)
  , Arbitrary (Value era)
  , Arbitrary (CompactForm (Value era))
  , -- Arbitrary State
    Arbitrary (CertState era)
  , Arbitrary (GovState era)
  , Arbitrary (InstantStake era)
  , Arbitrary (Accounts era)
  , Arbitrary (AccountState era)
  , -- ToExpr Core
    ToExpr (Tx TopTx era)
  , ToExpr (TxBody TopTx era)
  , ToExpr (TxWits era)
  , ToExpr (TxOut era)
  , ToExpr (TxAuxData era)
  , ToExpr (Script era)
  , ToExpr (PParamsHKD Identity era)
  , ToExpr (PParamsHKD StrictMaybe era)
  , ToExpr (TxCert era)
  , ToExpr (Value era)
  , ToExpr (CompactForm (Value era))
  , -- ToExpr State
    ToExpr (CertState era)
  , ToExpr (GovState era)
  , ToExpr (InstantStake era)
  , ToExpr (Accounts era)
  , ToExpr (AccountState era)
  , -- Un-annotated DecCBOR instances
    DecCBOR (Script era)
  , DecCBOR (NativeScript era)
  , DecCBOR (TxAuxData era)
  , DecCBOR (TxWits era)
  , DecCBOR (TxBody TopTx era)
  , DecCBOR (Tx TopTx era)
  , -- TranslationContext
    Eq (TranslationContext era)
  , Show (TranslationContext era)
  , Typeable (TranslationContext era)
  , ToJSON (TranslationContext era)
  , FromJSON (TranslationContext era)
  , Arbitrary (TranslationContext era)
  , UnliftRules era (EraRulesWithFailures era)
  ) =>
  EraTest era
  where
  -- | All Ledger rules with predicate failures
  type EraRulesWithFailures era :: [Symbol]

  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

  -- | Get the full path for the era directory.
  -- An use case for this is for saving golden files in a golden test directory
  -- for each era.
  mkEraFullPath :: FilePath -> IO FilePath

  -- | Example transaction that needs to be provided for each era. Doesn't need
  -- to be valid, but all possible fields must be set to some example value.
  exampleTx :: Tx TopTx era

  -- | Example PParams used for testing. All possible fields must be set.
  examplePParams :: PParams era

  -- | Example PParamsUpdate used for testing. All possible fields must be set.
  examplePParamsUpdate :: PParamsUpdate era

class EraTest era => EraSpec era where
  -- | All of Imp spec that is applicable to this era
  eraImpSpec :: Proxy era -> Spec

-- | This is the main entry point for every era's test suite. It contains all tests that must be
-- supplied by each era through `EraSpec` type class and then some through the extra argument
ledgerEraTestMain ::
  forall era.
  EraSpec era =>
  -- | Tests that are specific to this era, if any.
  Spec ->
  IO ()
ledgerEraTestMain :: forall era. EraSpec era => Spec -> IO ()
ledgerEraTestMain Spec
extraEraSpec =
  Spec -> IO ()
ledgerTestMain (Spec -> IO ()) -> Spec -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall era. Era era => String
eraName @era) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Imp" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ Proxy era -> Spec
forall era. EraSpec era => Proxy era -> Spec
eraImpSpec (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era)
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Binary" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
        String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
          String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Predicate Failures" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
            let
              go :: EraRuleProof era rs' -> Spec
              go :: forall (rs' :: [Symbol]). EraRuleProof era rs' -> Spec
go EraRuleProof era rs'
EraRuleProofEmpty = () -> Spec
forall a. a -> SpecM () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              go (EraRuleProofHead px :: Proxy r
px@(Proxy r
Proxy :: Proxy r) EraRuleProof era xs
nextRule) = do
                String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (Proxy r -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy r
px) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, Arbitrary t,
 HasCallStack) =>
Spec
roundTripEraSpec @era @(EraRuleFailure r era)
                EraRuleProof era xs -> Spec
forall (rs' :: [Symbol]). EraRuleProof era rs' -> Spec
go EraRuleProof era xs
nextRule
             in
              EraRuleProof era (EraRulesWithFailures era) -> Spec
forall (rs' :: [Symbol]). EraRuleProof era rs' -> Spec
go (EraRuleProof era (EraRulesWithFailures era) -> Spec)
-> EraRuleProof era (EraRulesWithFailures era) -> Spec
forall a b. (a -> b) -> a -> b
$ forall era (rs :: [Symbol]).
UnliftRules era rs =>
EraRuleProof era rs
unliftEraRuleProofs @era @(EraRulesWithFailures era)
        String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Golden" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
          (String -> IO String) -> String -> Version -> Tx TopTx era -> Spec
forall a.
(Eq a, Show a, ToCBOR a, DecCBOR (Annotator a), HasCallStack) =>
(String -> IO String) -> String -> Version -> a -> Spec
cborAnnGoldenSpec
            (forall era. EraTest era => String -> IO String
mkEraFullPath @era)
            String
"golden/tx.cbor"
            (forall era. Era era => Version
eraProtVerLow @era)
            (forall era. EraTest era => Tx TopTx era
exampleTx @era)
      String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Era-specific spec" Spec
extraEraSpec

-- | 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)