{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.Block (Block)
import Cardano.Ledger.Shelley ()
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 (C, 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 C -> Assertion
testCHAINExample :: HasCallStack => CHAINExample C -> Assertion
testCHAINExample (CHAINExample ChainState C
initSt Block (BHeader MockCrypto) C
block (Right ChainState C
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 C) ShelleyBase a -> a
forall a. ShelleyBase a -> a
runShelleyBase () (ReaderT
   (State (CHAIN C)
    -> Signal (CHAIN C)
    -> Either
         (NonEmpty (PredicateFailure (CHAIN C))) (State (CHAIN C)))
   IO
   (State (CHAIN C))
 -> Assertion)
-> ReaderT
     (State (CHAIN C)
      -> Signal (CHAIN C)
      -> Either
           (NonEmpty (PredicateFailure (CHAIN C))) (State (CHAIN C)))
     IO
     (State (CHAIN C))
-> Assertion
forall a b. (a -> b) -> a -> b
$
      ( ChainState C
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     (ChainState C)
forall a.
a
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainState C
initSt ReaderT
  (ChainState C
   -> Block (BHeader MockCrypto) C
   -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
  IO
  (ChainState C)
-> Block (BHeader MockCrypto) C
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     (ChainState C)
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) C
block
          ReaderT
  (ChainState C
   -> Block (BHeader MockCrypto) C
   -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
  IO
  (ChainState C)
-> (ChainState C -> ChainState C)
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     (ChainState C)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (NewEpochState C -> Identity (NewEpochState C))
-> ChainState C -> Identity (ChainState C)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState C -> Identity (NewEpochState C))
 -> ChainState C -> Identity (ChainState C))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> NewEpochState C -> Identity (NewEpochState C))
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> ChainState C
-> Identity (ChainState C)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState C -> Identity (NewEpochState C)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState C -> Identity (NewEpochState C))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> NewEpochState C
-> Identity (NewEpochState C)
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 C -> Identity (ChainState C))
-> CompactForm Coin -> ChainState C -> ChainState C
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty
          ReaderT
  (ChainState C
   -> Block (BHeader MockCrypto) C
   -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
  IO
  (ChainState C)
-> (ChainState C -> ChainState C)
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     (ChainState C)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (NewEpochState C -> Identity (NewEpochState C))
-> ChainState C -> Identity (ChainState C)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState C -> Identity (NewEpochState C))
 -> ChainState C -> Identity (ChainState C))
-> ((Map (KeyHash 'StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
    -> NewEpochState C -> Identity (NewEpochState C))
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
-> ChainState C
-> Identity (ChainState C)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState C -> Identity (NewEpochState C)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState C -> Identity (NewEpochState C))
-> ((Map (KeyHash 'StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
    -> PoolDistr -> Identity PoolDistr)
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
-> NewEpochState C
-> Identity (NewEpochState C)
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 C -> Identity (ChainState C))
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> ChainState C
-> ChainState C
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 C
   -> Block (BHeader MockCrypto) C
   -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
  IO
  (ChainState C)
-> ChainState C
-> ReaderT
     (ChainState C
      -> Block (BHeader MockCrypto) C
      -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
     IO
     (ChainState C)
forall (m :: * -> *) st.
(MonadIO m, Eq st, ToExpr st, HasCallStack) =>
m st -> st -> m st
.->> ( ChainState C
expectedSt
                 ChainState C -> (ChainState C -> ChainState C) -> ChainState C
forall a b. a -> (a -> b) -> b
& (NewEpochState C -> Identity (NewEpochState C))
-> ChainState C -> Identity (ChainState C)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState C -> Identity (NewEpochState C))
 -> ChainState C -> Identity (ChainState C))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> NewEpochState C -> Identity (NewEpochState C))
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> ChainState C
-> Identity (ChainState C)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState C -> Identity (NewEpochState C)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState C -> Identity (NewEpochState C))
-> ((CompactForm Coin -> Identity (CompactForm Coin))
    -> PoolDistr -> Identity PoolDistr)
-> (CompactForm Coin -> Identity (CompactForm Coin))
-> NewEpochState C
-> Identity (NewEpochState C)
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 C -> Identity (ChainState C))
-> CompactForm Coin -> ChainState C -> ChainState C
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty
                 ChainState C -> (ChainState C -> ChainState C) -> ChainState C
forall a b. a -> (a -> b) -> b
& (NewEpochState C -> Identity (NewEpochState C))
-> ChainState C -> Identity (ChainState C)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ChainState era -> f (ChainState era)
chainStateNesL ((NewEpochState C -> Identity (NewEpochState C))
 -> ChainState C -> Identity (ChainState C))
-> ((Map (KeyHash 'StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
    -> NewEpochState C -> Identity (NewEpochState C))
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
-> ChainState C
-> Identity (ChainState C)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> NewEpochState C -> Identity (NewEpochState C)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState C -> Identity (NewEpochState C))
-> ((Map (KeyHash 'StakePool) IndividualPoolStake
     -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
    -> PoolDistr -> Identity PoolDistr)
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Identity (Map (KeyHash 'StakePool) IndividualPoolStake))
-> NewEpochState C
-> Identity (NewEpochState C)
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 C -> Identity (ChainState C))
-> (Map (KeyHash 'StakePool) IndividualPoolStake
    -> Map (KeyHash 'StakePool) IndividualPoolStake)
-> ChainState C
-> ChainState C
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 C -> Coin
forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
ChainState era -> Coin
totalAda ChainState C
expectedSt) Coin
maxLLSupply
testCHAINExample (CHAINExample ChainState C
initSt Block (BHeader MockCrypto) C
block predicateFailure :: Either (NonEmpty (PredicateFailure (CHAIN C))) (ChainState C)
predicateFailure@(Left NonEmpty (PredicateFailure (CHAIN C))
_)) = do
  let st :: Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
st = ShelleyBase
  (Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
-> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
 -> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
-> ShelleyBase
     (Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C))
-> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
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 C) ((Environment (CHAIN C), State (CHAIN C), Signal (CHAIN C))
-> TRC (CHAIN C)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (CHAIN C)
ChainState C
initSt, Block (BHeader MockCrypto) C
Signal (CHAIN C)
block))
  Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
st Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
-> Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
-> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either (NonEmpty (PredicateFailure (CHAIN C))) (ChainState C)
Either (NonEmpty (TestChainPredicateFailure C)) (ChainState C)
predicateFailure