Skip to content

Commit

Permalink
Merge pull request #2190 from input-output-hk/jc/remove-pparam-annota…
Browse files Browse the repository at this point in the history 
…tors

remove annotators from PParams FromCBOR instances
  • Loading branch information
Jared Corduan authored Mar 22, 2021
2 parents 1306178 + fe69982 commit 2b00c29
Show file tree
Hide file tree
Showing 16 changed files with 204 additions and 310 deletions.
177 changes: 80 additions & 97 deletions alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,7 @@ module Cardano.Ledger.Alonzo.PParams
where

import Cardano.Binary
( Annotator,
( Encoding,
FromCBOR (..),
ToCBOR (..),
encodePreEncoded,
Expand All @@ -52,7 +52,6 @@ import Cardano.Ledger.SafeHash
HashAnnotated (..),
SafeToHash (..),
)
import Control.Applicative (liftA2)
import Control.DeepSeq (NFData)
import Data.ByteString.Short (fromShort)
import Data.Coders
Expand All @@ -64,10 +63,9 @@ import Data.Coders
decode,
encode,
field,
mapDecodeA,
mapEncode,
(!>),
(<*!),
(<!),
)
import Data.Default (Default (..))
import Data.Functor.Identity (Identity (..))
Expand All @@ -94,6 +92,7 @@ import Shelley.Spec.Ledger.PParams (HKD, ProtVer (..))
import Shelley.Spec.Ledger.Serialization
( FromCBORGroup (..),
ToCBORGroup (..),
mapFromCBOR,
mapToCBOR,
ratioFromCBOR,
ratioToCBOR,
Expand Down Expand Up @@ -220,33 +219,33 @@ instance (Era era) => ToCBOR (PParams era) where

instance
(Era era) =>
FromCBOR (Annotator (PParams era))
FromCBOR (PParams era)
where
fromCBOR =
decode $
Ann (RecD PParams)
<*! Ann From -- _minfeeA :: Integer
<*! Ann From -- _minfeeB :: Natural
<*! Ann From -- _maxBBSize :: Natural
<*! Ann From -- _maxTxSize :: Natural
<*! Ann From -- _maxBHSize :: Natural
<*! Ann From -- _keyDeposit :: Coin
<*! Ann From -- _poolDeposit :: Coin
<*! Ann From -- _eMax :: EpochNo
<*! Ann From -- _nOpt :: Natural
<*! Ann (D ratioFromCBOR) -- _a0 :: Rational
<*! Ann From -- _rho :: UnitInterval
<*! Ann From -- _tau :: UnitInterval
<*! Ann From -- _d :: UnitInterval
<*! Ann From -- _extraEntropy :: Nonce
<*! Ann (D fromCBORGroup) -- _protocolVersion :: ProtVer
<*! Ann From -- _minPoolCost :: Natural
RecD PParams
<! From -- _minfeeA :: Integer
<! From -- _minfeeB :: Natural
<! From -- _maxBBSize :: Natural
<! From -- _maxTxSize :: Natural
<! From -- _maxBHSize :: Natural
<! From -- _keyDeposit :: Coin
<! From -- _poolDeposit :: Coin
<! From -- _eMax :: EpochNo
<! From -- _nOpt :: Natural
<! (D ratioFromCBOR) -- _a0 :: Rational
<! From -- _rho :: UnitInterval
<! From -- _tau :: UnitInterval
<! From -- _d :: UnitInterval
<! From -- _extraEntropy :: Nonce
<! (D fromCBORGroup) -- _protocolVersion :: ProtVer
<! From -- _minPoolCost :: Natural
-- new/updated for alonzo
<*! Ann From -- _adaPerUTxOByte :: Coin
<*! mapDecodeA (Ann From) From -- _costmdls :: (Map Language CostModel)
<*! Ann From -- _prices = prices',
<*! Ann From -- _maxTxExUnits = maxTxExUnits',
<*! Ann From -- _maxBlockExUnits = maxBlockExUnits'
<! From -- _adaPerUTxOByte :: Coin
<! (D mapFromCBOR) -- _costmdls :: (Map Language CostModel)
<! From -- _prices = prices',
<! From -- _maxTxExUnits = maxTxExUnits',
<! From -- _maxBlockExUnits = maxBlockExUnits'

-- | Returns a basic "empty" `PParams` structure with all zero values.
emptyPParams :: PParams era
Expand Down Expand Up @@ -307,29 +306,31 @@ encodePParamsUpdate ::
Encode ('Closed 'Sparse) (PParamsUpdate era)
encodePParamsUpdate ppup =
Keyed PParams
!> omitStrictMaybe 0 (_minfeeA ppup)
!> omitStrictMaybe 1 (_minfeeB ppup)
!> omitStrictMaybe 2 (_maxBBSize ppup)
!> omitStrictMaybe 3 (_maxTxSize ppup)
!> omitStrictMaybe 4 (_maxBHSize ppup)
!> omitStrictMaybe 5 (_keyDeposit ppup)
!> omitStrictMaybe 6 (_poolDeposit ppup)
!> omitStrictMaybe 7 (_eMax ppup)
!> omitStrictMaybe 8 (_nOpt ppup)
!> Omit isSNothing (Key 9 (E (ratioToCBOR . fromSJust) (_a0 ppup)))
!> omitStrictMaybe 10 (_rho ppup)
!> omitStrictMaybe 11 (_tau ppup)
!> omitStrictMaybe 12 (_d ppup)
!> omitStrictMaybe 13 (_extraEntropy ppup)
!> omitStrictMaybe 14 (_protocolVersion ppup)
!> omitStrictMaybe 15 (_minPoolCost ppup)
!> omitStrictMaybe 16 (_adaPerUTxOByte ppup)
!> omitStrictMaybe 17 (_costmdls ppup)
!> omitStrictMaybe 18 (_prices ppup)
!> omitStrictMaybe 19 (_maxTxExUnits ppup)
!> omitStrictMaybe 20 (_maxBlockExUnits ppup)
!> omitStrictMaybe 0 (_minfeeA ppup) toCBOR
!> omitStrictMaybe 1 (_minfeeB ppup) toCBOR
!> omitStrictMaybe 2 (_maxBBSize ppup) toCBOR
!> omitStrictMaybe 3 (_maxTxSize ppup) toCBOR
!> omitStrictMaybe 4 (_maxBHSize ppup) toCBOR
!> omitStrictMaybe 5 (_keyDeposit ppup) toCBOR
!> omitStrictMaybe 6 (_poolDeposit ppup) toCBOR
!> omitStrictMaybe 7 (_eMax ppup) toCBOR
!> omitStrictMaybe 8 (_nOpt ppup) toCBOR
!> omitStrictMaybe 9 (_a0 ppup) ratioToCBOR
!> omitStrictMaybe 10 (_rho ppup) toCBOR
!> omitStrictMaybe 11 (_tau ppup) toCBOR
!> omitStrictMaybe 12 (_d ppup) toCBOR
!> omitStrictMaybe 13 (_extraEntropy ppup) toCBOR
!> omitStrictMaybe 14 (_protocolVersion ppup) toCBOR
!> omitStrictMaybe 15 (_minPoolCost ppup) toCBOR
!> omitStrictMaybe 16 (_adaPerUTxOByte ppup) toCBOR
!> omitStrictMaybe 17 (_costmdls ppup) mapToCBOR
!> omitStrictMaybe 18 (_prices ppup) toCBOR
!> omitStrictMaybe 19 (_maxTxExUnits ppup) toCBOR
!> omitStrictMaybe 20 (_maxBlockExUnits ppup) toCBOR
where
omitStrictMaybe key x = Omit isSNothing (Key key (E (toCBOR . fromSJust) x))
omitStrictMaybe ::
Word -> StrictMaybe a -> (a -> Encoding) -> Encode ('Closed 'Sparse) (StrictMaybe a)
omitStrictMaybe key x enc = Omit isSNothing (Key key (E (enc . fromSJust) x))

instance (Era era) => ToCBOR (PParamsUpdate era) where
toCBOR ppup = encode (encodePParamsUpdate ppup)
Expand Down Expand Up @@ -361,51 +362,34 @@ emptyPParamsUpdate =
_maxBlockExUnits = SNothing
}

