{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.HardFork (
  ConwayHARDFORK,
  ConwayHardForkEvent (..),
) where

import Cardano.Ledger.BaseTypes (ProtVer (..), ShelleyBase, StrictMaybe (..), natVersion)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayEra, ConwayHARDFORK)
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.UMap as UM
import Control.DeepSeq (NFData)
import Control.State.Transition (
  BaseM,
  Environment,
  Event,
  PredicateFailure,
  STS (..),
  Signal,
  State,
  TRC (TRC),
  TransitionRule,
  judgmentContext,
  tellEvent,
  transitionRules,
 )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Void (Void)
import GHC.Generics (Generic)
import Lens.Micro

newtype ConwayHardForkEvent era = ConwayHardForkEvent ProtVer
  deriving ((forall x.
 ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x)
-> (forall x.
    Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era)
-> Generic (ConwayHardForkEvent era)
forall x.
Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era
forall x.
ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era
forall era x.
ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x
$cfrom :: forall era x.
ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x
from :: forall x.
ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x
$cto :: forall era x.
Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era
to :: forall x.
Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era
Generic, ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
(ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool)
-> (ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool)
-> Eq (ConwayHardForkEvent era)
forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
== :: ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
$c/= :: forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
/= :: ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
Eq)
  deriving newtype (ConwayHardForkEvent era -> ()
(ConwayHardForkEvent era -> ()) -> NFData (ConwayHardForkEvent era)
forall era. ConwayHardForkEvent era -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall era. ConwayHardForkEvent era -> ()
rnf :: ConwayHardForkEvent era -> ()
NFData)

type instance EraRuleEvent "HARDFORK" ConwayEra = ConwayHardForkEvent ConwayEra

instance
  (EraGov era, EraStake era, EraCertState era, ConwayEraCertState era) =>
  STS (ConwayHARDFORK era)
  where
  type State (ConwayHARDFORK era) = EpochState era
  type Signal (ConwayHARDFORK era) = ProtVer
  type Environment (ConwayHARDFORK era) = ()
  type BaseM (ConwayHARDFORK era) = ShelleyBase
  type PredicateFailure (ConwayHARDFORK era) = Void
  type Event (ConwayHARDFORK era) = ConwayHardForkEvent era

  transitionRules :: [TransitionRule (ConwayHARDFORK era)]
transitionRules = [forall era.
ConwayEraCertState era =>
TransitionRule (ConwayHARDFORK era)
hardforkTransition @era]

hardforkTransition ::
  ConwayEraCertState era => TransitionRule (ConwayHARDFORK era)
