{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Shelley.Rules.Snap (
ShelleySNAP,
PredicateFailure,
ShelleySnapPredFailure,
SnapEvent (..),
SnapEnv (..),
)
where
import Cardano.Ledger.BaseTypes (ShelleyBase)
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.EpochBoundary (
SnapShot (ssDelegations, ssStake),
SnapShots (..),
Stake (unStake),
calculatePoolDistr,
emptySnapShots,
)
import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking))
import Cardano.Ledger.Shelley.Era (ShelleySNAP)
import Cardano.Ledger.Shelley.LedgerState (
CertState (..),
LedgerState (..),
UTxOState (..),
incrementalStakeDistr,
)
import Control.DeepSeq (NFData)
import Control.State.Transition (
STS (..),
TRC (..),
TransitionRule,
judgmentContext,
tellEvent,
)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.VMap as VMap
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
data ShelleySnapPredFailure era
deriving (Int -> ShelleySnapPredFailure era -> ShowS
forall era. Int -> ShelleySnapPredFailure era -> ShowS
forall era. [ShelleySnapPredFailure era] -> ShowS
forall era. ShelleySnapPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleySnapPredFailure era] -> ShowS
$cshowList :: forall era. [ShelleySnapPredFailure era] -> ShowS
show :: ShelleySnapPredFailure era -> String
$cshow :: forall era. ShelleySnapPredFailure era -> String
showsPrec :: Int -> ShelleySnapPredFailure era -> ShowS
$cshowsPrec :: forall era. Int -> ShelleySnapPredFailure era -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era
forall era x.
ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x
$cto :: forall era x.
Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era
$cfrom :: forall era x.
ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x
Generic, ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
$c/= :: forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
== :: ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
$c== :: forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
Eq)
instance NFData (ShelleySnapPredFailure era)
instance NoThunks (ShelleySnapPredFailure era)
newtype SnapEvent era
= StakeDistEvent
(Map (Credential 'Staking (EraCrypto era)) (Coin, KeyHash 'StakePool (EraCrypto era)))
deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (SnapEvent era) x -> SnapEvent era
forall era x. SnapEvent era -> Rep (SnapEvent era) x
$cto :: forall era x. Rep (SnapEvent era) x -> SnapEvent era
$cfrom :: forall era x. SnapEvent era -> Rep (SnapEvent era) x
Generic)
deriving instance Eq (SnapEvent era)
instance NFData (SnapEvent era)
data SnapEnv era = SnapEnv !(LedgerState era) !(PParams era)
instance EraTxOut era => STS (ShelleySNAP era) where
type State (ShelleySNAP era) = SnapShots (EraCrypto era)
type Signal (ShelleySNAP era) = ()
type Environment (ShelleySNAP era) = SnapEnv era
type BaseM (ShelleySNAP era) = ShelleyBase
type PredicateFailure (ShelleySNAP era) = ShelleySnapPredFailure era
type Event (ShelleySNAP era) = SnapEvent era
initialRules :: [InitialRule (ShelleySNAP era)]
initialRules = [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall c. SnapShots c
emptySnapShots]
transitionRules :: [TransitionRule (ShelleySNAP era)]
transitionRules = [forall era. EraPParams era => TransitionRule (ShelleySNAP era)
snapTransition]
snapTransition ::
forall era.
EraPParams era =>
TransitionRule (ShelleySNAP era)
snapTransition :: forall era. EraPParams era => TransitionRule (ShelleySNAP era)
snapTransition = do
TRC (Environment (ShelleySNAP era)
snapEnv, State (ShelleySNAP era)
s, Signal (ShelleySNAP era)
_) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
let SnapEnv (LedgerState (UTxOState UTxO era
_utxo Coin
_ Coin
fees GovState era
_ IncrementalStake (EraCrypto era)
incStake Coin
_) (CertState VState era
_ PState era
pstate DState era
dstate)) PParams era
pp = Environment (ShelleySNAP era)
snapEnv
istakeSnap :: SnapShot (EraCrypto era)
istakeSnap = forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr PParams era
pp IncrementalStake (EraCrypto era)
incStake DState era
dstate PState era
pstate
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$
let stMap :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stMap :: Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stMap = forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
unStake forall a b. (a -> b) -> a -> b
$ forall c. SnapShot c -> Stake c
ssStake SnapShot (EraCrypto era)
istakeSnap
stakeCoinMap :: Map (Credential 'Staking (EraCrypto era)) Coin
stakeCoinMap :: Map (Credential 'Staking (EraCrypto era)) Coin
stakeCoinMap = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Compactible a => CompactForm a -> a
fromCompact Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
stMap
stakePoolMap :: Map (Credential 'Staking (EraCrypto era)) (KeyHash 'StakePool (EraCrypto era))
stakePoolMap :: Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
stakePoolMap = forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap forall a b. (a -> b) -> a -> b
$ forall c.
SnapShot c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
ssDelegations SnapShot (EraCrypto era)
istakeSnap
stakeMap :: Map (Credential 'Staking (EraCrypto era)) (Coin, KeyHash 'StakePool (EraCrypto era))
stakeMap :: Map
(Credential 'Staking (EraCrypto era))
(Coin, KeyHash 'StakePool (EraCrypto era))
stakeMap = forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map (Credential 'Staking (EraCrypto era)) Coin
stakeCoinMap Map
(Credential 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
stakePoolMap
in forall era.
Map
(Credential 'Staking (EraCrypto era))
(Coin, KeyHash 'StakePool (EraCrypto era))
-> SnapEvent era
StakeDistEvent Map
(Credential 'Staking (EraCrypto era))
(Coin, KeyHash 'StakePool (EraCrypto era))
stakeMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
SnapShots
{ $sel:ssStakeMark:SnapShots :: SnapShot (EraCrypto era)
ssStakeMark = SnapShot (EraCrypto era)
istakeSnap
, $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr (EraCrypto era)
ssStakeMarkPoolDistr = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
istakeSnap
,
$sel:ssStakeSet:SnapShots :: SnapShot (EraCrypto era)
ssStakeSet = forall c. SnapShots c -> SnapShot c
ssStakeMark State (ShelleySNAP era)
s
, $sel:ssStakeGo:SnapShots :: SnapShot (EraCrypto era)
ssStakeGo = forall c. SnapShots c -> SnapShot c
ssStakeSet State (ShelleySNAP era)
s
, $sel:ssFee:SnapShots :: Coin
ssFee = Coin
fees
}