{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Tickf (
  ConwayTICKF,
  ConwayTickfPredFailure,
  ConwayTickfEvent,
) where

import Cardano.Ledger.BaseTypes (ShelleyBase, SlotNo)
import Cardano.Ledger.Conway.Era
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (solidifyNextEpochPParams)
import Cardano.Ledger.State (SnapShots (ssStakeMarkPoolDistr))
import Control.State.Transition
import GHC.Generics (Generic)
import Lens.Micro ((&), (.~), (^.))
import NoThunks.Class (NoThunks (..))

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

{------------------------------------------------------------------------------
-- TICKF transition

-- This is a variant on the TICK transition called only by the consensus layer
to tick the ledger state to a future slot.
------------------------------------------------------------------------------}

data ConwayTickfPredFailure era
  deriving ((forall x.
 ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x)
-> (forall x.
    Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era)
-> Generic (ConwayTickfPredFailure era)
forall x.
Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era
forall x.
ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era
forall era x.
ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x
$cfrom :: forall era x.
ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x
from :: forall x.
ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x
$cto :: forall era x.
Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era
to :: forall x.
Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era
Generic)

deriving instance
  Era era =>
  Show (ConwayTickfPredFailure era)

deriving instance
  Era era =>
  Eq (ConwayTickfPredFailure era)

instance NoThunks (ConwayTickfPredFailure era)

data ConwayTickfEvent era

instance
  EraGov era =>
  STS (ConwayTICKF era)
  where
  type State (ConwayTICKF era) = NewEpochState era
  type Signal (ConwayTICKF era) = SlotNo
  type Environment (ConwayTICKF era) = ()
  type BaseM (ConwayTICKF era) = ShelleyBase
  type PredicateFailure (ConwayTICKF era) = ConwayTickfPredFailure era
  type Event (ConwayTICKF era) = ConwayTickfEvent era

  initialRules :: [InitialRule (ConwayTICKF era)]
initialRules = []
  transitionRules :: [TransitionRule (ConwayTICKF era)]
transitionRules = TransitionRule (ConwayTICKF era)
-> [TransitionRule (ConwayTICKF era)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TransitionRule (ConwayTICKF era)
 -> [TransitionRule (ConwayTICKF era)])
-> TransitionRule (ConwayTICKF era)
-> [TransitionRule (ConwayTICKF era)]
forall a b. (a -> b) -> a -> b
$ do
    TRC ((), State (ConwayTICKF era)
nes0, Signal (ConwayTICKF era)
slot) <- Rule
  (ConwayTICKF era)
  'Transition
  (RuleContext 'Transition (ConwayTICKF era))
F (Clause (ConwayTICKF era) 'Transition) (TRC (ConwayTICKF era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
    -- This whole function is a specialization of an inlined 'NEWEPOCH'.
    --
    -- The ledger view, 'LedgerView', is built entirely from the 'nesPd' and 'esPp' and
    -- 'dsGenDelegs', so the correctness of 'validatingTickTransitionFORECAST' only
    -- depends on getting these three fields correct.

    (EpochNo
curEpochNo, NewEpochState era
nes) <- BaseM (ConwayTICKF era) (EpochNo, NewEpochState era)
-> Rule (ConwayTICKF era) 'Transition (EpochNo, NewEpochState era)
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (ConwayTICKF era) (EpochNo, NewEpochState era)
 -> Rule (ConwayTICKF era) 'Transition (EpochNo, NewEpochState era))
-> BaseM (ConwayTICKF era) (EpochNo, NewEpochState era)
-> Rule (ConwayTICKF era) 'Transition (EpochNo, NewEpochState era)
forall a b. (a -> b) -> a -> b
$ NewEpochState era
-> SlotNo -> ShelleyBase (EpochNo, NewEpochState era)
forall era.
EraGov era =>
NewEpochState era
-> SlotNo -> ShelleyBase (EpochNo, NewEpochState era)
solidifyNextEpochPParams State (ConwayTICKF era)
NewEpochState era
nes0 SlotNo
Signal (ConwayTICKF era)
slot

    let es :: EpochState era
es = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
        ss :: SnapShots
ss = EpochState era -> SnapShots
forall era. EpochState era -> SnapShots
esSnapshots EpochState era
es

    -- the relevant 'NEWEPOCH' logic
    let pd' :: PoolDistr
pd' = SnapShots -> PoolDistr
ssStakeMarkPoolDistr SnapShots
ss

    if EpochNo
curEpochNo EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochNo -> EpochNo
forall a. Enum a => a -> a
succ (NewEpochState era -> EpochNo
forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
nes)
      then NewEpochState era
-> F (Clause (ConwayTICKF era) 'Transition) (NewEpochState era)
forall a. a -> F (Clause (ConwayTICKF era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewEpochState era
nes
      else do
        let govState :: GovState era
govState = NewEpochState era
nes NewEpochState era
-> Getting (GovState era) (NewEpochState era) (GovState era)
-> GovState era
forall s a. s -> Getting a s a -> a
^. Getting (GovState era) (NewEpochState era) (GovState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL
        -- We can skip 'SNAP'; we already have the equivalent pd'.

        -- We can skip 'POOLREAP';
        -- we don't need to do the checks:
        -- if the checks would fail, then the node will fail in the 'TICK' rule
        -- if it ever then node tries to validate blocks for which the
        -- return value here was used to validate their headers.

        NewEpochState era
-> F (Clause (ConwayTICKF era) 'Transition) (NewEpochState era)
forall a. a -> F (Clause (ConwayTICKF era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era
 -> F (Clause (ConwayTICKF era) 'Transition) (NewEpochState era))
-> NewEpochState era
-> F (Clause (ConwayTICKF era) 'Transition) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$!
          NewEpochState era
nes {nesPd = pd'}
            NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Identity (GovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PParams era -> Identity (PParams era))
    -> GovState era -> Identity (GovState era))
-> (PParams era -> Identity (PParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> GovState era -> Identity (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL ((PParams era -> Identity (PParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> PParams era -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovState era -> PParams era
forall era. EraGov era => GovState era -> PParams era
nextEpochPParams GovState era
govState
            NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Identity (GovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PParams era -> Identity (PParams era))
    -> GovState era -> Identity (GovState era))
-> (PParams era -> Identity (PParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> GovState era -> Identity (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
prevPParamsGovStateL ((PParams era -> Identity (PParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> PParams era -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (GovState era
govState GovState era
-> Getting (PParams era) (GovState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (GovState era) (PParams era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL)
            NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Identity (GovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((FuturePParams era -> Identity (FuturePParams era))
    -> GovState era -> Identity (GovState era))
-> (FuturePParams era -> Identity (FuturePParams era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FuturePParams era -> Identity (FuturePParams era))
-> GovState era -> Identity (GovState era)
forall era. EraGov era => Lens' (GovState era) (FuturePParams era)
Lens' (GovState era) (FuturePParams era)
futurePParamsGovStateL ((FuturePParams era -> Identity (FuturePParams era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> FuturePParams era -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate