{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Cardano.Ledger.Generic.ApplyTx where
import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo)
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), AsIx (..), ExUnits (ExUnits))
import Cardano.Ledger.Alonzo.TxWits (TxDats (..))
import Cardano.Ledger.BaseTypes (ProtVer (..), StrictMaybe (..), TxIx, natVersion)
import Cardano.Ledger.Coin (Coin (..), addDeltaCoin)
import Cardano.Ledger.Conway.Core (
AlonzoEraPParams,
AlonzoEraTxBody (..),
AlonzoEraTxWits (..),
Withdrawals (..),
ppCollateralPercentageL,
ppCostModelsL,
ppMaxBlockExUnitsL,
ppMaxTxExUnitsL,
ppMaxValSizeL,
)
import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.Rewards (aggregateRewards)
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import Cardano.Ledger.Val (Val ((<+>), (<->)), inject)
import Cardano.Slotting.Slot (EpochNo (..))
import Control.Iterate.Exp (dom, (∈))
import Control.Iterate.SetAlgebra (eval)
import Data.Foldable (Foldable (..), fold)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word32)
import Lens.Micro
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Alonzo.Scripts (alwaysFails)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Era ()
import Test.Cardano.Ledger.Core.KeyPair (mkWitnessVKey)
import Test.Cardano.Ledger.Examples.STSTestUtils (
EraModel (..),
mkGenesisTxIn,
mkTxDats,
someAddr,
someKeys,
)
import Test.Cardano.Ledger.Generic.Functions (
createRUpdNonPulsing',
txInBalance,
)
import Test.Cardano.Ledger.Generic.GenState (PlutusPurposeTag (..))
import Test.Cardano.Ledger.Generic.ModelState (
Model,
ModelNewEpochState (..),
)
import Test.Cardano.Ledger.Generic.Proof hiding (lift)
import Test.Cardano.Ledger.Plutus (zeroTestingCostModels)
import Test.Cardano.Ledger.Shelley.Rewards (RewardUpdateOld (deltaFOld), rsOld)
applyTxSimple :: forall era. EraModel era => Int -> Model era -> Tx era -> Model era
applyTxSimple :: forall era. EraModel era => Int -> Model era -> Tx era -> Model era
applyTxSimple Int
count Model era
model Tx era
tx = Int -> Model era -> TxBody era -> Model era
forall era.
EraModel era =>
Int -> Model era -> TxBody era -> Model era
applyTxBody Int
count Model era
model (TxBody era -> Model era) -> TxBody era -> Model era
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
applyTxFail ::
(Reflect era, AlonzoEraTxBody era, EraModel era) => Int -> TxIx -> Model era -> Tx era -> Model era
applyTxFail :: forall era.
(Reflect era, AlonzoEraTxBody era, EraModel era) =>
Int -> TxIx -> Model era -> Tx era -> Model era
applyTxFail Int
count TxIx
nextTxIx Model era
model Tx era
tx = CollInfo era -> Model era -> Model era
forall era. CollInfo era -> Model era -> Model era
updateInfo CollInfo era
info Model era
model
where
info :: CollInfo era
info = Int
-> TxIx -> Model era -> CollInfo era -> TxBody era -> CollInfo era
forall era.
(HasCallStack, AlonzoEraTxBody era, EraModel era) =>
Int
-> TxIx -> Model era -> CollInfo era -> TxBody era -> CollInfo era
collInfo Int
count TxIx
nextTxIx Model era
model CollInfo era
forall era. CollInfo era
emptyCollInfo (TxBody era -> CollInfo era) -> TxBody era -> CollInfo era
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
collInfo ::
(HasCallStack, AlonzoEraTxBody era, EraModel era) =>
Int ->
TxIx ->
Model era ->
CollInfo era ->
TxBody era ->
CollInfo era
collInfo :: forall era.
(HasCallStack, AlonzoEraTxBody era, EraModel era) =>
Int
-> TxIx -> Model era -> CollInfo era -> TxBody era -> CollInfo era
collInfo Int
count TxIx
firstTxIx Model era
model CollInfo era
info TxBody era
txbody =
CollInfo era
afterColReturn
{ ciDelset = inputs
, ciBal = txInBalance inputs $ mUTxO model
}
where
inputs :: Set TxIn
inputs = TxBody era
txbody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
afterColReturn :: CollInfo era
afterColReturn =
case TxBody era
txbody TxBody era
-> Getting
(StrictMaybe (TxOut era)) (TxBody era) (StrictMaybe (TxOut era))
-> StrictMaybe (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
(StrictMaybe (TxOut era)) (TxBody era) (StrictMaybe (TxOut era))
forall era.
EraModel era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyT of
StrictMaybe (TxOut era)
SNothing -> CollInfo era
info
SJust TxOut era
txOut ->
case Int -> Map Int TxId -> Maybe TxId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
count (Model era -> Map Int TxId
forall era. ModelNewEpochState era -> Map Int TxId
mIndex Model era
model) of
Maybe TxId
Nothing -> [Char] -> CollInfo era
forall a. HasCallStack => [Char] -> a
error ([Char]
"Output not found phase2: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Map Int TxId) -> [Char]
forall a. Show a => a -> [Char]
show (Int
count, Model era -> Map Int TxId
forall era. ModelNewEpochState era -> Map Int TxId
mIndex Model era
model))
Just (TxId SafeHash EraIndependentTxBody
hash) ->
CollInfo era
info
{ ciRet = txOut ^. coinTxOutL
, ciAddmap = newstuff
}
where
newstuff :: MUtxo era
newstuff = SafeHash EraIndependentTxBody -> TxIx -> [TxOut era] -> MUtxo era
forall era.
SafeHash EraIndependentTxBody
-> TxIx -> [TxOut era] -> Map TxIn (TxOut era)
additions SafeHash EraIndependentTxBody
hash TxIx
firstTxIx [Item [TxOut era]
TxOut era
txOut]
defaultPPs :: AlonzoEraPParams era => PParams era -> PParams era
defaultPPs :: forall era. AlonzoEraPParams era => PParams era -> PParams era
defaultPPs PParams era
pp =
PParams era
pp
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
zeroTestingCostModels [Item [Language]
Language
PlutusV1]
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppMaxValSizeL ((Natural -> Identity Natural)
-> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
1000000000
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era))
-> ExUnits -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL ((ExUnits -> Identity ExUnits)
-> PParams era -> Identity (PParams era))
-> ExUnits -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Natural -> ExUnits
ExUnits Natural
1000000 Natural
1000000
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
-> PParams era -> Identity (PParams era))
-> ProtVer -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @5) Natural
0
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
2
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
5
PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCollateralPercentageL ((Natural -> Identity Natural)
-> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
100
pparams :: AlonzoEraPParams era => PParams era
pparams :: forall era. AlonzoEraPParams era => PParams era
pparams = PParams era -> PParams era
forall era. AlonzoEraPParams era => PParams era -> PParams era
defaultPPs PParams era
forall era. EraPParams era => PParams era
emptyPParams
epochBoundary ::
forall era. EraPParams era => EpochNo -> EpochNo -> Model era -> Model era
epochBoundary :: forall era.
EraPParams era =>
EpochNo -> EpochNo -> Model era -> Model era
epochBoundary EpochNo
transactionEpoch EpochNo
modelEpoch Model era
model =
if EpochNo
transactionEpoch EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
> EpochNo
modelEpoch
then
RewardUpdateOld -> Model era -> Model era
forall era. RewardUpdateOld -> Model era -> Model era
applyRUpd RewardUpdateOld
ru (Model era -> Model era) -> Model era -> Model era
forall a b. (a -> b) -> a -> b
$
Model era
model
{ mEL = transactionEpoch
}
else Model era
model
where
ru :: RewardUpdateOld
ru = forall era. EraPParams era => Model era -> RewardUpdateOld
createRUpdNonPulsing' @era Model era
model
applyTxBody :: EraModel era => Int -> Model era -> TxBody era -> Model era
applyTxBody :: forall era.
EraModel era =>
Int -> Model era -> TxBody era -> Model era
applyTxBody Int
count Model era
model TxBody era
txbody =
(Model era -> RewardAccount -> Coin -> Model era)
-> Model era -> Map RewardAccount Coin -> Model era
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Model era -> RewardAccount -> Coin -> Model era
forall era. Model era -> RewardAccount -> Coin -> Model era
applyWithdrawals ((Model era -> TxCert era -> Model era)
-> Model era -> StrictSeq (TxCert era) -> Model era
forall b a. (b -> a -> b) -> b -> StrictSeq a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Model era -> TxCert era -> Model era
forall era. EraModel era => Model era -> TxCert era -> Model era
applyCert Model era
model' (StrictSeq (TxCert era) -> Model era)
-> StrictSeq (TxCert era) -> Model era
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody TxBody era
-> Getting
(StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
(StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)
(Map RewardAccount Coin -> Model era)
-> (Withdrawals -> Map RewardAccount Coin)
-> Withdrawals
-> Model era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals
(Withdrawals -> Model era) -> Withdrawals -> Model era
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
where
mUTxOInputs :: Map TxIn (TxOut era)
mUTxOInputs = Map TxIn (TxOut era) -> Set TxIn -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys (Model era -> Map TxIn (TxOut era)
forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO Model era
model) (Set TxIn -> Map TxIn (TxOut era))
-> Set TxIn -> Map TxIn (TxOut era)
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
mUTxOOutputs :: Map TxIn (TxOut era)
mUTxOOutputs = case Int -> Map Int TxId -> Maybe TxId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
count (Model era -> Map Int TxId
forall era. ModelNewEpochState era -> Map Int TxId
mIndex Model era
model) of
Maybe TxId
Nothing -> [Char] -> Map TxIn (TxOut era)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Output not found phase1: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Map Int TxId -> [Char]
forall a. Show a => a -> [Char]
show (Model era -> Map Int TxId
forall era. ModelNewEpochState era -> Map Int TxId
mIndex Model era
model))
Just (TxId SafeHash EraIndependentTxBody
hash) -> Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (TxOut era)
newstuff Map TxIn (TxOut era)
mUTxOInputs
where
newstuff :: Map TxIn (TxOut era)
newstuff = SafeHash EraIndependentTxBody
-> TxIx -> [TxOut era] -> Map TxIn (TxOut era)
forall era.
SafeHash EraIndependentTxBody
-> TxIx -> [TxOut era] -> Map TxIn (TxOut era)
additions SafeHash EraIndependentTxBody
hash TxIx
forall a. Bounded a => a
minBound ([TxOut era] -> Map TxIn (TxOut era))
-> (StrictSeq (TxOut era) -> [TxOut era])
-> StrictSeq (TxOut era)
-> Map TxIn (TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut era) -> [TxOut era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (TxOut era) -> Map TxIn (TxOut era))
-> StrictSeq (TxOut era) -> Map TxIn (TxOut era)
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody TxBody era
-> Getting
(StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
(StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
model' :: Model era
model' =
Model era
model
{ mUTxO = mUTxOOutputs
, mFees = mFees model <+> (txbody ^. feeTxBodyL)
}
applyWithdrawals :: Model era -> RewardAccount -> Coin -> Model era
applyWithdrawals :: forall era. Model era -> RewardAccount -> Coin -> Model era
applyWithdrawals Model era
model (RewardAccount Network
_network Credential 'Staking
cred) Coin
coin =
Model era
model {mRewards = Map.adjust (<-> coin) cred (mRewards model)}
data CollInfo era = CollInfo
{ forall era. CollInfo era -> Coin
ciBal :: Coin
, forall era. CollInfo era -> Coin
ciRet :: Coin
, forall era. CollInfo era -> Set TxIn
ciDelset :: Set TxIn
, forall era. CollInfo era -> Map TxIn (TxOut era)
ciAddmap :: Map TxIn (TxOut era)
}
emptyCollInfo :: CollInfo era
emptyCollInfo :: forall era. CollInfo era
emptyCollInfo = Coin -> Coin -> Set TxIn -> Map TxIn (TxOut era) -> CollInfo era
forall era.
Coin -> Coin -> Set TxIn -> Map TxIn (TxOut era) -> CollInfo era
CollInfo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) Set TxIn
forall a. Set a
Set.empty Map TxIn (TxOut era)
forall k a. Map k a
Map.empty
updateInfo :: CollInfo era -> Model era -> Model era
updateInfo :: forall era. CollInfo era -> Model era -> Model era
updateInfo CollInfo era
info Model era
m =
Model era
m
{ mUTxO = Map.union (ciAddmap info) (Map.withoutKeys (mUTxO m) (ciDelset info))
, mFees = mFees m <+> ciBal info <-> ciRet info
}
additions ::
SafeHash EraIndependentTxBody ->
TxIx ->
[TxOut era] ->
Map TxIn (TxOut era)
additions :: forall era.
SafeHash EraIndependentTxBody
-> TxIx -> [TxOut era] -> Map TxIn (TxOut era)
additions SafeHash EraIndependentTxBody
bodyhash TxIx
firstTxIx [TxOut era]
outputs =
[(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (TxId -> TxIx -> TxIn
TxIn (SafeHash EraIndependentTxBody -> TxId
TxId SafeHash EraIndependentTxBody
bodyhash) TxIx
idx, TxOut era
out)
| (TxOut era
out, TxIx
idx) <- [TxOut era] -> [TxIx] -> [(TxOut era, TxIx)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxOut era]
outputs [Item [TxIx]
TxIx
firstTxIx ..]
]
filterRewards ::
EraPParams era =>
PParams era ->
Map (Credential 'Staking) (Set Reward) ->
( Map (Credential 'Staking) (Set Reward)
, Map (Credential 'Staking) (Set Reward)
)
filterRewards :: forall era.
EraPParams era =>
PParams era
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward))
filterRewards PParams era
pp Map (Credential 'Staking) (Set Reward)
rewards =
if ProtVer -> Version
pvMajor (PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL) Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2
then (Map (Credential 'Staking) (Set Reward)
rewards, Map (Credential 'Staking) (Set Reward)
forall k a. Map k a
Map.empty)
else
let mp :: Map (Credential 'Staking) (Reward, Set Reward)
mp = (Set Reward -> (Reward, Set Reward))
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Reward, Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Set Reward -> (Reward, Set Reward)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Map (Credential 'Staking) (Set Reward)
rewards
in (((Reward, Set Reward) -> Set Reward)
-> Map (Credential 'Staking) (Reward, Set Reward)
-> Map (Credential 'Staking) (Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Reward -> Set Reward
forall a. a -> Set a
Set.singleton (Reward -> Set Reward)
-> ((Reward, Set Reward) -> Reward)
-> (Reward, Set Reward)
-> Set Reward
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reward, Set Reward) -> Reward
forall a b. (a, b) -> a
fst) Map (Credential 'Staking) (Reward, Set Reward)
mp, (Set Reward -> Bool)
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Set Reward)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (Set Reward -> Bool) -> Set Reward -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Reward -> Bool
forall a. Set a -> Bool
Set.null) (Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Set Reward))
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) (Set Reward)
forall a b. (a -> b) -> a -> b
$ ((Reward, Set Reward) -> Set Reward)
-> Map (Credential 'Staking) (Reward, Set Reward)
-> Map (Credential 'Staking) (Set Reward)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Reward, Set Reward) -> Set Reward
forall a b. (a, b) -> b
snd Map (Credential 'Staking) (Reward, Set Reward)
mp)
filterAllRewards ::
EraPParams era =>
Map (Credential 'Staking) (Set Reward) ->
Model era ->
( Map (Credential 'Staking) (Set Reward)
, Map (Credential 'Staking) (Set Reward)
, Set (Credential 'Staking)
, Coin
)
filterAllRewards :: forall era.
EraPParams era =>
Map (Credential 'Staking) (Set Reward)
-> Model era
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward), Set (Credential 'Staking),
Coin)
filterAllRewards Map (Credential 'Staking) (Set Reward)
rs' Model era
m =
(Map (Credential 'Staking) (Set Reward)
registered, Map (Credential 'Staking) (Set Reward)
eraIgnored, Set (Credential 'Staking)
unregistered, Coin
totalUnregistered)
where
pp :: PParams era
pp = Model era -> PParams era
forall era. ModelNewEpochState era -> PParams era
mPParams Model era
m
(Map (Credential 'Staking) (Set Reward)
regRU, Map (Credential 'Staking) (Set Reward)
unregRU) =
(Credential 'Staking -> Set Reward -> Bool)
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward))
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
(\Credential 'Staking
k Set Reward
_ -> Exp Bool -> Bool
forall s t. Embed s t => Exp t -> s
eval (Credential 'Staking
k Credential 'Staking
-> Exp (Sett (Credential 'Staking) ()) -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
∈ Map (Credential 'Staking) Coin
-> Exp (Sett (Credential 'Staking) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom (Model era -> Map (Credential 'Staking) Coin
forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards Model era
m)))
Map (Credential 'Staking) (Set Reward)
rs'
totalUnregistered :: Coin
totalUnregistered = Map (Credential 'Staking) Coin -> Coin
forall m. Monoid m => Map (Credential 'Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential 'Staking) Coin -> Coin)
-> Map (Credential 'Staking) Coin -> Coin
forall a b. (a -> b) -> a -> b
$ ProtVer
-> Map (Credential 'Staking) (Set Reward)
-> Map (Credential 'Staking) Coin
aggregateRewards (PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL) Map (Credential 'Staking) (Set Reward)
unregRU
unregistered :: Set (Credential 'Staking)
unregistered = Map (Credential 'Staking) (Set Reward) -> Set (Credential 'Staking)
forall k a. Map k a -> Set k
Map.keysSet Map (Credential 'Staking) (Set Reward)
unregRU
(Map (Credential 'Staking) (Set Reward)
registered, Map (Credential 'Staking) (Set Reward)
eraIgnored) = PParams era
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward))
forall era.
EraPParams era =>
PParams era
-> Map (Credential 'Staking) (Set Reward)
-> (Map (Credential 'Staking) (Set Reward),
Map (Credential 'Staking) (Set Reward))
filterRewards PParams era
pp Map (Credential 'Staking) (Set Reward)
regRU
applyRUpd ::
forall era.
RewardUpdateOld ->
Model era ->
Model era
applyRUpd :: forall era. RewardUpdateOld -> Model era -> Model era
applyRUpd RewardUpdateOld
ru Model era
m =
Model era
m
{ mFees = mFees m `addDeltaCoin` deltaFOld ru
, mRewards = Map.unionWith (<>) (mRewards m) (rsOld ru)
}
notValidatingTx ::
forall era.
( AlonzoEraTxWits era
, EraPlutusTxInfo PlutusV1 era
, AlonzoEraTxBody era
, EraModel era
) =>
Tx era
notValidatingTx :: forall era.
(AlonzoEraTxWits era, EraPlutusTxInfo 'PlutusV1 era,
AlonzoEraTxBody era, EraModel era) =>
Tx era
notValidatingTx =
let s :: Script era
s = forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
Natural -> Script era
alwaysFails @PlutusV1 Natural
1
dat :: Data era
dat = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0)
in TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
notValidatingBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [SafeHash EraIndependentTxBody
-> KeyPair 'Payment -> WitVKey 'Witness
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody -> KeyPair kr -> WitVKey 'Witness
mkWitnessVKey (TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
notValidatingBody) KeyPair 'Payment
someKeys]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era))
-> ((Map ScriptHash (Script era)
-> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era)
-> Identity (Map ScriptHash (Script era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
-> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
-> Identity (Map ScriptHash (Script era)))
-> Tx era -> Identity (Tx era))
-> Map ScriptHash (Script era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
s, Script era
s)]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era))
-> ((TxDats era -> Identity (TxDats era))
-> TxWits era -> Identity (TxWits era))
-> (TxDats era -> Identity (TxDats era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Identity (TxDats era))
-> TxWits era -> Identity (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL ((TxDats era -> Identity (TxDats era))
-> Tx era -> Identity (Tx era))
-> TxDats era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats [(Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
dat, Data era
dat)]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era))
-> ((Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era))
-> (Redeemers era -> Identity (Redeemers era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
-> Tx era -> Identity (Tx era))
-> Redeemers era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers era
redeemers
where
notValidatingBody :: TxBody era
notValidatingBody =
TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
2]
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
12]
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
someAddr (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
2995)]
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
5
TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictMaybe ScriptIntegrityHash
-> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
((StrictMaybe ScriptIntegrityHash
-> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era))
-> StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
forall era.
EraModel era =>
PParams era
-> [Language]
-> Redeemers era
-> TxDats era
-> StrictMaybe ScriptIntegrityHash
newScriptIntegrityHash PParams era
forall era. AlonzoEraPParams era => PParams era
pparams [Item [Language]
Language
PlutusV1] Redeemers era
redeemers (Data era -> TxDats era
forall era. Era era => Data era -> TxDats era
mkTxDats (Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0)))
redeemers :: Redeemers era
redeemers = [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
forall era.
EraModel era =>
[((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags [((PlutusPurposeTag
Spending, Word32
0), (Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
1), Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000))]
mkAlonzoPlutusPurposePointer ::
forall era.
Era era =>
PlutusPurposeTag ->
Word32 ->
AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer :: forall era.
Era era =>
PlutusPurposeTag -> Word32 -> AlonzoPlutusPurpose AsIx era
mkAlonzoPlutusPurposePointer PlutusPurposeTag
tag Word32
i =
case PlutusPurposeTag
tag of
PlutusPurposeTag
Spending -> AsIx Word32 TxIn -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 TxIn -> AlonzoPlutusPurpose f era
AlonzoSpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Minting -> AsIx Word32 PolicyID -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> AlonzoPlutusPurpose f era
AlonzoMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Certifying -> AsIx Word32 (TxCert era) -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> AlonzoPlutusPurpose f era
AlonzoCertifying (Word32 -> AsIx Word32 (TxCert era)
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Rewarding -> AsIx Word32 RewardAccount -> AlonzoPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> AlonzoPlutusPurpose f era
AlonzoRewarding (Word32 -> AsIx Word32 RewardAccount
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
_ -> [Char] -> AlonzoPlutusPurpose AsIx era
forall a. HasCallStack => [Char] -> a
error ([Char] -> AlonzoPlutusPurpose AsIx era)
-> [Char] -> AlonzoPlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ [Char]
"Unsupported tag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PlutusPurposeTag -> [Char]
forall a. Show a => a -> [Char]
show PlutusPurposeTag
tag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in era " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall era. Era era => [Char]
eraName @era
mkConwayPlutusPurposePointer :: PlutusPurposeTag -> Word32 -> ConwayPlutusPurpose AsIx era
mkConwayPlutusPurposePointer :: forall era.
PlutusPurposeTag -> Word32 -> ConwayPlutusPurpose AsIx era
mkConwayPlutusPurposePointer PlutusPurposeTag
tag Word32
i =
case PlutusPurposeTag
tag of
PlutusPurposeTag
Spending -> AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
ConwaySpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Minting -> AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Certifying -> AsIx Word32 (TxCert era) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> ConwayPlutusPurpose f era
ConwayCertifying (Word32 -> AsIx Word32 (TxCert era)
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Rewarding -> AsIx Word32 RewardAccount -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> ConwayPlutusPurpose f era
ConwayRewarding (Word32 -> AsIx Word32 RewardAccount
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Voting -> AsIx Word32 Voter -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 Voter -> ConwayPlutusPurpose f era
ConwayVoting (Word32 -> AsIx Word32 Voter
forall ix it. ix -> AsIx ix it
AsIx Word32
i)
PlutusPurposeTag
Proposing -> AsIx Word32 (ProposalProcedure era) -> ConwayPlutusPurpose AsIx era
forall (f :: * -> * -> *) era.
f Word32 (ProposalProcedure era) -> ConwayPlutusPurpose f era
ConwayProposing (Word32 -> AsIx Word32 (ProposalProcedure era)
forall ix it. ix -> AsIx ix it
AsIx Word32
i)