{-# LANGUAGE GADTs #-}

module Test.Cardano.Ledger.Constrained.Trace.Actions where

import Cardano.Ledger.BaseTypes (addEpochInterval)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..), ConwayTxCert (..))
import Cardano.Ledger.Core
import Cardano.Ledger.DRep (DRepState (DRepState))
import Cardano.Ledger.TxIn (TxId (..), TxIn (..), mkTxInPartial)
import Cardano.Ledger.Val (Val (..))
import Control.Monad (forM_)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import Test.Cardano.Ledger.Constrained.Classes (TxOutF (..))
import Test.Cardano.Ledger.Constrained.Trace.TraceMonad (TraceM, getTerm, updateVar)
import Test.Cardano.Ledger.Constrained.Vars
import Test.Cardano.Ledger.Generic.Proof hiding (lift)

-- ====================================================================
-- Some experiments with updating the state (Stored in the Env)
-- Used as a means to track what applySTS does.

inputsAction :: Era era => Proof era -> Set TxIn -> TraceM era ()
inputsAction :: forall era. Era era => Proof era -> Set TxIn -> TraceM era ()
inputsAction Proof era
proof Set TxIn
is = forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar (forall era.
Era era =>
Proof era -> Term era (Map TxIn (TxOutF era))
utxo Proof era
proof) (\Map TxIn (TxOutF era)
u -> forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map TxIn (TxOutF era)
u Set TxIn
is)

outputsAction :: Reflect era => Proof era -> TxBody era -> [TxOutF era] -> TraceM era ()
outputsAction :: forall era.
Reflect era =>
Proof era -> TxBody era -> [TxOutF era] -> TraceM era ()
outputsAction Proof era
proof TxBody era
txb [TxOutF era]
outs = forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar (forall era.
Era era =>
Proof era -> Term era (Map TxIn (TxOutF era))
utxo Proof era
proof) (\Map TxIn (TxOutF era)
u -> forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (TxOutF era)
u ([TxOutF era] -> Map TxIn (TxOutF era)
makemap [TxOutF era]
outs))
  where
    makemap :: [TxOutF era] -> Map TxIn (TxOutF era)
makemap [TxOutF era]
outPuts = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TxOutF era
out, Integer
n) -> (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
txid Integer
n, TxOutF era
out)) (forall a b. [a] -> [b] -> [(a, b)]
zip [TxOutF era]
outPuts [Integer
0 ..]))
    txid :: TxId
txid = SafeHash EraIndependentTxBody -> TxId
TxId (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txb)

feesAction :: Era era => Coin -> TraceM era ()
feesAction :: forall era. Era era => Coin -> TraceM era ()
feesAction Coin
feeCoin = forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar forall era. Era era => Term era Coin
fees (forall t. Val t => t -> t -> t
<+> Coin
feeCoin)

certAction :: Era era => Proof era -> TxCert era -> TraceM era ()
certAction :: forall era. Era era => Proof era -> TxCert era -> TraceM era ()
certAction p :: Proof era
p@Proof era
Conway TxCert era
cert =
  case TxCert era
cert of
    ConwayTxCertGov (ConwayRegDRep Credential 'DRepRole
cred Coin
_ StrictMaybe Anchor
manchor) -> do
      EpochNo
epoch <- forall era a. Term era a -> TraceM era a
getTerm forall era. Era era => Term era EpochNo
currentEpoch
      EpochInterval
activity <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
ConwayEraPParams era =>
Proof era -> Term era EpochInterval
drepActivity Proof era
p)
      Coin
dep <- forall era a. Term era a -> TraceM era a
getTerm (forall era. ConwayEraPParams era => Proof era -> Term era Coin
drepDeposit Proof era
p)
      forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar
        forall era.
Era era =>
Term era (Map (Credential 'DRepRole) DRepState)
currentDRepState
        (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole
cred (EpochNo
-> StrictMaybe Anchor
-> Coin
-> Set (Credential 'Staking)
-> DRepState
DRepState (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
epoch EpochInterval
activity) StrictMaybe Anchor
manchor Coin
dep forall a. Monoid a => a
mempty))
    ConwayTxCertGov (ConwayUnRegDRep Credential 'DRepRole
cred Coin
dep) -> do
      forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar forall era.
Era era =>
Term era (Map (Credential 'DRepRole) DRepState)
currentDRepState (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Credential 'DRepRole
cred)
      forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar forall era. Era era => Term era Coin
deposits (forall t. Val t => t -> t -> t
<-> Coin
dep)
    ConwayTxCertGov (ConwayUpdateDRep Credential 'DRepRole
cred StrictMaybe Anchor
mAnchor) -> do
      EpochNo
epoch <- forall era a. Term era a -> TraceM era a
getTerm forall era. Era era => Term era EpochNo
currentEpoch
      EpochInterval
activity <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
ConwayEraPParams era =>
Proof era -> Term era EpochInterval
drepActivity Proof era
p)
      forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar
        forall era.
Era era =>
Term era (Map (Credential 'DRepRole) DRepState)
currentDRepState
        ( forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
            ( \(DRepState EpochNo
_ StrictMaybe Anchor
_ Coin
deposit Set (Credential 'Staking)
delegs) -> EpochNo
-> StrictMaybe Anchor
-> Coin
-> Set (Credential 'Staking)
-> DRepState
DRepState (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
epoch EpochInterval
activity) StrictMaybe Anchor
mAnchor Coin
deposit Set (Credential 'Staking)
delegs
            )
            Credential 'DRepRole
cred
        )
    TxCert era
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
certAction Proof era
_ TxCert era
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

certsAction :: (Foldable t, Era era) => Proof era -> t (TxCert era) -> TraceM era ()
certsAction :: forall (t :: * -> *) era.
(Foldable t, Era era) =>
Proof era -> t (TxCert era) -> TraceM era ()
certsAction Proof era
p t (TxCert era)
xs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (TxCert era)
xs (forall era. Era era => Proof era -> TxCert era -> TraceM era ()
certAction Proof era
p)