{-# 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 (Era (..), TxBody, TxCert)
import Cardano.Ledger.DRep (DRepState (DRepState))
import Cardano.Ledger.SafeHash (hashAnnotated)
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 (EraCrypto era)) -> TraceM era ()
inputsAction :: forall era.
Era era =>
Proof era -> Set (TxIn (EraCrypto era)) -> TraceM era ()
inputsAction Proof era
proof Set (TxIn (EraCrypto era))
is = forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar (forall era.
Era era =>
Proof era -> Term era (Map (TxIn (EraCrypto era)) (TxOutF era))
utxo Proof era
proof) (\Map (TxIn (EraCrypto era)) (TxOutF era)
u -> forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map (TxIn (EraCrypto era)) (TxOutF era)
u Set (TxIn (EraCrypto era))
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 (EraCrypto era)) (TxOutF era))
utxo Proof era
proof) (\Map (TxIn StandardCrypto) (TxOutF era)
u -> forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (TxIn StandardCrypto) (TxOutF era)
u ([TxOutF era] -> Map (TxIn StandardCrypto) (TxOutF era)
makemap [TxOutF era]
outs))
  where
    makemap :: [TxOutF era] -> Map (TxIn StandardCrypto) (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) -> (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId StandardCrypto
txid Integer
n, TxOutF era
out)) (forall a b. [a] -> [b] -> [(a, b)]
zip [TxOutF era]
outPuts [Integer
0 ..]))
    txid :: TxId StandardCrypto
txid = forall c. SafeHash c EraIndependentTxBody -> TxId c
TxId (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
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 (EraCrypto (ConwayEra StandardCrypto))
cred Coin
_ StrictMaybe (Anchor (EraCrypto (ConwayEra StandardCrypto)))
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 (EraCrypto era)) (DRepState (EraCrypto era)))
currentDRepState
        (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Credential 'DRepRole (EraCrypto (ConwayEra StandardCrypto))
cred (forall c.
EpochNo
-> StrictMaybe (Anchor c)
-> Coin
-> Set (Credential 'Staking c)
-> DRepState c
DRepState (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
epoch EpochInterval
activity) StrictMaybe (Anchor (EraCrypto (ConwayEra StandardCrypto)))
manchor Coin
dep forall a. Monoid a => a
mempty))
    ConwayTxCertGov (ConwayUnRegDRep Credential 'DRepRole (EraCrypto (ConwayEra StandardCrypto))
cred Coin
dep) -> do
      forall era t. Term era t -> (t -> t) -> TraceM era ()
updateVar forall era.
Era era =>
Term
  era
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
currentDRepState (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Credential 'DRepRole (EraCrypto (ConwayEra StandardCrypto))
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 (EraCrypto (ConwayEra StandardCrypto))
cred StrictMaybe (Anchor (EraCrypto (ConwayEra StandardCrypto)))
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 (EraCrypto era)) (DRepState (EraCrypto era)))
currentDRepState
        ( forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
            ( \(DRepState EpochNo
_ StrictMaybe (Anchor StandardCrypto)
_ Coin
deposit Set (Credential 'Staking StandardCrypto)
delegs) -> forall c.
EpochNo
-> StrictMaybe (Anchor c)
-> Coin
-> Set (Credential 'Staking c)
-> DRepState c
DRepState (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
epoch EpochInterval
activity) StrictMaybe (Anchor (EraCrypto (ConwayEra StandardCrypto)))
mAnchor Coin
deposit Set (Credential 'Staking StandardCrypto)
delegs
            )
            Credential 'DRepRole (EraCrypto (ConwayEra StandardCrypto))
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)