{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Plutus.Context (
  pparamUpdateToData,
  pparamUpdateFromData,
  conwayPParam,
  conwayPParamMap,
  ConwayEraPlutusTxInfo (..),
) where

import Cardano.Ledger.Alonzo.PParams (
  ppuCollateralPercentageL,
  ppuCostModelsL,
  ppuMaxBlockExUnitsL,
  ppuMaxCollateralInputsL,
  ppuMaxTxExUnitsL,
  ppuMaxValSizeL,
  ppuPricesL,
 )
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo)
import Cardano.Ledger.Babbage.PParams (CoinPerByte (..), ppuCoinsPerUTxOByteL)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.PParams (
  ConwayEraPParams (..),
  DRepVotingThresholds (..),
  PoolVotingThresholds (..),
  ppuCommitteeMaxTermLengthL,
  ppuCommitteeMinSizeL,
  ppuDRepActivityL,
  ppuDRepDepositL,
  ppuDRepVotingThresholdsL,
  ppuGovActionDepositL,
  ppuGovActionLifetimeL,
  ppuMinFeeRefScriptCostPerByteL,
  ppuPoolVotingThresholdsL,
 )
import Cardano.Ledger.Core (
  EraPParams (..),
  PParam (..),
  PParamsUpdate,
  emptyPParamsUpdate,
  makePParamMap,
  ppuA0L,
  ppuEMaxL,
  ppuKeyDepositL,
  ppuMaxBBSizeL,
  ppuMaxBHSizeL,
  ppuMaxTxSizeL,
  ppuMinFeeAL,
  ppuMinFeeBL,
  ppuMinPoolCostL,
  ppuNOptL,
  ppuPoolDepositL,
  ppuRhoL,
  ppuTauL,
 )
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
import Data.Foldable (foldlM)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Lens.Micro ((&), (.~), (^.))
import PlutusLedgerApi.Common (Data (..))
import qualified PlutusLedgerApi.V3 as PV3

-- ====================================================================
-- Generic, Table (Map Word (PParam era)) driven translators for
-- PParamUpdate, A table for some era, will make instances for (PParamUpdate era) for that Era.

-- | Translate a PParamUpdate to Data, using the PParamMap.
-- The PParamUpdate is Basically (Map (tag t) (Some (StrictMaybe t)))
-- The idea is to only store (Map (tag t) (Some t)) for just the components
-- that had (SJust t), and to leave out the other tags. To transform this
-- back to a (Map (tag t) (Some t)), we start with a full map where everything is
-- SNothing, and then override the tags we find in the data with (SJust t)
-- That is what happens in pparamUpdateFromData below
pparamUpdateToData :: Map Word (PParam era) -> PParamsUpdate era -> Data
pparamUpdateToData :: forall era. Map Word (PParam era) -> PParamsUpdate era -> Data
pparamUpdateToData Map Word (PParam era)
pparamMap PParamsUpdate era
ppu = [(Data, Data)] -> Data
Map (forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' Word -> PParam era -> [(Data, Data)] -> [(Data, Data)]
toMapPair [] Map Word (PParam era)
pparamMap)
  where
    toMapPair :: Word -> PParam era -> [(Data, Data)] -> [(Data, Data)]
toMapPair Word
tag (PParam Word
_ Lens' (PParamsUpdate era) (StrictMaybe t)
ppuL) [(Data, Data)]
ans =
      case PParamsUpdate era
ppu forall s a. s -> Getting a s a -> a
^. Lens' (PParamsUpdate era) (StrictMaybe t)
ppuL of
        StrictMaybe t
SNothing -> [(Data, Data)]
ans
        SJust t
t -> (Integer -> Data
I (forall a. Integral a => a -> Integer
toInteger @Word Word
tag), forall x. ToPlutusData x => x -> Data
toPlutusData t
t) forall a. a -> [a] -> [a]
: [(Data, Data)]
ans

-- | Translate Data to a PParamUpdate, using the PParamMap.
pparamUpdateFromData :: EraPParams era => Map Word (PParam era) -> Data -> Maybe (PParamsUpdate era)
pparamUpdateFromData :: forall era.
EraPParams era =>
Map Word (PParam era) -> Data -> Maybe (PParamsUpdate era)
pparamUpdateFromData Map Word (PParam era)
pparamMap (Map [(Data, Data)]
pairs) =
  forall a b. (a, b) -> a
fst
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall {k} {era}.
(ToPlutusData k, Ord k) =>
(PParamsUpdate era, Map k (PParam era))
-> (Data, Data) -> Maybe (PParamsUpdate era, Map k (PParam era))
accum (forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate, Map Word (PParam era)
pparamMap) [(Data, Data)]
pairs
  where
    accum :: (PParamsUpdate era, Map k (PParam era))
-> (Data, Data) -> Maybe (PParamsUpdate era, Map k (PParam era))
accum (!PParamsUpdate era
ppu, !Map k (PParam era)
leftOverMap) (Data
key, Data
value) = do
      k
tg <- forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
key
      PParam Word
_ Lens' (PParamsUpdate era) (StrictMaybe t)
ppuL <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
tg Map k (PParam era)
leftOverMap
      t
val <- forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
value
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (PParamsUpdate era
ppu forall a b. a -> (a -> b) -> b
& Lens' (PParamsUpdate era) (StrictMaybe t)
ppuL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust t
val, forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
tg Map k (PParam era)
leftOverMap)
pparamUpdateFromData Map Word (PParam era)
_ Data
_ = forall a. Maybe a
Nothing