-- ===============================================================================
-- To deserialise the Sparse encoding (produced by encodePParamsUpdate) where
-- 1) only the 'x' part of the (SJust x) has been serialized, and
-- 2) some fields only have FormCBOR(Annotated instances),
-- we need special functions for constructing Field decoders that handle both cases.

-- | if we have a normal (FromCBOR field) instance we use fieldNorm
fieldNorm :: (StrictMaybe field -> b -> b) -> Decode w field -> Field (Annotator b)
fieldNorm update dec = Field (liftA2 update) (decode (Ann (Map SJust dec)))

-- | if we only have a (FromCBOR (Annotator field)) instance we use fieldAnn
fieldAnn ::
(StrictMaybe field -> b -> b) ->
Decode w (Annotator field) ->
Field (Annotator b)
fieldAnn update dec = Field (liftA2 update) (do x <- decode dec; pure (SJust <$> x))

updateField :: Word -> Field (Annotator (PParamsUpdate era))
updateField 0 = fieldNorm (\x up -> up {_minfeeA = x}) From
updateField 1 = fieldNorm (\x up -> up {_minfeeB = x}) From
updateField 2 = fieldNorm (\x up -> up {_maxBBSize = x}) From
updateField 3 = fieldNorm (\x up -> up {_maxTxSize = x}) From
updateField 4 = fieldNorm (\x up -> up {_maxBHSize = x}) From
updateField 5 = fieldNorm (\x up -> up {_keyDeposit = x}) From
updateField 6 = fieldNorm (\x up -> up {_poolDeposit = x}) From
updateField 7 = fieldNorm (\x up -> up {_eMax = x}) From
updateField 8 = fieldNorm (\x up -> up {_nOpt = x}) From
updateField 9 = fieldNorm (\x up -> up {_a0 = x}) (D ratioFromCBOR)
updateField 10 = fieldNorm (\x up -> up {_rho = x}) From
updateField 11 = fieldNorm (\x up -> up {_tau = x}) From
updateField 12 = fieldNorm (\x up -> up {_d = x}) From
updateField 13 = fieldNorm (\x up -> up {_extraEntropy = x}) From
updateField 14 = fieldNorm (\x up -> up {_protocolVersion = x}) From
updateField 15 = fieldNorm (\x up -> up {_minPoolCost = x}) From
updateField 16 = fieldNorm (\x up -> up {_adaPerUTxOByte = x}) From
updateField 17 = fieldAnn (\x up -> up {_costmdls = x}) (mapDecodeA (Ann From) From)
updateField 18 = fieldNorm (\x up -> up {_prices = x}) From
updateField 19 = fieldNorm (\x up -> up {_maxTxExUnits = x}) From
updateField 20 = fieldNorm (\x up -> up {_maxBlockExUnits = x}) From
updateField :: Word -> Field (PParamsUpdate era)
updateField 0 = field (\x up -> up {_minfeeA = SJust x}) From
updateField 1 = field (\x up -> up {_minfeeB = SJust x}) From
updateField 2 = field (\x up -> up {_maxBBSize = SJust x}) From
updateField 3 = field (\x up -> up {_maxTxSize = SJust x}) From
updateField 4 = field (\x up -> up {_maxBHSize = SJust x}) From
updateField 5 = field (\x up -> up {_keyDeposit = SJust x}) From
updateField 6 = field (\x up -> up {_poolDeposit = SJust x}) From
updateField 7 = field (\x up -> up {_eMax = SJust x}) From
updateField 8 = field (\x up -> up {_nOpt = SJust x}) From
updateField 9 = field (\x up -> up {_a0 = x}) (D $ SJust <$> ratioFromCBOR)
updateField 10 = field (\x up -> up {_rho = SJust x}) From
updateField 11 = field (\x up -> up {_tau = SJust x}) From
updateField 12 = field (\x up -> up {_d = SJust x}) From
updateField 13 = field (\x up -> up {_extraEntropy = SJust x}) From
updateField 14 = field (\x up -> up {_protocolVersion = SJust x}) From
updateField 15 = field (\x up -> up {_minPoolCost = SJust x}) From
updateField 16 = field (\x up -> up {_adaPerUTxOByte = SJust x}) From
updateField 17 = field (\x up -> up {_costmdls = x}) (D $ SJust <$> mapFromCBOR)
updateField 18 = field (\x up -> up {_prices = SJust x}) From
updateField 19 = field (\x up -> up {_maxTxExUnits = SJust x}) From
updateField 20 = field (\x up -> up {_maxBlockExUnits = SJust x}) From
updateField k = field (\_x up -> up) (Invalid k)

