{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Mary.Examples (
  testMaryNoDelegLEDGER,
) where

import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Shelley.API (LedgerEnv (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  LedgerStateWithLimits (..),
  UTxOState (..),
  smartUTxOState,
 )
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.State (UTxO)
import Control.State.Transition.Extended hiding (Assertion)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty)
import GHC.Stack
import Lens.Micro
import Test.Cardano.Ledger.Mary.TreeDiff ()
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
import Test.Control.State.Transition.Trace (checkTrace, (.-), (.->>))
import Test.Tasty.HUnit (Assertion, (@?=))

ignoreAllButUTxO ::
  Either (NonEmpty (PredicateFailure (Shelley.LEDGER MaryEra))) (LedgerStateWithLimits MaryEra) ->
  Either (NonEmpty (PredicateFailure (Shelley.LEDGER MaryEra))) (UTxO MaryEra)
ignoreAllButUTxO :: Either
  (NonEmpty (PredicateFailure (LEDGER MaryEra)))
  (LedgerStateWithLimits MaryEra)
-> Either
     (NonEmpty (PredicateFailure (LEDGER MaryEra))) (UTxO MaryEra)
ignoreAllButUTxO = (LedgerStateWithLimits MaryEra -> UTxO MaryEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra))
     (LedgerStateWithLimits MaryEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
forall a b.
(a -> b)
-> Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) a
-> Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(LedgerStateWithLimits (LedgerState (UTxOState UTxO MaryEra
utxo Coin
_ Coin
_ GovState MaryEra
_ InstantStake MaryEra
_ Coin
_) CertState MaryEra
_ StrictMaybe EbAnnouncement
_) BlockBodyLimits MaryEra
_) -> UTxO MaryEra
utxo)

testMaryNoDelegLEDGER ::
  HasCallStack =>
  UTxO MaryEra ->
  Tx TopTx MaryEra ->
  LedgerEnv MaryEra ->
  Either (NonEmpty (PredicateFailure (Shelley.LEDGER MaryEra))) (UTxO MaryEra) ->
  Assertion
testMaryNoDelegLEDGER :: HasCallStack =>
UTxO MaryEra
-> Tx TopTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (LEDGER MaryEra))) (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER UTxO MaryEra
utxo Tx TopTx MaryEra
tx LedgerEnv MaryEra
env (Right UTxO MaryEra
expectedUTxO) =
  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 @(Shelley.LEDGER MaryEra) ShelleyBase a -> a
forall a. ShelleyBase a -> a
runShelleyBase LedgerEnv MaryEra
Environment (LEDGER MaryEra)
env (ReaderT
   (State (LEDGER MaryEra)
    -> Signal (LEDGER MaryEra)
    -> Either
         (NonEmpty (PredicateFailure (LEDGER MaryEra)))
         (State (LEDGER MaryEra)))
   IO
   (State (LEDGER MaryEra))
 -> Assertion)
-> ReaderT
     (State (LEDGER MaryEra)
      -> Signal (LEDGER MaryEra)
      -> Either
           (NonEmpty (PredicateFailure (LEDGER MaryEra)))
           (State (LEDGER MaryEra)))
     IO
     (State (LEDGER MaryEra))
-> Assertion
forall a b. (a -> b) -> a -> b
$ do
    st <- LedgerStateWithLimits MaryEra
-> ReaderT
     (LedgerStateWithLimits MaryEra
      -> Tx TopTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerStateWithLimits MaryEra))
     IO
     (LedgerStateWithLimits MaryEra)
forall a.
a
-> ReaderT
     (LedgerStateWithLimits MaryEra
      -> Tx TopTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerStateWithLimits MaryEra))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState MaryEra
-> BlockBodyLimits MaryEra -> LedgerStateWithLimits MaryEra
forall era.
LedgerState era -> BlockBodyLimits era -> LedgerStateWithLimits era
LedgerStateWithLimits LedgerState MaryEra
initSt BlockBodyLimits MaryEra
ShelleyBlockBodyLimits MaryEra
forall a. Monoid a => a
mempty) ReaderT
  (LedgerStateWithLimits MaryEra
   -> Tx TopTx MaryEra
   -> Either
        (NonEmpty (ShelleyLedgerPredFailure MaryEra))
        (LedgerStateWithLimits MaryEra))
  IO
  (LedgerStateWithLimits MaryEra)
-> Tx TopTx MaryEra
-> ReaderT
     (LedgerStateWithLimits MaryEra
      -> Tx TopTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerStateWithLimits MaryEra))
     IO
     (LedgerStateWithLimits MaryEra)
forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- Tx TopTx MaryEra
tx
    _ <- pure (lswlLedgerState st) .->> expectedSt'
    pure st
  where
    initSt :: LedgerState MaryEra
initSt = UTxOState MaryEra
-> CertState MaryEra
-> StrictMaybe EbAnnouncement
-> LedgerState MaryEra
forall era.
UTxOState era
-> CertState era -> StrictMaybe EbAnnouncement -> LedgerState era
LedgerState (PParams MaryEra
-> UTxO MaryEra
-> Coin
-> Coin
-> GovState MaryEra
-> Coin
-> UTxOState MaryEra
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (LedgerEnv MaryEra -> PParams MaryEra
forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) GovState MaryEra
ShelleyGovState MaryEra
forall a. Default a => a
def Coin
forall a. Monoid a => a
mempty) CertState MaryEra
ShelleyCertState MaryEra
forall a. Default a => a
def StrictMaybe EbAnnouncement
forall a. StrictMaybe a
SNothing
    txFee :: Coin
