{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Genesis (
  ConwayGenesis (..),
  toConwayGenesisPairs,
  cgDelegsL,
)
where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
 )
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Conway.Era (ConwayEra)
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams, toUpgradeConwayPParamsUpdatePairs)
import Cardano.Ledger.Conway.TxCert (Delegatee)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.DRep (DRepState)
import Cardano.Ledger.Genesis (EraGenesis (..))
import Data.Aeson (
  FromJSON (..),
  KeyValue (..),
  ToJSON (..),
  Value (..),
  object,
  pairs,
  withObject,
  (.!=),
  (.:),
  (.:?),
 )
import Data.Functor.Identity (Identity)
import Data.ListMap (ListMap)
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens)
import NoThunks.Class (NoThunks)

data ConwayGenesis = ConwayGenesis
  { ConwayGenesis -> UpgradeConwayPParams Identity
cgUpgradePParams :: !(UpgradeConwayPParams Identity)
  , ConwayGenesis -> Constitution ConwayEra
cgConstitution :: !(Constitution ConwayEra)
  , ConwayGenesis -> Committee ConwayEra
cgCommittee :: !(Committee ConwayEra)
  , ConwayGenesis -> ListMap (Credential 'Staking) Delegatee
cgDelegs :: ListMap (Credential 'Staking) Delegatee
  , ConwayGenesis -> ListMap (Credential 'DRepRole) DRepState
cgInitialDReps :: ListMap (Credential 'DRepRole) DRepState
  }
  deriving (ConwayGenesis -> ConwayGenesis -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConwayGenesis -> ConwayGenesis -> Bool
$c/= :: ConwayGenesis -> ConwayGenesis -> Bool
== :: ConwayGenesis -> ConwayGenesis -> Bool
$c== :: ConwayGenesis -> ConwayGenesis -> Bool
Eq, forall x. Rep ConwayGenesis x -> ConwayGenesis
forall x. ConwayGenesis -> Rep ConwayGenesis x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConwayGenesis x -> ConwayGenesis
$cfrom :: forall x. ConwayGenesis -> Rep ConwayGenesis x
Generic, Int -> ConwayGenesis -> ShowS
[ConwayGenesis] -> ShowS
ConwayGenesis -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConwayGenesis] -> ShowS
$cshowList :: [ConwayGenesis] -> ShowS
show :: ConwayGenesis -> String
$cshow :: ConwayGenesis -> String
showsPrec :: Int -> ConwayGenesis -> ShowS
$cshowsPrec :: Int -> ConwayGenesis -> ShowS
Show)

cgDelegsL :: Lens' ConwayGenesis (ListMap (Credential 'Staking) Delegatee)
cgDelegsL :: Lens' ConwayGenesis (ListMap (Credential 'Staking) Delegatee)
cgDelegsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ConwayGenesis -> ListMap (Credential 'Staking) Delegatee
cgDelegs (\ConwayGenesis
x ListMap (Credential 'Staking) Delegatee
y -> ConwayGenesis
x {cgDelegs :: ListMap (Credential 'Staking) Delegatee
cgDelegs = ListMap (Credential 'Staking) Delegatee
y})

instance EraGenesis ConwayEra where
  type Genesis ConwayEra = ConwayGenesis

instance NoThunks ConwayGenesis

-- | Genesis are always encoded with the version of era they are defined in.
instance FromCBOR ConwayGenesis where
  fromCBOR :: forall s. Decoder s ConwayGenesis
fromCBOR =
    forall era t s. Era era => Decoder s t -> Decoder s t
eraDecoder @ConwayEra forall a b. (a -> b) -> a -> b
$
      forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
        forall t. t -> Decode ('Closed 'Dense) t
RecD UpgradeConwayPParams Identity
-> Constitution ConwayEra
-> Committee ConwayEra
-> ListMap (Credential 'Staking) Delegatee
-> ListMap (Credential 'DRepRole) DRepState
-> ConwayGenesis
ConwayGenesis forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance ToCBOR ConwayGenesis where
  toCBOR :: ConwayGenesis -> Encoding
toCBOR x :: ConwayGenesis
x@(ConwayGenesis UpgradeConwayPParams Identity
_ Constitution ConwayEra
_ Committee ConwayEra
_ ListMap (Credential 'Staking) Delegatee
_ ListMap (Credential 'DRepRole) DRepState
_) =
    let ConwayGenesis {ListMap (Credential 'Staking) Delegatee
ListMap (Credential 'DRepRole) DRepState
Constitution ConwayEra
Committee ConwayEra
UpgradeConwayPParams Identity
cgInitialDReps :: ListMap (Credential 'DRepRole) DRepState
cgDelegs :: ListMap (Credential 'Staking) Delegatee
cgCommittee :: Committee ConwayEra
cgConstitution :: Constitution ConwayEra
cgUpgradePParams :: UpgradeConwayPParams Identity
cgInitialDReps :: ConwayGenesis -> ListMap (Credential 'DRepRole) DRepState
cgDelegs :: ConwayGenesis -> ListMap (Credential 'Staking) Delegatee
cgCommittee :: ConwayGenesis -> Committee ConwayEra
cgConstitution :: ConwayGenesis -> Constitution ConwayEra
cgUpgradePParams :: ConwayGenesis -> UpgradeConwayPParams Identity
..} = ConwayGenesis
x
     in forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @ConwayEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
          forall t. t -> Encode ('Closed 'Dense) t
Rec UpgradeConwayPParams Identity
-> Constitution ConwayEra
-> Committee ConwayEra
-> ListMap (Credential 'Staking) Delegatee
-> ListMap (Credential 'DRepRole) DRepState
-> ConwayGenesis
ConwayGenesis
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To UpgradeConwayPParams Identity
cgUpgradePParams
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Constitution ConwayEra
cgConstitution
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Committee ConwayEra
cgCommittee
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ListMap (Credential 'Staking) Delegatee
cgDelegs
            forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ListMap (Credential 'DRepRole) DRepState
cgInitialDReps

instance DecCBOR ConwayGenesis
instance EncCBOR ConwayGenesis

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

instance FromJSON ConwayGenesis where
  parseJSON :: Value -> Parser ConwayGenesis
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ConwayGenesis" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      UpgradeConwayPParams Identity
upgradeProtocolPParams <- forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
obj)
      UpgradeConwayPParams Identity
-> Constitution ConwayEra
-> Committee ConwayEra
-> ListMap (Credential 'Staking) Delegatee
-> ListMap (Credential 'DRepRole) DRepState
-> ConwayGenesis
ConwayGenesis
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure UpgradeConwayPParams Identity
upgradeProtocolPParams
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"constitution"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"committee"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"delegs" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"initialDReps" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall a. Monoid a => a
mempty

toConwayGenesisPairs :: KeyValue e a => ConwayGenesis -> [a]
toConwayGenesisPairs :: forall e a. KeyValue e a => ConwayGenesis -> [a]
toConwayGenesisPairs cg :: ConwayGenesis
cg@(ConwayGenesis UpgradeConwayPParams Identity
_ Constitution ConwayEra
_ Committee ConwayEra
_ ListMap (Credential 'Staking) Delegatee
_ ListMap (Credential 'DRepRole) DRepState
_) =
  let ConwayGenesis {ListMap (Credential 'Staking) Delegatee
ListMap (Credential 'DRepRole) DRepState
Constitution ConwayEra
Committee ConwayEra
UpgradeConwayPParams Identity
cgInitialDReps :: ListMap (Credential 'DRepRole) DRepState
cgDelegs :: ListMap (Credential 'Staking) Delegatee
cgCommittee :: Committee ConwayEra
cgConstitution :: Constitution ConwayEra
cgUpgradePParams :: UpgradeConwayPParams Identity
cgInitialDReps :: ConwayGenesis -> ListMap (Credential 'DRepRole) DRepState
cgDelegs :: ConwayGenesis -> ListMap (Credential 'Staking) Delegatee
cgCommittee :: ConwayGenesis -> Committee ConwayEra
cgConstitution :: ConwayGenesis -> Constitution ConwayEra
cgUpgradePParams :: ConwayGenesis -> UpgradeConwayPParams Identity
..} = ConwayGenesis
cg
   in [ Key
"constitution" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Constitution ConwayEra
cgConstitution
      , Key
"committee" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Committee ConwayEra
cgCommittee
      ]
        forall a. [a] -> [a] -> [a]
++ [Key
"delegs" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap (Credential 'Staking) Delegatee
cgDelegs | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null ListMap (Credential 'Staking) Delegatee
cgDelegs)]
        forall a. [a] -> [a] -> [a]
++ [Key
"initialDReps" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ListMap (Credential 'DRepRole) DRepState
cgInitialDReps | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null ListMap (Credential 'DRepRole) DRepState
cgInitialDReps)]
        forall a. [a] -> [a] -> [a]
++ forall e a. KeyValue e a => UpgradeConwayPParams Identity -> [a]
toUpgradeConwayPParamsUpdatePairs UpgradeConwayPParams Identity
cgUpgradePParams