{-# 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.EpochBoundary (SnapShots (ssStakeMarkPoolDistr))
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (solidifyNextEpochPParams)
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 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
$cto :: forall era x.
Rep (ConwayTickfPredFailure era) x -> ConwayTickfPredFailure era
$cfrom :: forall era x.
ConwayTickfPredFailure era -> Rep (ConwayTickfPredFailure era) x
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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ do
    TRC ((), State (ConwayTICKF era)
nes0, Signal (ConwayTICKF era)
slot) <- 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) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall era.
EraGov era =>
NewEpochState era
-> SlotNo -> ShelleyBase (EpochNo, NewEpochState era)
solidifyNextEpochPParams State (ConwayTICKF era)
nes0 Signal (ConwayTICKF era)
slot

    let es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
        ss :: SnapShots
ss = 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 forall a. Eq a => a -> a -> Bool
/= forall a. Enum a => a -> a
succ (forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
nes)
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure NewEpochState era
nes
      else do
        let govState :: GovState era
govState = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (GovState 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.

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