{-# 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.State (
  ConwayEraCertState (..),
  vsDRepsL,
 )
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,
  esLStateL,
  lsCertStateL,
  nesEsL,
 )
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, ConwayEraCertState 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.
ConwayEraCertState 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.
ConwayEraCertState 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)