{-# 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.Shelley.Era (ShelleySNAP)
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  UTxOState (..),
 )
import Cardano.Ledger.State
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 Lens.Micro
import NoThunks.Class (NoThunks (..))

-- ======================================================

data ShelleySnapPredFailure era -- No predicate failures
  deriving (Int -> ShelleySnapPredFailure era -> ShowS
[ShelleySnapPredFailure era] -> ShowS
ShelleySnapPredFailure era -> String
(Int -> ShelleySnapPredFailure era -> ShowS)
-> (ShelleySnapPredFailure era -> String)
-> ([ShelleySnapPredFailure era] -> ShowS)
-> Show (ShelleySnapPredFailure era)
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
$cshowsPrec :: forall era. Int -> ShelleySnapPredFailure era -> ShowS
showsPrec :: Int -> ShelleySnapPredFailure era -> ShowS
$cshow :: forall era. ShelleySnapPredFailure era -> String
show :: ShelleySnapPredFailure era -> String
$cshowList :: forall era. [ShelleySnapPredFailure era] -> ShowS
showList :: [ShelleySnapPredFailure era] -> ShowS
Show, (forall x.
 ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x)
-> (forall x.
    Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era)
-> Generic (ShelleySnapPredFailure era)
forall x.
Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era
forall x.
ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x
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
$cfrom :: forall era x.
ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x
from :: forall x.
ShelleySnapPredFailure era -> Rep (ShelleySnapPredFailure era) x
$cto :: forall era x.
Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era
to :: forall x.
Rep (ShelleySnapPredFailure era) x -> ShelleySnapPredFailure era
Generic, ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
(ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool)
-> (ShelleySnapPredFailure era
    -> ShelleySnapPredFailure era -> Bool)
-> Eq (ShelleySnapPredFailure era)
forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
== :: ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
$c/= :: forall era.
ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
/= :: ShelleySnapPredFailure era -> ShelleySnapPredFailure era -> Bool
Eq)

instance NFData (ShelleySnapPredFailure era)

instance NoThunks (ShelleySnapPredFailure era)

newtype SnapEvent era
  = StakeDistEvent
      (Map (Credential 'Staking) (Coin, KeyHash 'StakePool))
  deriving ((forall x. SnapEvent era -> Rep (SnapEvent era) x)
-> (forall x. Rep (SnapEvent era) x -> SnapEvent era)
-> Generic (SnapEvent era)
forall x. Rep (SnapEvent era) x -> SnapEvent era
forall x. SnapEvent era -> Rep (SnapEvent era) x
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
$cfrom :: forall era x. SnapEvent era -> Rep (SnapEvent era) x
from :: forall x. SnapEvent era -> Rep (SnapEvent era) x
$cto :: forall era x. Rep (SnapEvent era) x -> SnapEvent era
to :: forall x. Rep (SnapEvent era) x -> SnapEvent era
Generic)

deriving instance Eq (SnapEvent era)

instance NFData (SnapEvent era)

data SnapEnv era = SnapEnv (LedgerState era) (PParams era)

