{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.Rules.SubEntities (
  SubEntitiesPredFailure (..),
  SubEntitiesEvent (..),
) where

import Cardano.Ledger.Address (DirectDeposits (..))
import Cardano.Ledger.BaseTypes (Globals (networkId), Mismatch (..), Relation (..), ShelleyBase)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.Core
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Dijkstra.Era (DijkstraEra, SUBCERTS, SUBENTITIES)
import Cardano.Ledger.Dijkstra.Rules.SubCerts (
  DijkstraSubCertsEvent,
  DijkstraSubCertsPredFailure,
  SubCertsEnv (..),
 )
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody, directDepositsTxBodyL)
import Cardano.Ledger.Rules.ValidationMode (runTest)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import Data.List.NonEmpty (NonEmpty)
import Data.Map.NonEmpty (NonEmptyMap)
import qualified Data.Map.NonEmpty as NEM
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq)
import GHC.Generics (Generic)
import Lens.Micro

data SubEntitiesPredFailure era
  = SubCertsFailure (PredicateFailure (EraRule "SUBCERTS" era))
  | SubWdrlNotDelegatedToDRep (NonEmpty (KeyHash Staking))
  | SubWithdrawalsMissingAccounts Withdrawals
  | SubWithdrawalAmountsExceedAccountBalances (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin))
  | SubDirectDepositsToMissingAccounts DirectDeposits
  deriving ((forall x.
 SubEntitiesPredFailure era -> Rep (SubEntitiesPredFailure era) x)
-> (forall x.
    Rep (SubEntitiesPredFailure era) x -> SubEntitiesPredFailure era)
-> Generic (SubEntitiesPredFailure era)
forall x.
Rep (SubEntitiesPredFailure era) x -> SubEntitiesPredFailure era
forall x.
SubEntitiesPredFailure era -> Rep (SubEntitiesPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (SubEntitiesPredFailure era) x -> SubEntitiesPredFailure era
forall era x.
SubEntitiesPredFailure era -> Rep (SubEntitiesPredFailure era) x
$cfrom :: forall era x.
SubEntitiesPredFailure era -> Rep (SubEntitiesPredFailure era) x
from :: forall x.
SubEntitiesPredFailure era -> Rep (SubEntitiesPredFailure era) x
$cto :: forall era x.
Rep (SubEntitiesPredFailure era) x -> SubEntitiesPredFailure era
to :: forall x.
Rep (SubEntitiesPredFailure era) x -> SubEntitiesPredFailure era
Generic)

deriving stock instance
  Eq (PredicateFailure (EraRule "SUBCERTS" era)) => Eq (SubEntitiesPredFailure era)

deriving stock instance
  Show (PredicateFailure (EraRule "SUBCERTS" era)) => Show (SubEntitiesPredFailure era)

instance
  NFData (PredicateFailure (EraRule "SUBCERTS" era)) =>
  NFData (SubEntitiesPredFailure era)

instance
  ( Era era
  , EncCBOR (PredicateFailure (EraRule "SUBCERTS" era))
  ) =>
  EncCBOR (SubEntitiesPredFailure era)
  where
  encCBOR :: SubEntitiesPredFailure era -> Encoding
encCBOR =
    Encode Open (SubEntitiesPredFailure era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode Open (SubEntitiesPredFailure era) -> Encoding)
-> (SubEntitiesPredFailure era
    -> Encode Open (SubEntitiesPredFailure era))
-> SubEntitiesPredFailure era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      SubCertsFailure PredicateFailure (EraRule "SUBCERTS" era)
x -> (PredicateFailure (EraRule "SUBCERTS" era)
 -> SubEntitiesPredFailure era)
-> Word
-> Encode
     Open
     (PredicateFailure (EraRule "SUBCERTS" era)
      -> SubEntitiesPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure @era) Word
0 Encode
  Open
  (PredicateFailure (EraRule "SUBCERTS" era)
   -> SubEntitiesPredFailure era)
-> Encode
     (Closed Dense) (PredicateFailure (EraRule "SUBCERTS" era))
-> Encode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> PredicateFailure (EraRule "SUBCERTS" era)
-> Encode
     (Closed Dense) (PredicateFailure (EraRule "SUBCERTS" era))
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To PredicateFailure (EraRule "SUBCERTS" era)
x
      SubWdrlNotDelegatedToDRep NonEmpty (KeyHash Staking)
x -> (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
-> Word
-> Encode
     Open (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era.
NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era
SubWdrlNotDelegatedToDRep @era) Word
1 Encode
  Open (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
-> Encode (Closed Dense) (NonEmpty (KeyHash Staking))
-> Encode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> NonEmpty (KeyHash Staking)
-> Encode (Closed Dense) (NonEmpty (KeyHash Staking))
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To NonEmpty (KeyHash Staking)
x
      SubWithdrawalsMissingAccounts Withdrawals
x -> (Withdrawals -> SubEntitiesPredFailure era)
-> Word -> Encode Open (Withdrawals -> SubEntitiesPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era. Withdrawals -> SubEntitiesPredFailure era
SubWithdrawalsMissingAccounts @era) Word
2 Encode Open (Withdrawals -> SubEntitiesPredFailure era)
-> Encode (Closed Dense) Withdrawals
-> Encode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> Withdrawals -> Encode (Closed Dense) Withdrawals
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To Withdrawals
x
      SubWithdrawalAmountsExceedAccountBalances NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
x -> (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
 -> SubEntitiesPredFailure era)
-> Word
-> Encode
     Open
     (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
      -> SubEntitiesPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era.
NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
-> SubEntitiesPredFailure era
SubWithdrawalAmountsExceedAccountBalances @era) Word
3 Encode
  Open
  (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
   -> SubEntitiesPredFailure era)
-> Encode
     (Closed Dense) (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin))
-> Encode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
-> Encode
     (Closed Dense) (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin))
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
x
      SubDirectDepositsToMissingAccounts DirectDeposits
x -> (DirectDeposits -> SubEntitiesPredFailure era)
-> Word
-> Encode Open (DirectDeposits -> SubEntitiesPredFailure era)
forall t. t -> Word -> Encode Open t
Sum (forall era. DirectDeposits -> SubEntitiesPredFailure era
SubDirectDepositsToMissingAccounts @era) Word
4 Encode Open (DirectDeposits -> SubEntitiesPredFailure era)
-> Encode (Closed Dense) DirectDeposits
-> Encode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> DirectDeposits -> Encode (Closed Dense) DirectDeposits
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To DirectDeposits
x

instance
  ( Era era
  , DecCBOR (PredicateFailure (EraRule "SUBCERTS" era))
  ) =>
  DecCBOR (SubEntitiesPredFailure era)
  where
  decCBOR :: forall s. Decoder s (SubEntitiesPredFailure era)
decCBOR = Decode (Closed Dense) (SubEntitiesPredFailure era)
-> Decoder s (SubEntitiesPredFailure era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode (Closed Dense) (SubEntitiesPredFailure era)
 -> Decoder s (SubEntitiesPredFailure era))
-> ((Word -> Decode Open (SubEntitiesPredFailure era))
    -> Decode (Closed Dense) (SubEntitiesPredFailure era))
-> (Word -> Decode Open (SubEntitiesPredFailure era))
-> Decoder s (SubEntitiesPredFailure era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> (Word -> Decode Open (SubEntitiesPredFailure era))
-> Decode (Closed Dense) (SubEntitiesPredFailure era)
forall t.
Text -> (Word -> Decode Open t) -> Decode (Closed Dense) t
Summands Text
"SubEntitiesPredFailure" ((Word -> Decode Open (SubEntitiesPredFailure era))
 -> Decoder s (SubEntitiesPredFailure era))
-> (Word -> Decode Open (SubEntitiesPredFailure era))
-> Decoder s (SubEntitiesPredFailure era)
forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> (PredicateFailure (EraRule "SUBCERTS" era)
 -> SubEntitiesPredFailure era)
-> Decode
     Open
     (PredicateFailure (EraRule "SUBCERTS" era)
      -> SubEntitiesPredFailure era)
forall t. t -> Decode Open t
SumD PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure Decode
  Open
  (PredicateFailure (EraRule "SUBCERTS" era)
   -> SubEntitiesPredFailure era)
-> Decode
     (Closed (ZonkAny 0)) (PredicateFailure (EraRule "SUBCERTS" era))
-> Decode Open (SubEntitiesPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode
  (Closed (ZonkAny 0)) (PredicateFailure (EraRule "SUBCERTS" era))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
1 -> (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
-> Decode
     Open (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
forall t. t -> Decode Open t
SumD NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era
forall era.
NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era
SubWdrlNotDelegatedToDRep Decode
  Open (NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era)
-> Decode (Closed (ZonkAny 1)) (NonEmpty (KeyHash Staking))
-> Decode Open (SubEntitiesPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 1)) (NonEmpty (KeyHash Staking))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> (Withdrawals -> SubEntitiesPredFailure era)
-> Decode Open (Withdrawals -> SubEntitiesPredFailure era)
forall t. t -> Decode Open t
SumD Withdrawals -> SubEntitiesPredFailure era
forall era. Withdrawals -> SubEntitiesPredFailure era
SubWithdrawalsMissingAccounts Decode Open (Withdrawals -> SubEntitiesPredFailure era)
-> Decode (Closed (ZonkAny 2)) Withdrawals
-> Decode Open (SubEntitiesPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 2)) Withdrawals
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
3 -> (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
 -> SubEntitiesPredFailure era)
-> Decode
     Open
     (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
      -> SubEntitiesPredFailure era)
forall t. t -> Decode Open t
SumD NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
-> SubEntitiesPredFailure era
forall era.
NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
-> SubEntitiesPredFailure era
SubWithdrawalAmountsExceedAccountBalances Decode
  Open
  (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin)
   -> SubEntitiesPredFailure era)
-> Decode
     (Closed (ZonkAny 3))
     (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin))
-> Decode Open (SubEntitiesPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode
  (Closed (ZonkAny 3))
  (NonEmptyMap AccountAddress (Mismatch RelLTEQ Coin))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
4 -> (DirectDeposits -> SubEntitiesPredFailure era)
-> Decode Open (DirectDeposits -> SubEntitiesPredFailure era)
forall t. t -> Decode Open t
SumD DirectDeposits -> SubEntitiesPredFailure era
forall era. DirectDeposits -> SubEntitiesPredFailure era
SubDirectDepositsToMissingAccounts Decode Open (DirectDeposits -> SubEntitiesPredFailure era)
-> Decode (Closed (ZonkAny 4)) DirectDeposits
-> Decode Open (SubEntitiesPredFailure era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode (Closed w) a -> Decode w1 t
<! Decode (Closed (ZonkAny 4)) DirectDeposits
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> Word -> Decode Open (SubEntitiesPredFailure era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

newtype SubEntitiesEvent era = SubCertsEvent (Event (EraRule "SUBCERTS" era))
  deriving ((forall x. SubEntitiesEvent era -> Rep (SubEntitiesEvent era) x)
-> (forall x. Rep (SubEntitiesEvent era) x -> SubEntitiesEvent era)
-> Generic (SubEntitiesEvent era)
forall x. Rep (SubEntitiesEvent era) x -> SubEntitiesEvent era
forall x. SubEntitiesEvent era -> Rep (SubEntitiesEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (SubEntitiesEvent era) x -> SubEntitiesEvent era
forall era x. SubEntitiesEvent era -> Rep (SubEntitiesEvent era) x
$cfrom :: forall era x. SubEntitiesEvent era -> Rep (SubEntitiesEvent era) x
from :: forall x. SubEntitiesEvent era -> Rep (SubEntitiesEvent era) x
$cto :: forall era x. Rep (SubEntitiesEvent era) x -> SubEntitiesEvent era
to :: forall x. Rep (SubEntitiesEvent era) x -> SubEntitiesEvent era
Generic)

deriving instance Eq (Event (EraRule "SUBCERTS" era)) => Eq (SubEntitiesEvent era)

instance NFData (Event (EraRule "SUBCERTS" era)) => NFData (SubEntitiesEvent era)

type instance EraRuleFailure "SUBENTITIES" DijkstraEra = SubEntitiesPredFailure DijkstraEra

type instance EraRuleEvent "SUBENTITIES" DijkstraEra = SubEntitiesEvent DijkstraEra

instance InjectRuleFailure "SUBENTITIES" SubEntitiesPredFailure DijkstraEra

instance InjectRuleFailure "SUBENTITIES" DijkstraSubCertsPredFailure DijkstraEra where
  injectFailure :: DijkstraSubCertsPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBCERTS" DijkstraEra)
-> SubEntitiesPredFailure DijkstraEra
DijkstraSubCertsPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure

instance InjectRuleFailure "SUBENTITIES" Conway.ConwayCertsPredFailure DijkstraEra where
  injectFailure :: ConwayCertsPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
injectFailure = PredicateFailure (EraRule "SUBCERTS" DijkstraEra)
-> SubEntitiesPredFailure DijkstraEra
DijkstraSubCertsPredFailure DijkstraEra
-> SubEntitiesPredFailure DijkstraEra
forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure (DijkstraSubCertsPredFailure DijkstraEra
 -> SubEntitiesPredFailure DijkstraEra)
-> (ConwayCertsPredFailure DijkstraEra
    -> DijkstraSubCertsPredFailure DijkstraEra)
-> ConwayCertsPredFailure DijkstraEra
-> SubEntitiesPredFailure DijkstraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure @"SUBCERTS"

instance InjectRuleFailure "SUBENTITIES" Conway.ConwayLedgerPredFailure DijkstraEra where
  injectFailure :: ConwayLedgerPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
injectFailure = ConwayLedgerPredFailure DijkstraEra
-> EraRuleFailure "SUBENTITIES" DijkstraEra
ConwayLedgerPredFailure DijkstraEra
-> SubEntitiesPredFailure DijkstraEra
forall era.
ConwayLedgerPredFailure era -> SubEntitiesPredFailure era
conwayToDijkstraSubEntitiesPredFailure

instance
  ( EraTx era
  , DijkstraEraTxBody era
  , ConwayEraCertState era
  , Embed (EraRule "SUBCERTS" era) (SUBENTITIES era)
  , State (EraRule "SUBCERTS" era) ~ CertState era
  , Signal (EraRule "SUBCERTS" era) ~ Seq (TxCert era)
  , Environment (EraRule "SUBCERTS" era) ~ SubCertsEnv era
  , EraRule "SUBENTITIES" era ~ SUBENTITIES era
  , InjectRuleFailure "SUBENTITIES" SubEntitiesPredFailure era
  , InjectRuleFailure "SUBENTITIES" Conway.ConwayLedgerPredFailure era
  ) =>
  STS (SUBENTITIES era)
  where
  type State (SUBENTITIES era) = CertState era
  type Signal (SUBENTITIES era) = Seq (TxCert era)
  type Environment (SUBENTITIES era) = SubCertsEnv era
  type BaseM (SUBENTITIES era) = ShelleyBase
  type PredicateFailure (SUBENTITIES era) = SubEntitiesPredFailure era
  type Event (SUBENTITIES era) = SubEntitiesEvent era

  initialRules :: [InitialRule (SUBENTITIES era)]
initialRules = []
  transitionRules :: [TransitionRule (SUBENTITIES era)]
transitionRules = [forall era.
(EraTx era, DijkstraEraTxBody era, ConwayEraCertState era,
 Embed (EraRule "SUBCERTS" era) (SUBENTITIES era),
 State (EraRule "SUBCERTS" era) ~ CertState era,
 Signal (EraRule "SUBCERTS" era) ~ Seq (TxCert era),
 Environment (EraRule "SUBCERTS" era) ~ SubCertsEnv era,
 EraRule "SUBENTITIES" era ~ SUBENTITIES era,
 InjectRuleFailure "SUBENTITIES" SubEntitiesPredFailure era,
 InjectRuleFailure "SUBENTITIES" ConwayLedgerPredFailure era) =>
TransitionRule (SUBENTITIES era)
dijkstraSubEntitiesTransition @era]

dijkstraSubEntitiesTransition ::
  forall era.
  ( EraTx era
  , DijkstraEraTxBody era
  , ConwayEraCertState era
  , Embed (EraRule "SUBCERTS" era) (SUBENTITIES era)
  , State (EraRule "SUBCERTS" era) ~ CertState era
  , Signal (EraRule "SUBCERTS" era) ~ Seq (TxCert era)
  , Environment (EraRule "SUBCERTS" era) ~ SubCertsEnv era
  , EraRule "SUBENTITIES" era ~ SUBENTITIES era
  , InjectRuleFailure "SUBENTITIES" SubEntitiesPredFailure era
  , InjectRuleFailure "SUBENTITIES" Conway.ConwayLedgerPredFailure era
  ) =>
  TransitionRule (SUBENTITIES era)
dijkstraSubEntitiesTransition :: forall era.
(EraTx era, DijkstraEraTxBody era, ConwayEraCertState era,
 Embed (EraRule "SUBCERTS" era) (SUBENTITIES era),
 State (EraRule "SUBCERTS" era) ~ CertState era,
 Signal (EraRule "SUBCERTS" era) ~ Seq (TxCert era),
 Environment (EraRule "SUBCERTS" era) ~ SubCertsEnv era,
 EraRule "SUBENTITIES" era ~ SUBENTITIES era,
 InjectRuleFailure "SUBENTITIES" SubEntitiesPredFailure era,
 InjectRuleFailure "SUBENTITIES" ConwayLedgerPredFailure era) =>
TransitionRule (SUBENTITIES era)
dijkstraSubEntitiesTransition = do
  TRC (subCertsEnv, certState, certificates) <- Rule
  (SUBENTITIES era)
  'Transition
  (RuleContext 'Transition (SUBENTITIES era))
F (Clause (SUBENTITIES era) 'Transition) (TRC (SUBENTITIES era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let tx = SubCertsEnv era -> Tx SubTx era
forall era. SubCertsEnv era -> Tx SubTx era
certsTx Environment (SUBENTITIES era)
SubCertsEnv era
subCertsEnv
      pp = SubCertsEnv era -> PParams era
forall era. SubCertsEnv era -> PParams era
certsPParams Environment (SUBENTITIES era)
SubCertsEnv era
subCertsEnv
      curEpoch = SubCertsEnv era -> EpochNo
forall era. SubCertsEnv era -> EpochNo
certsCurrentEpoch Environment (SUBENTITIES era)
SubCertsEnv era
subCertsEnv
      withdrawals = Tx SubTx era
tx Tx SubTx era
-> Getting Withdrawals (Tx SubTx era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era -> Const Withdrawals (TxBody SubTx era))
-> Tx SubTx era -> Const Withdrawals (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Const Withdrawals (TxBody SubTx era))
 -> Tx SubTx era -> Const Withdrawals (Tx SubTx era))
-> ((Withdrawals -> Const Withdrawals Withdrawals)
    -> TxBody SubTx era -> Const Withdrawals (TxBody SubTx era))
-> Getting Withdrawals (Tx SubTx era) Withdrawals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Withdrawals -> Const Withdrawals Withdrawals)
-> TxBody SubTx era -> Const Withdrawals (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL
      accounts = CertState era
State (SUBENTITIES era)
certState CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL

  runTest $ Conway.validateWithdrawalsDelegated accounts tx

  network <- liftSTS $ asks networkId
  let (missingWithdrawals, exceededWithdrawals) =
        case withdrawalsThatExceedAccountBalance withdrawals network accounts of
          Maybe (Withdrawals, Map AccountAddress (Mismatch RelLTEQ Coin))
Nothing -> (Map AccountAddress Coin
forall k a. Map k a
Map.empty, Map AccountAddress (Mismatch RelLTEQ Coin)
forall k a. Map k a
Map.empty)
          Just (Withdrawals
missing, Map AccountAddress (Mismatch RelLTEQ Coin)
exceeded) -> (Withdrawals -> Map AccountAddress Coin
unWithdrawals Withdrawals
missing, Map AccountAddress (Mismatch RelLTEQ Coin)
exceeded)
  failOnNonEmptyMap missingWithdrawals $
    injectFailure . SubWithdrawalsMissingAccounts . Withdrawals . NEM.toMap
  failOnNonEmptyMap exceededWithdrawals $ injectFailure . SubWithdrawalAmountsExceedAccountBalances

  let certStateBeforeSubCerts =
        CertState era
State (SUBENTITIES era)
certState
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& Tx SubTx era -> EpochNo -> CertState era -> CertState era
forall era (l :: TxLevel).
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx l era -> EpochNo -> CertState era -> CertState era
Conway.updateDormantDRepExpiries Tx SubTx era
tx EpochNo
curEpoch
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& Tx SubTx era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
forall era (l :: TxLevel).
(EraTx era, ConwayEraTxBody era, ConwayEraCertState era) =>
Tx l era
-> EpochNo -> EpochInterval -> CertState era -> CertState era
Conway.updateVotingDRepExpiries Tx SubTx era
tx EpochNo
curEpoch (PParams era
pp PParams era
-> Getting EpochInterval (PParams era) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams era) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppDRepActivityL)
          CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Accounts era -> Identity (Accounts era))
    -> DState era -> Identity (DState era))
-> (Accounts era -> Identity (Accounts era))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> CertState era -> Identity (CertState era))
-> (Accounts era -> Accounts era) -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Withdrawals -> Accounts era -> Accounts era
forall era.
EraAccounts era =>
Withdrawals -> Accounts era -> Accounts era
applyWithdrawals Withdrawals
withdrawals
  certStateAfterSubCerts <-
    trans @(EraRule "SUBCERTS" era) $ TRC (subCertsEnv, certStateBeforeSubCerts, certificates)

  let directDeposits = Tx SubTx era
tx Tx SubTx era
-> Getting DirectDeposits (Tx SubTx era) DirectDeposits
-> DirectDeposits
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era -> Const DirectDeposits (TxBody SubTx era))
-> Tx SubTx era -> Const DirectDeposits (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Const DirectDeposits (TxBody SubTx era))
 -> Tx SubTx era -> Const DirectDeposits (Tx SubTx era))
