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

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

import Cardano.Ledger.Binary (
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  decSharePlusLensCBOR,
  decodeRecordNamedT,
  encodeListLen,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.State
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 -> 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 :: EraCertState era => PState era -> DState era -> CertState era
mkShelleyCertState :: forall era.
EraCertState era =>
PState era -> DState era -> CertState era
mkShelleyCertState PState era
p DState era
d =
  forall a. Default a => a
def
    forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
p
    forall a b. a -> (a -> b) -> b
& forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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 #-}

toCertStatePairs :: KeyValue e a => ShelleyCertState era -> [a]
toCertStatePairs :: forall e a era. KeyValue e a => ShelleyCertState era -> [a]
toCertStatePairs certState :: ShelleyCertState era
certState@(ShelleyCertState PState era
_ DState era
_) =
  let ShelleyCertState {DState era
PState era
shelleyCertDState :: DState era
shelleyCertPState :: PState era
shelleyCertDState :: forall era. ShelleyCertState era -> DState era
shelleyCertPState :: forall era. ShelleyCertState era -> PState 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
      ]

shelleyObligationCertState :: EraCertState era => CertState era -> Obligations
shelleyObligationCertState :: forall era. EraCertState era => CertState era -> Obligations
shelleyObligationCertState CertState era
certState =
  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 (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL)))
    , 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) (CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (PState era)
certPStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (PState era) (Map (KeyHash 'StakePool) Coin)
psDepositsL)
    , oblDRep :: Coin
oblDRep = Integer -> Coin
Coin Integer
0
    , 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} =
  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 a b. a -> b -> a
const forall a. Maybe a
Nothing)

instance EraCertState ShelleyEra where
  type CertState ShelleyEra = ShelleyCertState ShelleyEra

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

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

  obligationCertState :: CertState ShelleyEra -> Obligations
obligationCertState = forall era. EraCertState era => CertState 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} =
    Word -> Encoding
encodeListLen Word
2
      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
2) forall a b. (a -> b) -> a -> b
$ do
    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
shelleyCertDState :: DState era
shelleyCertPState :: PState era
shelleyCertDState :: DState era
shelleyCertPState :: PState era
..}

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

instance Era era => NoThunks (ShelleyCertState era)

instance Era era => NFData (ShelleyCertState era)