{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Transition (
  ConwayEraTransition (..),
  TransitionConfig (..),
  toConwayTransitionConfigPairs,
) where

import Cardano.Ledger.Alonzo.Transition (toAlonzoTransitionConfigPairs)
import Cardano.Ledger.Babbage
import Cardano.Ledger.Babbage.Transition (TransitionConfig (BabbageTransitionConfig))
import Cardano.Ledger.Conway.Core (Era (..))
import Cardano.Ledger.Conway.Era
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..), toConwayGenesisPairs)
import Cardano.Ledger.Conway.Translation ()
import Cardano.Ledger.Conway.TxCert (Delegatee, getStakePoolDelegatee, getVoteDelegatee)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Crypto
import Cardano.Ledger.DRep (DRepState)
import Cardano.Ledger.Keys (KeyRole (..))
import Cardano.Ledger.Shelley.LedgerState (
  NewEpochState,
  certDStateL,
  certVStateL,
  dsUnifiedL,
  esLStateL,
  lsCertStateL,
  nesEsL,
  vsDRepsL,
 )
import Cardano.Ledger.Shelley.Transition
import Cardano.Ledger.UMap (UMElem (..), umElemsL)
import Control.Applicative (Alternative (..))
import Data.Aeson (
  FromJSON (..),
  KeyValue (..),
  ToJSON (..),
  Value (..),
  object,
  pairs,
  withObject,
  (.:),
 )
import Data.ListMap (ListMap)
import qualified Data.ListMap as ListMap
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe)
import GHC.Generics
import Lens.Micro
import NoThunks.Class (NoThunks (..))