instance (EraTxOut era, EraStake era, EraCertState era) => STS (ShelleySNAP era) where
  type State (ShelleySNAP era) = SnapShots
  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 = [SnapShots -> F (Clause (ShelleySNAP era) 'Initial) SnapShots
forall a. a -> F (Clause (ShelleySNAP era) 'Initial) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShots
emptySnapShots]
  transitionRules :: [TransitionRule (ShelleySNAP era)]
transitionRules = [TransitionRule (ShelleySNAP era)
forall era.
(EraStake era, EraCertState era) =>
TransitionRule (ShelleySNAP era)
snapTransition]

-- | The stake distribution was previously computed as in the spec:
--
-- @
--  stakeDistr @era utxo dstate pstate
-- @
--
-- but is now computed incrementally. We leave the comment as a historical note about
-- where important changes were made to the source code.
snapTransition :: (EraStake era, EraCertState era) => TransitionRule (ShelleySNAP era)
snapTransition :: forall era.
(EraStake era, EraCertState era) =>
TransitionRule (ShelleySNAP era)
snapTransition = do
  TRC (Environment (ShelleySNAP era)
snapEnv, State (ShelleySNAP era)
s, Signal (ShelleySNAP era)
_) <- Rule
  (ShelleySNAP era)
  'Transition
  (RuleContext 'Transition (ShelleySNAP era))
F (Clause (ShelleySNAP era) 'Transition) (TRC (ShelleySNAP era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

  let SnapEnv ls :: LedgerState era
ls@(LedgerState (UTxOState UTxO era
_utxo Coin
_ Coin
fees GovState era
_ InstantStake era
_ Coin
_) CertState era
certState) PParams era
_pp = Environment (ShelleySNAP era)
snapEnv
      instantStake :: InstantStake era
instantStake = LedgerState era
ls LedgerState era
-> Getting (InstantStake era) (LedgerState era) (InstantStake era)
-> InstantStake era
forall s a. s -> Getting a s a -> a
^. Getting (InstantStake era) (LedgerState era) (InstantStake era)
forall era. SimpleGetter (LedgerState era) (InstantStake era)
forall (t :: * -> *) era.
CanGetInstantStake t =>
SimpleGetter (t era) (InstantStake era)
instantStakeG
      -- per the spec: stakeSnap = stakeDistr @era utxo dstate pstate
      istakeSnap :: SnapShot
istakeSnap = InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake InstantStake era
instantStake (CertState era
certState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL) (CertState era
certState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)

  Event (ShelleySNAP era) -> Rule (ShelleySNAP era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ShelleySNAP era) -> Rule (ShelleySNAP era) 'Transition ())
-> Event (ShelleySNAP era) -> Rule (ShelleySNAP era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
    let stMap :: Map (Credential 'Staking) (CompactForm Coin)
        stMap :: Map (Credential 'Staking) (CompactForm Coin)
stMap = VMap VB VP (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (VMap VB VP (Credential 'Staking) (CompactForm Coin)
 -> Map (Credential 'Staking) (CompactForm Coin))
-> (Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin))
-> Stake
-> Map (Credential 'Staking) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake (Stake -> Map (Credential 'Staking) (CompactForm Coin))
-> Stake -> Map (Credential 'Staking) (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$ SnapShot -> Stake
ssStake SnapShot
istakeSnap

        stakeCoinMap :: Map (Credential 'Staking) Coin
        stakeCoinMap :: Map (Credential 'Staking) Coin
stakeCoinMap = (CompactForm Coin -> Coin)
-> Map (Credential 'Staking) (CompactForm Coin)
-> Map (Credential 'Staking) Coin
forall a b.
(a -> b)
-> Map (Credential 'Staking) a -> Map (Credential 'Staking) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact Map (Credential 'Staking) (CompactForm Coin)
stMap

        stakePoolMap :: Map (Credential 'Staking) (KeyHash 'StakePool)
        stakePoolMap :: Map (Credential 'Staking) (KeyHash 'StakePool)
stakePoolMap = VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
 -> Map (Credential 'Staking) (KeyHash 'StakePool))
-> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
forall a b. (a -> b) -> a -> b
$ SnapShot -> VMap VB VB (Credential 'Staking) (KeyHash 'StakePool)
ssDelegations SnapShot
istakeSnap

        stakeMap :: Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
        stakeMap :: Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
stakeMap = (Coin -> KeyHash 'StakePool -> (Coin, KeyHash 'StakePool))
-> Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map (Credential 'Staking) Coin
stakeCoinMap Map (Credential 'Staking) (KeyHash 'StakePool)
stakePoolMap
     in Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
-> SnapEvent era
forall era.
Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
-> SnapEvent era
StakeDistEvent Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
stakeMap

  SnapShots -> F (Clause (ShelleySNAP era) 'Transition) SnapShots
forall a. a -> F (Clause (ShelleySNAP era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapShots -> F (Clause (ShelleySNAP era) 'Transition) SnapShots)
-> SnapShots -> F (Clause (ShelleySNAP era) 'Transition) SnapShots
forall a b. (a -> b) -> a -> b
$
    SnapShots
      { $sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark = SnapShot
istakeSnap
      , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
istakeSnap
      , -- ssStakeMarkPoolDistr exists for performance reasons, see ADR-7
        $sel:ssStakeSet:SnapShots :: SnapShot
ssStakeSet = SnapShots -> SnapShot
ssStakeMark SnapShots
State (ShelleySNAP era)
s
      , $sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo = SnapShots -> SnapShot
ssStakeSet SnapShots
State (ShelleySNAP era)
s
      , $sel:ssFee:SnapShots :: Coin
ssFee = Coin
fees
      }