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

module Cardano.Ledger.Shelley.Rules.Rupd
  ( RUPD,
    RupdEnv (..),
    PredicateFailure,
    RupdPredicateFailure,
    epochInfoRange,
    PulsingRewUpdate (..),
    startStep,
    pulseStep,
    completeStep,
    lift,
    Identity (..),
    RupdEvent (..),
  )
where

import Cardano.Ledger.BaseTypes
  ( BlocksMade,
    NonNegativeInterval,
    ProtVer,
    ShelleyBase,
    StrictMaybe (..),
    UnitInterval,
    activeSlotCoeff,
    epochInfoPure,
    maxLovelaceSupply,
    randomnessStabilisationWindow,
    securityParameter,
  )
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Keys (KeyRole (Staking))
import Cardano.Ledger.Shelley.LedgerState
  ( EpochState,
    PulsingRewUpdate (..),
    completeStep,
    pulseStep,
    startStep,
  )
import Cardano.Ledger.Shelley.Rewards (Reward)
import Cardano.Ledger.Slot
  ( Duration (..),
    EpochNo,
    SlotNo,
    epochInfoEpoch,
    epochInfoFirst,
    epochInfoSize,
    (+*),
  )
import Cardano.Slotting.EpochInfo.API (epochInfoRange)
import Control.Monad.Identity (Identity (..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition
  ( Rule,
    STS (..),
    TRC (..),
    TransitionRule,
    judgmentContext,
    liftSTS,
    tellEvent,
  )
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

data RUPD era

data RupdEnv era
  = RupdEnv (BlocksMade (Crypto era)) (EpochState era)

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

instance NoThunks (RupdPredicateFailure era)

instance
  ( Era era,
    HasField "_a0" (Core.PParams era) NonNegativeInterval,
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_nOpt" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    HasField "_rho" (Core.PParams era) UnitInterval,
    HasField "_tau" (Core.PParams era) UnitInterval
  ) =>
  STS (RUPD era)
  where
  type State (RUPD era) = StrictMaybe (PulsingRewUpdate (Crypto era))
  type Signal (RUPD era) = SlotNo
  type Environment (RUPD era) = RupdEnv era
  type BaseM (RUPD era) = ShelleyBase
  type PredicateFailure (RUPD era) = RupdPredicateFailure era
  type Event (RUPD era) = RupdEvent (Crypto era)

  initialRules :: [InitialRule (RUPD era)]
initialRules = [StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Initial)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. StrictMaybe a
SNothing]
  transitionRules :: [TransitionRule (RUPD era)]
transitionRules = [TransitionRule (RUPD era)
forall era.
(Era era, HasField "_a0" (PParams era) NonNegativeInterval,
 HasField "_d" (PParams era) UnitInterval,
 HasField "_nOpt" (PParams era) Natural,
 HasField "_protocolVersion" (PParams era) ProtVer,
 HasField "_rho" (PParams era) UnitInterval,
 HasField "_tau" (PParams era) UnitInterval) =>
TransitionRule (RUPD era)
rupdTransition]

data RupdEvent crypto = RupdEvent !EpochNo !(Map.Map (Credential 'Staking crypto) (Set (Reward crypto)))

-- | tell a RupdEvent only if the map is non-empty
tellRupd :: String -> RupdEvent (Crypto era) -> Rule (RUPD era) rtype ()
tellRupd :: String -> RupdEvent (Crypto era) -> Rule (RUPD era) rtype ()
tellRupd String
_ (RupdEvent EpochNo
_ Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
m) | Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> Bool
forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
m = () -> Rule (RUPD era) rtype ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellRupd String
_message RupdEvent (Crypto era)
x = Event (RUPD era) -> Rule (RUPD era) rtype ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent Event (RUPD era)
RupdEvent (Crypto era)
x

-- | The Goldilocks labeling of when to do the reward calculation.
data RewardTiming = RewardsTooEarly | RewardsJustRight | RewardsTooLate

determineRewardTiming :: SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming :: SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming SlotNo
currentSlot SlotNo
startAftterSlot SlotNo
endSlot =
  if SlotNo
currentSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
endSlot
    then RewardTiming
RewardsTooLate
    else
      if SlotNo
currentSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
startAftterSlot
        then RewardTiming
RewardsTooEarly
        else RewardTiming
RewardsJustRight

rupdTransition ::
  ( Era era,
    HasField "_a0" (Core.PParams era) NonNegativeInterval,
    HasField "_d" (Core.PParams era) UnitInterval,
    HasField "_nOpt" (Core.PParams era) Natural,
    HasField "_protocolVersion" (Core.PParams era) ProtVer,
    HasField "_rho" (Core.PParams era) UnitInterval,
    HasField "_tau" (Core.PParams era) UnitInterval
  ) =>
  TransitionRule (RUPD era)
rupdTransition :: TransitionRule (RUPD era)
rupdTransition = do
  TRC (RupdEnv b es, State (RUPD era)
ru, Signal (RUPD era)
s) <- F (Clause (RUPD era) 'Transition) (TRC (RUPD era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  (EpochSize
slotsPerEpoch, SlotNo
slot, SlotNo
slotForce, Word64
maxLL, ActiveSlotCoeff
asc, Word64
k, EpochNo
e) <- BaseM
  (RUPD era)
  (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
   EpochNo)
-> Rule
     (RUPD era)
     'Transition
     (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
      EpochNo)
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM
   (RUPD era)
   (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
    EpochNo)
 -> Rule
      (RUPD era)
      'Transition
      (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
       EpochNo))
-> BaseM
     (RUPD era)
     (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
      EpochNo)
-> Rule
     (RUPD era)
     'Transition
     (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
      EpochNo)
forall a b. (a -> b) -> a -> b
$ do
    EpochInfo Identity
ei <- (Globals -> EpochInfo Identity)
-> ReaderT Globals Identity (EpochInfo Identity)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo Identity
epochInfoPure
    Word64
sr <- (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
randomnessStabilisationWindow
    EpochNo
e <- HasCallStack => EpochInfo Identity -> SlotNo -> ShelleyBase EpochNo
EpochInfo Identity -> SlotNo -> ShelleyBase EpochNo
epochInfoEpoch EpochInfo Identity
ei SlotNo
Signal (RUPD era)
s
    EpochSize
slotsPerEpoch <- HasCallStack =>
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
epochInfoSize EpochInfo Identity
ei EpochNo
e
    SlotNo
slot <- HasCallStack => EpochInfo Identity -> EpochNo -> ShelleyBase SlotNo
EpochInfo Identity -> EpochNo -> ShelleyBase SlotNo
epochInfoFirst EpochInfo Identity
ei EpochNo
e ShelleyBase SlotNo -> (SlotNo -> SlotNo) -> ShelleyBase SlotNo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SlotNo -> Duration -> SlotNo
+* Word64 -> Duration
Duration Word64
sr)
    Word64
maxLL <- (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
maxLovelaceSupply
    ActiveSlotCoeff
asc <- (Globals -> ActiveSlotCoeff)
-> ReaderT Globals Identity ActiveSlotCoeff
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> ActiveSlotCoeff
activeSlotCoeff
    Word64
k <- (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
securityParameter -- Maximum number of blocks we are allowed to roll back
    (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
 EpochNo)
-> ReaderT
     Globals
     Identity
     (EpochSize, SlotNo, SlotNo, Word64, ActiveSlotCoeff, Word64,
      EpochNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (EpochSize
slotsPerEpoch, SlotNo
slot, (SlotNo
slot SlotNo -> Duration -> SlotNo
+* Word64 -> Duration
Duration Word64
sr), Word64
maxLL, ActiveSlotCoeff
asc, Word64
k, EpochNo
e)
  let maxsupply :: Coin
maxsupply = Integer -> Coin
Coin (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxLL)
  case SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming SlotNo
Signal (RUPD era)
s SlotNo
slot SlotNo
slotForce of
    -- Waiting for the stability point, do nothing, keep waiting
    RewardTiming
RewardsTooEarly -> StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. StrictMaybe a
SNothing
    -- More blocks to come, get things started or take a step
    RewardTiming
RewardsJustRight ->
      case State (RUPD era)
ru of
        State (RUPD era)
SNothing ->
          -- This is the first opportunity to pulse, so start pulsing.
          -- SJust <$> tellLeaderEvents (e + 1) (fst (startStep slotsPerEpoch b es maxsupply asc k))
          (StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictMaybe (PulsingRewUpdate (Crypto era))
 -> F (Clause (RUPD era) 'Transition)
      (StrictMaybe (PulsingRewUpdate (Crypto era))))
-> ((PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
    -> StrictMaybe (PulsingRewUpdate (Crypto era)))
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingRewUpdate (Crypto era)
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. a -> StrictMaybe a
SJust (PulsingRewUpdate (Crypto era)
 -> StrictMaybe (PulsingRewUpdate (Crypto era)))
-> ((PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
    -> PulsingRewUpdate (Crypto era))
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
-> PulsingRewUpdate (Crypto era)
forall a b. (a, b) -> a
fst) (EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
forall era.
UsesPP era =>
EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
startStep EpochSize
slotsPerEpoch BlocksMade (Crypto era)
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k)
        (SJust p@(Pulsing _ _)) -> do
          -- We began pulsing earlier, so run another pulse
          (PulsingRewUpdate (Crypto era)
ans, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event) <- BaseM
  (RUPD era)
  (PulsingRewUpdate (Crypto era),
   Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM
   (RUPD era)
   (PulsingRewUpdate (Crypto era),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
 -> Rule
      (RUPD era)
      'Transition
      (PulsingRewUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> BaseM
     (RUPD era)
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate (Crypto era)
-> ShelleyBase
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall crypto.
PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
pulseStep PulsingRewUpdate (Crypto era)
p
          String -> RupdEvent (Crypto era) -> Rule (RUPD era) 'Transition ()
forall era (rtype :: RuleType).
String -> RupdEvent (Crypto era) -> Rule (RUPD era) rtype ()
tellRupd String
"Pulsing Rupd" (EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> RupdEvent (Crypto era)
forall crypto.
EpochNo
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> RupdEvent crypto
RupdEvent (EpochNo
e EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1) Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event)
          StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PulsingRewUpdate (Crypto era)
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (Crypto era)
ans)
        (SJust p@(Complete _)) -> StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PulsingRewUpdate (Crypto era)
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (Crypto era)
p)
    -- Time to force the completion of the pulser so that downstream tools such as db-sync
    -- have time to see the reward update before the epoch boundary rollover.
    RewardTiming
RewardsTooLate ->
      case State (RUPD era)
ru of
        State (RUPD era)
SNothing -> do
          -- Nothing has been done, so start, and then complete the pulser. We hope this is very rare.
          let pulser :: PulsingRewUpdate (Crypto era)
pulser = (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
-> PulsingRewUpdate (Crypto era)
forall a b. (a, b) -> a
fst (EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
forall era.
UsesPP era =>
EpochSize
-> BlocksMade (Crypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> (PulsingRewUpdate (Crypto era), RewardProvenance (Crypto era))
startStep EpochSize
slotsPerEpoch BlocksMade (Crypto era)
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k)
          (PulsingRewUpdate (Crypto era)
reward, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event) <- ShelleyBase
  (PulsingRewUpdate (Crypto era),
   Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (ShelleyBase
   (PulsingRewUpdate (Crypto era),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
 -> Rule
      (RUPD era)
      'Transition
      (PulsingRewUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> (PulsingRewUpdate (Crypto era)
    -> ShelleyBase
         (PulsingRewUpdate (Crypto era),
          Map
            (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> PulsingRewUpdate (Crypto era)
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingRewUpdate (Crypto era)
-> ShelleyBase
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall crypto.
PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
completeStep (PulsingRewUpdate (Crypto era)
 -> Rule
      (RUPD era)
      'Transition
      (PulsingRewUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> PulsingRewUpdate (Crypto era)
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate (Crypto era)
pulser
          String -> RupdEvent (Crypto era) -> Rule (RUPD era) 'Transition ()
forall era (rtype :: RuleType).
String -> RupdEvent (Crypto era) -> Rule (RUPD era) rtype ()
tellRupd String
"Starting too late" (EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> RupdEvent (Crypto era)
forall crypto.
EpochNo
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> RupdEvent crypto
RupdEvent (EpochNo
e EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1) Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event)
          StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PulsingRewUpdate (Crypto era)
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (Crypto era)
reward)
        SJust p@(Pulsing _ _) -> do
          -- We have been pulsing, but we ran out of time, so complete the pulser.
          (PulsingRewUpdate (Crypto era)
reward, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event) <- ShelleyBase
  (PulsingRewUpdate (Crypto era),
   Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (ShelleyBase
   (PulsingRewUpdate (Crypto era),
    Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
 -> Rule
      (RUPD era)
      'Transition
      (PulsingRewUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> (PulsingRewUpdate (Crypto era)
    -> ShelleyBase
         (PulsingRewUpdate (Crypto era),
          Map
            (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> PulsingRewUpdate (Crypto era)
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PulsingRewUpdate (Crypto era)
-> ShelleyBase
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall crypto.
PulsingRewUpdate crypto
-> ShelleyBase (PulsingRewUpdate crypto, RewardEvent crypto)
completeStep (PulsingRewUpdate (Crypto era)
 -> Rule
      (RUPD era)
      'Transition
      (PulsingRewUpdate (Crypto era),
       Map
         (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))))
-> PulsingRewUpdate (Crypto era)
-> Rule
     (RUPD era)
     'Transition
     (PulsingRewUpdate (Crypto era),
      Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))))
forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate (Crypto era)
p
          String -> RupdEvent (Crypto era) -> Rule (RUPD era) 'Transition ()
forall era (rtype :: RuleType).
String -> RupdEvent (Crypto era) -> Rule (RUPD era) rtype ()
tellRupd String
"completing too late" (EpochNo
-> Map
     (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
-> RupdEvent (Crypto era)
forall crypto.
EpochNo
-> Map (Credential 'Staking crypto) (Set (Reward crypto))
-> RupdEvent crypto
RupdEvent (EpochNo
e EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1) Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))
event)
          StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PulsingRewUpdate (Crypto era)
-> StrictMaybe (PulsingRewUpdate (Crypto era))
forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (Crypto era)
reward)
        complete :: State (RUPD era)
complete@(SJust (Complete _)) -> StrictMaybe (PulsingRewUpdate (Crypto era))
-> F (Clause (RUPD era) 'Transition)
     (StrictMaybe (PulsingRewUpdate (Crypto era)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (PulsingRewUpdate (Crypto era))
State (RUPD era)
complete