{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.Imp.EpochSpec (
  spec,
) where

import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval, epochInfoPure)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.API.Forecast (futureForecast, poolDistrForecastL)
import Cardano.Ledger.Shelley.LedgerState (
  esLStateL,
  esSnapshotsL,
  lsCertStateL,
  lsUTxOStateL,
  msSnapShotL,
  nesELL,
  nesEsL,
  nesStakePoolDistrG,
  ssSnapShotL,
  ssStakeMarkL,
  ssStakeSetL,
  totalObligation,
  utxosDepositedL,
  utxosGovStateL,
 )
import Cardano.Ledger.Slot (epochInfoFirst)
import Cardano.Ledger.Val (Val (..))
import Lens.Micro ((^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"EPOCH" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Runs basic transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    do
      certState <- SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (CertState era)
 -> ImpTestM era (CertState era))
-> SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((CertState era -> Const r (CertState era))
    -> EpochState era -> Const r (EpochState era))
-> (CertState era -> Const r (CertState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((CertState era -> Const r (CertState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (CertState era -> Const r (CertState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
      govState <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL
      totalObligation certState govState `shouldBe` zero
    do
      deposited <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin)
    -> LedgerState era -> Const r (LedgerState era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const r (UTxOState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const r (UTxOState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Coin -> Const r Coin)
    -> UTxOState era -> Const r (UTxOState era))
-> (Coin -> Const r Coin)
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL
      deposited `shouldBe` zero
    String -> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ String
"simple transaction" (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
    ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Crosses epoch boundaries" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    startEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
    Positive n <- arbitrary
    passNEpochs $ fromIntegral n
    getsNES nesELL `shouldReturn` addEpochInterval startEpochNo (EpochInterval n)

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Forecast across the epoch boundary agrees with TICK" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Delegate stake to a fresh pool and cross a boundary, so that the mark snapshot holds that
    -- stake while the set snapshot does not
    pool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    registerPool pool
    stakingCred <- KeyHashObj <$> freshKeyHash
    _ <- registerStakeCredential stakingCred
    delegateStake stakingCred pool
    paymentKeyHash <- freshKeyHash @Payment
    sendCoinTo_ (mkAddr paymentKeyHash stakingCred) (Coin 1_000_000_000)
    passEpoch
    markSnapShot <- getsNES $ nesEsL . esSnapshotsL . ssStakeMarkL . msSnapShotL
    setSnapShot <- getsNES $ nesEsL . esSnapshotsL . ssStakeSetL . ssSnapShotL
    markSnapShot `shouldNotBe` setSnapShot

    globals <- use impGlobalsL
    nes <- getsNES id
    -- The first slot of the next epoch, where TICKF crosses the boundary
    let nextEpochFirstSlot = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ (NewEpochState era
nes NewEpochState era
-> Getting EpochNo (NewEpochState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL))
        forecastPoolDistr = Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
futureForecast Globals
globals SlotNo
nextEpochFirstSlot NewEpochState era
nes Forecast Future era
-> Getting PoolDistr (Forecast Future era) PoolDistr -> PoolDistr
forall s a. s -> Getting a s a -> a
^. Getting PoolDistr (Forecast Future era) PoolDistr
forall era (t :: Timeline).
EraForecast era =>
Lens' (Forecast t era) PoolDistr
forall (t :: Timeline). Lens' (Forecast t era) PoolDistr
poolDistrForecastL
    forecastPoolDistr `shouldNotBe` (nes ^. nesStakePoolDistrG)

    passEpoch
    getsNES nesStakePoolDistrG `shouldReturn` forecastPoolDistr