{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Shelley.Rules.Snap
  ( SNAP,
    PredicateFailure,
    SnapPredicateFailure,
    SnapEvent (..),
  )
where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Era (Crypto)
import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking))
import Cardano.Ledger.Shelley.Constraints (UsesTxOut, UsesValue)
import Cardano.Ledger.Shelley.EpochBoundary
import Cardano.Ledger.Shelley.LedgerState
  ( DPState (..),
    LedgerState (..),
    UTxOState (..),
    incrementalStakeDistr,
  )
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 SNAP era

data SnapPredicateFailure era -- No predicate failures
  deriving (Int -> SnapPredicateFailure era -> ShowS
[SnapPredicateFailure era] -> ShowS
SnapPredicateFailure era -> String
(Int -> SnapPredicateFailure era -> ShowS)
-> (SnapPredicateFailure era -> String)
-> ([SnapPredicateFailure era] -> ShowS)
-> Show (SnapPredicateFailure era)
forall era. Int -> SnapPredicateFailure era -> ShowS
forall era. [SnapPredicateFailure era] -> ShowS
forall era. SnapPredicateFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SnapPredicateFailure era] -> ShowS
$cshowList :: forall era. [SnapPredicateFailure era] -> ShowS
show :: SnapPredicateFailure era -> String
$cshow :: forall era. SnapPredicateFailure era -> String
showsPrec :: Int -> SnapPredicateFailure era -> ShowS
$cshowsPrec :: forall era. Int -> SnapPredicateFailure era -> ShowS
Show, (forall x.
 SnapPredicateFailure era -> Rep (SnapPredicateFailure era) x)
-> (forall x.
    Rep (SnapPredicateFailure era) x -> SnapPredicateFailure era)
-> Generic (SnapPredicateFailure era)
forall x.
Rep (SnapPredicateFailure era) x -> SnapPredicateFailure era
forall x.
SnapPredicateFailure era -> Rep (SnapPredicateFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (SnapPredicateFailure era) x -> SnapPredicateFailure era
forall era x.
SnapPredicateFailure era -> Rep (SnapPredicateFailure era) x
$cto :: forall era x.
Rep (SnapPredicateFailure era) x -> SnapPredicateFailure era
$cfrom :: forall era x.
SnapPredicateFailure era -> Rep (SnapPredicateFailure era) x
Generic, SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
(SnapPredicateFailure era -> SnapPredicateFailure era -> Bool)
-> (SnapPredicateFailure era -> SnapPredicateFailure era -> Bool)
-> Eq (SnapPredicateFailure era)
forall era.
SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
$c/= :: forall era.
SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
== :: SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
$c== :: forall era.
SnapPredicateFailure era -> SnapPredicateFailure era -> Bool
Eq)

instance NoThunks (SnapPredicateFailure era)

data SnapEvent era
  = StakeDistEvent !(Map (Credential 'Staking (Crypto era)) (Coin, (KeyHash 'StakePool (Crypto era))))

instance (UsesTxOut era, UsesValue era) => STS (SNAP era) where
  type State (SNAP era) = SnapShots (Crypto era)
  type Signal (SNAP era) = ()
  type Environment (SNAP era) = LedgerState era
  type BaseM (SNAP era) = ShelleyBase
  type PredicateFailure (SNAP era) = SnapPredicateFailure era
  type Event (SNAP era) = SnapEvent era
  initialRules :: [InitialRule (SNAP era)]
