{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.Examples.Chain (
  CHAINExample (..),
  testCHAINExample,
) where

import Cardano.Ledger.Block (Block)
import Cardano.Ledger.Coin (knownNonZeroCoin)
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses, nesPdL)
import Cardano.Ledger.State
import Cardano.Protocol.TPraos.BHeader (BHeader)
import Control.State.Transition.Extended hiding (Assertion)
import Data.List.NonEmpty (NonEmpty)
import GHC.Stack
import Lens.Micro
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN, ChainState, chainStateNesL, totalAda)
import Test.Cardano.Ledger.Shelley.TreeDiff (expectExprEqual)
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, maxLLSupply, runShelleyBase)
import Test.Control.State.Transition.Trace (checkTrace, (.-), (.->>))
import Test.Tasty.HUnit (Assertion, (@?=))

data CHAINExample era = CHAINExample
  { forall era. CHAINExample era -> ChainState era
startState :: ChainState era
  -- ^ State to start testing with
  , forall era. CHAINExample era -> Block (BHeader MockCrypto) era
newBlock :: Block (BHeader MockCrypto) era
  -- ^ Block to run chain state transition system on
  , forall era.
CHAINExample era
-> Either
     (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
intendedResult :: Either (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era)
  -- ^ type of fatal error, if failure expected and final chain state if success expected
  }

deriving instance
  ( EraGov era
  , EraTxOut era
  , Show (BlockBody era)
  , Show (CertState era)
  , Show (InstantStake era)
  , Show (StashedAVVMAddresses era)
  , Show (PredicateFailure (EraRule "BBODY" era))
  , Show (PredicateFailure (EraRule "TICK" era))
  , Show (PredicateFailure (EraRule "TICKN" era))
  ) =>
  Show (CHAINExample era)

-- | Runs example, applies chain state transition system rule (STS),
--   and checks that trace ends with expected state or expected error.
testCHAINExample :: HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample :: HasCallStack => CHAINExample ShelleyEra -> Assertion
testCHAINExample (CHAINExample ChainState ShelleyEra
initSt Block (BHeader MockCrypto) ShelleyEra
block (Right ChainState ShelleyEra
expectedSt)) = do
  ( forall s (m :: * -> *).
(STS s, BaseM s ~ m) =>
(forall a. m a -> a)
-> Environment s
-> ReaderT
     (State s
      -> Signal s -> Either (NonEmpty (PredicateFailure s)) (State s))
     IO
     (State s)
-> Assertion
checkTrace @(CHAIN ShelleyEra) ShelleyBase a -> a
forall a. ShelleyBase a -> a
runShelleyBase () (ReaderT
   (State (CHAIN ShelleyEra)
    -> Signal (CHAIN ShelleyEra)
    -> Either
         (NonEmpty (PredicateFailure (CHAIN ShelleyEra)))
         (State (CHAIN ShelleyEra)))
   IO
   (State (CHAIN ShelleyEra))
 -> Assertion)
-> ReaderT
     (State (CHAIN ShelleyEra)
      -> Signal (CHAIN ShelleyEra)
      -> Either
           (NonEmpty (PredicateFailure (CHAIN ShelleyEra)))
           (State (CHAIN ShelleyEra)))
     IO
     (State (CHAIN ShelleyEra))
-> Assertion
forall a b. (a -> b) -> a -> b
$
      ( ChainState ShelleyEra
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     (ChainState ShelleyEra)
forall a.
a
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainState ShelleyEra
initSt ReaderT
  (ChainState ShelleyEra
   -> Block (BHeader MockCrypto) ShelleyEra
   -> Either
        (NonEmpty (TestChainPredicateFailure ShelleyEra))
        (ChainState ShelleyEra))
  IO
  (ChainState ShelleyEra)
-> Block (BHeader MockCrypto) ShelleyEra
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     (ChainState ShelleyEra)
forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- Block (BHeader MockCrypto) ShelleyEra
block
          ReaderT
  (ChainState ShelleyEra
   -> Block (BHeader MockCrypto) ShelleyEra
   -> Either
        (NonEmpty (TestChainPredicateFailure ShelleyEra))
        (ChainState ShelleyEra))
  IO
  (ChainState ShelleyEra)
-> (ChainState ShelleyEra -> ChainState ShelleyEra)
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     (ChainState ShelleyEra)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ChainState ShelleyEra -> Identity (ChainState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> ((NonZero Coin -> Identity (NonZero Coin))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (NonZero Coin -> Identity (NonZero Coin))
-> ChainState ShelleyEra
-> Identity (ChainState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ((NonZero Coin -> Identity (NonZero Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (NonZero Coin -> Identity (NonZero Coin))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonZero Coin -> Identity (NonZero Coin))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (NonZero Coin)
poolDistrTotalL ((NonZero Coin -> Identity (NonZero Coin))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> NonZero Coin -> ChainState ShelleyEra -> ChainState ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
          ReaderT
  (ChainState ShelleyEra
   -> Block (BHeader MockCrypto) ShelleyEra
   -> Either
        (NonEmpty (TestChainPredicateFailure ShelleyEra))
        (ChainState ShelleyEra))
  IO
  (ChainState ShelleyEra)
-> (ChainState ShelleyEra -> ChainState ShelleyEra)
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     (ChainState ShelleyEra)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ChainState ShelleyEra -> Identity (ChainState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> ((Map (KeyHash StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> ChainState ShelleyEra
-> Identity (ChainState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ((Map (KeyHash StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
    -> PoolDistr -> Identity PoolDistr)
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) IndividualPoolStake
 -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (Map (KeyHash StakePool) IndividualPoolStake)
poolDistrDistrL ((Map (KeyHash StakePool) IndividualPoolStake
  -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Map (KeyHash StakePool) IndividualPoolStake)
-> ChainState ShelleyEra
-> ChainState ShelleyEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map (KeyHash StakePool) IndividualPoolStake
-> (IndividualPoolStake -> IndividualPoolStake)
-> Map (KeyHash StakePool) IndividualPoolStake
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CompactForm Coin -> Identity (CompactForm Coin))
-> IndividualPoolStake -> Identity IndividualPoolStake
Lens' IndividualPoolStake (CompactForm Coin)
individualTotalPoolStakeL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> IndividualPoolStake -> Identity IndividualPoolStake)
-> CompactForm Coin -> IndividualPoolStake -> IndividualPoolStake
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty)
      )
        ReaderT
  (ChainState ShelleyEra
   -> Block (BHeader MockCrypto) ShelleyEra
   -> Either
        (NonEmpty (TestChainPredicateFailure ShelleyEra))
        (ChainState ShelleyEra))
  IO
  (ChainState ShelleyEra)
-> ChainState ShelleyEra
-> ReaderT
     (ChainState ShelleyEra
      -> Block (BHeader MockCrypto) ShelleyEra
      -> Either
           (NonEmpty (TestChainPredicateFailure ShelleyEra))
           (ChainState ShelleyEra))
     IO
     (ChainState ShelleyEra)
forall (m :: * -> *) st.
(MonadIO m, Eq st, ToExpr st, HasCallStack) =>
m st -> st -> m st
.->> ( ChainState ShelleyEra
expectedSt
                 ChainState ShelleyEra
-> (ChainState ShelleyEra -> ChainState ShelleyEra)
-> ChainState ShelleyEra
forall a b. a -> (a -> b) -> b
& (NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ChainState ShelleyEra -> Identity (ChainState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> ((NonZero Coin -> Identity (NonZero Coin))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (NonZero Coin -> Identity (NonZero Coin))
-> ChainState ShelleyEra
-> Identity (ChainState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ((NonZero Coin -> Identity (NonZero Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (NonZero Coin -> Identity (NonZero Coin))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonZero Coin -> Identity (NonZero Coin))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (NonZero Coin)
poolDistrTotalL ((NonZero Coin -> Identity (NonZero Coin))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> NonZero Coin -> ChainState ShelleyEra -> ChainState ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
                 ChainState ShelleyEra
-> (ChainState ShelleyEra -> ChainState ShelleyEra)
-> ChainState ShelleyEra
forall a b. a -> (a -> b) -> b
& (NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ChainState ShelleyEra -> Identity (ChainState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> ((Map (KeyHash StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> ChainState ShelleyEra
-> Identity (ChainState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> ((Map (KeyHash StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
    -> PoolDistr -> Identity PoolDistr)
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) IndividualPoolStake
 -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (Map (KeyHash StakePool) IndividualPoolStake)
poolDistrDistrL ((Map (KeyHash StakePool) IndividualPoolStake
  -> Identity (Map (KeyHash StakePool) IndividualPoolStake))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> (Map (KeyHash StakePool) IndividualPoolStake
    -> Map (KeyHash StakePool) IndividualPoolStake)
-> ChainState ShelleyEra
-> ChainState ShelleyEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map (KeyHash StakePool) IndividualPoolStake
-> (IndividualPoolStake -> IndividualPoolStake)
-> Map (KeyHash StakePool) IndividualPoolStake
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (CompactForm Coin -> Identity (CompactForm Coin))
-> IndividualPoolStake -> Identity IndividualPoolStake
Lens' IndividualPoolStake (CompactForm Coin)
individualTotalPoolStakeL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> IndividualPoolStake -> Identity IndividualPoolStake)
-> CompactForm Coin -> IndividualPoolStake -> IndividualPoolStake
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty)
             )
    )
    Assertion -> Assertion -> Assertion
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Coin -> Coin -> Assertion
forall a. (Eq a, ToExpr a) => a -> a -> Assertion
expectExprEqual (ChainState ShelleyEra -> Coin
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
ChainState era -> Coin
totalAda ChainState ShelleyEra
expectedSt) Coin
maxLLSupply
testCHAINExample (CHAINExample ChainState ShelleyEra
initSt Block (BHeader MockCrypto) ShelleyEra
block predicateFailure :: Either
  (NonEmpty (PredicateFailure (CHAIN ShelleyEra)))
  (ChainState ShelleyEra)
predicateFailure@(Left NonEmpty (PredicateFailure (CHAIN ShelleyEra))
_)) = do
  let st :: Either
  (NonEmpty (TestChainPredicateFailure ShelleyEra))
  (ChainState ShelleyEra)
st = ShelleyBase
  (Either
     (NonEmpty (TestChainPredicateFailure ShelleyEra))
     (ChainState ShelleyEra))
-> Either
     (NonEmpty (TestChainPredicateFailure ShelleyEra))
     (ChainState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (TestChainPredicateFailure ShelleyEra))
      (ChainState ShelleyEra))
 -> Either
      (NonEmpty (TestChainPredicateFailure ShelleyEra))
      (ChainState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (TestChainPredicateFailure ShelleyEra))
        (ChainState ShelleyEra))
-> Either
     (NonEmpty (TestChainPredicateFailure ShelleyEra))
     (ChainState ShelleyEra)
forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(CHAIN ShelleyEra) ((Environment (CHAIN ShelleyEra), State (CHAIN ShelleyEra),
 Signal (CHAIN ShelleyEra))
-> TRC (CHAIN ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (CHAIN ShelleyEra)
ChainState ShelleyEra
initSt, Block (BHeader MockCrypto) ShelleyEra
Signal (CHAIN ShelleyEra)
block))
  Either
  (NonEmpty (TestChainPredicateFailure ShelleyEra))
  (ChainState ShelleyEra)
st Either
  (NonEmpty (TestChainPredicateFailure ShelleyEra))
  (ChainState ShelleyEra)
-> Either
     (NonEmpty (TestChainPredicateFailure ShelleyEra))
     (ChainState ShelleyEra)
-> Assertion
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (CHAIN ShelleyEra)))
  (ChainState ShelleyEra)
Either
  (NonEmpty (TestChainPredicateFailure ShelleyEra))
  (ChainState ShelleyEra)
predicateFailure