{-# 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 ((), nes0, 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.

    (curEpochNo, nes) <- liftSTS $ solidifyNextEpochPParams nes0 slot

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

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

    if curEpochNo /= succ (nesEL nes)
      then pure nes
      else do
        let 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.

        pure $!
          nes {nesPd = pd'}
            & newEpochStateGovStateL . curPParamsGovStateL .~ nextEpochPParams govState
            & newEpochStateGovStateL . prevPParamsGovStateL .~ (govState ^. curPParamsGovStateL)
            & newEpochStateGovStateL . futurePParamsGovStateL .~ NoPParamsUpdate