initialRules = [SnapShots (Crypto era)
-> F (Clause (SNAP era) 'Initial) (SnapShots (Crypto era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapShots (Crypto era)
forall crypto. SnapShots crypto
emptySnapShots]
  transitionRules :: [TransitionRule (SNAP era)]
transitionRules = [TransitionRule (SNAP era)
forall era. TransitionRule (SNAP 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.
  TransitionRule (SNAP era)
snapTransition :: TransitionRule (SNAP era)
snapTransition = do
  TRC (Environment (SNAP era)
lstate, State (SNAP era)
s, Signal (SNAP era)
_) <- F (Clause (SNAP era) 'Transition) (TRC (SNAP era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

  let LedgerState (UTxOState UTxO era
_utxo Coin
_ Coin
fees State (EraRule "PPUP" era)
_ IncrementalStake (Crypto era)
incStake) (DPState DState (Crypto era)
dstate PState (Crypto era)
pstate) = Environment (SNAP era)
LedgerState era
lstate
      -- stakeSnap = stakeDistr @era utxo dstate pstate  -- HISTORICAL NOTE
      istakeSnap :: SnapShot (Crypto era)
istakeSnap = IncrementalStake (Crypto era)
-> DState (Crypto era)
-> PState (Crypto era)
-> SnapShot (Crypto era)
forall crypto.
IncrementalStake crypto
-> DState crypto -> PState crypto -> SnapShot crypto
incrementalStakeDistr @(Crypto era) IncrementalStake (Crypto era)
incStake DState (Crypto era)
dstate PState (Crypto era)
pstate

  Event (SNAP era) -> Rule (SNAP era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (SNAP era) -> Rule (SNAP era) 'Transition ())
-> Event (SNAP era) -> Rule (SNAP era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
    let stMap :: Map (Credential 'Staking (Crypto era)) (CompactForm Coin)
        stMap :: Map (Credential 'Staking (Crypto era)) (CompactForm Coin)
stMap = VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
-> Map (Credential 'Staking (Crypto era)) (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 (Crypto era)) (CompactForm Coin)
 -> Map (Credential 'Staking (Crypto era)) (CompactForm Coin))
-> (Stake (Crypto era)
    -> VMap
         VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin))
-> Stake (Crypto era)
-> Map (Credential 'Staking (Crypto era)) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stake (Crypto era)
-> VMap VB VP (Credential 'Staking (Crypto era)) (CompactForm Coin)
forall crypto.
Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
unStake (Stake (Crypto era)
 -> Map (Credential 'Staking (Crypto era)) (CompactForm Coin))
-> Stake (Crypto era)
-> Map (Credential 'Staking (Crypto era)) (CompactForm Coin)
forall a b. (a -> b) -> a -> b
$ SnapShot (Crypto era) -> Stake (Crypto era)
forall crypto. SnapShot crypto -> Stake crypto
_stake SnapShot (Crypto era)
istakeSnap

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

        stakePoolMap :: Map (Credential 'Staking (Crypto era)) (KeyHash 'StakePool (Crypto era))
        stakePoolMap :: Map
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
stakePoolMap = VMap
  VB
  VB
  (Credential 'Staking (Crypto era))
  (KeyHash 'StakePool (Crypto era))
-> Map
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
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 (Crypto era))
   (KeyHash 'StakePool (Crypto era))
 -> Map
      (Credential 'Staking (Crypto era))
      (KeyHash 'StakePool (Crypto era)))
-> VMap
     VB
     VB
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
-> Map
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
forall a b. (a -> b) -> a -> b
$ SnapShot (Crypto era)
-> VMap
     VB
     VB
     (Credential 'Staking (Crypto era))
     (KeyHash 'StakePool (Crypto era))
forall crypto.
SnapShot crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
_delegations SnapShot (Crypto era)
istakeSnap

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

  SnapShots (Crypto era)
-> F (Clause (SNAP era) 'Transition) (SnapShots (Crypto era))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapShots (Crypto era)
 -> F (Clause (SNAP era) 'Transition) (SnapShots (Crypto era)))
-> SnapShots (Crypto era)
-> F (Clause (SNAP era) 'Transition) (SnapShots (Crypto era))
forall a b. (a -> b) -> a -> b
$
    State (SNAP era)
SnapShots (Crypto era)
s
      { $sel:_pstakeMark:SnapShots :: SnapShot (Crypto era)
_pstakeMark = SnapShot (Crypto era)
istakeSnap,
        $sel:_pstakeSet:SnapShots :: SnapShot (Crypto era)
_pstakeSet = SnapShots (Crypto era) -> SnapShot (Crypto era)
forall crypto. SnapShots crypto -> SnapShot crypto
_pstakeMark State (SNAP era)
SnapShots (Crypto era)
s,
        $sel:_pstakeGo:SnapShots :: SnapShot (Crypto era)
_pstakeGo = SnapShots (Crypto era) -> SnapShot (Crypto era)
forall crypto. SnapShots crypto -> SnapShot crypto
_pstakeSet State (SNAP era)
SnapShots (Crypto era)
s,
        $sel:_feeSS:SnapShots :: Coin
_feeSS = Coin
fees
      }