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

module Cardano.Ledger.Shelley.CertState (
  ShelleyCertState (..),
  mkShelleyCertState,
  shelleyCertDStateL,
  shelleyCertVStateL,
  shelleyCertPStateL,
  shelleyObligationCertState,
  shelleyCertsTotalDepositsTxBody,
  shelleyCertsTotalRefundsTxBody,
) where

import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  encodeListLen,
 )
import Cardano.Ledger.CertState
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData (..))
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (Default (..))
import qualified Data.Foldable as F
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, _2)
import NoThunks.Class (NoThunks (..))

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

mkShelleyCertState :: VState era -> PState era -> DState era -> ShelleyCertState era
mkShelleyCertState :: forall era.
VState era -> PState era -> DState era -> ShelleyCertState era
mkShelleyCertState VState era
v PState era
p DState era
d =
  ShelleyCertState
    { shelleyCertVState :: VState era
shelleyCertVState = VState era
v
    , shelleyCertPState :: PState era
shelleyCertPState = PState era
p
    , shelleyCertDState :: DState era
shelleyCertDState = DState era
d
    }

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

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

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

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

shelleyObligationCertState :: ShelleyCertState era -> Obligations
shelleyObligationCertState :: forall era. ShelleyCertState era -> Obligations
shelleyObligationCertState (ShelleyCertState VState {Map (Credential 'DRepRole) DRepState
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps :: Map (Credential 'DRepRole) DRepState
vsDReps} PState {Map (KeyHash 'StakePool) Coin
psDeposits :: forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits} DState {UMap
dsUnified :: forall era. DState era -> UMap
dsUnified :: UMap
dsUnified}) =
  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 Obligations
        { oblStake :: Coin
oblStake = forall a. Compactible a => CompactForm a -> a
UM.fromCompact (forall k. UView k RDPair -> CompactForm Coin
UM.sumDepositUView (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView UMap
dsUnified))
        , oblPool :: Coin
oblPool = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall a. Semigroup a => a -> a -> a
(<>) (Integer -> Coin
Coin Integer
0) Map (KeyHash 'StakePool) Coin
psDeposits
        , 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) Map (Credential 'DRepRole) DRepState
vsDReps
        , oblProposal :: Coin
oblProposal = Integer -> Coin
Coin Integer
0
        }

shelleyCertsTotalDepositsTxBody ::
  EraTxBody era => PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalDepositsTxBody :: forall era.
EraTxBody era =>
PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalDepositsTxBody PParams era
pp ShelleyCertState {PState era
shelleyCertPState :: PState era
shelleyCertPState :: forall era. ShelleyCertState era -> PState era
shelleyCertPState} =
  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
shelleyCertPState)

shelleyCertsTotalRefundsTxBody ::
  EraTxBody era => PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalRefundsTxBody :: forall era.
EraTxBody era =>
PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalRefundsTxBody PParams era
pp ShelleyCertState {DState era
shelleyCertDState :: DState era
shelleyCertDState :: forall era. ShelleyCertState era -> DState era
shelleyCertDState, VState era
shelleyCertVState :: VState era
shelleyCertVState :: forall era. ShelleyCertState era -> VState era
shelleyCertVState} =
  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
shelleyCertDState)
    (forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState VState era
shelleyCertVState)

instance EraCertState ShelleyEra where
  type CertState ShelleyEra = ShelleyCertState ShelleyEra

  mkCertState :: VState ShelleyEra
-> PState ShelleyEra -> DState ShelleyEra -> CertState ShelleyEra
mkCertState = forall era.
VState era -> PState era -> DState era -> ShelleyCertState era
mkShelleyCertState

  upgradeCertState :: EraCertState (PreviousEra ShelleyEra) =>
CertState (PreviousEra ShelleyEra) -> CertState ShelleyEra
upgradeCertState = forall a. HasCallStack => String -> a
error String
"Impossible: ByronEra does not have `EraCertState` instance"

  certDStateL :: Lens' (CertState ShelleyEra) (DState ShelleyEra)
certDStateL = forall era. Lens' (ShelleyCertState era) (DState era)
shelleyCertDStateL
  {-# INLINE certDStateL #-}

  certVStateL :: Lens' (CertState ShelleyEra) (VState ShelleyEra)
certVStateL = forall era. Lens' (ShelleyCertState era) (VState era)
shelleyCertVStateL
  {-# INLINE certVStateL #-}

  certPStateL :: Lens' (CertState ShelleyEra) (PState ShelleyEra)
certPStateL = forall era. Lens' (ShelleyCertState era) (PState era)
shelleyCertPStateL
  {-# INLINE certPStateL #-}

  obligationCertState :: CertState ShelleyEra -> Obligations
obligationCertState = forall era. ShelleyCertState era -> Obligations
shelleyObligationCertState

  certsTotalDepositsTxBody :: EraTxBody ShelleyEra =>
PParams ShelleyEra
-> CertState ShelleyEra -> TxBody ShelleyEra -> Coin
certsTotalDepositsTxBody = forall era.
EraTxBody era =>
PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalDepositsTxBody

  certsTotalRefundsTxBody :: EraTxBody ShelleyEra =>
PParams ShelleyEra
-> CertState ShelleyEra -> TxBody ShelleyEra -> Coin
certsTotalRefundsTxBody = forall era.
EraTxBody era =>
PParams era -> ShelleyCertState era -> TxBody era -> Coin
shelleyCertsTotalRefundsTxBody

instance ToJSON (ShelleyCertState era) where
  toJSON :: ShelleyCertState era -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a era. KeyValue e a => ShelleyCertState era -> [a]
toCertStatePairs
  toEncoding :: ShelleyCertState 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 => ShelleyCertState era -> [a]
toCertStatePairs

instance Era era => EncCBOR (ShelleyCertState era) where
  encCBOR :: ShelleyCertState era -> Encoding
encCBOR ShelleyCertState {PState era
shelleyCertPState :: PState era
shelleyCertPState :: forall era. ShelleyCertState era -> PState era
shelleyCertPState, DState era
shelleyCertDState :: DState era
shelleyCertDState :: forall era. ShelleyCertState era -> DState era
shelleyCertDState, VState era
shelleyCertVState :: VState era
shelleyCertVState :: forall era. ShelleyCertState era -> VState era
shelleyCertVState} =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR VState era
shelleyCertVState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR PState era
shelleyCertPState
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR DState era
shelleyCertDState

instance Era era => DecShareCBOR (ShelleyCertState era) where
  type
    Share (ShelleyCertState era) =
      ( Interns (Credential 'Staking)
      , Interns (KeyHash 'StakePool)
      , Interns (Credential 'DRepRole)
      , Interns (Credential 'HotCommitteeRole)
      )
  decSharePlusCBOR :: forall s.
StateT
  (Share (ShelleyCertState era)) (Decoder s) (ShelleyCertState 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
"ShelleyCertState" (forall a b. a -> b -> a
const Int
3) forall a b. (a -> b) -> a -> b
$ do
    VState era
shelleyCertVState <-
      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
shelleyCertPState <- 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
shelleyCertDState <-
      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 ShelleyCertState {DState era
PState era
VState era
shelleyCertDState :: DState era
shelleyCertPState :: PState era
shelleyCertVState :: VState era
shelleyCertDState :: DState era
shelleyCertPState :: PState era
shelleyCertVState :: VState era
..}

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

instance Era era => NoThunks (ShelleyCertState era)

instance Era era => NFData (ShelleyCertState era)