{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.State.CertState (
  ConwayCertState (..),
  ConwayEraCertState (..),
  csCommitteeCredsL,
  epochStateRegDrepL,
  mkConwayCertState,
  conwayCertDStateL,
  conwayCertPStateL,
  conwayCertVStateL,
  conwayObligationCertState,
  conwayCertsTotalDepositsTxBody,
  conwayCertsTotalRefundsTxBody,
)
where

import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  encodeListLen,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.State.VState
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.LedgerState (EpochState (..), esLStateL, lsCertStateL)
import Cardano.Ledger.Shelley.State
import Control.DeepSeq (NFData (..))
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (Default (def))
import qualified Data.Foldable as F
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (&), (.~), (^.), _2)
import NoThunks.Class (NoThunks (..))

data ConwayCertState era = ConwayCertState
  { forall era. ConwayCertState era -> VState era
conwayCertVState :: !(VState era)
  , forall era. ConwayCertState era -> PState era
conwayCertPState :: !(PState era)
  , forall era. ConwayCertState era -> DState era
conwayCertDState :: !(DState era)
  }
  deriving (Int -> ConwayCertState era -> ShowS
forall era. Int -> ConwayCertState era -> ShowS
forall era. [ConwayCertState era] -> ShowS
forall era. ConwayCertState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayCertState era] -> ShowS
$cshowList :: forall era. [ConwayCertState era] -> ShowS
show :: ConwayCertState era -> String
$cshow :: forall era. ConwayCertState era -> String
showsPrec :: Int -> ConwayCertState era -> ShowS
$cshowsPrec :: forall era. Int -> ConwayCertState era -> ShowS
Show, ConwayCertState era -> ConwayCertState era -> Bool
forall era. ConwayCertState era -> ConwayCertState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayCertState era -> ConwayCertState era -> Bool
$c/= :: forall era. ConwayCertState era -> ConwayCertState era -> Bool
== :: ConwayCertState era -> ConwayCertState era -> Bool
$c== :: forall era. ConwayCertState era -> ConwayCertState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ConwayCertState era) x -> ConwayCertState era
forall era x. ConwayCertState era -> Rep (ConwayCertState era) x
$cto :: forall era x. Rep (ConwayCertState era) x -> ConwayCertState era
$cfrom :: forall era x. ConwayCertState era -> Rep (ConwayCertState era) x
Generic)

-- ===================================
-- VState

csCommitteeCredsL ::
  Lens' (CommitteeState era) (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL :: forall era.
Lens'
  (CommitteeState era)
  (Map (Credential 'ColdCommitteeRole) CommitteeAuthorization)
csCommitteeCredsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
CommitteeState era
-> Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds (\CommitteeState era
cs Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
u -> CommitteeState era
cs {csCommitteeCreds :: Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
csCommitteeCreds = Map (Credential 'ColdCommitteeRole) CommitteeAuthorization
u})

epochStateRegDrepL ::
  ConwayEraCertState era => Lens' (EpochState era) (Map (Credential 'DRepRole) DRepState)
epochStateRegDrepL :: forall era.
ConwayEraCertState era =>
Lens' (EpochState era) (Map (Credential 'DRepRole) DRepState)
epochStateRegDrepL = forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL

class EraCertState era => ConwayEraCertState era where
  certVStateL :: Lens' (CertState era) (VState era)

mkConwayCertState ::
  ConwayEraCertState era => VState era -> PState era -> DState era -> CertState era
mkConwayCertState :: forall era.
ConwayEraCertState era =>
VState era -> PState era -> DState era -> CertState era
mkConwayCertState VState era
v PState era
p DState era
d =
  forall era.
EraCertState era =>
PState era -> DState era -> CertState era
mkShelleyCertState PState era
p DState era
d forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ VState era
v

