{-# 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.DRep
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 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
$cto :: forall era x.
Rep (ConwayHardForkEvent era) x -> ConwayHardForkEvent era
$cfrom :: forall era x.
ConwayHardForkEvent era -> Rep (ConwayHardForkEvent era) x
Generic, ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
$c/= :: forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
== :: ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
$c== :: forall era.
ConwayHardForkEvent era -> ConwayHardForkEvent era -> Bool
Eq)
  deriving newtype (ConwayHardForkEvent era -> ()
forall era. ConwayHardForkEvent era -> ()
forall a. (a -> ()) -> NFData a
rnf :: ConwayHardForkEvent era -> ()
$crnf :: forall era. ConwayHardForkEvent era -> ()
NFData)

type instance EraRuleEvent "HARDFORK" ConwayEra = ConwayHardForkEvent ConwayEra

instance
  EraGov 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. TransitionRule (ConwayHARDFORK era)
hardforkTransition @era]

hardforkTransition :: TransitionRule (ConwayHARDFORK era)
hardforkTransition :: forall era. TransitionRule (ConwayHARDFORK era)
hardforkTransition = do
  TRC (Environment (ConwayHARDFORK era)
_, State (ConwayHARDFORK era)
epochState, Signal (ConwayHARDFORK era)
newPv) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent Signal (ConwayHARDFORK era)
newPv
  if ProtVer -> Version
pvMajor Signal (ConwayHARDFORK era)
newPv forall a. Eq a => a -> a -> Bool
== forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10
    then
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        State (ConwayHARDFORK era)
epochState
          forall a b. a -> (a -> b) -> b
& forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \CertState era
certState ->
            let umap :: UMap
umap = CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL
                dReps :: Map (Credential 'DRepRole) DRepState
dReps =
                  -- Reset all delegations in order to remove any inconsistencies
                  -- Delegations will be reset accordingly below.
                  forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\DRepState
dRepState -> DRepState
dRepState {drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Set a
Set.empty}) forall a b. (a -> b) -> a -> b
$
                    CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL
                (Map (Credential 'DRepRole) DRepState
dRepsWithDelegations, Map (Credential 'Staking) UMElem
elemsWithoutUnknownDRepDelegations) =
                  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 =
                            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DRepState
dRepState {drepDelegs :: Set (Credential 'Staking)
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking
stakeCred (DRepState -> Set (Credential 'Staking)
drepDelegs DRepState
dRepState)}
                       in case 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 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:
                  forall a b. a -> (a -> b) -> b
& (forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) UMap
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap
umap {umElems :: Map (Credential 'Staking) UMElem
UM.umElems = Map (Credential 'Staking) UMElem
elemsWithoutUnknownDRepDelegations})
                  -- Populate DRep delegations with delegatees
                  forall a b. a -> (a -> b) -> b
& (forall era. Lens' (CertState era) (VState era)
certVStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (VState era) (Map (Credential 'DRepRole) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential 'DRepRole) DRepState
dRepsWithDelegations)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure State (ConwayHARDFORK era)
epochState