{-# 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 c) = ConwayHardForkEvent (ConwayEra c)

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 (EraCrypto era)
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 (EraCrypto era))
dsUnifiedL
                dReps :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps = 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 (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL
                (Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dRepsWithDelegations, Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
elemsWithoutUnknownDRepDelegations) =
                  forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumWithKey forall {c} {c}.
Map (Credential 'DRepRole c) (DRepState c)
-> Credential 'Staking c
-> UMElem c
-> (Map (Credential 'DRepRole c) (DRepState c), UMElem c)
adjustDelegations Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dReps (forall c. UMap c -> Map (Credential 'Staking c) (UMElem c)
UM.umElems UMap (EraCrypto era)
umap)
                adjustDelegations :: Map (Credential 'DRepRole c) (DRepState c)
-> Credential 'Staking c
-> UMElem c
-> (Map (Credential 'DRepRole c) (DRepState c), UMElem c)
adjustDelegations Map (Credential 'DRepRole c) (DRepState c)
ds Credential 'Staking c
stakeCred umElem :: UMElem c
umElem@(UM.UMElem StrictMaybe RDPair
rd Set Ptr
ptr StrictMaybe (KeyHash 'StakePool c)
stakePool StrictMaybe (DRep c)
mDrep) =
                  case StrictMaybe (DRep c)
mDrep of
                    SJust (DRepCredential Credential 'DRepRole c
dRep) ->
                      let addDelegation :: Credential 'DRepRole c -> DRepState c -> Maybe (DRepState c)
addDelegation Credential 'DRepRole c
_ DRepState c
dRepState =
                            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DRepState c
dRepState {drepDelegs :: Set (Credential 'Staking c)
drepDelegs = forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'Staking c
stakeCred (forall c. DRepState c -> Set (Credential 'Staking c)
drepDelegs DRepState c
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 c -> DRepState c -> Maybe (DRepState c)
addDelegation Credential 'DRepRole c
dRep Map (Credential 'DRepRole c) (DRepState c)
ds of
                            (Maybe (DRepState c)
Nothing, Map (Credential 'DRepRole c) (DRepState c)
_) -> (Map (Credential 'DRepRole c) (DRepState c)
ds, forall c.
StrictMaybe RDPair
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool c)
-> StrictMaybe (DRep c)
-> UMElem c
UM.UMElem StrictMaybe RDPair
rd Set Ptr
ptr StrictMaybe (KeyHash 'StakePool c)
stakePool forall a. StrictMaybe a
SNothing)
                            (Just DRepState c
_, Map (Credential 'DRepRole c) (DRepState c)
ds') -> (Map (Credential 'DRepRole c) (DRepState c)
ds', UMElem c
umElem)
                    StrictMaybe (DRep c)
_ -> (Map (Credential 'DRepRole c) (DRepState c)
ds, UMElem c
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 (EraCrypto era))
dsUnifiedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ UMap (EraCrypto era)
umap {umElems :: Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
UM.umElems = Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
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 (EraCrypto era)) (DRepState (EraCrypto era)))
vsDRepsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dRepsWithDelegations)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure State (ConwayHARDFORK era)
epochState