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

module Test.Cardano.Ledger.Dijkstra.ImpTest () where

import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
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.Plutus (SLanguage (..))
import Cardano.Ledger.Shelley.LedgerState (epochStateGovStateL, nesEsL)
import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure)
import qualified Cardano.Ledger.Shelley.Rules as Shelley
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
DijkstraGenesis

  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"