class EraTransition era => ConwayEraTransition era where
  tcDelegsL ::
    Lens'
      (TransitionConfig era)
      (ListMap (Credential 'Staking (EraCrypto era)) (Delegatee (EraCrypto era)))

  tcInitialDRepsL ::
    Lens'
      (TransitionConfig era)
      (ListMap (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))

  tcConwayGenesisL :: Lens' (TransitionConfig era) (ConwayGenesis (EraCrypto era))

registerDRepsThenDelegs ::
  ConwayEraTransition era =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerDRepsThenDelegs :: forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerDRepsThenDelegs TransitionConfig era
cfg =
  -- NOTE: The order of registration does not matter.
  forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerDelegs TransitionConfig era
cfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialDReps TransitionConfig era
cfg

instance Crypto c => EraTransition (ConwayEra c) where
  data TransitionConfig (ConwayEra c) = ConwayTransitionConfig
    { forall c. TransitionConfig (ConwayEra c) -> ConwayGenesis c
ctcConwayGenesis :: !(ConwayGenesis c)
    , forall c.
TransitionConfig (ConwayEra c) -> TransitionConfig (BabbageEra c)
ctcBabbageTransitionConfig :: !(TransitionConfig (BabbageEra c))
    }
    deriving (Int -> TransitionConfig (ConwayEra c) -> ShowS
forall c.
Crypto c =>
Int -> TransitionConfig (ConwayEra c) -> ShowS
forall c. Crypto c => [TransitionConfig (ConwayEra c)] -> ShowS
forall c. Crypto c => TransitionConfig (ConwayEra c) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransitionConfig (ConwayEra c)] -> ShowS
$cshowList :: forall c. Crypto c => [TransitionConfig (ConwayEra c)] -> ShowS
show :: TransitionConfig (ConwayEra c) -> String
$cshow :: forall c. Crypto c => TransitionConfig (ConwayEra c) -> String
showsPrec :: Int -> TransitionConfig (ConwayEra c) -> ShowS
$cshowsPrec :: forall c.
Crypto c =>
Int -> TransitionConfig (ConwayEra c) -> ShowS
Show, TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
forall c.
Crypto c =>
TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
$c/= :: forall c.
Crypto c =>
TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
== :: TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
$c== :: forall c.
Crypto c =>
TransitionConfig (ConwayEra c)
-> TransitionConfig (ConwayEra c) -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (TransitionConfig (ConwayEra c)) x
-> TransitionConfig (ConwayEra c)
forall c x.
TransitionConfig (ConwayEra c)
-> Rep (TransitionConfig (ConwayEra c)) x
$cto :: forall c x.
Rep (TransitionConfig (ConwayEra c)) x
-> TransitionConfig (ConwayEra c)
$cfrom :: forall c x.
TransitionConfig (ConwayEra c)
-> Rep (TransitionConfig (ConwayEra c)) x
Generic)

  mkTransitionConfig :: TranslationContext (ConwayEra c)
-> TransitionConfig (PreviousEra (ConwayEra c))
-> TransitionConfig (ConwayEra c)
mkTransitionConfig = forall c.
ConwayGenesis c
-> TransitionConfig (BabbageEra c)
-> TransitionConfig (ConwayEra c)
ConwayTransitionConfig

  injectIntoTestState :: TransitionConfig (ConwayEra c)
-> NewEpochState (ConwayEra c) -> NewEpochState (ConwayEra c)
injectIntoTestState TransitionConfig (ConwayEra c)
cfg =
    forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerDRepsThenDelegs TransitionConfig (ConwayEra c)
cfg
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking TransitionConfig (ConwayEra c)
cfg

  tcPreviousEraConfigL :: EraTransition (PreviousEra (ConwayEra c)) =>
Lens'
  (TransitionConfig (ConwayEra c))
  (TransitionConfig (PreviousEra (ConwayEra c)))
tcPreviousEraConfigL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
TransitionConfig (ConwayEra c) -> TransitionConfig (BabbageEra c)
ctcBabbageTransitionConfig (\TransitionConfig (ConwayEra c)
ctc TransitionConfig (BabbageEra c)
pc -> TransitionConfig (ConwayEra c)
ctc {ctcBabbageTransitionConfig :: TransitionConfig (BabbageEra c)
ctcBabbageTransitionConfig = TransitionConfig (BabbageEra c)
pc})

  tcTranslationContextL :: Lens'
  (TransitionConfig (ConwayEra c)) (TranslationContext (ConwayEra c))
tcTranslationContextL =
    forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. TransitionConfig (ConwayEra c) -> ConwayGenesis c
ctcConwayGenesis (\TransitionConfig (ConwayEra c)
ctc ConwayGenesis c
ag -> TransitionConfig (ConwayEra c)
ctc {ctcConwayGenesis :: ConwayGenesis c
ctcConwayGenesis = ConwayGenesis c
ag})

instance Crypto c => ConwayEraTransition (ConwayEra c) where
  tcConwayGenesisL :: Lens'
  (TransitionConfig (ConwayEra c))
  (ConwayGenesis (EraCrypto (ConwayEra c)))
tcConwayGenesisL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. TransitionConfig (ConwayEra c) -> ConwayGenesis c
ctcConwayGenesis (\TransitionConfig (ConwayEra c)
g ConwayGenesis c
x -> TransitionConfig (ConwayEra c)
g {ctcConwayGenesis :: ConwayGenesis c
ctcConwayGenesis = ConwayGenesis c
x})

  tcDelegsL :: Lens'
  (TransitionConfig (ConwayEra c))
  (ListMap
     (Credential 'Staking (EraCrypto (ConwayEra c)))
     (Delegatee (EraCrypto (ConwayEra c))))
tcDelegsL =
    forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"ConwayDelegs" forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$
      forall era.
ConwayEraTransition era =>
Lens' (TransitionConfig era) (ConwayGenesis (EraCrypto era))
tcConwayGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
ConwayGenesis c -> ListMap (Credential 'Staking c) (Delegatee c)
cgDelegs (\ConwayGenesis c
g ListMap (Credential 'Staking c) (Delegatee c)
x -> ConwayGenesis c
g {cgDelegs :: ListMap (Credential 'Staking c) (Delegatee c)
cgDelegs = ListMap (Credential 'Staking c) (Delegatee c)
x})

  tcInitialDRepsL :: Lens'
  (TransitionConfig (ConwayEra c))
  (ListMap
     (Credential 'DRepRole (EraCrypto (ConwayEra c)))
     (DRepState (EraCrypto (ConwayEra c))))
tcInitialDRepsL =
    forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialDReps" forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$
      forall era.
ConwayEraTransition era =>
Lens' (TransitionConfig era) (ConwayGenesis (EraCrypto era))
tcConwayGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c.
ConwayGenesis c -> ListMap (Credential 'DRepRole c) (DRepState c)
cgInitialDReps (\ConwayGenesis c
g ListMap (Credential 'DRepRole c) (DRepState c)
x -> ConwayGenesis c
g {cgInitialDReps :: ListMap (Credential 'DRepRole c) (DRepState c)
cgInitialDReps = ListMap (Credential 'DRepRole c) (DRepState c)
x})

instance Crypto c => NoThunks (TransitionConfig (ConwayEra c))

instance Crypto c => ToJSON (TransitionConfig (ConwayEra c)) where
  toJSON :: TransitionConfig (ConwayEra c) -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ConwayEra c) -> [a]
toConwayTransitionConfigPairs
  toEncoding :: TransitionConfig (ConwayEra c) -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ConwayEra c) -> [a]
toConwayTransitionConfigPairs

toConwayTransitionConfigPairs :: (KeyValue e a, Crypto c) => TransitionConfig (ConwayEra c) -> [a]
toConwayTransitionConfigPairs :: forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ConwayEra c) -> [a]
toConwayTransitionConfigPairs TransitionConfig (ConwayEra c)
conwayConfig =
  forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (AlonzoEra c) -> [a]
toAlonzoTransitionConfigPairs TransitionConfig (AlonzoEra c)
alonzoConfig
    forall a. [a] -> [a] -> [a]
++ [Key
"conway" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (forall c e a. (Crypto c, KeyValue e a) => ConwayGenesis c -> [a]
toConwayGenesisPairs (TransitionConfig (ConwayEra c)
conwayConfig forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL))]
  where
    babbageConfig :: TransitionConfig (BabbageEra c)
babbageConfig = TransitionConfig (ConwayEra c)
conwayConfig forall s a. s -> Getting a s a -> a
^. forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL
    alonzoConfig :: TransitionConfig (AlonzoEra c)
alonzoConfig = TransitionConfig (BabbageEra c)
babbageConfig forall s a. s -> Getting a s a -> a
^. forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL

instance Crypto c => FromJSON (TransitionConfig (ConwayEra c)) where
  parseJSON :: Value -> Parser (TransitionConfig (ConwayEra c))
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ConwayTransitionConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    ConwayGenesis c
pc <- forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
    TransitionConfig (BabbageEra c)
ag <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"conway"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig ConwayGenesis c
pc TransitionConfig (BabbageEra c)
ag

registerInitialDReps ::
  ConwayEraTransition era =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialDReps :: forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialDReps TransitionConfig era
cfg =
  forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b c a. (b -> c) -> (a -> b) -> a -> c
. 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))
drepsMap
  where
    drepsMap :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
drepsMap = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap forall a b. (a -> b) -> a -> b
$ TransitionConfig era
cfg forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTransition era =>
Lens'
  (TransitionConfig era)
  (ListMap
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
tcInitialDRepsL

registerDelegs ::
  forall era.
  ConwayEraTransition era =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerDelegs :: forall era.
ConwayEraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerDelegs TransitionConfig era
cfg =
  forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (UMap c) (Map (Credential 'Staking c) (UMElem c))
umElemsL
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
m -> forall k a b. ((k, a) -> b -> b) -> b -> ListMap k a -> b
ListMap.foldrWithKey (\(Credential 'Staking (EraCrypto era)
k, Delegatee (EraCrypto era)
v) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall {c}. UMElem c -> UMElem c -> UMElem c
joinUMElems Credential 'Staking (EraCrypto era)
k forall a b. (a -> b) -> a -> b
$ forall {c}. Delegatee c -> UMElem c
delegateeToUMElem Delegatee (EraCrypto era)
v) Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era))
m ListMap
  (Credential 'Staking (EraCrypto era)) (Delegatee (EraCrypto era))
delegs
  where
    delegs :: ListMap
  (Credential 'Staking (EraCrypto era)) (Delegatee (EraCrypto era))
delegs = TransitionConfig era
cfg forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTransition era =>
Lens'
  (TransitionConfig era)
  (ListMap
     (Credential 'Staking (EraCrypto era)) (Delegatee (EraCrypto era)))
tcDelegsL
    delegateeToUMElem :: Delegatee c -> UMElem c
delegateeToUMElem Delegatee c
d =
      forall c.
StrictMaybe RDPair
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool c)
-> StrictMaybe (DRep c)
-> UMElem c
UMElem
        forall a. StrictMaybe a
SNothing
        forall a. Monoid a => a
mempty
        (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe forall a b. (a -> b) -> a -> b
$ forall c. Delegatee c -> Maybe (KeyHash 'StakePool c)
getStakePoolDelegatee Delegatee c
d)
        (forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe forall a b. (a -> b) -> a -> b
$ forall c. Delegatee c -> Maybe (DRep c)
getVoteDelegatee Delegatee c
d)
    joinUMElems :: UMElem c -> UMElem c -> UMElem c
joinUMElems
      (UMElem StrictMaybe RDPair
_ Set Ptr
_ StrictMaybe (KeyHash 'StakePool c)
newStakePool StrictMaybe (DRep c)
newDRep)
      (UMElem StrictMaybe RDPair
rdp Set Ptr
ptrs StrictMaybe (KeyHash 'StakePool c)
oldStakePool StrictMaybe (DRep c)
oldDRrep) =
        forall c.
StrictMaybe RDPair
-> Set Ptr
-> StrictMaybe (KeyHash 'StakePool c)
-> StrictMaybe (DRep c)
-> UMElem c
UMElem
          StrictMaybe RDPair
rdp
          Set Ptr
ptrs
          (StrictMaybe (KeyHash 'StakePool c)
oldStakePool forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StrictMaybe (KeyHash 'StakePool c)
newStakePool)
          (StrictMaybe (DRep c)
oldDRrep forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StrictMaybe (DRep c)
newDRep)