{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.Block (Block)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState (nesPdL)
import Cardano.Ledger.Shelley.Scripts ()
import Cardano.Ledger.State (individualTotalPoolStakeL, poolDistrDistrL, poolDistrTotalL)
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
  }

-- | 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))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (CompactForm Coin -> Identity (CompactForm 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))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompactForm Coin -> Identity (CompactForm Coin))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (CompactForm Coin)
poolDistrTotalL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> CompactForm Coin
-> ChainState ShelleyEra
-> ChainState ShelleyEra
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 -> 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))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> NewEpochState ShelleyEra -> Identity (NewEpochState ShelleyEra))
-> (CompactForm Coin -> Identity (CompactForm 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))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> NewEpochState ShelleyEra
-> Identity (NewEpochState ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompactForm Coin -> Identity (CompactForm Coin))
-> PoolDistr -> Identity PoolDistr
Lens' PoolDistr (CompactForm Coin)
poolDistrTotalL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> ChainState ShelleyEra -> Identity (ChainState ShelleyEra))
-> CompactForm Coin
-> ChainState ShelleyEra
-> ChainState ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty
                 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. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (CHAIN ShelleyEra)))
  (ChainState ShelleyEra)
Either
  (NonEmpty (TestChainPredicateFailure ShelleyEra))
  (ChainState ShelleyEra)
predicateFailure