instance (Era era) => FromCBOR (Annotator (PParamsUpdate era)) where
instance (Era era) => FromCBOR (PParamsUpdate era) where
fromCBOR =
decode
(SparseKeyed "PParamsUpdate" (pure emptyPParamsUpdate) updateField [])
(SparseKeyed "PParamsUpdate" emptyPParamsUpdate updateField [])

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

Expand All @@ -421,8 +405,8 @@ instance NoThunks (ProposedPPUpdates era)
instance Era era => ToCBOR (ProposedPPUpdates era) where
toCBOR (ProposedPPUpdates m) = mapToCBOR m

instance Era era => FromCBOR (Annotator (ProposedPPUpdates era)) where
fromCBOR = (ProposedPPUpdates <$>) <$> (decode (mapDecodeA (Ann From) From)) -- splitMapFromCBOR fromCBOR fromCBOR
instance Era era => FromCBOR (ProposedPPUpdates era) where
fromCBOR = ProposedPPUpdates <$> mapFromCBOR

emptyPPPUpdates :: ProposedPPUpdates era
emptyPPPUpdates = ProposedPPUpdates Map.empty
Expand Down Expand Up @@ -507,13 +491,12 @@ pattern OtherView n <- LangDepViewConstr (Memo (RawOtherView cm) _)

