{-# LANGUAGE ScopedTypeVariables #-}

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

import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.LedgerState (
  esLStateL,
  lsCertStateL,
  lsUTxOStateL,
  nesELL,
  nesEsL,
  totalObligation,
  utxosDepositedL,
  utxosGovStateL,
 )
import Cardano.Ledger.Val (Val (..))
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 era
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 era
govState <- SimpleGetter (NewEpochState era) (GovState era)
-> ImpTestM era (GovState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (GovState era)
 -> ImpTestM era (GovState era))
-> SimpleGetter (NewEpochState era) (GovState era)
-> ImpTestM era (GovState 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))
-> ((GovState era -> Const r (GovState era))
    -> EpochState era -> Const r (EpochState era))
-> (GovState era -> Const r (GovState 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))
-> ((GovState era -> Const r (GovState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (GovState era -> Const r (GovState era))
-> 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))
-> ((GovState era -> Const r (GovState era))
    -> UTxOState era -> Const r (UTxOState era))
-> (GovState era -> Const r (GovState era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const r (GovState era))
-> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL
      CertState era -> GovState era -> Coin
forall era.
(EraGov era, EraCertState era) =>
CertState era -> GovState era -> Coin
totalObligation CertState era
certState GovState era
govState Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
forall t. Val t => t
zero
    do
      Coin
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
      Coin
deposited Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
forall t. Val t => t
zero
    String -> Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era ()
submitTxAnn_ String
"simple transaction" (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody 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
    EpochNo
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 Word32
n <- ImpM (LedgerSpec era) (Positive Word32)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
    Natural -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs (Natural -> ImpM (LedgerSpec era) ())
-> Natural -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n
    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 ImpTestM era EpochNo -> EpochNo -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
n)