{-# 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 -- No predicate failures
  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]

-- | 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 ::
  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
      -- per the spec: stakeSnap = stakeDistr @era utxo dstate pstate
      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
      , -- ssStakeMarkPoolDistr exists for performance reasons, see ADR-7
        $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
      }