-- ===================================================================
-- ToPlutusData instances necessary for (PParamUpdate (CowayEra c))

instance ToPlutusData PoolVotingThresholds where
  toPlutusData :: PoolVotingThresholds -> Data
toPlutusData PoolVotingThresholds
x =
    [Data] -> Data
List
      [ forall x. ToPlutusData x => x -> Data
toPlutusData (PoolVotingThresholds -> UnitInterval
pvtMotionNoConfidence PoolVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (PoolVotingThresholds -> UnitInterval
pvtCommitteeNormal PoolVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (PoolVotingThresholds -> UnitInterval
pvtCommitteeNoConfidence PoolVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (PoolVotingThresholds -> UnitInterval
pvtHardForkInitiation PoolVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (PoolVotingThresholds -> UnitInterval
pvtPPSecurityGroup PoolVotingThresholds
x)
      ]
  fromPlutusData :: Data -> Maybe PoolVotingThresholds
fromPlutusData (List [Data
a, Data
b, Data
c, Data
d, Data
e]) =
    UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> PoolVotingThresholds
PoolVotingThresholds
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
a
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
b
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
c
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
d
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
e
  fromPlutusData Data
_ = forall a. Maybe a
Nothing

instance ToPlutusData DRepVotingThresholds where
  toPlutusData :: DRepVotingThresholds -> Data
toPlutusData DRepVotingThresholds
x =
    [Data] -> Data
List
      [ forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtMotionNoConfidence DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtCommitteeNormal DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtCommitteeNoConfidence DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtUpdateToConstitution DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtHardForkInitiation DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtPPNetworkGroup DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtPPEconomicGroup DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtPPTechnicalGroup DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtPPGovGroup DRepVotingThresholds
x)
      , forall x. ToPlutusData x => x -> Data
toPlutusData (DRepVotingThresholds -> UnitInterval
dvtTreasuryWithdrawal DRepVotingThresholds
x)
      ]
  fromPlutusData :: Data -> Maybe DRepVotingThresholds
fromPlutusData (List [Data
a, Data
b, Data
c, Data
d, Data
e, Data
f, Data
g, Data
h, Data
i, Data
j]) =
    UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> UnitInterval
-> DRepVotingThresholds
DRepVotingThresholds
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
a
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
b
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
c
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
d
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
e
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
f
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
g
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
h
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
i
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData Data
j
  fromPlutusData Data
_ = forall a. Maybe a
Nothing

instance ToPlutusData CoinPerByte where
  toPlutusData :: CoinPerByte -> Data
toPlutusData (CoinPerByte Coin
c) = forall x. ToPlutusData x => x -> Data
toPlutusData @Coin Coin
c
  fromPlutusData :: Data -> Maybe CoinPerByte
fromPlutusData Data
x = Coin -> CoinPerByte
CoinPerByte forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall x. ToPlutusData x => Data -> Maybe x
fromPlutusData @Coin Data
x

-- ==========================================================

-- | A Map for the Conway era
conwayPParamMap :: ConwayEraPParams era => Map Word (PParam era)
conwayPParamMap :: forall era. ConwayEraPParams era => Map Word (PParam era)
conwayPParamMap = forall era. [PParam era] -> Map Word (PParam era)
makePParamMap forall era. ConwayEraPParams era => [PParam era]
conwayPParam

-- | A list for the Conway era, other eras may have different tags and lenses.
conwayPParam :: ConwayEraPParams era => [PParam era]
conwayPParam :: forall era. ConwayEraPParams era => [PParam era]
conwayPParam =
  [ forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
0 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
1 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeBL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
2 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word32)
ppuMaxBBSizeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
3 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word32)
ppuMaxTxSizeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
4 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuMaxBHSizeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
5 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuKeyDepositL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
6 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuPoolDepositL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
7 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
ppuEMaxL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
8 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Word16)
ppuNOptL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
9 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe NonNegativeInterval)
ppuA0L
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
10 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe UnitInterval)
ppuRhoL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
11 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe UnitInterval)
ppuTauL
  , -- Missing in Conway [12,13,14,15]
    forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
16 forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinPoolCostL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
17 forall era.
BabbageEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CoinPerByte)
ppuCoinsPerUTxOByteL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
18 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
19 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Prices)
ppuPricesL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
20 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe ExUnits)
ppuMaxTxExUnitsL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
21 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe ExUnits)
ppuMaxBlockExUnitsL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
22 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuMaxValSizeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
23 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCollateralPercentageL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
24 forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuMaxCollateralInputsL
  , -- New to Conway [25 .. 33]
    forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
25 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe PoolVotingThresholds)
ppuPoolVotingThresholdsL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
26 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe DRepVotingThresholds)
ppuDRepVotingThresholdsL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
27 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
28 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
ppuCommitteeMaxTermLengthL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
29 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
ppuGovActionLifetimeL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
30 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuGovActionDepositL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
31 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuDRepDepositL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
32 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
ppuDRepActivityL
  , forall t era.
ToPlutusData t =>
Word -> Lens' (PParamsUpdate era) (StrictMaybe t) -> PParam era
PParam Word
33 forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe NonNegativeInterval)
ppuMinFeeRefScriptCostPerByteL
  ]

-- ===========================================================
-- A class to compute the changed parameters in the TxInfo
-- given a ToPlutusData instance for PParamsUpdate

class
  ( ToPlutusData (PParamsUpdate era)
  , EraPlutusTxInfo l era
  ) =>
  ConwayEraPlutusTxInfo (l :: Language) era
  where
  toPlutusChangedParameters :: proxy l -> PParamsUpdate era -> PV3.ChangedParameters