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

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

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Shelley.API (LedgerEnv (..), ShelleyLEDGER)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), UTxOState (..), smartUTxOState)
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
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 (ShelleyLEDGER MaryEra))) (LedgerState MaryEra) ->
  Either (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))) (UTxO MaryEra)
ignoreAllButUTxO :: Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (LedgerState MaryEra)
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
ignoreAllButUTxO = (LedgerState MaryEra -> UTxO MaryEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState 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 (\(LedgerState (UTxOState UTxO MaryEra
utxo Coin
_ Coin
_ GovState MaryEra
_ InstantStake MaryEra
_ Coin
_) CertState MaryEra
_) -> UTxO MaryEra
utxo)

testMaryNoDelegLEDGER ::
  HasCallStack =>
  UTxO MaryEra ->
  ShelleyTx MaryEra ->
  LedgerEnv MaryEra ->
  Either (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))) (UTxO MaryEra) ->
  Assertion
testMaryNoDelegLEDGER :: HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER UTxO MaryEra
utxo ShelleyTx MaryEra
tx LedgerEnv MaryEra
env (Right UTxO MaryEra
expectedUTxO) = 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 @(ShelleyLEDGER MaryEra) ShelleyBase a -> a
forall a. ShelleyBase a -> a
runShelleyBase LedgerEnv MaryEra
Environment (ShelleyLEDGER MaryEra)
env (ReaderT
   (State (ShelleyLEDGER MaryEra)
    -> Signal (ShelleyLEDGER MaryEra)
    -> Either
         (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
         (State (ShelleyLEDGER MaryEra)))
   IO
   (State (ShelleyLEDGER MaryEra))
 -> Assertion)
-> ReaderT
     (State (ShelleyLEDGER MaryEra)
      -> Signal (ShelleyLEDGER MaryEra)
      -> Either
           (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
           (State (ShelleyLEDGER MaryEra)))
     IO
     (State (ShelleyLEDGER MaryEra))
-> Assertion
forall a b. (a -> b) -> a -> b
$
    LedgerState MaryEra
-> ReaderT
     (LedgerState MaryEra
      -> ShelleyTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerState MaryEra))
     IO
     (LedgerState MaryEra)
forall a.
a
-> ReaderT
     (LedgerState MaryEra
      -> ShelleyTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerState MaryEra))
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState MaryEra -> CertState MaryEra -> LedgerState MaryEra
forall era. UTxOState era -> CertState era -> 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)
      ReaderT
  (LedgerState MaryEra
   -> ShelleyTx MaryEra
   -> Either
        (NonEmpty (ShelleyLedgerPredFailure MaryEra))
        (LedgerState MaryEra))
  IO
  (LedgerState MaryEra)
-> ShelleyTx MaryEra
-> ReaderT
     (LedgerState MaryEra
      -> ShelleyTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerState MaryEra))
     IO
     (LedgerState MaryEra)
forall (m :: * -> *) st sig err.
(MonadIO m, MonadReader (st -> sig -> Either err st) m, Show err,
 HasCallStack) =>
m st -> sig -> m st
.- ShelleyTx MaryEra
tx
      ReaderT
  (LedgerState MaryEra
   -> ShelleyTx MaryEra
   -> Either
        (NonEmpty (ShelleyLedgerPredFailure MaryEra))
        (LedgerState MaryEra))
  IO
  (LedgerState MaryEra)
-> LedgerState MaryEra
-> ReaderT
     (LedgerState MaryEra
      -> ShelleyTx MaryEra
      -> Either
           (NonEmpty (ShelleyLedgerPredFailure MaryEra))
           (LedgerState MaryEra))
     IO
     (LedgerState MaryEra)
forall (m :: * -> *) st.
(MonadIO m, Eq st, ToExpr st, HasCallStack) =>
m st -> st -> m st
.->> LedgerState MaryEra
expectedSt'
  where
    txFee :: Coin
txFee = ShelleyTx MaryEra
tx ShelleyTx MaryEra -> Getting Coin (ShelleyTx MaryEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody MaryEra -> Const Coin (TxBody MaryEra))
-> Tx MaryEra -> Const Coin (Tx MaryEra)
(TxBody MaryEra -> Const Coin (TxBody MaryEra))
-> ShelleyTx MaryEra -> Const Coin (ShelleyTx MaryEra)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx MaryEra) (TxBody MaryEra)
bodyTxL ((TxBody MaryEra -> Const Coin (TxBody MaryEra))
 -> ShelleyTx MaryEra -> Const Coin (ShelleyTx MaryEra))
-> ((Coin -> Const Coin Coin)
    -> TxBody MaryEra -> Const Coin (TxBody MaryEra))
-> Getting Coin (ShelleyTx MaryEra) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody MaryEra -> Const Coin (TxBody MaryEra)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody MaryEra) Coin
feeTxBodyL
    expectedSt' :: LedgerState MaryEra
expectedSt' = UTxOState MaryEra -> CertState MaryEra -> LedgerState MaryEra
forall era. UTxOState era -> CertState era -> 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
testMaryNoDelegLEDGER UTxO MaryEra
utxo ShelleyTx MaryEra
tx LedgerEnv MaryEra
env predicateFailure :: Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (UTxO MaryEra)
predicateFailure@(Left NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))
_) = do
  let st :: Either
  (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState MaryEra)
st =
        ShelleyBase
  (Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra))
     (LedgerState MaryEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState MaryEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyLedgerPredFailure MaryEra))
      (LedgerState MaryEra))
 -> Either
      (NonEmpty (ShelleyLedgerPredFailure MaryEra))
      (LedgerState MaryEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyLedgerPredFailure MaryEra))
        (LedgerState MaryEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState 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 @(ShelleyLEDGER MaryEra)
            ( (Environment (ShelleyLEDGER MaryEra),
 State (ShelleyLEDGER MaryEra), Signal (ShelleyLEDGER MaryEra))
-> TRC (ShelleyLEDGER MaryEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( LedgerEnv MaryEra
Environment (ShelleyLEDGER MaryEra)
env
                , UTxOState MaryEra -> CertState MaryEra -> LedgerState MaryEra
forall era. UTxOState era -> CertState era -> 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
                , ShelleyTx MaryEra
Signal (ShelleyLEDGER MaryEra)
tx
                )
            )
  Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (LedgerState MaryEra)
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
ignoreAllButUTxO Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (LedgerState MaryEra)
Either
  (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState MaryEra)
st Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
-> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (UTxO MaryEra)
Either (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (UTxO MaryEra)
predicateFailure