txFee = Tx TopTx MaryEra
tx Tx TopTx MaryEra -> Getting Coin (Tx TopTx MaryEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx MaryEra -> Const Coin (TxBody TopTx MaryEra))
-> Tx TopTx MaryEra -> Const Coin (Tx TopTx MaryEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l MaryEra) (TxBody l MaryEra)
bodyTxL ((TxBody TopTx MaryEra -> Const Coin (TxBody TopTx MaryEra))
 -> Tx TopTx MaryEra -> Const Coin (Tx TopTx MaryEra))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx MaryEra -> Const Coin (TxBody TopTx MaryEra))
-> Getting Coin (Tx TopTx MaryEra) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx MaryEra -> Const Coin (TxBody TopTx MaryEra)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx MaryEra) Coin
feeTxBodyL
    expectedSt' :: LedgerState MaryEra
expectedSt' = UTxOState MaryEra
-> CertState MaryEra
-> StrictMaybe EbAnnouncement
-> LedgerState MaryEra
forall era.
UTxOState era
-> CertState era -> StrictMaybe EbAnnouncement -> LedgerState era
LedgerState (PParams MaryEra
-> UTxO MaryEra
-> Coin
-> Coin
-> GovState MaryEra
-> Coin
-> UTxOState MaryEra
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (LedgerEnv MaryEra -> PParams MaryEra
forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
expectedUTxO (Integer -> Coin
Coin Integer
0) Coin
txFee GovState MaryEra
ShelleyGovState MaryEra
forall a. Default a => a
def Coin
forall a. Monoid a => a
mempty) CertState MaryEra
ShelleyCertState MaryEra
forall a. Default a => a
def StrictMaybe EbAnnouncement
forall a. StrictMaybe a
SNothing
testMaryNoDelegLEDGER UTxO MaryEra
utxo Tx TopTx MaryEra
tx LedgerEnv MaryEra
env predicateFailure :: Either
  (NonEmpty (PredicateFailure (LEDGER MaryEra))) (UTxO MaryEra)
predicateFailure@(Left NonEmpty (PredicateFailure (LEDGER MaryEra))
_) = do
  let st :: Either
  (NonEmpty (ShelleyLedgerPredFailure MaryEra))
  (LedgerStateWithLimits MaryEra)
st =
        ShelleyBase
  (Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra))
     (LedgerStateWithLimits MaryEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra))
     (LedgerStateWithLimits MaryEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyLedgerPredFailure MaryEra))
      (LedgerStateWithLimits MaryEra))
 -> Either
      (NonEmpty (ShelleyLedgerPredFailure MaryEra))
      (LedgerStateWithLimits MaryEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyLedgerPredFailure MaryEra))
        (LedgerStateWithLimits MaryEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra))
     (LedgerStateWithLimits MaryEra)
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 @(Shelley.LEDGER MaryEra)
            ( (Environment (LEDGER MaryEra), State (LEDGER MaryEra),
 Signal (LEDGER MaryEra))
-> TRC (LEDGER MaryEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( LedgerEnv MaryEra
Environment (LEDGER MaryEra)
env
                , LedgerState MaryEra
-> BlockBodyLimits MaryEra -> LedgerStateWithLimits MaryEra
forall era.
LedgerState era -> BlockBodyLimits era -> LedgerStateWithLimits era
LedgerStateWithLimits
                    (UTxOState MaryEra
-> CertState MaryEra
-> StrictMaybe EbAnnouncement
-> LedgerState MaryEra
forall era.
UTxOState era
-> CertState era -> StrictMaybe EbAnnouncement -> LedgerState era
LedgerState (PParams MaryEra
-> UTxO MaryEra
-> Coin
-> Coin
-> GovState MaryEra
-> Coin
-> UTxOState MaryEra
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (LedgerEnv MaryEra -> PParams MaryEra
forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) GovState MaryEra
ShelleyGovState MaryEra
forall a. Default a => a
def Coin
forall a. Monoid a => a
mempty) CertState MaryEra
ShelleyCertState MaryEra
forall a. Default a => a
def StrictMaybe EbAnnouncement
forall a. StrictMaybe a
SNothing)
                    BlockBodyLimits MaryEra
ShelleyBlockBodyLimits MaryEra
forall a. Monoid a => a
mempty
                , Tx TopTx MaryEra
Signal (LEDGER MaryEra)
tx
                )
            )
  Either
  (NonEmpty (PredicateFailure (LEDGER MaryEra)))
  (LedgerStateWithLimits MaryEra)
-> Either
     (NonEmpty (PredicateFailure (LEDGER MaryEra))) (UTxO MaryEra)
ignoreAllButUTxO Either
  (NonEmpty (PredicateFailure (LEDGER MaryEra)))
  (LedgerStateWithLimits MaryEra)
Either
  (NonEmpty (ShelleyLedgerPredFailure MaryEra))
  (LedgerStateWithLimits MaryEra)
st Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
-> Assertion
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (LEDGER MaryEra))) (UTxO MaryEra)
Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
predicateFailure