conwayCertDStateL :: Lens' (ConwayCertState era) (DState era)
conwayCertDStateL :: forall era. Lens' (ConwayCertState era) (DState era)
conwayCertDStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ConwayCertState era -> DState era
conwayCertDState (\ConwayCertState era
ds DState era
u -> ConwayCertState era
ds {conwayCertDState :: DState era
conwayCertDState = DState era
u})
{-# INLINE conwayCertDStateL #-}

conwayCertPStateL :: Lens' (ConwayCertState era) (PState era)
conwayCertPStateL :: forall era. Lens' (ConwayCertState era) (PState era)
conwayCertPStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ConwayCertState era -> PState era
conwayCertPState (\ConwayCertState era
ds PState era
u -> ConwayCertState era
ds {conwayCertPState :: PState era
conwayCertPState = PState era
u})
{-# INLINE conwayCertPStateL #-}

conwayCertVStateL :: Lens' (ConwayCertState era) (VState era)
conwayCertVStateL :: forall era. Lens' (ConwayCertState era) (VState era)
conwayCertVStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. ConwayCertState era -> VState era
conwayCertVState (\ConwayCertState era
ds VState era
u -> ConwayCertState era
ds {conwayCertVState :: VState era
conwayCertVState = VState era
u})
{-# INLINE conwayCertVStateL #-}

toCertStatePairs :: KeyValue e a => ConwayCertState era -> [a]
toCertStatePairs :: forall e a era. KeyValue e a => ConwayCertState era -> [a]
toCertStatePairs certState :: ConwayCertState era
certState@(ConwayCertState VState era
_ PState era
_ DState era
_) =
  let ConwayCertState {PState era
DState era
VState era
conwayCertDState :: DState era
conwayCertPState :: PState era
conwayCertVState :: VState era
conwayCertDState :: forall era. ConwayCertState era -> DState era
conwayCertPState :: forall era. ConwayCertState era -> PState era
conwayCertVState :: forall era. ConwayCertState era -> VState era
..} = ConwayCertState era
certState
   in [ Key
"dstate" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DState era
conwayCertDState
      , Key
"pstate" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PState era
conwayCertPState
      , Key
"vstate" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VState era
conwayCertVState
      ]

conwayObligationCertState :: ConwayEraCertState era => CertState era -> Obligations
conwayObligationCertState :: forall era. ConwayEraCertState era => CertState era -> Obligations
conwayObligationCertState CertState era
certState =
  let accum :: Coin -> DRepState -> Coin
accum Coin
ans DRepState
drepState = Coin
ans forall a. Semigroup a => a -> a -> a
<> DRepState -> Coin
drepDeposit DRepState
drepState
   in (forall era. EraCertState era => CertState era -> Obligations
shelleyObligationCertState CertState era
certState)
        { oblDRep :: Coin
oblDRep = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Coin -> DRepState -> Coin
accum (Integer -> Coin
Coin Integer
0) (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL)
        }

conwayCertsTotalDepositsTxBody ::
  EraTxBody era => PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalDepositsTxBody :: forall era.
EraTxBody era =>
PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalDepositsTxBody PParams era
pp ConwayCertState {PState era
conwayCertPState :: PState era
conwayCertPState :: forall era. ConwayCertState era -> PState era
conwayCertPState} =
  forall era.
EraTxBody era =>
PParams era -> (KeyHash 'StakePool -> Bool) -> TxBody era -> Coin
getTotalDepositsTxBody PParams era
pp (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams PState era
conwayCertPState)

conwayCertsTotalRefundsTxBody ::
  EraTxBody era => PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalRefundsTxBody :: forall era.
EraTxBody era =>
PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalRefundsTxBody PParams era
pp ConwayCertState {DState era
conwayCertDState :: DState era
conwayCertDState :: forall era. ConwayCertState era -> DState era
conwayCertDState, VState era
conwayCertVState :: VState era
conwayCertVState :: forall era. ConwayCertState era -> VState era
conwayCertVState} =
  forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody
    PParams era
pp
    (forall era. DState era -> Credential 'Staking -> Maybe Coin
lookupDepositDState DState era
conwayCertDState)
    (forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState VState era
conwayCertVState)

instance EraCertState ConwayEra where
  type CertState ConwayEra = ConwayCertState ConwayEra

  certDStateL :: Lens' (CertState ConwayEra) (DState ConwayEra)
certDStateL = forall era. Lens' (ConwayCertState era) (DState era)
conwayCertDStateL
  {-# INLINE certDStateL #-}

  certPStateL :: Lens' (CertState ConwayEra) (PState ConwayEra)
certPStateL = forall era. Lens' (ConwayCertState era) (PState era)
conwayCertPStateL
  {-# INLINE certPStateL #-}

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

  certsTotalDepositsTxBody :: EraTxBody ConwayEra =>
PParams ConwayEra
-> CertState ConwayEra -> TxBody ConwayEra -> Coin
certsTotalDepositsTxBody = forall era.
EraTxBody era =>
PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalDepositsTxBody

  certsTotalRefundsTxBody :: EraTxBody ConwayEra =>
PParams ConwayEra
-> CertState ConwayEra -> TxBody ConwayEra -> Coin
certsTotalRefundsTxBody = forall era.
EraTxBody era =>
PParams era -> ConwayCertState era -> TxBody era -> Coin
conwayCertsTotalRefundsTxBody

instance ConwayEraCertState ConwayEra where
  certVStateL :: Lens' (CertState ConwayEra) (VState ConwayEra)
certVStateL = forall era. Lens' (ConwayCertState era) (VState era)
conwayCertVStateL
  {-# INLINE certVStateL #-}

instance ToJSON (ConwayCertState era) where
  toJSON :: ConwayCertState era -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ConwayCertState era -> [a]
toCertStatePairs
  toEncoding :: ConwayCertState era -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ConwayCertState era -> [a]
toCertStatePairs

instance Era era => EncCBOR (ConwayCertState era) where
  encCBOR :: ConwayCertState era -> Encoding
encCBOR ConwayCertState {PState era
conwayCertPState :: PState era
conwayCertPState :: forall era. ConwayCertState era -> PState era
conwayCertPState, DState era
conwayCertDState :: DState era
conwayCertDState :: forall era. ConwayCertState era -> DState era
conwayCertDState, VState era
conwayCertVState :: VState era
conwayCertVState :: forall era. ConwayCertState era -> VState era
conwayCertVState} =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VState era
conwayCertVState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR PState era
conwayCertPState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR DState era
conwayCertDState

instance Era era => DecShareCBOR (ConwayCertState era) where
  type
    Share (ConwayCertState era) =
      ( Interns (Credential 'Staking)
      , Interns (KeyHash 'StakePool)
      , Interns (Credential 'DRepRole)
      , Interns (Credential 'HotCommitteeRole)
      )
  decSharePlusCBOR :: forall s.
StateT
  (Share (ConwayCertState era)) (Decoder s) (ConwayCertState era)
decSharePlusCBOR = forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
"ConwayCertState" (forall a b. a -> b -> a
const Int
3) forall a b. (a -> b) -> a -> b
$ do
    VState era
conwayCertVState <-
      forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall a b. (a -> b) -> a -> b
$
        forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
_, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
ch) -> (Interns (Credential 'Staking)
cs, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
ch)) (\(Interns (Credential 'Staking)
_, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
_, Interns (Credential 'HotCommitteeRole)
_) (Interns (Credential 'Staking)
cs, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
ch) -> (Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
ch))
    PState era
conwayCertPState <- forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall s t a b. Field2 s t a b => Lens s t a b
_2
    DState era
conwayCertDState <-
      forall b bs s.
DecShareCBOR b =>
Lens' bs (Share b) -> StateT bs (Decoder s) b
decSharePlusLensCBOR forall a b. (a -> b) -> a -> b
$
        forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
_) -> (Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
cd)) (\(Interns (Credential 'Staking)
_, Interns (KeyHash 'StakePool)
_, Interns (Credential 'DRepRole)
_, Interns (Credential 'HotCommitteeRole)
ch) (Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
cd) -> (Interns (Credential 'Staking)
cs, Interns (KeyHash 'StakePool)
ks, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
ch))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ConwayCertState {PState era
DState era
VState era
conwayCertDState :: DState era
conwayCertPState :: PState era
conwayCertVState :: VState era
conwayCertDState :: DState era
conwayCertPState :: PState era
conwayCertVState :: VState era
..}

instance Default (ConwayCertState era) where
  def :: ConwayCertState era
def = forall era.
VState era -> PState era -> DState era -> ConwayCertState era
ConwayCertState forall a. Default a => a
def forall a. Default a => a
def forall a. Default a => a
def

instance Era era => NoThunks (ConwayCertState era)

instance Era era => NFData (ConwayCertState era)