{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Dijkstra.ImpTest (
  module Test.Cardano.Ledger.Conway.ImpTest,
  exampleDijkstraGenesis,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (..),
  EpochInterval (..),
  addEpochInterval,
  knownNonZeroBounded,
 )
import Cardano.Ledger.Conway.Governance (ConwayEraGov (..), committeeMembersL)
import Cardano.Ledger.Conway.Rules (
  ConwayCertPredFailure (..),
  ConwayCertsPredFailure (..),
  ConwayDelegPredFailure (..),
  ConwayLedgerPredFailure (..),
 )
import Cardano.Ledger.Dijkstra (DijkstraEra)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Genesis (DijkstraGenesis (..))
import Cardano.Ledger.Dijkstra.PParams (UpgradeDijkstraPParams (..))
import Cardano.Ledger.Plutus (SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState (epochStateGovStateL, nesEsL)
import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Data.Maybe (fromJust)
import Lens.Micro ((%~), (&))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Dijkstra.Era ()

instance ShelleyEraImp DijkstraEra where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (Genesis DijkstraEra)
initGenesis = DijkstraGenesis -> m DijkstraGenesis
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DijkstraGenesis
exampleDijkstraGenesis

  initNewEpochState :: forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadFail m) =>
m (NewEpochState DijkstraEra)
initNewEpochState = (NewEpochState (PreviousEra DijkstraEra)
 -> NewEpochState (PreviousEra DijkstraEra))
-> m (NewEpochState DijkstraEra)
forall era g s (m :: * -> *).
(MonadState s m, HasKeyPairs s, HasStatefulGen g m, MonadFail m,
 ShelleyEraImp era, ShelleyEraImp (PreviousEra era),
 TranslateEra era NewEpochState,
 TranslationError era NewEpochState ~ Void,
 TranslationContext era ~ Genesis era) =>
(NewEpochState (PreviousEra era)
 -> NewEpochState (PreviousEra era))
-> m (NewEpochState era)
defaultInitNewEpochState ((NewEpochState (PreviousEra DijkstraEra)
  -> NewEpochState (PreviousEra DijkstraEra))
 -> m (NewEpochState DijkstraEra))
-> (NewEpochState (PreviousEra DijkstraEra)
    -> NewEpochState (PreviousEra DijkstraEra))
-> m (NewEpochState DijkstraEra)
forall a b. (a -> b) -> a -> b
$ \NewEpochState (PreviousEra DijkstraEra)
nes ->
    NewEpochState (PreviousEra DijkstraEra)
NewEpochState ConwayEra
nes
      NewEpochState ConwayEra
-> (NewEpochState ConwayEra -> NewEpochState ConwayEra)
-> NewEpochState ConwayEra
forall a b. a -> (a -> b) -> b
& (EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState ConwayEra -> Identity (EpochState ConwayEra))
 -> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra))
-> ((StrictMaybe (Committee ConwayEra)
     -> Identity (StrictMaybe (Committee ConwayEra)))
    -> EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> Identity (StrictMaybe (Committee ConwayEra)))
-> NewEpochState ConwayEra
-> Identity (NewEpochState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState ConwayEra -> Identity (GovState ConwayEra))
-> EpochState ConwayEra -> Identity (EpochState ConwayEra)
(ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
-> EpochState ConwayEra -> Identity (EpochState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> EpochState era -> f (EpochState era)
epochStateGovStateL ((ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
 -> EpochState ConwayEra -> Identity (EpochState ConwayEra))
-> ((StrictMaybe (Committee ConwayEra)
     -> Identity (StrictMaybe (Committee ConwayEra)))
    -> ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> Identity (StrictMaybe (Committee ConwayEra)))
-> EpochState ConwayEra
-> Identity (EpochState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee ConwayEra)
 -> Identity (StrictMaybe (Committee ConwayEra)))
-> GovState ConwayEra -> Identity (GovState ConwayEra)
(StrictMaybe (Committee ConwayEra)
 -> Identity (StrictMaybe (Committee ConwayEra)))
-> ConwayGovState ConwayEra -> Identity (ConwayGovState ConwayEra)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState ConwayEra) (StrictMaybe (Committee ConwayEra))
committeeGovStateL ((StrictMaybe (Committee ConwayEra)
  -> Identity (StrictMaybe (Committee ConwayEra)))
 -> NewEpochState ConwayEra -> Identity (NewEpochState ConwayEra))
-> (StrictMaybe (Committee ConwayEra)
    -> StrictMaybe (Committee ConwayEra))
-> NewEpochState ConwayEra
-> NewEpochState ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Committee ConwayEra -> Committee ConwayEra)
-> StrictMaybe (Committee ConwayEra)
-> StrictMaybe (Committee ConwayEra)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Committee ConwayEra -> Committee ConwayEra
forall {era}. Committee era -> Committee era
updateCommitteeExpiry
    where
      updateCommitteeExpiry :: Committee era -> Committee era
updateCommitteeExpiry =
        (Map (Credential 'ColdCommitteeRole) EpochNo
 -> Identity (Map (Credential 'ColdCommitteeRole) EpochNo))
-> Committee era -> Identity (Committee era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'ColdCommitteeRole) EpochNo
 -> f (Map (Credential 'ColdCommitteeRole) EpochNo))
-> Committee era -> f (Committee era)
committeeMembersL
          ((Map (Credential 'ColdCommitteeRole) EpochNo
  -> Identity (Map (Credential 'ColdCommitteeRole) EpochNo))
 -> Committee era -> Identity (Committee era))
-> (Map (Credential 'ColdCommitteeRole) EpochNo
    -> Map (Credential 'ColdCommitteeRole) EpochNo)
-> Committee era
-> Committee era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (EpochNo -> EpochNo)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> Map (Credential 'ColdCommitteeRole) EpochNo
forall a b.
(a -> b)
-> Map (Credential 'ColdCommitteeRole) a
-> Map (Credential 'ColdCommitteeRole) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochNo -> EpochNo -> EpochNo
forall a b. a -> b -> a
const (EpochNo -> EpochNo -> EpochNo) -> EpochNo -> EpochNo -> EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval (forall era. Era era => EpochNo
impEraStartEpochNo @DijkstraEra) (Word32 -> EpochInterval
EpochInterval Word32
15))

  impSatisfyNativeScript :: Set (KeyHash 'Witness)
-> TxBody DijkstraEra
-> NativeScript DijkstraEra
-> ImpTestM
     DijkstraEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impSatisfyNativeScript = Set (KeyHash 'Witness)
-> TxBody DijkstraEra
-> NativeScript DijkstraEra
-> ImpTestM
     DijkstraEra (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
forall era.
(AllegraEraScript era, AllegraEraTxBody era,
 NativeScript era ~ Timelock era) =>
Set (KeyHash 'Witness)
-> TxBody era
-> NativeScript era
-> ImpTestM era (Maybe (Map (KeyHash 'Witness) (KeyPair 'Witness)))
impAllegraSatisfyNativeScript

  modifyPParams :: (PParams DijkstraEra -> PParams DijkstraEra)
-> ImpTestM DijkstraEra ()
modifyPParams = (PParams DijkstraEra -> PParams DijkstraEra)
-> ImpTestM DijkstraEra ()
forall era.
ConwayEraGov era =>
(PParams era -> PParams era) -> ImpTestM era ()
conwayModifyPParams

  fixupTx :: HasCallStack =>
Tx DijkstraEra -> ImpTestM DijkstraEra (Tx DijkstraEra)
fixupTx = Tx DijkstraEra -> ImpTestM DijkstraEra (Tx DijkstraEra)
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era (Tx era)
babbageFixupTx
  expectTxSuccess :: HasCallStack => Tx DijkstraEra -> ImpTestM DijkstraEra ()
expectTxSuccess = Tx DijkstraEra -> ImpTestM DijkstraEra ()
forall era.
(HasCallStack, AlonzoEraImp era, BabbageEraTxBody era) =>
Tx era -> ImpTestM era ()
impBabbageExpectTxSuccess

instance MaryEraImp DijkstraEra

instance AlonzoEraImp DijkstraEra where
  scriptTestContexts :: Map ScriptHash ScriptTestContext
scriptTestContexts =
    SLanguage 'PlutusV1 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1
      Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV2 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV2
SPlutusV2
      Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
-> Map ScriptHash ScriptTestContext
forall a. Semigroup a => a -> a -> a
<> SLanguage 'PlutusV3 -> Map ScriptHash ScriptTestContext
forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> Map ScriptHash ScriptTestContext
plutusTestScripts SLanguage 'PlutusV3
SPlutusV3

instance ConwayEraImp DijkstraEra

-- Partial implementation used for checking predicate failures
instance InjectRuleFailure "LEDGER" ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "LEDGER" DijkstraEra
injectFailure = PredicateFailure (EraRule "CERTS" DijkstraEra)
-> ConwayLedgerPredFailure DijkstraEra
ConwayCertsPredFailure DijkstraEra
-> ConwayLedgerPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "CERTS" era)
-> ConwayLedgerPredFailure era
ConwayCertsFailure (ConwayCertsPredFailure DijkstraEra
 -> ConwayLedgerPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayCertsPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> ConwayLedgerPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERTS" DijkstraEra
ShelleyDelegPredFailure DijkstraEra
-> ConwayCertsPredFailure DijkstraEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERTS" ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERTS" DijkstraEra
injectFailure = PredicateFailure (EraRule "CERT" DijkstraEra)
-> ConwayCertsPredFailure DijkstraEra
ConwayCertPredFailure DijkstraEra
-> ConwayCertsPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "CERT" era) -> ConwayCertsPredFailure era
CertFailure (ConwayCertPredFailure DijkstraEra
 -> ConwayCertsPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayCertPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> ConwayCertsPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERT" DijkstraEra
ShelleyDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "CERT" ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "CERT" DijkstraEra
injectFailure = PredicateFailure (EraRule "DELEG" DijkstraEra)
-> ConwayCertPredFailure DijkstraEra
ConwayDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "DELEG" era) -> ConwayCertPredFailure era
DelegFailure (ConwayDelegPredFailure DijkstraEra
 -> ConwayCertPredFailure DijkstraEra)
-> (ShelleyDelegPredFailure DijkstraEra
    -> ConwayDelegPredFailure DijkstraEra)
-> ShelleyDelegPredFailure DijkstraEra
-> ConwayCertPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "DELEG" DijkstraEra
ShelleyDelegPredFailure DijkstraEra
-> ConwayDelegPredFailure DijkstraEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure

instance InjectRuleFailure "DELEG" ShelleyDelegPredFailure DijkstraEra where
  injectFailure :: ShelleyDelegPredFailure DijkstraEra
-> EraRuleFailure "DELEG" DijkstraEra
injectFailure (Shelley.StakeKeyAlreadyRegisteredDELEG Credential 'Staking
c) = Credential 'Staking -> ConwayDelegPredFailure DijkstraEra
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG Credential 'Staking
c
  injectFailure (Shelley.StakeKeyNotRegisteredDELEG Credential 'Staking
c) = Credential 'Staking -> ConwayDelegPredFailure DijkstraEra
forall era. Credential 'Staking -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking
c
  injectFailure (Shelley.StakeKeyNonZeroAccountBalanceDELEG Coin
c) = Coin -> ConwayDelegPredFailure DijkstraEra
forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
c
  injectFailure ShelleyDelegPredFailure DijkstraEra
_ = [Char] -> ConwayDelegPredFailure DijkstraEra
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot inject ShelleyDelegPredFailure into DijkstraEra"

exampleDijkstraGenesis :: DijkstraGenesis
exampleDijkstraGenesis :: DijkstraGenesis
exampleDijkstraGenesis =
  DijkstraGenesis
    { dgUpgradePParams :: UpgradeDijkstraPParams Identity DijkstraEra
dgUpgradePParams =
        UpgradeDijkstraPParams
          { udppMaxRefScriptSizePerBlock :: HKD Identity Word32
udppMaxRefScriptSizePerBlock = Word32
1024 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 -- 1MiB
          , udppMaxRefScriptSizePerTx :: HKD Identity Word32
udppMaxRefScriptSizePerTx = Word32
200 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
1024 -- 200KiB
          , udppRefScriptCostStride :: HKD Identity (NonZero Word32)
udppRefScriptCostStride = forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @25_600 -- 25 KiB
          , udppRefScriptCostMultiplier :: HKD Identity PositiveInterval
udppRefScriptCostMultiplier = Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (HKD Identity PositiveInterval)
 -> HKD Identity PositiveInterval)
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe PositiveInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
1.2
          }
    }