{-# COMPLETE PlutusView {- OtherView -} #-}

instance (Typeable era) => FromCBOR (Annotator (LangDepView era)) where
instance (Typeable era) => FromCBOR (LangDepView era) where
fromCBOR = decode $ Summands "LangDepView" decodeTag
where
decodeTag :: Word -> Decode 'Open (Annotator (LangDepView era))
decodeTag 0 = Ann (SumD PlutusView) <*! From
-- Since CostModel has only (FromCBOR (Annotator CostModel) insatnce
-- decodeTag 1 = Ann (SumD OtherView) <*! (Ann From)
decodeTag :: Word -> Decode 'Open (LangDepView era)
decodeTag 0 = SumD PlutusView <! From
-- decodeTag 1 = SumD OtherView <! From
-- Since Int has FromCBOR instance
decodeTag n = Invalid n

Expand Down
11 changes: 3 additions & 8 deletions alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -72,6 +72,7 @@ import Numeric.Natural (Natural)
import qualified Plutus.V1.Ledger.Examples as Plutus (alwaysFailingNAryFunction, alwaysSucceedingNAryFunction)
import qualified Plutus.V1.Ledger.Scripts as Plutus (Script)
import Shelley.Spec.Ledger.Coin (Coin (..))
import Shelley.Spec.Ledger.Serialization (mapFromCBOR)

-- | Marker indicating the part of a transaction for which this script is acting
-- as a validator.
Expand Down Expand Up @@ -181,14 +182,8 @@ instance NFData CostModel

deriving instance ToCBOR CostModel

-- This is needed to derive the FromCBOR (Annotator CostModel) instance
instance FromCBOR (Annotator (Map ByteString Integer)) where
fromCBOR = pure <$> fromCBOR

deriving via
Mem (Map ByteString Integer)
instance
FromCBOR (Annotator CostModel)
instance FromCBOR CostModel where
fromCBOR = CostModel <$> mapFromCBOR

-- CostModel is not parameterized by Crypto or Era so we use the
-- hashWithCrypto function, rather than hashAnnotated
Expand Down
6 changes: 3 additions & 3 deletions alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -333,7 +333,7 @@ instance Era era => FromCBOR (Annotator (WitnessPPDataRaw era)) where
decode
( Ann (RecD WitnessPPDataRaw)
<*! mapDecodeA (Ann From) From
<*! setDecodeA From
<*! setDecodeA (Ann From)
)

newtype WitnessPPData era = WitnessPPDataConstr (MemoBytes (WitnessPPDataRaw era))
Expand Down Expand Up @@ -752,7 +752,7 @@ instance
FromCBOR (Annotator (Core.Script era)),
FromCBOR (Annotator (Core.TxBody era)),
FromCBOR (Annotator (Core.AuxiliaryData era)),
Core.AnnotatedData (PParamsDelta era),
FromCBOR (PParamsDelta era),
ToCBOR (Core.Script era),
Typeable (Core.Script era),
Typeable (Core.AuxiliaryData era),
Expand Down Expand Up @@ -782,7 +782,7 @@ deriving via
FromCBOR (Annotator (Core.Script era)),
FromCBOR (Annotator (Core.TxBody era)),
FromCBOR (Annotator (Core.AuxiliaryData era)),
Core.AnnotatedData (PParamsDelta era),
FromCBOR (PParamsDelta era),
ToCBOR (Core.Script era),
Typeable (Core.Script era),
Typeable (Core.AuxiliaryData era),
Expand Down
Loading

0 comments on commit 2b00c29

Please sign in to comment.