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

module Cardano.Ledger.Conway.State.VState (
  VState (..),
  vsDRepsL,
  vsCommitteeStateL,
  vsNumDormantEpochsL,
  vsActualDRepExpiry,
  lookupDepositVState,
)
where

import Cardano.Ledger.BaseTypes (binOpEpochNo)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
  Interns,
  decNoShareCBOR,
  decodeMap,
  interns,
  internsFromSet,
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Slot (EpochNo (..))
import Control.DeepSeq (NFData (..))
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import Data.Default (Default (def))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (^.))
import NoThunks.Class (NoThunks (..))

-- | The state that tracks the voting entities (DReps and Constitutional Committee
-- members). In the formal ledger specification this type is called @GState@
data VState era = VState
  { forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps :: !(Map (Credential 'DRepRole) DRepState)
  , forall era. VState era -> CommitteeState era
vsCommitteeState :: !(CommitteeState era)
  , forall era. VState era -> EpochNo
vsNumDormantEpochs :: !EpochNo
  -- ^ Number of contiguous epochs in which there are exactly zero
  -- active governance proposals to vote on. It is incremented in every
  -- EPOCH rule if the number of active governance proposals to vote on
  -- continues to be zero. It is reset to zero when a new governance
  -- action is successfully proposed. We need this counter in order to
  -- bump DRep expiries through dormant periods when DReps do not have
  -- an opportunity to vote on anything.
  }
  deriving (Int -> VState era -> ShowS
forall era. Int -> VState era -> ShowS
forall era. [VState era] -> ShowS
forall era. VState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VState era] -> ShowS
$cshowList :: forall era. [VState era] -> ShowS
show :: VState era -> String
$cshow :: forall era. VState era -> String
showsPrec :: Int -> VState era -> ShowS
$cshowsPrec :: forall era. Int -> VState era -> ShowS
Show, VState era -> VState era -> Bool
forall era. VState era -> VState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VState era -> VState era -> Bool
$c/= :: forall era. VState era -> VState era -> Bool
== :: VState era -> VState era -> Bool
$c== :: forall era. VState era -> VState era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (VState era) x -> VState era
forall era x. VState era -> Rep (VState era) x
$cto :: forall era x. Rep (VState era) x -> VState era
$cfrom :: forall era x. VState era -> Rep (VState era) x
Generic)

-- | Function that looks up the deposit for currently registered DRep
lookupDepositVState :: VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState :: forall era. VState era -> Credential 'DRepRole -> Maybe Coin
lookupDepositVState VState era
vstate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DRepState -> Coin
drepDeposit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (VState era
vstate forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL)

instance Default (VState era) where
  def :: VState era
def = forall era.
Map (Credential 'DRepRole) DRepState
-> CommitteeState era -> EpochNo -> VState era
VState forall a. Default a => a
def forall a. Default a => a
def (Word64 -> EpochNo
EpochNo Word64
0)

instance NoThunks (VState era)

instance NFData (VState era)

instance Era era => DecShareCBOR (VState era) where
  type
    Share (VState era) =
      ( Interns (Credential 'Staking)
      , Interns (Credential 'DRepRole)
      , Interns (Credential 'HotCommitteeRole)
      )
  getShare :: VState era -> Share (VState era)
getShare VState {Map (Credential 'DRepRole) DRepState
vsDReps :: Map (Credential 'DRepRole) DRepState
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps, CommitteeState era
vsCommitteeState :: CommitteeState era
vsCommitteeState :: forall era. VState era -> CommitteeState era
vsCommitteeState} =
    (forall k. Ord k => Set k -> Interns k
internsFromSet (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DRepState -> Set (Credential 'Staking)
drepDelegs Map (Credential 'DRepRole) DRepState
vsDReps), forall a b. (a, b) -> a
fst (forall a. DecShareCBOR a => a -> Share a
getShare Map (Credential 'DRepRole) DRepState
vsDReps), forall a. DecShareCBOR a => a -> Share a
getShare CommitteeState era
vsCommitteeState)
  decShareCBOR :: forall s. Share (VState era) -> Decoder s (VState era)
decShareCBOR (Interns (Credential 'Staking)
cs, Interns (Credential 'DRepRole)
cd, Interns (Credential 'HotCommitteeRole)
_) =
    forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Decode ('Closed 'Dense) t
RecD forall era.
Map (Credential 'DRepRole) DRepState
-> CommitteeState era -> EpochNo -> VState era
VState
        forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall k s v.
Ord k =>
Decoder s k -> Decoder s v -> Decoder s (Map k v)
decodeMap (forall k. Interns k -> k -> k
interns Interns (Credential 'DRepRole)
cd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR) (forall a s. DecShareCBOR a => Share a -> Decoder s a
decShareCBOR Interns (Credential 'Staking)
cs))
        forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR
        forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance Era era => DecCBOR (VState era) where
  decCBOR :: forall s. Decoder s (VState era)
decCBOR = forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

instance Era era => EncCBOR (VState era) where
  encCBOR :: VState era -> Encoding
encCBOR VState {Map (Credential 'DRepRole) DRepState
CommitteeState era
EpochNo
vsNumDormantEpochs :: EpochNo
vsCommitteeState :: CommitteeState era
vsDReps :: Map (Credential 'DRepRole) DRepState
vsNumDormantEpochs :: forall era. VState era -> EpochNo
vsCommitteeState :: forall era. VState era -> CommitteeState era
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
..} =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec (forall era.
Map (Credential 'DRepRole) DRepState
-> CommitteeState era -> EpochNo -> VState era
VState @era)
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Map (Credential 'DRepRole) DRepState
vsDReps
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To CommitteeState era
vsCommitteeState
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
vsNumDormantEpochs

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

toVStatePair :: KeyValue e a => VState era -> [a]
toVStatePair :: forall e a era. KeyValue e a => VState era -> [a]
toVStatePair vs :: VState era
vs@(VState Map (Credential 'DRepRole) DRepState
_ CommitteeState era
_ EpochNo
_) =
  let VState {Map (Credential 'DRepRole) DRepState
CommitteeState era
EpochNo
vsNumDormantEpochs :: EpochNo
vsCommitteeState :: CommitteeState era
vsDReps :: Map (Credential 'DRepRole) DRepState
vsNumDormantEpochs :: forall era. VState era -> EpochNo
vsCommitteeState :: forall era. VState era -> CommitteeState era
vsDReps :: forall era. VState era -> Map (Credential 'DRepRole) DRepState
..} = VState era
vs
   in [ Key
"dreps" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map (Credential 'DRepRole) DRepState
vsDReps
      , Key
"committeeState" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CommitteeState era
vsCommitteeState
      , Key
"numDormantEpochs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= EpochNo
vsNumDormantEpochs
      ]

vsDRepsL :: Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL :: forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps (\VState era
vs Map (Credential 'DRepRole) DRepState
u -> VState era
vs {vsDReps :: Map (Credential 'DRepRole) DRepState
vsDReps = Map (Credential 'DRepRole) DRepState
u})

vsCommitteeStateL :: Lens' (VState era) (CommitteeState era)
vsCommitteeStateL :: forall era. Lens' (VState era) (CommitteeState era)
vsCommitteeStateL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> CommitteeState era
vsCommitteeState (\VState era
vs CommitteeState era
u -> VState era
vs {vsCommitteeState :: CommitteeState era
vsCommitteeState = CommitteeState era
u})

vsNumDormantEpochsL :: Lens' (VState era) EpochNo
vsNumDormantEpochsL :: forall era. Lens' (VState era) EpochNo
vsNumDormantEpochsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. VState era -> EpochNo
vsNumDormantEpochs (\VState era
vs EpochNo
u -> VState era
vs {vsNumDormantEpochs :: EpochNo
vsNumDormantEpochs = EpochNo
u})

vsActualDRepExpiry :: Credential 'DRepRole -> VState era -> Maybe EpochNo
vsActualDRepExpiry :: forall era. Credential 'DRepRole -> VState era -> Maybe EpochNo
vsActualDRepExpiry Credential 'DRepRole
cred VState era
vs =
  (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo
binOpEpochNo forall a. Num a => a -> a -> a
(+) (forall era. VState era -> EpochNo
vsNumDormantEpochs VState era
vs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepState -> EpochNo
drepExpiry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole
cred (forall era. VState era -> Map (Credential 'DRepRole) DRepState
vsDReps VState era
vs)