{-# 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.UTxO (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(LedgerState (UTxOState UTxO MaryEra
utxo Coin
_ Coin
_ GovState MaryEra
_ IncrementalStake
_ 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) forall a. ShelleyBase a -> a
runShelleyBase LedgerEnv MaryEra
env forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState (forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) forall a. Default a => a
def forall a. Monoid a => a
mempty) forall a. Default a => a
def)
      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
      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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
    expectedSt' :: LedgerState MaryEra
expectedSt' = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState (forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
expectedUTxO (Integer -> Coin
Coin Integer
0) Coin
txFee forall a. Default a => a
def forall a. Monoid a => a
mempty) 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 =
        forall a. ShelleyBase a -> a
runShelleyBase 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)
            ( forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( LedgerEnv MaryEra
env
                , forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState (forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState (forall era. LedgerEnv era -> PParams era
ledgerPp LedgerEnv MaryEra
env) UTxO MaryEra
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) forall a. Default a => a
def forall a. Monoid a => a
mempty) forall a. Default a => a
def
                , ShelleyTx MaryEra
tx
                )
            )
  Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (LedgerState MaryEra)
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
ignoreAllButUTxO Either
  (NonEmpty (ShelleyLedgerPredFailure MaryEra)) (LedgerState MaryEra)
st forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either
  (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
  (UTxO MaryEra)
predicateFailure