{-# 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.Era
import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..), toConwayGenesisPairs)
import Cardano.Ledger.Conway.Rules.Deleg (processDelegation)
import Cardano.Ledger.Conway.Translation ()
import Cardano.Ledger.Conway.TxCert (Delegatee)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRepState)
import Cardano.Ledger.Keys (KeyRole (..))
import Cardano.Ledger.Shelley.LedgerState (
  NewEpochState,
  certVStateL,
  esLStateL,
  lsCertStateL,
  nesEsL,
  vsDRepsL,
 )
import Cardano.Ledger.Shelley.Transition
import Data.Aeson (
  FromJSON (..),
  KeyValue (..),
  ToJSON (..),
  Value (..),
  object,
  pairs,
  withObject,
  (.:),
 )
import Data.ListMap (ListMap)
import qualified Data.ListMap as ListMap
import GHC.Generics
import Lens.Micro
import NoThunks.Class (NoThunks (..))

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

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

  tcConwayGenesisL :: Lens' (TransitionConfig era) ConwayGenesis

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

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

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

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

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

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

  tcDelegsL :: Lens'
  (TransitionConfig ConwayEra)
  (ListMap (Credential 'Staking) Delegatee)
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
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 ConwayGenesis -> ListMap (Credential 'Staking) Delegatee
cgDelegs (\ConwayGenesis
g ListMap (Credential 'Staking) Delegatee
x -> ConwayGenesis
g {cgDelegs :: ListMap (Credential 'Staking) Delegatee
cgDelegs = ListMap (Credential 'Staking) Delegatee
x})

  tcInitialDRepsL :: Lens'
  (TransitionConfig ConwayEra)
  (ListMap (Credential 'DRepRole) DRepState)
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
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 ConwayGenesis -> ListMap (Credential 'DRepRole) DRepState
cgInitialDReps (\ConwayGenesis
g ListMap (Credential 'DRepRole) DRepState
x -> ConwayGenesis
g {cgInitialDReps :: ListMap (Credential 'DRepRole) DRepState
cgInitialDReps = ListMap (Credential 'DRepRole) DRepState
x})

instance NoThunks (TransitionConfig ConwayEra)

instance ToJSON (TransitionConfig ConwayEra) where
  toJSON :: TransitionConfig ConwayEra -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => TransitionConfig ConwayEra -> [a]
toConwayTransitionConfigPairs
  toEncoding :: TransitionConfig ConwayEra -> 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. KeyValue e a => TransitionConfig ConwayEra -> [a]
toConwayTransitionConfigPairs

toConwayTransitionConfigPairs :: KeyValue e a => TransitionConfig ConwayEra -> [a]
toConwayTransitionConfigPairs :: forall e a. KeyValue e a => TransitionConfig ConwayEra -> [a]
toConwayTransitionConfigPairs TransitionConfig ConwayEra
conwayConfig =
  forall e a. KeyValue e a => TransitionConfig AlonzoEra -> [a]
toAlonzoTransitionConfigPairs TransitionConfig AlonzoEra
alonzoConfig
    forall a. [a] -> [a] -> [a]
++ [Key
"conway" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (forall e a. KeyValue e a => ConwayGenesis -> [a]
toConwayGenesisPairs (TransitionConfig ConwayEra
conwayConfig forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL))]
  where
    babbageConfig :: TransitionConfig BabbageEra
babbageConfig = TransitionConfig ConwayEra
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
alonzoConfig = TransitionConfig BabbageEra
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 FromJSON (TransitionConfig ConwayEra) where
  parseJSON :: Value -> Parser (TransitionConfig ConwayEra)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ConwayTransitionConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    ConwayGenesis
pc <- forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
    TransitionConfig BabbageEra
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
pc TransitionConfig BabbageEra
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) DRepState)
vsDRepsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential 'DRepRole) DRepState
drepsMap
  where
    drepsMap :: Map (Credential 'DRepRole) DRepState
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) DRepState)
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 s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \CertState era
certState -> forall k a b. ((k, a) -> b -> b) -> b -> ListMap k a -> b
ListMap.foldrWithKey (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era.
Credential 'Staking -> Delegatee -> CertState era -> CertState era
processDelegation) CertState era
certState (TransitionConfig era
cfg forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraTransition era =>
Lens'
  (TransitionConfig era) (ListMap (Credential 'Staking) Delegatee)
tcDelegsL)