{-# 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.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) (Coin, KeyHash 'StakePool))
  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
  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 SnapShots
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
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
istakeSnap = forall era.
EraPParams era =>
PParams era
-> IncrementalStake -> DState era -> PState era -> SnapShot
incrementalStakeDistr PParams era
pp IncrementalStake
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) (CompactForm Coin)
        stMap :: Map (Credential 'Staking) (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
. Stake -> VMap VB VP (Credential 'Staking) (CompactForm Coin)
unStake forall a b. (a -> b) -> a -> b
$ SnapShot -> Stake
ssStake SnapShot
istakeSnap

        stakeCoinMap :: Map (Credential 'Staking) Coin
        stakeCoinMap :: Map (Credential 'Staking) 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) (CompactForm Coin)
stMap

        stakePoolMap :: Map (Credential 'Staking) (KeyHash 'StakePool)
        stakePoolMap :: Map (Credential 'Staking) (KeyHash 'StakePool)
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
$ 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 = 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 forall era.
Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
-> SnapEvent era
StakeDistEvent Map (Credential 'Staking) (Coin, KeyHash 'StakePool)
stakeMap

  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 State (ShelleySNAP era)
s
      , $sel:ssStakeGo:SnapShots :: SnapShot
ssStakeGo = SnapShots -> SnapShot
ssStakeSet State (ShelleySNAP era)
s
      , $sel:ssFee:SnapShots :: Coin
ssFee = Coin
fees
      }