hardforkTransition :: forall era.
ConwayEraCertState era =>
TransitionRule (ConwayHARDFORK era)
hardforkTransition = do
  TRC (Environment (ConwayHARDFORK era)
_, State (ConwayHARDFORK era)
epochState, Signal (ConwayHARDFORK era)
newPv) <-
    Rule
  (ConwayHARDFORK era)
  'Transition
  (RuleContext 'Transition (ConwayHARDFORK era))
F (Clause (ConwayHARDFORK era) 'Transition)
  (TRC (ConwayHARDFORK era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  Event (ConwayHARDFORK era)
-> Rule (ConwayHARDFORK era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ConwayHARDFORK era)
 -> Rule (ConwayHARDFORK era) 'Transition ())
-> Event (ConwayHARDFORK era)
-> Rule (ConwayHARDFORK era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ ProtVer -> ConwayHardForkEvent era
forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent ProtVer
Signal (ConwayHARDFORK era)
newPv
  if ProtVer -> Version
pvMajor ProtVer
Signal (ConwayHARDFORK era)
newPv Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10
    then
      EpochState era
-> F (Clause (ConwayHARDFORK era) 'Transition) (EpochState era)
forall a. a -> F (Clause (ConwayHARDFORK era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochState era
 -> F (Clause (ConwayHARDFORK era) 'Transition) (EpochState era))
-> EpochState era
-> F (Clause (ConwayHARDFORK era) 'Transition) (EpochState era)
forall a b. (a -> b) -> a -> b
$
        State (ConwayHARDFORK era)
EpochState era
epochState
          EpochState era
-> (EpochState era -> EpochState era) -> EpochState era
forall a b. a -> (a -> b) -> b
& (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((CertState era -> Identity (CertState era))
    -> LedgerState era -> Identity (LedgerState era))
-> (CertState era -> Identity (CertState era))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> EpochState era -> Identity (EpochState era))
-> (CertState era -> CertState era)
-> EpochState era
-> EpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \CertState era
certState ->
            let umap :: UMap
umap = CertState era
certState CertState era -> Getting UMap (CertState era) UMap -> UMap
forall s a. s -> Getting a s a -> a
^. (DState era -> Const UMap (DState era))
-> CertState era -> Const UMap (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const UMap (DState era))
 -> CertState era -> Const UMap (CertState era))
-> ((UMap -> Const UMap UMap)
    -> DState era -> Const UMap (DState era))
-> Getting UMap (CertState era) UMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Const UMap UMap) -> DState era -> Const UMap (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL
                dReps :: Map (Credential 'DRepRole) DRepState
dReps =
                  -- Reset all delegations in order to remove any inconsistencies
                  -- Delegations will be reset accordingly below.
                  (DRepState -> DRepState)
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\DRepState
dRepState -> DRepState
dRepState {drepDelegs = Set.empty}) (Map (Credential 'DRepRole) DRepState
 -> Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) DRepState
forall a b. (a -> b) -> a -> b
$
                    CertState era
certState CertState era
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
-> Map (Credential 'DRepRole) DRepState
forall s a. s -> Getting a s a -> a
^. (VState era
 -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> CertState era
-> Const (Map (Credential 'DRepRole) DRepState) (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era
  -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
 -> CertState era
 -> Const (Map (Credential 'DRepRole) DRepState) (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Const
          (Map (Credential 'DRepRole) DRepState)
          (Map (Credential 'DRepRole) DRepState))
    -> VState era
    -> Const (Map (Credential 'DRepRole) DRepState) (VState era))
-> Getting
     (Map (Credential 'DRepRole) DRepState)
     (CertState era)
     (Map (Credential 'DRepRole) DRepState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Const
      (Map (Credential 'DRepRole) DRepState)
      (Map (Credential 'DRepRole) DRepState))
-> VState era
-> Const (Map (Credential 'DRepRole) DRepState) (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL
                (Map (Credential 'DRepRole) DRepState
dRepsWithDelegations, Map (Credential 'Staking) UMElem
elemsWithoutUnknownDRepDelegations) =
                  (Map (Credential 'DRepRole) DRepState
 -> Credential 'Staking
 -> UMElem
 -> (Map (Credential 'DRepRole) DRepState, UMElem))
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'Staking) UMElem
-> (Map (Credential 'DRepRole) DRepState,
    Map (Credential 'Staking) UMElem)
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumWithKey Map (Credential 'DRepRole) DRepState
-> Credential 'Staking
-> UMElem
-> (Map (Credential 'DRepRole) DRepState, UMElem)
adjustDelegations Map (Credential 'DRepRole) DRepState
dReps (UMap -> Map (Credential 'Staking) UMElem
UM.umElems UMap
umap)
                adjustDelegations :: Map (Credential 'DRepRole) DRepState
-> Credential 'Staking
-> UMElem
-> (Map (Credential 'DRepRole) DRepState, UMElem)
adjustDelegations Map (Credential 'DRepRole) DRepState
ds Credential 'Staking
stakeCred umElem :: UMElem
umElem@(UM.UMElem StrictMaybe RDPair
rd Set Ptr
ptr StrictMaybe (KeyHash 'StakePool)
stakePool StrictMaybe DRep
mDrep) =
                  case StrictMaybe DRep
mDrep of
                    SJust (DRepCredential Credential 'DRepRole
dRep) ->
                      let addDelegation :: Credential 'DRepRole -> DRepState -> Maybe DRepState
addDelegation Credential 'DRepRole
_ DRepState
dRepState =
                            DRepState -> Maybe DRepState
forall a. a -> Maybe a
Just (DRepState -> Maybe DRepState) -> DRepState -> Maybe DRepState
forall a b. (a -> b) -> a -> b
$ DRepState
dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)}
                       in case (Credential 'DRepRole -> DRepState -> Maybe DRepState)
-> Credential 'DRepRole
-> Map (Credential 'DRepRole) DRepState
-> (Maybe DRepState, Map (Credential 'DRepRole) DRepState)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey Credential 'DRepRole -> DRepState -> Maybe DRepState
addDelegation Credential 'DRepRole
dRep Map (Credential 'DRepRole) DRepState
ds of
                            (Maybe DRepState
Nothing, Map (Credential 'DRepRole) DRepState
_) -> (Map (Credential 'DRepRole) DRepState
ds, StrictMaybe RDPair
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool)
-> StrictMaybe DRep
-> UMElem
UM.UMElem StrictMaybe RDPair
rd Set Ptr
ptr StrictMaybe (KeyHash 'StakePool)
stakePool StrictMaybe DRep
forall a. StrictMaybe a
SNothing)
                            (Just DRepState
_, Map (Credential 'DRepRole) DRepState
ds') -> (Map (Credential 'DRepRole) DRepState
ds', UMElem
umElem)
                    StrictMaybe DRep
_ -> (Map (Credential 'DRepRole) DRepState
ds, UMElem
umElem)
             in CertState era
certState
                  -- Remove dangling delegations to non-existent DReps:
                  CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& ((DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((UMap -> Identity UMap) -> DState era -> Identity (DState era))
-> (UMap -> Identity UMap)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UMap -> Identity UMap) -> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(UMap -> f UMap) -> DState era -> f (DState era)
dsUnifiedL ((UMap -> Identity UMap)
 -> CertState era -> Identity (CertState era))
-> UMap -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap
umap {UM.umElems = elemsWithoutUnknownDRepDelegations})
                  -- Populate DRep delegations with delegatees
                  CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& ((VState era -> Identity (VState era))
-> CertState era -> Identity (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Identity (VState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (Credential 'DRepRole) DRepState
     -> Identity (Map (Credential 'DRepRole) DRepState))
    -> VState era -> Identity (VState era))
-> (Map (Credential 'DRepRole) DRepState
    -> Identity (Map (Credential 'DRepRole) DRepState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential 'DRepRole) DRepState
 -> Identity (Map (Credential 'DRepRole) DRepState))
-> VState era -> Identity (VState era)
forall era (f :: * -> *).
Functor f =>
(Map (Credential 'DRepRole) DRepState
 -> f (Map (Credential 'DRepRole) DRepState))
-> VState era -> f (VState era)
vsDRepsL ((Map (Credential 'DRepRole) DRepState
  -> Identity (Map (Credential 'DRepRole) DRepState))
 -> CertState era -> Identity (CertState era))
-> Map (Credential 'DRepRole) DRepState
-> CertState era
-> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential 'DRepRole) DRepState
dRepsWithDelegations)
    else EpochState era
-> F (Clause (ConwayHARDFORK era) 'Transition) (EpochState era)
forall a. a -> F (Clause (ConwayHARDFORK era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State (ConwayHARDFORK era)
EpochState era
epochState