{-# 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,
  SnapEvent (..),
  SnapEnv (..),
) where

import Cardano.Ledger.BaseTypes (ShelleyBase, unNonZero)
import Cardano.Ledger.Coin (Coin)
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 Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro

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

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) = Void
  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 (snapEnv, s, _) <- 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 (UTxOState _utxo _ fees _ _ _) certState) _pp = snapEnv
      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 =
        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)

  tellEvent $
    let stakeMap :: Map (Credential Staking) (Coin, KeyHash StakePool)
        stakeMap =
          (StakeWithDelegation -> (Coin, KeyHash StakePool))
-> Map (Credential Staking) StakeWithDelegation
-> Map (Credential Staking) (Coin, KeyHash StakePool)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
            (\StakeWithDelegation
swd -> (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ NonZero (CompactForm Coin) -> CompactForm Coin
forall a. NonZero a -> a
unNonZero (NonZero (CompactForm Coin) -> CompactForm Coin)
-> NonZero (CompactForm Coin) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ StakeWithDelegation -> NonZero (CompactForm Coin)
swdStake StakeWithDelegation
swd, StakeWithDelegation -> KeyHash StakePool
swdDelegation StakeWithDelegation
swd))
            (VMap VB VB (Credential Staking) StakeWithDelegation
-> Map (Credential Staking) StakeWithDelegation
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) StakeWithDelegation
 -> Map (Credential Staking) StakeWithDelegation)
-> VMap VB VB (Credential Staking) StakeWithDelegation
-> Map (Credential Staking) StakeWithDelegation
forall a b. (a -> b) -> a -> b
$ ActiveStake -> VMap VB VB (Credential Staking) StakeWithDelegation
unActiveStake (ActiveStake
 -> VMap VB VB (Credential Staking) StakeWithDelegation)
-> ActiveStake
-> VMap VB VB (Credential Staking) StakeWithDelegation
forall a b. (a -> b) -> a -> b
$ SnapShot -> ActiveStake
ssActiveStake SnapShot
istakeSnap)
     in StakeDistEvent stakeMap

  pure $
    SnapShots
      { ssStakeMark = istakeSnap
      , ssStakeMarkPoolDistr = calculatePoolDistr istakeSnap
      , -- ssStakeMarkPoolDistr exists for performance reasons, see ADR-7
        ssStakeSet = ssStakeMark s
      , ssStakeGo = ssStakeSet s
      , ssFee = fees
      }