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

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

import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Dijkstra (DijkstraEra)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.PParams
import Cardano.Ledger.Plutus.CostModels (costModelsValid)
import Cardano.Ledger.Plutus.Language (Language (PlutusV4))
import Data.Functor.Identity (Identity)
import qualified Data.Map.Strict as Map
import Lens.Micro
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DijkstraGenesis" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String
-> (UpgradeDijkstraPParams Identity DijkstraEra
    -> PParams ConwayEra -> Property)
-> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Upgrades" UpgradeDijkstraPParams Identity DijkstraEra
-> PParams ConwayEra -> Property
propDijkstraPParamsUpgrade

propDijkstraPParamsUpgrade ::
  UpgradeDijkstraPParams Identity DijkstraEra -> PParams ConwayEra -> Property
propDijkstraPParamsUpgrade :: UpgradeDijkstraPParams Identity DijkstraEra
-> PParams ConwayEra -> Property
propDijkstraPParamsUpgrade UpgradeDijkstraPParams Identity DijkstraEra
ppu PParams ConwayEra
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 DijkstraEra
pp' = UpgradePParams Identity DijkstraEra
-> PParams (PreviousEra DijkstraEra) -> PParams DijkstraEra
forall era.
(EraPParams era, EraPParams (PreviousEra era)) =>
UpgradePParams Identity era
-> PParams (PreviousEra era) -> PParams era
upgradePParams UpgradePParams Identity DijkstraEra
UpgradeDijkstraPParams Identity DijkstraEra
ppu PParams (PreviousEra DijkstraEra)
PParams ConwayEra
pp :: PParams DijkstraEra
      oldCostModels :: Map Language CostModel
oldCostModels = 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)
      newCostModels :: Map Language CostModel
newCostModels = CostModels -> Map Language CostModel
costModelsValid (PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting CostModels (PParams DijkstraEra) CostModels
-> CostModels
forall s a. s -> Getting a s a -> a
^. Getting CostModels (PParams DijkstraEra) CostModels
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams DijkstraEra) CostModels
ppCostModelsL)
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting Word32 (PParams DijkstraEra) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams DijkstraEra) Word32
forall era. DijkstraEraPParams era => Lens' (PParams era) Word32
Lens' (PParams DijkstraEra) Word32
ppMaxRefScriptSizePerBlockL Word32 -> Word32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra -> HKD Identity Word32
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f Word32
udppMaxRefScriptSizePerBlock UpgradeDijkstraPParams Identity DijkstraEra
ppu
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting Word32 (PParams DijkstraEra) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams DijkstraEra) Word32
forall era. DijkstraEraPParams era => Lens' (PParams era) Word32
Lens' (PParams DijkstraEra) Word32
ppMaxRefScriptSizePerTxL Word32 -> Word32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra -> HKD Identity Word32
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f Word32
udppMaxRefScriptSizePerTx UpgradeDijkstraPParams Identity DijkstraEra
ppu
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting (NonZero Word32) (PParams DijkstraEra) (NonZero Word32)
-> NonZero Word32
forall s a. s -> Getting a s a -> a
^. Getting (NonZero Word32) (PParams DijkstraEra) (NonZero Word32)
forall era.
DijkstraEraPParams era =>
Lens' (PParams era) (NonZero Word32)
Lens' (PParams DijkstraEra) (NonZero Word32)
ppRefScriptCostStrideL NonZero Word32 -> NonZero Word32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra
-> HKD Identity (NonZero Word32)
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f (NonZero Word32)
udppRefScriptCostStride UpgradeDijkstraPParams Identity DijkstraEra
ppu
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting PositiveInterval (PParams DijkstraEra) PositiveInterval
-> PositiveInterval
forall s a. s -> Getting a s a -> a
^. Getting PositiveInterval (PParams DijkstraEra) PositiveInterval
forall era.
DijkstraEraPParams era =>
Lens' (PParams era) PositiveInterval
Lens' (PParams DijkstraEra) PositiveInterval
ppRefScriptCostMultiplierL PositiveInterval -> PositiveInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra
-> HKD Identity PositiveInterval
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f PositiveInterval
udppRefScriptCostMultiplier UpgradeDijkstraPParams Identity DijkstraEra
ppu
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting
     MaxPledgeLeverage (PParams DijkstraEra) MaxPledgeLeverage
-> MaxPledgeLeverage
forall s a. s -> Getting a s a -> a
^. Getting MaxPledgeLeverage (PParams DijkstraEra) MaxPledgeLeverage
forall era.
DijkstraEraPParams era =>
Lens' (PParams era) MaxPledgeLeverage
Lens' (PParams DijkstraEra) MaxPledgeLeverage
ppMaxPledgeLeverageL MaxPledgeLeverage -> MaxPledgeLeverage -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra
-> HKD Identity MaxPledgeLeverage
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f MaxPledgeLeverage
udppMaxPledgeLeverage UpgradeDijkstraPParams Identity DijkstraEra
ppu
  PParams DijkstraEra
pp' PParams DijkstraEra
-> Getting UnitInterval (PParams DijkstraEra) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams DijkstraEra) UnitInterval
forall era.
DijkstraEraPParams era =>
Lens' (PParams era) UnitInterval
Lens' (PParams DijkstraEra) UnitInterval
ppMinPoolMarginL UnitInterval -> UnitInterval -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` UpgradeDijkstraPParams Identity DijkstraEra
-> HKD Identity UnitInterval
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f UnitInterval
udppMinPoolMargin UpgradeDijkstraPParams Identity DijkstraEra
ppu
  -- The PlutusV4 CostModel from DijkstraGenesis must win over any pre-existing entry
  Language -> Map Language CostModel -> Maybe CostModel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Language
PlutusV4 Map Language CostModel
newCostModels 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 (UpgradeDijkstraPParams Identity DijkstraEra
-> HKD Identity CostModel
forall (f :: * -> *) era.
UpgradeDijkstraPParams f era -> HKD f CostModel
udppPlutusV4CostModel UpgradeDijkstraPParams Identity DijkstraEra
ppu)
  -- All other cost models must carry over from Conway unchanged
  Language -> Map Language CostModel -> Map Language CostModel
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Language
PlutusV4 Map Language CostModel
newCostModels Map Language CostModel -> Map Language CostModel -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Language -> Map Language CostModel -> Map Language CostModel
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Language
PlutusV4 Map Language CostModel
oldCostModels