{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.State.CertState () where

import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Conway.TxBody (conwayProposalsDeposits)
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
import Cardano.Ledger.Dijkstra.State.Account ()
import Cardano.Ledger.Dijkstra.Tx ()
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..))
import Cardano.Ledger.Val ((<+>))
import Data.Foldable (foldMap')
import qualified Data.Map.Strict as Map
import Lens.Micro ((^.))

instance EraCertState DijkstraEra where
  type CertState DijkstraEra = ConwayCertState DijkstraEra

  certDStateL :: Lens' (CertState DijkstraEra) (DState DijkstraEra)
certDStateL = (DState DijkstraEra -> f (DState DijkstraEra))
-> CertState DijkstraEra -> f (CertState DijkstraEra)
(DState DijkstraEra -> f (DState DijkstraEra))
-> ConwayCertState DijkstraEra -> f (ConwayCertState DijkstraEra)
forall era (f :: * -> *).
Functor f =>
(DState era -> f (DState era))
-> ConwayCertState era -> f (ConwayCertState era)
conwayCertDStateL
  {-# INLINE certDStateL #-}

  certPStateL :: Lens' (CertState DijkstraEra) (PState DijkstraEra)
certPStateL = (PState DijkstraEra -> f (PState DijkstraEra))
-> CertState DijkstraEra -> f (CertState DijkstraEra)
(PState DijkstraEra -> f (PState DijkstraEra))
-> ConwayCertState DijkstraEra -> f (ConwayCertState DijkstraEra)
forall era (f :: * -> *).
Functor f =>
(PState era -> f (PState era))
-> ConwayCertState era -> f (ConwayCertState era)
conwayCertPStateL
  {-# INLINE certPStateL #-}

  obligationCertState :: CertState DijkstraEra -> Obligations
obligationCertState = CertState DijkstraEra -> Obligations
forall era. ConwayEraCertState era => CertState era -> Obligations
conwayObligationCertState

  certsTotalDepositsTxBody :: EraTxBody DijkstraEra =>
PParams DijkstraEra
-> CertState DijkstraEra -> TxBody TopTx DijkstraEra -> Coin
certsTotalDepositsTxBody = PParams DijkstraEra
-> CertState DijkstraEra -> TxBody TopTx DijkstraEra -> Coin
PParams DijkstraEra
-> ConwayCertState DijkstraEra -> TxBody TopTx DijkstraEra -> Coin
forall era.
(EraTx era, DijkstraEraTxBody era) =>
PParams era -> ConwayCertState era -> TxBody TopTx era -> Coin
dijkstraCertsTotalDepositsTxBody

  certsTotalRefundsTxBody :: forall (t :: TxLevel).
EraTxBody DijkstraEra =>
PParams DijkstraEra
-> Accounts DijkstraEra -> TxBody t DijkstraEra -> Coin
certsTotalRefundsTxBody = PParams DijkstraEra
-> Accounts DijkstraEra -> TxBody t DijkstraEra -> Coin
forall era (l :: TxLevel).
(EraTx era, DijkstraEraTxBody era,
 STxLevel l era ~ STxBothLevels l era) =>
PParams era -> Accounts era -> TxBody l era -> Coin
dijkstraCertsTotalRefundsTxBody

instance ConwayEraCertState DijkstraEra where
  certVStateL :: Lens' (CertState DijkstraEra) (VState DijkstraEra)
certVStateL = (VState DijkstraEra -> f (VState DijkstraEra))
-> CertState DijkstraEra -> f (CertState DijkstraEra)
(VState DijkstraEra -> f (VState DijkstraEra))
-> ConwayCertState DijkstraEra -> f (ConwayCertState DijkstraEra)
forall era (f :: * -> *).
Functor f =>
(VState era -> f (VState era))
-> ConwayCertState era -> f (ConwayCertState era)
conwayCertVStateL
  {-# INLINE certVStateL #-}

-- | Total deposits for a transaction, summed across the top-level tx and its subtransactions
dijkstraCertsTotalDepositsTxBody ::
  forall era.
  ( EraTx era
  , DijkstraEraTxBody era
  ) =>
  PParams era ->
  ConwayCertState era ->
  TxBody TopTx era ->
  Coin
dijkstraCertsTotalDepositsTxBody :: forall era.
(EraTx era, DijkstraEraTxBody era) =>
PParams era -> ConwayCertState era -> TxBody TopTx era -> Coin
dijkstraCertsTotalDepositsTxBody PParams era
pp ConwayCertState era
certState TxBody TopTx era
topTxBody =
  PParams era
-> (KeyHash StakePool -> Bool) -> StrictSeq (TxCert era) -> Coin
forall era (f :: * -> *).
(EraTxCert era, Foldable f) =>
PParams era
-> (KeyHash StakePool -> Bool) -> f (TxCert era) -> Coin
forall (f :: * -> *).
Foldable f =>
PParams era
-> (KeyHash StakePool -> Bool) -> f (TxCert era) -> Coin
getTotalDepositsTxCerts PParams era
pp KeyHash StakePool -> Bool
isPoolReg StrictSeq (TxCert era)
batchTxCerts
    Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> PParams era -> TxBody TopTx era -> Coin
forall era (l :: TxLevel).
ConwayEraTxBody era =>
PParams era -> TxBody l era -> Coin
conwayProposalsDeposits PParams era
pp TxBody TopTx era
topTxBody
    Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Tx SubTx era -> Coin) -> OMap TxId (Tx SubTx era) -> Coin
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (PParams era -> TxBody SubTx era -> Coin
forall era (l :: TxLevel).
ConwayEraTxBody era =>
PParams era -> TxBody l era -> Coin
conwayProposalsDeposits PParams era
pp (TxBody SubTx era -> Coin)
-> (Tx SubTx era -> TxBody SubTx era) -> Tx SubTx era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tx SubTx era
-> Getting (TxBody SubTx era) (Tx SubTx era) (TxBody SubTx era)
-> TxBody SubTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody SubTx era) (Tx SubTx era) (TxBody 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)) OMap TxId (Tx SubTx era)
subTxs
  where
    subTxs :: OMap TxId (Tx SubTx era)
subTxs = TxBody TopTx era
topTxBody TxBody TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (TxBody TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. Getting
  (OMap TxId (Tx SubTx era))
  (TxBody TopTx era)
  (OMap TxId (Tx SubTx era))
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL
    batchTxCerts :: StrictSeq (TxCert era)
batchTxCerts =
      (Tx SubTx era -> StrictSeq (TxCert era))
-> OMap TxId (Tx SubTx era) -> StrictSeq (TxCert era)
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (Tx SubTx era
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Tx SubTx era -> Const (StrictSeq (TxCert era)) (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 (StrictSeq (TxCert era)) (TxBody SubTx era))
 -> Tx SubTx era -> Const (StrictSeq (TxCert era)) (Tx SubTx era))
-> ((StrictSeq (TxCert era)
     -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
    -> TxBody SubTx era
    -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era)
 -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
-> TxBody SubTx era
-> Const (StrictSeq (TxCert era)) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL) OMap TxId (Tx SubTx era)
subTxs
        StrictSeq (TxCert era)
-> StrictSeq (TxCert era) -> StrictSeq (TxCert era)
forall a. Semigroup a => a -> a -> a
<> (TxBody TopTx era
topTxBody TxBody TopTx era
-> Getting
     (StrictSeq (TxCert era))
     (TxBody TopTx era)
     (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era))
  (TxBody TopTx era)
  (StrictSeq (TxCert era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL)
    isPoolReg :: KeyHash StakePool -> Bool
isPoolReg = (KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (ConwayCertState era -> PState era
forall era. ConwayCertState era -> PState era
conwayCertPState ConwayCertState era
certState))

-- | Total refunds for a transaction, summed across the top-level tx and its subtransactions
dijkstraCertsTotalRefundsTxBody ::
  forall era l.
  ( EraTx era
  , DijkstraEraTxBody era
  , STxLevel l era ~ STxBothLevels l era
  ) =>
  PParams era ->
  Accounts era ->
  TxBody l era ->
  Coin
dijkstraCertsTotalRefundsTxBody :: forall era (l :: TxLevel).
(EraTx era, DijkstraEraTxBody era,
 STxLevel l era ~ STxBothLevels l era) =>
PParams era -> Accounts era -> TxBody l era -> Coin
dijkstraCertsTotalRefundsTxBody PParams era
pp Accounts era
_ TxBody l era
txBody =
  PParams era
-> (Credential Staking -> Maybe Coin)
-> StrictSeq (TxCert era)
-> Coin
forall era (f :: * -> *).
(EraTxCert era, Foldable f) =>
PParams era
-> (Credential Staking -> Maybe Coin) -> f (TxCert era) -> Coin
forall (f :: * -> *).
Foldable f =>
PParams era
-> (Credential Staking -> Maybe Coin) -> f (TxCert era) -> Coin
getTotalRefundsTxCerts PParams era
pp (Maybe Coin -> Credential Staking -> Maybe Coin
forall a b. a -> b -> a
const Maybe Coin
forall a. Maybe a
Nothing) (StrictSeq (TxCert era) -> Coin) -> StrictSeq (TxCert era) -> Coin
forall a b. (a -> b) -> a -> b
$
    TxBody l era
-> (TxBody TopTx era -> StrictSeq (TxCert era))
-> (TxBody SubTx era -> StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall (l :: TxLevel) era (t :: TxLevel -> * -> *) a.
(HasEraTxLevel t era, STxLevel l era ~ STxBothLevels l era) =>
t l era -> (t TopTx era -> a) -> (t SubTx era -> a) -> a
withBothTxLevels
      TxBody l era
txBody
      ( \TxBody TopTx era
topTxBody ->
          (Tx SubTx era -> StrictSeq (TxCert era))
-> OMap TxId (Tx SubTx era) -> StrictSeq (TxCert era)
forall m a. Monoid m => (a -> m) -> OMap TxId a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (Tx SubTx era
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. (TxBody SubTx era
 -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Tx SubTx era -> Const (StrictSeq (TxCert era)) (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 (StrictSeq (TxCert era)) (TxBody SubTx era))
 -> Tx SubTx era -> Const (StrictSeq (TxCert era)) (Tx SubTx era))
-> ((StrictSeq (TxCert era)
     -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
    -> TxBody SubTx era
    -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> Getting
     (StrictSeq (TxCert era)) (Tx SubTx era) (StrictSeq (TxCert era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era)
 -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
-> TxBody SubTx era
-> Const (StrictSeq (TxCert era)) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL) (TxBody TopTx era
topTxBody TxBody TopTx era
-> Getting
     (OMap TxId (Tx SubTx era))
     (TxBody TopTx era)
     (OMap TxId (Tx SubTx era))
-> OMap TxId (Tx SubTx era)
forall s a. s -> Getting a s a -> a
^. Getting
  (OMap TxId (Tx SubTx era))
  (TxBody TopTx era)
  (OMap TxId (Tx SubTx era))
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL)
            StrictSeq (TxCert era)
-> StrictSeq (TxCert era) -> StrictSeq (TxCert era)
forall a. Semigroup a => a -> a -> a
<> (TxBody TopTx era
topTxBody TxBody TopTx era
-> Getting
     (StrictSeq (TxCert era))
     (TxBody TopTx era)
     (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era))
  (TxBody TopTx era)
  (StrictSeq (TxCert era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL)
      )
      (TxBody SubTx era
-> ((StrictSeq (TxCert era)
     -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
    -> TxBody SubTx era
    -> Const (StrictSeq (TxCert era)) (TxBody SubTx era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. (StrictSeq (TxCert era)
 -> Const (StrictSeq (TxCert era)) (StrictSeq (TxCert era)))
-> TxBody SubTx era
-> Const (StrictSeq (TxCert era)) (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL)