{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Conway.GenesisSpec (spec) where

import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Plutus.CostModels (costModelsValid)
import Cardano.Ledger.Plutus.Language (Language (PlutusV3))
import Data.Aeson hiding (Encoding)
import Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import Lens.Micro
import Paths_cardano_ledger_conway (getDataFileName)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Genesis (expectedConwayGenesis)
import Test.Cardano.Slotting.Numeric ()

spec :: Spec
spec :: Spec
spec = do
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"ConwayGenesis" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"Golden Spec" Spec
goldenConwayGenesisJSON
    [Char]
-> (UpgradeConwayPParams Identity
    -> PParams BabbageEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Upgrades" UpgradeConwayPParams Identity -> PParams BabbageEra -> Property
propConwayPParamsUpgrade

fileName :: String
fileName :: [Char]
fileName = [Char]
"test/data/conway-genesis.json"

goldenConwayGenesisJSON :: Spec
goldenConwayGenesisJSON :: Spec
goldenConwayGenesisJSON =
  [Char] -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"should deserialize to the default value" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    [Char]
file <- [Char] -> IO [Char]
getDataFileName [Char]
fileName
    Either [Char] ConwayGenesis
dec <- [Char] -> IO (Either [Char] ConwayGenesis)
forall a. FromJSON a => [Char] -> IO (Either [Char] a)
eitherDecodeFileStrict' [Char]
file
    ConwayGenesis
cg <- case Either [Char] ConwayGenesis
dec of
      Left [Char]
err -> [Char] -> IO ConwayGenesis
forall a. HasCallStack => [Char] -> a
error ([Char]
"Failed to deserialize JSON: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
      Right ConwayGenesis
x -> ConwayGenesis -> IO ConwayGenesis
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConwayGenesis
x
    ConwayGenesis
cg ConwayGenesis -> ConwayGenesis -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` ConwayGenesis
expectedConwayGenesis

propConwayPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams BabbageEra -> Property
propConwayPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams BabbageEra -> Property
propConwayPParamsUpgrade UpgradeConwayPParams Identity
ppu PParams BabbageEra
pp = IO () -> Property
forall prop. Testable prop => prop -> Property
property (IO () -> Property) -> IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  let pp' :: PParams ConwayEra
pp' = UpgradePParams Identity ConwayEra
-> PParams (PreviousEra ConwayEra) -> PParams ConwayEra
forall era.
(EraPParams era, EraPParams (PreviousEra era)) =>
UpgradePParams Identity era
-> PParams (PreviousEra era) -> PParams era
upgradePParams UpgradePParams Identity ConwayEra
UpgradeConwayPParams Identity
ppu PParams (PreviousEra ConwayEra)
PParams BabbageEra
pp :: PParams ConwayEra
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting
     PoolVotingThresholds (PParams ConwayEra) PoolVotingThresholds
-> PoolVotingThresholds
forall s a. s -> Getting a s a -> a
^. Getting
  PoolVotingThresholds (PParams ConwayEra) PoolVotingThresholds
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams ConwayEra) PoolVotingThresholds
ppPoolVotingThresholdsL PoolVotingThresholds -> PoolVotingThresholds -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity PoolVotingThresholds
forall (f :: * -> *).
UpgradeConwayPParams f -> HKD f PoolVotingThresholds
ucppPoolVotingThresholds UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting
     DRepVotingThresholds (PParams ConwayEra) DRepVotingThresholds
-> DRepVotingThresholds
forall s a. s -> Getting a s a -> a
^. Getting
  DRepVotingThresholds (PParams ConwayEra) DRepVotingThresholds
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams ConwayEra) DRepVotingThresholds
ppDRepVotingThresholdsL DRepVotingThresholds -> DRepVotingThresholds -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity DRepVotingThresholds
forall (f :: * -> *).
UpgradeConwayPParams f -> HKD f DRepVotingThresholds
ucppDRepVotingThresholds UpgradeConwayPParams Identity
ppu
  Natural -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams ConwayEra
pp' PParams ConwayEra
-> Getting Natural (PParams ConwayEra) Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural (PParams ConwayEra) Natural
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams ConwayEra) Natural
ppCommitteeMinSizeL) Word16 -> Word16 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity Word16
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f Word16
ucppCommitteeMinSize UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting EpochInterval (PParams ConwayEra) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams ConwayEra) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams ConwayEra) EpochInterval
ppCommitteeMaxTermLengthL EpochInterval -> EpochInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity EpochInterval
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f EpochInterval
ucppCommitteeMaxTermLength UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting EpochInterval (PParams ConwayEra) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams ConwayEra) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams ConwayEra) EpochInterval
ppGovActionLifetimeL EpochInterval -> EpochInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity EpochInterval
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f EpochInterval
ucppGovActionLifetime UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra -> Getting Coin (PParams ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams ConwayEra) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams ConwayEra) Coin
ppGovActionDepositL Coin -> Coin -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity Coin
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f Coin
ucppGovActionDeposit UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra -> Getting Coin (PParams ConwayEra) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams ConwayEra) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams ConwayEra) Coin
ppDRepDepositL Coin -> Coin -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity Coin
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f Coin
ucppDRepDeposit UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting EpochInterval (PParams ConwayEra) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams ConwayEra) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams ConwayEra) EpochInterval
ppDRepActivityL EpochInterval -> EpochInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity EpochInterval
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f EpochInterval
ucppDRepActivity UpgradeConwayPParams Identity
ppu
  PParams ConwayEra
pp' PParams ConwayEra
-> Getting
     NonNegativeInterval (PParams ConwayEra) NonNegativeInterval
-> NonNegativeInterval
forall s a. s -> Getting a s a -> a
^. Getting NonNegativeInterval (PParams ConwayEra) NonNegativeInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams ConwayEra) NonNegativeInterval
ppMinFeeRefScriptCostPerByteL NonNegativeInterval -> NonNegativeInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeConwayPParams Identity -> HKD Identity NonNegativeInterval
forall (f :: * -> *).
UpgradeConwayPParams f -> HKD f NonNegativeInterval
ucppMinFeeRefScriptCostPerByte UpgradeConwayPParams Identity
ppu
  Language -> Map Language CostModel -> Maybe CostModel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Language
PlutusV3 (CostModels -> Map Language CostModel
costModelsValid (PParams ConwayEra
pp' PParams ConwayEra
-> Getting CostModels (PParams ConwayEra) CostModels -> CostModels
forall s a. s -> Getting a s a -> a
^. Getting CostModels (PParams ConwayEra) CostModels
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams ConwayEra) CostModels
ppCostModelsL))
    Maybe CostModel -> Maybe CostModel -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` CostModel -> Maybe CostModel
forall a. a -> Maybe a
Just (UpgradeConwayPParams Identity -> HKD Identity CostModel
forall (f :: * -> *). UpgradeConwayPParams f -> HKD f CostModel
ucppPlutusV3CostModel UpgradeConwayPParams Identity
ppu)