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

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

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Mary (Mary)
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.Class (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 Mary))) (LedgerState Mary) ->
  Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (UTxO Mary)
ignoreAllButUTxO :: Either
  (NonEmpty
     (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
  (LedgerState (MaryEra StandardCrypto))
-> Either
     (NonEmpty
        (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
     (UTxO (MaryEra StandardCrypto))
ignoreAllButUTxO = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(LedgerState (UTxOState UTxO (MaryEra StandardCrypto)
utxo Coin
_ Coin
_ GovState (MaryEra StandardCrypto)
_ IncrementalStake (EraCrypto (MaryEra StandardCrypto))
_ Coin
_) CertState (MaryEra StandardCrypto)
_) -> UTxO (MaryEra StandardCrypto)
utxo)

testMaryNoDelegLEDGER ::
  HasCallStack =>
  UTxO Mary ->
  ShelleyTx Mary ->
  LedgerEnv Mary ->
  Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (UTxO Mary) ->
  Assertion
testMaryNoDelegLEDGER :: HasCallStack =>
UTxO (MaryEra StandardCrypto)
-> ShelleyTx (MaryEra StandardCrypto)
-> LedgerEnv (MaryEra StandardCrypto)
-> Either
     (NonEmpty
        (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
     (UTxO (MaryEra StandardCrypto))
-> Assertion
testMaryNoDelegLEDGER UTxO (MaryEra StandardCrypto)
utxo ShelleyTx (MaryEra StandardCrypto)
tx LedgerEnv (MaryEra StandardCrypto)
env (Right UTxO (MaryEra StandardCrypto)
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 Mary) forall a. ShelleyBase a -> a
runShelleyBase LedgerEnv (MaryEra StandardCrypto)
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 StandardCrypto)
env) UTxO (MaryEra StandardCrypto)
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 StandardCrypto)
tx
      forall (m :: * -> *) st.
(MonadIO m, Eq st, ToExpr st, HasCallStack) =>
m st -> st -> m st
.->> LedgerState (MaryEra StandardCrypto)
expectedSt'
  where
    txFee :: Coin
txFee = ShelleyTx (MaryEra StandardCrypto)
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 StandardCrypto)
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 StandardCrypto)
env) UTxO (MaryEra StandardCrypto)
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 StandardCrypto)
utxo ShelleyTx (MaryEra StandardCrypto)
tx LedgerEnv (MaryEra StandardCrypto)
env predicateFailure :: Either
  (NonEmpty
     (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
  (UTxO (MaryEra StandardCrypto))
predicateFailure@(Left NonEmpty
  (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto)))
_) = do
  let st :: Either
  (NonEmpty (ShelleyLedgerPredFailure (MaryEra StandardCrypto)))
  (LedgerState (MaryEra StandardCrypto))
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 Mary)
            ( forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                ( LedgerEnv (MaryEra StandardCrypto)
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 StandardCrypto)
env) UTxO (MaryEra StandardCrypto)
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 StandardCrypto)
tx
                )
            )
  Either
  (NonEmpty
     (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
  (LedgerState (MaryEra StandardCrypto))
-> Either
     (NonEmpty
        (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
     (UTxO (MaryEra StandardCrypto))
ignoreAllButUTxO Either
  (NonEmpty (ShelleyLedgerPredFailure (MaryEra StandardCrypto)))
  (LedgerState (MaryEra StandardCrypto))
st forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Either
  (NonEmpty
     (PredicateFailure (ShelleyLEDGER (MaryEra StandardCrypto))))
  (UTxO (MaryEra StandardCrypto))
predicateFailure