-> ((DirectDeposits -> Const DirectDeposits DirectDeposits)
    -> TxBody SubTx era -> Const DirectDeposits (TxBody SubTx era))
-> Getting DirectDeposits (Tx SubTx era) DirectDeposits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DirectDeposits -> Const DirectDeposits DirectDeposits)
-> TxBody SubTx era -> Const DirectDeposits (TxBody SubTx era)
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) DirectDeposits
forall (l :: TxLevel). Lens' (TxBody l era) DirectDeposits
directDepositsTxBodyL
      accountsAfterSubCerts = CertState era
certStateAfterSubCerts CertState era
-> Getting (Accounts era) (CertState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> Getting (Accounts era) (CertState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  failOnJust (directDepositsMissingAccounts directDeposits accountsAfterSubCerts) $
    injectFailure . SubDirectDepositsToMissingAccounts

  pure $ certStateAfterSubCerts & certDStateL . accountsL %~ applyDirectDeposits directDeposits

conwayToDijkstraSubEntitiesPredFailure ::
  forall era. Conway.ConwayLedgerPredFailure era -> SubEntitiesPredFailure era
conwayToDijkstraSubEntitiesPredFailure :: forall era.
ConwayLedgerPredFailure era -> SubEntitiesPredFailure era
conwayToDijkstraSubEntitiesPredFailure = \case
  Conway.ConwayWdrlNotDelegatedToDRep NonEmpty (KeyHash Staking)
khs -> NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era
forall era.
NonEmpty (KeyHash Staking) -> SubEntitiesPredFailure era
SubWdrlNotDelegatedToDRep NonEmpty (KeyHash Staking)
khs
  Conway.ConwayUtxowFailure PredicateFailure (EraRule "UTXOW" era)
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayUtxowFailure"
  Conway.ConwayCertsFailure PredicateFailure (EraRule "CERTS" era)
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayCertsFailure"
  Conway.ConwayGovFailure PredicateFailure (EraRule "GOV" era)
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayGovFailure"
  Conway.ConwayTreasuryValueMismatch Mismatch RelEQ Coin
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayTreasuryValueMismatch"
  Conway.ConwayTxRefScriptsSizeTooBig Mismatch RelLTEQ Int
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayTxRefScriptsSizeTooBig"
  Conway.ConwayMempoolFailure Text
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayMempoolFailure"
  Conway.ConwayWithdrawalsMissingAccounts Withdrawals
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayWithdrawalsMissingAccounts"
  Conway.ConwayIncompleteWithdrawals NonEmptyMap AccountAddress (Mismatch RelEQ Coin)
_ -> String -> SubEntitiesPredFailure era
forall {a}. String -> a
impossible String
"ConwayIncompleteWithdrawals"
  where
    impossible :: String -> a
impossible String
name = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Impossible: `" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"` for SUBENTITIES"

instance
  ( STS (SUBCERTS era)
  , PredicateFailure (EraRule "SUBCERTS" era) ~ DijkstraSubCertsPredFailure era
  , Event (EraRule "SUBCERTS" era) ~ DijkstraSubCertsEvent era
  ) =>
  Embed (SUBCERTS era) (SUBENTITIES era)
  where
  wrapFailed :: PredicateFailure (SUBCERTS era)
-> PredicateFailure (SUBENTITIES era)
wrapFailed = PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
PredicateFailure (SUBCERTS era)
-> PredicateFailure (SUBENTITIES era)
forall era.
PredicateFailure (EraRule "SUBCERTS" era)
-> SubEntitiesPredFailure era
SubCertsFailure
  wrapEvent :: Event (SUBCERTS era) -> Event (SUBENTITIES era)
wrapEvent = Event (EraRule "SUBCERTS" era) -> SubEntitiesEvent era
Event (SUBCERTS era) -> Event (SUBENTITIES era)
forall era. Event (EraRule "SUBCERTS" era) -> SubEntitiesEvent era
SubCertsEvent