From aa2624e63d9b3a3295d29d10e2cf64e97a8d0c9b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 17 Jan 2025 14:01:03 +0000 Subject: [PATCH] Remove `era` type parameter from `MemoBytes` type And adjust usages accordingly --- eras/allegra/impl/CHANGELOG.md | 8 ++ .../src/Cardano/Ledger/Allegra/Scripts.hs | 64 +++++---- .../src/Cardano/Ledger/Allegra/TxAuxData.hs | 25 ++-- .../Cardano/Ledger/Allegra/TxBody/Internal.hs | 36 +++-- .../src/Cardano/Ledger/Alonzo/TxAuxData.hs | 34 +++-- .../Cardano/Ledger/Alonzo/TxBody/Internal.hs | 46 +++--- .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 52 ++++--- .../Cardano/Ledger/Babbage/TxBody/Internal.hs | 101 ++++++------- .../Cardano/Ledger/Conway/TxBody/Internal.hs | 75 ++++++---- .../Cardano/Ledger/Mary/TxBody/Internal.hs | 18 ++- eras/shelley/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Shelley/Scripts.hs | 17 +-- .../src/Cardano/Ledger/Shelley/Tx/Internal.hs | 24 ++-- .../src/Cardano/Ledger/Shelley/TxAuxData.hs | 15 +- .../impl/src/Cardano/Ledger/Shelley/TxBody.hs | 37 +++-- .../impl/src/Cardano/Ledger/Shelley/TxWits.hs | 18 +-- libs/cardano-ledger-core/CHANGELOG.md | 18 +++ .../src/Cardano/Ledger/MemoBytes/Internal.hs | 134 +++++++++--------- .../src/Cardano/Ledger/Plutus/Data.hs | 16 +-- .../testlib/Test/Cardano/Ledger/TreeDiff.hs | 2 +- .../Constrained/Conway/Instances/Ledger.hs | 4 +- .../Ledger/Constrained/Preds/Universes.hs | 5 +- 22 files changed, 432 insertions(+), 318 deletions(-) diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index e54ab89aeb2..d1e622be515 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -2,6 +2,14 @@ ## 1.7.0.0 +* Add `Era era` constraint to `NoThunks` instance for `TimeLock` +* Remove `Era era` constraint from: + * `getRequireSignatureTimelock` + * `getRequireAllOfTimelock` + * `getRequireAnyOfTimelock` + * `getRequireMOfTimelock` + * `getTimeStartTimelock` + * `getTimeExpireTimelock` * Add `MemPack` instance for `Timelock` * Remove deprecated `AuxiliaryData` type synonym * Deprecate `Allegra` type synonym diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs index ad4f0b8d472..25e1e46e771 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs @@ -12,6 +12,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -72,10 +73,12 @@ import Cardano.Ledger.Binary.Coders ( import Cardano.Ledger.Core import Cardano.Ledger.MemoBytes ( EqRaw (..), - Mem, MemoBytes (Memo), Memoized (..), getMemoRawType, + mbpackM, + mbpackedByteCount, + mbunpackM, mkMemoBytes, mkMemoized, ) @@ -87,14 +90,13 @@ import Cardano.Ledger.Shelley.Scripts ( pattern RequireMOf, pattern RequireSignature, ) -import Data.MemPack - import Cardano.Slotting.Slot (SlotNo (..)) import Control.DeepSeq (NFData (..)) import Data.Aeson (ToJSON (..), (.=)) import qualified Data.Aeson as Aeson import Data.ByteString.Lazy (fromStrict) import Data.ByteString.Short (fromShort) +import Data.MemPack import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|))) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set (Set, member) @@ -208,24 +210,28 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where -- They rely on memoBytes, and TimelockRaw to memoize each constructor of Timelock -- ================================================================= -newtype Timelock era = TimelockConstr (MemoBytes TimelockRaw era) +newtype Timelock era = TimelockConstr (MemoBytes (TimelockRaw era)) deriving (Eq, Generic) - deriving newtype (ToCBOR, NoThunks, NFData, SafeToHash, MemPack) + deriving newtype (ToCBOR, NFData, SafeToHash) + +instance Era era => MemPack (Timelock era) where + packedByteCount (TimelockConstr mb) = mbpackedByteCount mb + packM (TimelockConstr mb) = mbpackM mb + unpackM = TimelockConstr <$> mbunpackM (eraProtVerLow @era) +instance Era era => NoThunks (Timelock era) instance Era era => EncCBOR (Timelock era) -instance Memoized Timelock where - type RawType Timelock = TimelockRaw +instance Memoized (Timelock era) where + type RawType (Timelock era) = TimelockRaw era deriving instance Show (Timelock era) instance EqRaw (Timelock era) where eqRaw = eqTimelockRaw -deriving via - Mem TimelockRaw era - instance - Era era => DecCBOR (Annotator (Timelock era)) +instance Era era => DecCBOR (Annotator (Timelock era)) where + decCBOR = fmap TimelockConstr <$> decCBOR -- | Since Timelock scripts are a strictly backwards compatible extension of -- MultiSig scripts, we can use the same 'scriptPrefixTag' tag here as we did @@ -286,39 +292,39 @@ pattern RequireTimeStart mslot <- (getTimeStart -> Just mslot) , RequireTimeStart #-} -mkRequireSignatureTimelock :: Era era => KeyHash 'Witness -> Timelock era -mkRequireSignatureTimelock = mkMemoized . Signature -getRequireSignatureTimelock :: Era era => Timelock era -> Maybe (KeyHash 'Witness) +mkRequireSignatureTimelock :: forall era. Era era => KeyHash 'Witness -> Timelock era +mkRequireSignatureTimelock = mkMemoized (eraProtVerLow @era) . Signature +getRequireSignatureTimelock :: Timelock era -> Maybe (KeyHash 'Witness) getRequireSignatureTimelock (TimelockConstr (Memo (Signature kh) _)) = Just kh getRequireSignatureTimelock _ = Nothing -mkRequireAllOfTimelock :: Era era => StrictSeq (Timelock era) -> Timelock era -mkRequireAllOfTimelock = mkMemoized . AllOf -getRequireAllOfTimelock :: Era era => Timelock era -> Maybe (StrictSeq (Timelock era)) +mkRequireAllOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era +mkRequireAllOfTimelock = mkMemoized (eraProtVerLow @era) . AllOf +getRequireAllOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era)) getRequireAllOfTimelock (TimelockConstr (Memo (AllOf ms) _)) = Just ms getRequireAllOfTimelock _ = Nothing -mkRequireAnyOfTimelock :: Era era => StrictSeq (Timelock era) -> Timelock era -mkRequireAnyOfTimelock = mkMemoized . AnyOf -getRequireAnyOfTimelock :: Era era => Timelock era -> Maybe (StrictSeq (Timelock era)) +mkRequireAnyOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era +mkRequireAnyOfTimelock = mkMemoized (eraProtVerLow @era) . AnyOf +getRequireAnyOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era)) getRequireAnyOfTimelock (TimelockConstr (Memo (AnyOf ms) _)) = Just ms getRequireAnyOfTimelock _ = Nothing -mkRequireMOfTimelock :: Era era => Int -> StrictSeq (Timelock era) -> Timelock era -mkRequireMOfTimelock n = mkMemoized . MOfN n -getRequireMOfTimelock :: Era era => Timelock era -> Maybe (Int, (StrictSeq (Timelock era))) +mkRequireMOfTimelock :: forall era. Era era => Int -> StrictSeq (Timelock era) -> Timelock era +mkRequireMOfTimelock n = mkMemoized (eraProtVerLow @era) . MOfN n +getRequireMOfTimelock :: Timelock era -> Maybe (Int, StrictSeq (Timelock era)) getRequireMOfTimelock (TimelockConstr (Memo (MOfN n ms) _)) = Just (n, ms) getRequireMOfTimelock _ = Nothing -mkTimeStartTimelock :: Era era => SlotNo -> Timelock era -mkTimeStartTimelock = mkMemoized . TimeStart -getTimeStartTimelock :: Era era => Timelock era -> Maybe SlotNo +mkTimeStartTimelock :: forall era. Era era => SlotNo -> Timelock era +mkTimeStartTimelock = mkMemoized (eraProtVerLow @era) . TimeStart +getTimeStartTimelock :: Timelock era -> Maybe SlotNo getTimeStartTimelock (TimelockConstr (Memo (TimeStart mslot) _)) = Just mslot getTimeStartTimelock _ = Nothing -mkTimeExpireTimelock :: Era era => SlotNo -> Timelock era -mkTimeExpireTimelock = mkMemoized . TimeExpire -getTimeExpireTimelock :: Era era => Timelock era -> Maybe SlotNo +mkTimeExpireTimelock :: forall era. Era era => SlotNo -> Timelock era +mkTimeExpireTimelock = mkMemoized (eraProtVerLow @era) . TimeExpire +getTimeExpireTimelock :: Timelock era -> Maybe SlotNo getTimeExpireTimelock (TimelockConstr (Memo (TimeExpire mslot) _)) = Just mslot getTimeExpireTimelock _ = Nothing diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs index 438646e0a11..ad7542b7865 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs @@ -9,7 +9,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -96,17 +98,21 @@ instance EraTxAuxData AllegraEra where validateTxAuxData _ (AllegraTxAuxData md as) = as `deepseq` all validMetadatum md -metadataAllegraTxAuxDataL :: Era era => Lens' (AllegraTxAuxData era) (Map Word64 Metadatum) +metadataAllegraTxAuxDataL :: + forall era. Era era => Lens' (AllegraTxAuxData era) (Map Word64 Metadatum) metadataAllegraTxAuxDataL = - lensMemoRawType atadrMetadata $ \txAuxDataRaw md -> txAuxDataRaw {atadrMetadata = md} + lensMemoRawType (eraProtVerLow @era) atadrMetadata $ + \txAuxDataRaw md -> txAuxDataRaw {atadrMetadata = md} instance AllegraEraTxAuxData AllegraEra where timelockScriptsTxAuxDataL = timelockScriptsAllegraTxAuxDataL timelockScriptsAllegraTxAuxDataL :: + forall era. Era era => Lens' (AllegraTxAuxData era) (StrictSeq (Timelock era)) timelockScriptsAllegraTxAuxDataL = - lensMemoRawType atadrTimelock $ \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts} + lensMemoRawType (eraProtVerLow @era) atadrTimelock $ + \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts} deriving instance Show (AllegraTxAuxDataRaw era) @@ -114,14 +120,14 @@ deriving instance Era era => NoThunks (AllegraTxAuxDataRaw era) instance NFData (AllegraTxAuxDataRaw era) -newtype AllegraTxAuxData era = AuxiliaryDataWithBytes (MemoBytes AllegraTxAuxDataRaw era) +newtype AllegraTxAuxData era = AuxiliaryDataWithBytes (MemoBytes (AllegraTxAuxDataRaw era)) deriving (Generic) deriving newtype (Eq, ToCBOR, SafeToHash) -instance Memoized AllegraTxAuxData where - type RawType AllegraTxAuxData = AllegraTxAuxDataRaw +instance Memoized (AllegraTxAuxData era) where + type RawType (AllegraTxAuxData era) = AllegraTxAuxDataRaw era -type instance MemoHashIndex AllegraTxAuxDataRaw = EraIndependentTxAuxData +type instance MemoHashIndex (AllegraTxAuxDataRaw era) = EraIndependentTxAuxData instance HashAnnotated (AllegraTxAuxData era) EraIndependentTxAuxData where hashAnnotated = getMemoSafeHash @@ -135,13 +141,14 @@ deriving newtype instance NFData (AllegraTxAuxData era) instance EqRaw (AllegraTxAuxData era) pattern AllegraTxAuxData :: + forall era. Era era => Map Word64 Metadatum -> StrictSeq (Timelock era) -> AllegraTxAuxData era pattern AllegraTxAuxData blob sp <- (getMemoRawType -> AllegraTxAuxDataRaw blob sp) where - AllegraTxAuxData blob sp = mkMemoized $ AllegraTxAuxDataRaw blob sp + AllegraTxAuxData blob sp = mkMemoized (eraProtVerLow @era) $ AllegraTxAuxDataRaw blob sp {-# COMPLETE AllegraTxAuxData #-} @@ -181,6 +188,6 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where ) deriving via - (Mem AllegraTxAuxDataRaw era) + (Mem (AllegraTxAuxDataRaw era)) instance Era era => DecCBOR (Annotator (AllegraTxAuxData era)) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs index a0f03b76a76..ee8e8fb0503 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs @@ -209,11 +209,11 @@ emptyAllegraTxBodyRaw = -- =========================================================================== -- Wrap it all up in a newtype, hiding the insides with a pattern construtor. -newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw ()) e) +newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw () e)) deriving newtype (SafeToHash, ToCBOR) -instance Memoized AllegraTxBody where - type RawType AllegraTxBody = AllegraTxBodyRaw () +instance Memoized (AllegraTxBody era) where + type RawType (AllegraTxBody era) = AllegraTxBodyRaw () era deriving instance (Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) => @@ -241,17 +241,18 @@ deriving newtype instance instance Era era => EncCBOR (AllegraTxBody era) deriving via - Mem (AllegraTxBodyRaw ()) era + Mem (AllegraTxBodyRaw () era) instance AllegraEraTxBody era => DecCBOR (Annotator (AllegraTxBody era)) -type instance MemoHashIndex (AllegraTxBodyRaw c) = EraIndependentTxBody +type instance MemoHashIndex (AllegraTxBodyRaw c era) = EraIndependentTxBody instance Era era => HashAnnotated (AllegraTxBody era) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -- | A pattern to keep the newtype and the MemoBytes hidden pattern AllegraTxBody :: + forall era. (EraTxOut era, EraTxCert era) => Set TxIn -> StrictSeq (TxOut era) -> @@ -294,7 +295,7 @@ pattern AllegraTxBody validityInterval update auxDataHash = - mkMemoized $ + mkMemoized (eraProtVerLow @era) $ AllegraTxBodyRaw { atbrInputs = inputs , atbrOutputs = outputs @@ -312,22 +313,25 @@ pattern AllegraTxBody instance EraTxBody AllegraEra where type TxBody AllegraEra = AllegraTxBody AllegraEra - mkBasicTxBody = mkMemoized emptyAllegraTxBodyRaw + mkBasicTxBody = mkMemoized (eraProtVerLow @AllegraEra) emptyAllegraTxBodyRaw inputsTxBodyL = - lensMemoRawType atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} + lensMemoRawType (eraProtVerLow @AllegraEra) atbrInputs $ + \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType atbrOutputs $ \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} + lensMemoRawType (eraProtVerLow @AllegraEra) atbrOutputs $ + \txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = - lensMemoRawType atbrTxFee $ \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} + lensMemoRawType (eraProtVerLow @AllegraEra) atbrTxFee $ + \txBodyRaw fee -> txBodyRaw {atbrTxFee = fee} {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType atbrAuxDataHash $ + lensMemoRawType (eraProtVerLow @AllegraEra) atbrAuxDataHash $ \txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} @@ -338,12 +342,13 @@ instance EraTxBody AllegraEra where {-# INLINEABLE allInputsTxBodyF #-} withdrawalsTxBodyL = - lensMemoRawType atbrWithdrawals $ + lensMemoRawType (eraProtVerLow @AllegraEra) atbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType atbrCerts $ \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} + lensMemoRawType (eraProtVerLow @AllegraEra) atbrCerts $ + \txBodyRaw certs -> txBodyRaw {atbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -370,12 +375,13 @@ instance ShelleyEraTxBody AllegraEra where {-# INLINEABLE ttlTxBodyL #-} updateTxBodyL = - lensMemoRawType atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} + lensMemoRawType (eraProtVerLow @AllegraEra) atbrUpdate $ + \txBodyRaw update -> txBodyRaw {atbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} instance AllegraEraTxBody AllegraEra where vldtTxBodyL = - lensMemoRawType atbrValidityInterval $ + lensMemoRawType (eraProtVerLow @AllegraEra) atbrValidityInterval $ \txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt} {-# INLINEABLE vldtTxBodyL #-} diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs index 495cf21e7f6..546b2d3d551 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs @@ -150,7 +150,8 @@ mkAlonzoTxAuxData :: f (AlonzoScript era) -> AlonzoTxAuxData era mkAlonzoTxAuxData atadrMetadata allScripts = - mkMemoized $ AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus} + mkMemoized (eraProtVerLow @era) $ + AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus} where partitionScripts (tss, pss) = \case @@ -237,12 +238,12 @@ emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty -- ================================================================================ -- Version with serialized bytes. -newtype AlonzoTxAuxData era = AlonzoTxAuxDataConstr (MemoBytes AlonzoTxAuxDataRaw era) +newtype AlonzoTxAuxData era = AlonzoTxAuxDataConstr (MemoBytes (AlonzoTxAuxDataRaw era)) deriving (Generic) deriving newtype (ToCBOR, SafeToHash) -instance Memoized AlonzoTxAuxData where - type RawType AlonzoTxAuxData = AlonzoTxAuxDataRaw +instance Memoized (AlonzoTxAuxData era) where + type RawType (AlonzoTxAuxData era) = AlonzoTxAuxDataRaw era instance EqRaw (AlonzoTxAuxData era) @@ -254,7 +255,7 @@ instance EraTxAuxData AlonzoEra where metadataTxAuxDataL = metadataAlonzoTxAuxDataL upgradeTxAuxData (AllegraTxAuxData md scripts) = - mkMemoized $ + mkMemoized (eraProtVerLow @AlonzoEra) $ AlonzoTxAuxDataRaw { atadrMetadata = md , atadrTimelock = translateTimelock <$> scripts @@ -263,9 +264,11 @@ instance EraTxAuxData AlonzoEra where validateTxAuxData = validateAlonzoTxAuxData -metadataAlonzoTxAuxDataL :: Era era => Lens' (AlonzoTxAuxData era) (Map Word64 Metadatum) +metadataAlonzoTxAuxDataL :: + forall era. Era era => Lens' (AlonzoTxAuxData era) (Map Word64 Metadatum) metadataAlonzoTxAuxDataL = - lensMemoRawType atadrMetadata $ \txAuxDataRaw md -> txAuxDataRaw {atadrMetadata = md} + lensMemoRawType (eraProtVerLow @era) atadrMetadata $ + \txAuxDataRaw md -> txAuxDataRaw {atadrMetadata = md} hashAlonzoTxAuxData :: HashAnnotated x EraIndependentTxAuxData => @@ -287,17 +290,19 @@ instance AllegraEraTxAuxData AlonzoEra where timelockScriptsTxAuxDataL = timelockScriptsAlonzoTxAuxDataL timelockScriptsAlonzoTxAuxDataL :: - Era era => Lens' (AlonzoTxAuxData era) (StrictSeq (Timelock era)) + forall era. Era era => Lens' (AlonzoTxAuxData era) (StrictSeq (Timelock era)) timelockScriptsAlonzoTxAuxDataL = - lensMemoRawType atadrTimelock $ \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts} + lensMemoRawType (eraProtVerLow @era) atadrTimelock $ + \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts} instance AlonzoEraTxAuxData AlonzoEra where plutusScriptsTxAuxDataL = plutusScriptsAllegraTxAuxDataL plutusScriptsAllegraTxAuxDataL :: - Era era => Lens' (AlonzoTxAuxData era) (Map Language (NE.NonEmpty PlutusBinary)) + forall era. Era era => Lens' (AlonzoTxAuxData era) (Map Language (NE.NonEmpty PlutusBinary)) plutusScriptsAllegraTxAuxDataL = - lensMemoRawType atadrPlutus $ \txAuxDataRaw ts -> txAuxDataRaw {atadrPlutus = ts} + lensMemoRawType (eraProtVerLow @era) atadrPlutus $ + \txAuxDataRaw ts -> txAuxDataRaw {atadrPlutus = ts} instance HashAnnotated (AlonzoTxAuxData era) EraIndependentTxAuxData where hashAnnotated = getMemoSafeHash @@ -308,7 +313,7 @@ deriving instance Eq (AlonzoTxAuxData era) deriving instance Show (AlonzoTxAuxData era) -type instance MemoHashIndex AlonzoTxAuxDataRaw = EraIndependentTxAuxData +type instance MemoHashIndex (AlonzoTxAuxDataRaw era) = EraIndependentTxAuxData deriving via InspectHeapNamed "AlonzoTxAuxDataRaw" (AlonzoTxAuxData era) @@ -316,7 +321,7 @@ deriving via NoThunks (AlonzoTxAuxData era) deriving via - (Mem AlonzoTxAuxDataRaw era) + Mem (AlonzoTxAuxDataRaw era) instance Era era => DecCBOR (Annotator (AlonzoTxAuxData era)) @@ -340,7 +345,8 @@ pattern AlonzoTxAuxData {atadMetadata, atadTimelock, atadPlutus} <- intercalate "," (show <$> Map.keys unsupportedScripts) ++ if Map.size unsupportedScripts > 1 then " languages are" else " language is" in if Map.null unsupportedScripts - then mkMemoized $ AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus} + then + mkMemoized (eraProtVerLow @era) $ AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus} else error $ prefix ++ " not supported in " ++ eraName @era {-# COMPLETE AlonzoTxAuxData #-} diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs index 6b2743a263b..b84045d29e6 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs @@ -215,12 +215,12 @@ deriving instance (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => Show (AlonzoTxBodyRaw era) -newtype AlonzoTxBody era = TxBodyConstr (MemoBytes AlonzoTxBodyRaw era) +newtype AlonzoTxBody era = TxBodyConstr (MemoBytes (AlonzoTxBodyRaw era)) deriving (ToCBOR, Generic) deriving newtype (SafeToHash) -instance Memoized AlonzoTxBody where - type RawType AlonzoTxBody = AlonzoTxBodyRaw +instance Memoized (AlonzoTxBody era) where + type RawType (AlonzoTxBody era) = AlonzoTxBodyRaw era data AlonzoTxBodyUpgradeError = -- | The TxBody contains a protocol parameter update that attempts to update @@ -233,22 +233,26 @@ instance EraTxBody AlonzoEra where type TxBody AlonzoEra = AlonzoTxBody AlonzoEra type TxBodyUpgradeError AlonzoEra = AlonzoTxBodyUpgradeError - mkBasicTxBody = mkMemoized emptyAlonzoTxBodyRaw + mkBasicTxBody = mkMemoized (eraProtVerLow @AlonzoEra) emptyAlonzoTxBodyRaw inputsTxBodyL = - lensMemoRawType atbrInputs (\txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrInputs $ + \txBodyRaw inputs_ -> txBodyRaw {atbrInputs = inputs_} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType atbrOutputs (\txBodyRaw outputs_ -> txBodyRaw {atbrOutputs = outputs_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrOutputs $ + \txBodyRaw outputs_ -> txBodyRaw {atbrOutputs = outputs_} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = - lensMemoRawType atbrTxFee (\txBodyRaw fee_ -> txBodyRaw {atbrTxFee = fee_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrTxFee $ + \txBodyRaw fee_ -> txBodyRaw {atbrTxFee = fee_} {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = lensMemoRawType + (eraProtVerLow @AlonzoEra) atbrAuxDataHash (\txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash}) {-# INLINEABLE auxDataHashTxBodyL #-} @@ -262,12 +266,14 @@ instance EraTxBody AlonzoEra where withdrawalsTxBodyL = lensMemoRawType + (eraProtVerLow @AlonzoEra) atbrWithdrawals (\txBodyRaw withdrawals_ -> txBodyRaw {atbrWithdrawals = withdrawals_}) {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType atbrCerts (\txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrCerts $ + \txBodyRaw certs_ -> txBodyRaw {atbrCerts = certs_} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -330,17 +336,20 @@ instance ShelleyEraTxBody AlonzoEra where ttlTxBodyL = notSupportedInThisEraL updateTxBodyL = - lensMemoRawType atbrUpdate (\txBodyRaw update_ -> txBodyRaw {atbrUpdate = update_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrUpdate $ + \txBodyRaw update_ -> txBodyRaw {atbrUpdate = update_} {-# INLINEABLE updateTxBodyL #-} instance AllegraEraTxBody AlonzoEra where vldtTxBodyL = - lensMemoRawType atbrValidityInterval (\txBodyRaw vldt_ -> txBodyRaw {atbrValidityInterval = vldt_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrValidityInterval $ + \txBodyRaw vldt_ -> txBodyRaw {atbrValidityInterval = vldt_} {-# INLINEABLE vldtTxBodyL #-} instance MaryEraTxBody AlonzoEra where mintTxBodyL = - lensMemoRawType atbrMint (\txBodyRaw mint_ -> txBodyRaw {atbrMint = mint_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrMint $ + \txBodyRaw mint_ -> txBodyRaw {atbrMint = mint_} {-# INLINEABLE mintTxBodyL #-} mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) @@ -351,23 +360,27 @@ instance MaryEraTxBody AlonzoEra where instance AlonzoEraTxBody AlonzoEra where collateralInputsTxBodyL = - lensMemoRawType atbrCollateral (\txBodyRaw collateral_ -> txBodyRaw {atbrCollateral = collateral_}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrCollateral $ + \txBodyRaw collateral_ -> txBodyRaw {atbrCollateral = collateral_} {-# INLINEABLE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = lensMemoRawType + (eraProtVerLow @AlonzoEra) atbrReqSignerHashes (\txBodyRaw reqSignerHashes_ -> txBodyRaw {atbrReqSignerHashes = reqSignerHashes_}) {-# INLINEABLE reqSignerHashesTxBodyL #-} scriptIntegrityHashTxBodyL = lensMemoRawType + (eraProtVerLow @AlonzoEra) atbrScriptIntegrityHash (\txBodyRaw scriptIntegrityHash_ -> txBodyRaw {atbrScriptIntegrityHash = scriptIntegrityHash_}) {-# INLINEABLE scriptIntegrityHashTxBodyL #-} networkIdTxBodyL = - lensMemoRawType atbrTxNetworkId (\txBodyRaw networkId -> txBodyRaw {atbrTxNetworkId = networkId}) + lensMemoRawType (eraProtVerLow @AlonzoEra) atbrTxNetworkId $ + \txBodyRaw networkId -> txBodyRaw {atbrTxNetworkId = networkId} {-# INLINEABLE networkIdTxBodyL #-} redeemerPointer = alonzoRedeemerPointer @@ -391,12 +404,13 @@ deriving instance Show (AlonzoTxBody era) deriving via - (Mem AlonzoTxBodyRaw era) + Mem (AlonzoTxBodyRaw era) instance (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => DecCBOR (Annotator (AlonzoTxBody era)) pattern AlonzoTxBody :: + forall era. (EraTxOut era, EraTxCert era) => Set TxIn -> Set TxIn -> @@ -459,7 +473,7 @@ pattern AlonzoTxBody scriptIntegrityHash auxDataHash txNetworkId = - mkMemoized $ + mkMemoized (eraProtVerLow @era) $ AlonzoTxBodyRaw { atbrInputs = inputs , atbrCollateral = collateral @@ -478,7 +492,7 @@ pattern AlonzoTxBody {-# COMPLETE AlonzoTxBody #-} -type instance MemoHashIndex AlonzoTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (AlonzoTxBodyRaw era) = EraIndependentTxBody instance HashAnnotated (AlonzoTxBody era) EraIndependentTxBody where hashAnnotated = getMemoSafeHash diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 9f541703ab5..1b840686085 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -163,14 +163,14 @@ instance AlonzoEraScript era => EncCBOR (RedeemersRaw era) where <> encCBOR dats <> encCBOR exs -instance Memoized Redeemers where - type RawType Redeemers = RedeemersRaw +instance Memoized (Redeemers era) where + type RawType (Redeemers era) = RedeemersRaw era -- | Note that 'Redeemers' are based on 'MemoBytes' since we must preserve -- the original bytes for the 'Cardano.Ledger.Alonzo.Tx.ScriptIntegrity'. -- Since the 'Redeemers' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. -newtype Redeemers era = RedeemersConstr (MemoBytes RedeemersRaw era) +newtype Redeemers era = RedeemersConstr (MemoBytes (RedeemersRaw era)) deriving newtype (Generic, ToCBOR, SafeToHash, Typeable) deriving newtype instance AlonzoEraScript era => Eq (Redeemers era) @@ -195,7 +195,7 @@ pattern Redeemers :: pattern Redeemers rs <- (getMemoRawType -> RedeemersRaw rs) where - Redeemers rs' = mkMemoized $ RedeemersRaw rs' + Redeemers rs' = mkMemoized (eraProtVerLow @era) $ RedeemersRaw rs' {-# COMPLETE Redeemers #-} @@ -263,12 +263,12 @@ instance ) => NFData (AlonzoTxWitsRaw era) -newtype AlonzoTxWits era = TxWitnessConstr (MemoBytes AlonzoTxWitsRaw era) +newtype AlonzoTxWits era = TxWitnessConstr (MemoBytes (AlonzoTxWitsRaw era)) deriving newtype (SafeToHash, ToCBOR) deriving (Generic) -instance Memoized AlonzoTxWits where - type RawType AlonzoTxWits = AlonzoTxWitsRaw +instance Memoized (AlonzoTxWits era) where + type RawType (AlonzoTxWits era) = AlonzoTxWitsRaw era instance AlonzoEraScript era => Semigroup (AlonzoTxWits era) where (<>) x y | isEmptyTxWitness x = y @@ -308,10 +308,10 @@ pattern TxDats' m <- (getMemoRawType -> TxDatsRaw m) {-# COMPLETE TxDats' #-} -pattern TxDats :: Era era => Map DataHash (Data era) -> TxDats era +pattern TxDats :: forall era. Era era => Map DataHash (Data era) -> TxDats era pattern TxDats m <- (getMemoRawType -> TxDatsRaw m) where - TxDats m = mkMemoized (TxDatsRaw m) + TxDats m = mkMemoized (eraProtVerLow @era) (TxDatsRaw m) {-# COMPLETE TxDats #-} @@ -337,12 +337,12 @@ instance Era era => DecCBOR (Annotator (TxDatsRaw era)) where -- the original bytes for the 'Cardano.Ledger.Alonzo.Tx.ScriptIntegrity'. -- Since the 'TxDats' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. -newtype TxDats era = TxDatsConstr (MemoBytes TxDatsRaw era) +newtype TxDats era = TxDatsConstr (MemoBytes (TxDatsRaw era)) deriving newtype (SafeToHash, ToCBOR, Eq, NoThunks, NFData) deriving (Generic) -instance Memoized TxDats where - type RawType TxDats = TxDatsRaw +instance Memoized (TxDats era) where + type RawType (TxDats era) = TxDatsRaw era deriving instance Show (TxDats era) @@ -356,7 +356,7 @@ instance Era era => Monoid (TxDats era) where instance Era era => EncCBOR (TxDats era) deriving via - (Mem TxDatsRaw era) + Mem (TxDatsRaw era) instance Era era => DecCBOR (Annotator (TxDats era)) @@ -401,6 +401,7 @@ pattern AlonzoTxWits' {txwitsVKey', txwitsBoot', txscripts', txdats', txrdmrs'} {-# COMPLETE AlonzoTxWits' #-} pattern AlonzoTxWits :: + forall era. AlonzoEraScript era => Set (WitVKey 'Witness) -> Set BootstrapWitness -> @@ -412,7 +413,7 @@ pattern AlonzoTxWits {txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs} <- (getMemoRawType -> AlonzoTxWitsRaw txwitsVKey txwitsBoot txscripts txdats txrdmrs) where AlonzoTxWits witsVKey' witsBoot' witsScript' witsDat' witsRdmr' = - mkMemoized $ AlonzoTxWitsRaw witsVKey' witsBoot' witsScript' witsDat' witsRdmr' + mkMemoized (eraProtVerLow @era) $ AlonzoTxWitsRaw witsVKey' witsBoot' witsScript' witsDat' witsRdmr' {-# COMPLETE AlonzoTxWits #-} @@ -421,39 +422,48 @@ pattern AlonzoTxWits {txwitsVKey, txwitsBoot, txscripts, txdats, txrdmrs} <- -- ======================================================= addrAlonzoTxWitsL :: + forall era. AlonzoEraScript era => Lens' (AlonzoTxWits era) (Set (WitVKey 'Witness)) addrAlonzoTxWitsL = - lensMemoRawType atwrAddrTxWits $ \witsRaw addrWits -> witsRaw {atwrAddrTxWits = addrWits} + lensMemoRawType (eraProtVerLow @era) atwrAddrTxWits $ + \witsRaw addrWits -> witsRaw {atwrAddrTxWits = addrWits} {-# INLINEABLE addrAlonzoTxWitsL #-} bootAddrAlonzoTxWitsL :: + forall era. AlonzoEraScript era => Lens' (AlonzoTxWits era) (Set BootstrapWitness) bootAddrAlonzoTxWitsL = - lensMemoRawType atwrBootAddrTxWits $ + lensMemoRawType (eraProtVerLow @era) atwrBootAddrTxWits $ \witsRaw bootAddrWits -> witsRaw {atwrBootAddrTxWits = bootAddrWits} {-# INLINEABLE bootAddrAlonzoTxWitsL #-} scriptAlonzoTxWitsL :: + forall era. AlonzoEraScript era => Lens' (AlonzoTxWits era) (Map ScriptHash (Script era)) scriptAlonzoTxWitsL = - lensMemoRawType atwrScriptTxWits $ \witsRaw scriptWits -> witsRaw {atwrScriptTxWits = scriptWits} + lensMemoRawType (eraProtVerLow @era) atwrScriptTxWits $ + \witsRaw scriptWits -> witsRaw {atwrScriptTxWits = scriptWits} {-# INLINEABLE scriptAlonzoTxWitsL #-} datsAlonzoTxWitsL :: + forall era. AlonzoEraScript era => Lens' (AlonzoTxWits era) (TxDats era) datsAlonzoTxWitsL = - lensMemoRawType atwrDatsTxWits $ \witsRaw datsWits -> witsRaw {atwrDatsTxWits = datsWits} + lensMemoRawType (eraProtVerLow @era) atwrDatsTxWits $ + \witsRaw datsWits -> witsRaw {atwrDatsTxWits = datsWits} {-# INLINEABLE datsAlonzoTxWitsL #-} rdmrsAlonzoTxWitsL :: + forall era. AlonzoEraScript era => Lens' (AlonzoTxWits era) (Redeemers era) rdmrsAlonzoTxWitsL = - lensMemoRawType atwrRdmrsTxWits $ \witsRaw rdmrsWits -> witsRaw {atwrRdmrsTxWits = rdmrsWits} + lensMemoRawType (eraProtVerLow @era) atwrRdmrsTxWits $ + \witsRaw rdmrsWits -> witsRaw {atwrRdmrsTxWits = rdmrsWits} {-# INLINEABLE rdmrsAlonzoTxWitsL #-} instance EraScript AlonzoEra => EraTxWits AlonzoEra where @@ -594,7 +604,7 @@ instance AlonzoEraScript era => DecCBOR (Annotator (RedeemersRaw era)) where instance AlonzoEraScript era => EncCBOR (Redeemers era) deriving via - (Mem RedeemersRaw era) + Mem (RedeemersRaw era) instance AlonzoEraScript era => DecCBOR (Annotator (Redeemers era)) @@ -713,7 +723,7 @@ instance {-# INLINE decCBOR #-} deriving via - (Mem AlonzoTxWitsRaw era) + Mem (AlonzoTxWitsRaw era) instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWits era)) diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs index 853a4fa34a1..de228d20195 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs @@ -215,7 +215,7 @@ instance && F.foldl' (\acc (x', y') -> acc && x' `eqUnsized` y') True (StrictSeq.zip x y) eqUnsized x y = sizedValue x == sizedValue y -type instance MemoHashIndex BabbageTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (BabbageTxBodyRaw era) = EraIndependentTxBody deriving instance (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => @@ -233,38 +233,39 @@ deriving instance (Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era)) => Show (BabbageTxBodyRaw era) -newtype BabbageTxBody era = TxBodyConstr (MemoBytes BabbageTxBodyRaw era) +newtype BabbageTxBody era = TxBodyConstr (MemoBytes (BabbageTxBodyRaw era)) deriving newtype (Generic, SafeToHash, ToCBOR) -instance Memoized BabbageTxBody where - type RawType BabbageTxBody = BabbageTxBodyRaw +instance Memoized (BabbageTxBody era) where + type RawType (BabbageTxBody era) = BabbageTxBodyRaw era deriving newtype instance (Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era)) => NFData (BabbageTxBody era) inputsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set TxIn) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set TxIn) inputsBabbageTxBodyL = - lensMemoRawType btbrSpendInputs $ \txBodyRaw inputs -> txBodyRaw {btbrSpendInputs = inputs} + lensMemoRawType (eraProtVerLow @era) btbrSpendInputs $ \txBodyRaw inputs -> txBodyRaw {btbrSpendInputs = inputs} {-# INLINEABLE inputsBabbageTxBodyL #-} outputsBabbageTxBodyL :: forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxOut era)) outputsBabbageTxBodyL = - lensMemoRawType (fmap sizedValue . btbrOutputs) $ + lensMemoRawType (eraProtVerLow @era) (fmap sizedValue . btbrOutputs) $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = mkSized (eraProtVerLow @era) <$> outputs} {-# INLINEABLE outputsBabbageTxBodyL #-} -feeBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) Coin +feeBabbageTxBodyL :: forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) Coin feeBabbageTxBodyL = - lensMemoRawType btbrTxFee $ \txBodyRaw fee -> txBodyRaw {btbrTxFee = fee} + lensMemoRawType (eraProtVerLow @era) btbrTxFee $ + \txBodyRaw fee -> txBodyRaw {btbrTxFee = fee} {-# INLINEABLE feeBabbageTxBodyL #-} auxDataHashBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe TxAuxDataHash) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe TxAuxDataHash) auxDataHashBabbageTxBodyL = - lensMemoRawType btbrAuxDataHash $ + lensMemoRawType (eraProtVerLow @era) btbrAuxDataHash $ \txBodyRaw auxDataHash -> txBodyRaw {btbrAuxDataHash = auxDataHash} {-# INLINEABLE auxDataHashBabbageTxBodyL #-} @@ -290,34 +291,38 @@ mintedBabbageTxBodyF = to (policies . btbrMint . getMemoRawType) {-# INLINEABLE mintedBabbageTxBodyF #-} withdrawalsBabbbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) Withdrawals + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) Withdrawals withdrawalsBabbbageTxBodyL = - lensMemoRawType btbrWithdrawals $ + lensMemoRawType (eraProtVerLow @era) btbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {btbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsBabbbageTxBodyL #-} updateBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (Update era)) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (Update era)) updateBabbageTxBodyL = - lensMemoRawType btbrUpdate $ \txBodyRaw update -> txBodyRaw {btbrUpdate = update} + lensMemoRawType (eraProtVerLow @era) btbrUpdate $ + \txBodyRaw update -> txBodyRaw {btbrUpdate = update} {-# INLINEABLE updateBabbageTxBodyL #-} certsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxCert era)) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (TxCert era)) certsBabbageTxBodyL = - lensMemoRawType btbrCerts $ \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} + lensMemoRawType (eraProtVerLow @era) btbrCerts $ + \txBodyRaw certs -> txBodyRaw {btbrCerts = certs} {-# INLINEABLE certsBabbageTxBodyL #-} -vldtBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) ValidityInterval +vldtBabbageTxBodyL :: + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) ValidityInterval vldtBabbageTxBodyL = - lensMemoRawType btbrValidityInterval $ \txBodyRaw vldt -> txBodyRaw {btbrValidityInterval = vldt} + lensMemoRawType (eraProtVerLow @era) btbrValidityInterval $ + \txBodyRaw vldt -> txBodyRaw {btbrValidityInterval = vldt} {-# INLINEABLE vldtBabbageTxBodyL #-} mintBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) MultiAsset + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) MultiAsset mintBabbageTxBodyL = - lensMemoRawType btbrMint $ \txBodyRaw mint -> txBodyRaw {btbrMint = mint} + lensMemoRawType (eraProtVerLow @era) btbrMint $ + \txBodyRaw mint -> txBodyRaw {btbrMint = mint} {-# INLINEABLE mintBabbageTxBodyL #-} mintValueBabbageTxBodyF :: @@ -327,69 +332,66 @@ mintValueBabbageTxBodyF = mintBabbageTxBodyL . to (MaryValue mempty) {-# INLINEABLE mintValueBabbageTxBodyF #-} collateralInputsBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set TxIn) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set TxIn) collateralInputsBabbageTxBodyL = - lensMemoRawType btbrCollateralInputs $ + lensMemoRawType (eraProtVerLow @era) btbrCollateralInputs $ \txBodyRaw collateral -> txBodyRaw {btbrCollateralInputs = collateral} {-# INLINEABLE collateralInputsBabbageTxBodyL #-} reqSignerHashesBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (KeyHash 'Witness)) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set (KeyHash 'Witness)) reqSignerHashesBabbageTxBodyL = - lensMemoRawType btbrReqSignerHashes $ + lensMemoRawType (eraProtVerLow @era) btbrReqSignerHashes $ \txBodyRaw reqSignerHashes -> txBodyRaw {btbrReqSignerHashes = reqSignerHashes} {-# INLINEABLE reqSignerHashesBabbageTxBodyL #-} scriptIntegrityHashBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe ScriptIntegrityHash) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe ScriptIntegrityHash) scriptIntegrityHashBabbageTxBodyL = - lensMemoRawType btbrScriptIntegrityHash $ + lensMemoRawType (eraProtVerLow @era) btbrScriptIntegrityHash $ \txBodyRaw scriptIntegrityHash -> txBodyRaw {btbrScriptIntegrityHash = scriptIntegrityHash} {-# INLINEABLE scriptIntegrityHashBabbageTxBodyL #-} -networkIdBabbageTxBodyL :: BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Network) +networkIdBabbageTxBodyL :: + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Network) networkIdBabbageTxBodyL = - lensMemoRawType btbrTxNetworkId $ \txBodyRaw networkId -> txBodyRaw {btbrTxNetworkId = networkId} + lensMemoRawType (eraProtVerLow @era) btbrTxNetworkId $ + \txBodyRaw networkId -> txBodyRaw {btbrTxNetworkId = networkId} {-# INLINEABLE networkIdBabbageTxBodyL #-} sizedOutputsBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictSeq (Sized (TxOut era))) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictSeq (Sized (TxOut era))) sizedOutputsBabbageTxBodyL = - lensMemoRawType btbrOutputs $ \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} + lensMemoRawType (eraProtVerLow @era) btbrOutputs $ + \txBodyRaw outputs -> txBodyRaw {btbrOutputs = outputs} {-# INLINEABLE sizedOutputsBabbageTxBodyL #-} referenceInputsBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (Set TxIn) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (Set TxIn) referenceInputsBabbageTxBodyL = - lensMemoRawType btbrReferenceInputs $ + lensMemoRawType (eraProtVerLow @era) btbrReferenceInputs $ \txBodyRaw reference -> txBodyRaw {btbrReferenceInputs = reference} {-# INLINEABLE referenceInputsBabbageTxBodyL #-} totalCollateralBabbageTxBodyL :: - BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Coin) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe Coin) totalCollateralBabbageTxBodyL = - lensMemoRawType btbrTotalCollateral $ + lensMemoRawType (eraProtVerLow @era) btbrTotalCollateral $ \txBodyRaw totalCollateral -> txBodyRaw {btbrTotalCollateral = totalCollateral} {-# INLINEABLE totalCollateralBabbageTxBodyL #-} collateralReturnBabbageTxBodyL :: - forall era. - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe (TxOut era)) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (TxOut era)) collateralReturnBabbageTxBodyL = - lensMemoRawType (fmap sizedValue . btbrCollateralReturn) $ + lensMemoRawType (eraProtVerLow @era) (fmap sizedValue . btbrCollateralReturn) $ \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = mkSized (eraProtVerLow @era) <$> collateralReturn} {-# INLINEABLE collateralReturnBabbageTxBodyL #-} sizedCollateralReturnBabbageTxBodyL :: - BabbageEraTxBody era => - Lens' (BabbageTxBody era) (StrictMaybe (Sized (TxOut era))) + forall era. BabbageEraTxBody era => Lens' (BabbageTxBody era) (StrictMaybe (Sized (TxOut era))) sizedCollateralReturnBabbageTxBodyL = - lensMemoRawType btbrCollateralReturn $ + lensMemoRawType (eraProtVerLow @era) btbrCollateralReturn $ \txBodyRaw collateralReturn -> txBodyRaw {btbrCollateralReturn = collateralReturn} {-# INLINEABLE sizedCollateralReturnBabbageTxBodyL #-} @@ -417,7 +419,7 @@ instance EraTxBody BabbageEra where type TxBody BabbageEra = BabbageTxBody BabbageEra type TxBodyUpgradeError BabbageEra = BabbageTxBodyUpgradeError - mkBasicTxBody = mkMemoized basicBabbageTxBodyRaw + mkBasicTxBody = mkMemoized (eraProtVerLow @BabbageEra) basicBabbageTxBodyRaw inputsTxBodyL = inputsBabbageTxBodyL {-# INLINE inputsTxBodyL #-} @@ -573,7 +575,7 @@ deriving instance Show (BabbageTxBody era) deriving via - (Mem BabbageTxBodyRaw era) + Mem (BabbageTxBodyRaw era) instance (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => DecCBOR (Annotator (BabbageTxBody era)) @@ -585,6 +587,7 @@ instance decCBOR = pure <$> decCBOR pattern BabbageTxBody :: + forall era. BabbageEraTxBody era => Set TxIn -> Set TxIn -> @@ -659,7 +662,7 @@ pattern BabbageTxBody scriptIntegrityHash auxDataHash txNetworkId = - mkMemoized $ + mkMemoized (eraProtVerLow @era) $ BabbageTxBodyRaw { btbrSpendInputs = inputs , btbrCollateralInputs = collateral diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs index c436983feaf..892bdccf710 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs @@ -128,8 +128,8 @@ import GHC.Generics (Generic) import Lens.Micro (Lens', to, (^.)) import NoThunks.Class (NoThunks) -instance Memoized ConwayTxBody where - type RawType ConwayTxBody = ConwayTxBodyRaw +instance Memoized (ConwayTxBody era) where + type RawType (ConwayTxBody era) = ConwayTxBodyRaw era data ConwayTxBodyRaw era = ConwayTxBodyRaw { ctbrSpendInputs :: !(Set TxIn) @@ -264,7 +264,7 @@ instance emptyFailure fieldName requirement = "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" -newtype ConwayTxBody era = TxBodyConstr (MemoBytes ConwayTxBodyRaw era) +newtype ConwayTxBody era = TxBodyConstr (MemoBytes (ConwayTxBodyRaw era)) deriving (Generic, SafeToHash, ToCBOR) deriving instance @@ -283,7 +283,7 @@ deriving instance (EraPParams era, Show (TxOut era)) => Show (ConwayTxBody era) -type instance MemoHashIndex ConwayTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (ConwayTxBodyRaw era) = EraIndependentTxBody instance HashAnnotated (ConwayTxBody era) EraIndependentTxBody where hashAnnotated = getMemoSafeHash @@ -299,7 +299,7 @@ instance decCBOR = pure <$> decCBOR deriving via - (Mem ConwayTxBodyRaw era) + Mem (ConwayTxBodyRaw era) instance ( DecCBOR (TxOut era) , EraPParams era @@ -308,8 +308,8 @@ deriving via ) => DecCBOR (Annotator (ConwayTxBody era)) -mkConwayTxBody :: ConwayEraTxBody era => ConwayTxBody era -mkConwayTxBody = mkMemoized basicConwayTxBodyRaw +mkConwayTxBody :: forall era. ConwayEraTxBody era => ConwayTxBody era +mkConwayTxBody = mkMemoized (eraProtVerLow @era) basicConwayTxBodyRaw basicConwayTxBodyRaw :: ConwayTxBodyRaw era basicConwayTxBodyRaw = @@ -349,19 +349,22 @@ instance EraTxBody ConwayEra where mkBasicTxBody = mkConwayTxBody - inputsTxBodyL = lensMemoRawType ctbrSpendInputs (\txb x -> txb {ctbrSpendInputs = x}) + inputsTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrSpendInputs $ + \txb x -> txb {ctbrSpendInputs = x} {-# INLINE inputsTxBodyL #-} outputsTxBodyL = lensMemoRawType + (eraProtVerLow @ConwayEra) (fmap sizedValue . ctbrOutputs) (\txb x -> txb {ctbrOutputs = mkSized (eraProtVerLow @ConwayEra) <$> x}) {-# INLINE outputsTxBodyL #-} - feeTxBodyL = lensMemoRawType ctbrTxfee (\txb x -> txb {ctbrTxfee = x}) + feeTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrTxfee (\txb x -> txb {ctbrTxfee = x}) {-# INLINE feeTxBodyL #-} - auxDataHashTxBodyL = lensMemoRawType ctbrAuxDataHash (\txb x -> txb {ctbrAuxDataHash = x}) + auxDataHashTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrAuxDataHash $ + \txb x -> txb {ctbrAuxDataHash = x} {-# INLINE auxDataHashTxBodyL #-} spendableInputsTxBodyF = babbageSpendableInputsTxBodyF @@ -370,11 +373,13 @@ instance EraTxBody ConwayEra where allInputsTxBodyF = babbageAllInputsTxBodyF {-# INLINE allInputsTxBodyF #-} - withdrawalsTxBodyL = lensMemoRawType ctbrWithdrawals (\txb x -> txb {ctbrWithdrawals = x}) + withdrawalsTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrWithdrawals $ + \txb x -> txb {ctbrWithdrawals = x} {-# INLINE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType (OSet.toStrictSeq . ctbrCerts) (\txb x -> txb {ctbrCerts = OSet.fromStrictSeq x}) + lensMemoRawType (eraProtVerLow @ConwayEra) (OSet.toStrictSeq . ctbrCerts) $ + \txb x -> txb {ctbrCerts = OSet.fromStrictSeq x} {-# INLINE certsTxBodyL #-} getTotalDepositsTxBody = conwayTotalDepositsTxBody @@ -452,11 +457,13 @@ conwayProposalsDeposits pp txBody = numProposals <×> depositPerProposal depositPerProposal = pp ^. ppGovActionDepositL instance AllegraEraTxBody ConwayEra where - vldtTxBodyL = lensMemoRawType ctbrVldt (\txb x -> txb {ctbrVldt = x}) + vldtTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrVldt $ + \txb x -> txb {ctbrVldt = x} {-# INLINE vldtTxBodyL #-} instance MaryEraTxBody ConwayEra where - mintTxBodyL = lensMemoRawType ctbrMint (\txb x -> txb {ctbrMint = x}) + mintTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrMint $ + \txb x -> txb {ctbrMint = x} {-# INLINE mintTxBodyL #-} mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) @@ -467,18 +474,22 @@ instance MaryEraTxBody ConwayEra where instance AlonzoEraTxBody ConwayEra where collateralInputsTxBodyL = - lensMemoRawType ctbrCollateralInputs (\txb x -> txb {ctbrCollateralInputs = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrCollateralInputs $ + \txb x -> txb {ctbrCollateralInputs = x} {-# INLINE collateralInputsTxBodyL #-} reqSignerHashesTxBodyL = - lensMemoRawType ctbrReqSignerHashes (\txb x -> txb {ctbrReqSignerHashes = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrReqSignerHashes $ + \txb x -> txb {ctbrReqSignerHashes = x} {-# INLINE reqSignerHashesTxBodyL #-} scriptIntegrityHashTxBodyL = - lensMemoRawType ctbrScriptIntegrityHash (\txb x -> txb {ctbrScriptIntegrityHash = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrScriptIntegrityHash $ + \txb x -> txb {ctbrScriptIntegrityHash = x} {-# INLINE scriptIntegrityHashTxBodyL #-} - networkIdTxBodyL = lensMemoRawType ctbrTxNetworkId (\txb x -> txb {ctbrTxNetworkId = x}) + networkIdTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrTxNetworkId $ + \txb x -> txb {ctbrTxNetworkId = x} {-# INLINE networkIdTxBodyL #-} redeemerPointer = conwayRedeemerPointer @@ -486,25 +497,30 @@ instance AlonzoEraTxBody ConwayEra where redeemerPointerInverse = conwayRedeemerPointerInverse instance BabbageEraTxBody ConwayEra where - sizedOutputsTxBodyL = lensMemoRawType ctbrOutputs (\txb x -> txb {ctbrOutputs = x}) + sizedOutputsTxBodyL = lensMemoRawType (eraProtVerLow @ConwayEra) ctbrOutputs $ + \txb x -> txb {ctbrOutputs = x} {-# INLINE sizedOutputsTxBodyL #-} referenceInputsTxBodyL = - lensMemoRawType ctbrReferenceInputs (\txb x -> txb {ctbrReferenceInputs = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrReferenceInputs $ + \txb x -> txb {ctbrReferenceInputs = x} {-# INLINE referenceInputsTxBodyL #-} totalCollateralTxBodyL = - lensMemoRawType ctbrTotalCollateral (\txb x -> txb {ctbrTotalCollateral = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrTotalCollateral $ + \txb x -> txb {ctbrTotalCollateral = x} {-# INLINE totalCollateralTxBodyL #-} collateralReturnTxBodyL = lensMemoRawType + (eraProtVerLow @ConwayEra) (fmap sizedValue . ctbrCollateralReturn) (\txb x -> txb {ctbrCollateralReturn = mkSized (eraProtVerLow @ConwayEra) <$> x}) {-# INLINE collateralReturnTxBodyL #-} sizedCollateralReturnTxBodyL = - lensMemoRawType ctbrCollateralReturn (\txb x -> txb {ctbrCollateralReturn = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrCollateralReturn $ + \txb x -> txb {ctbrCollateralReturn = x} {-# INLINE sizedCollateralReturnTxBodyL #-} allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF @@ -512,16 +528,20 @@ instance BabbageEraTxBody ConwayEra where instance ConwayEraTxBody ConwayEra where votingProceduresTxBodyL = - lensMemoRawType ctbrVotingProcedures (\txb x -> txb {ctbrVotingProcedures = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrVotingProcedures $ + \txb x -> txb {ctbrVotingProcedures = x} {-# INLINE votingProceduresTxBodyL #-} proposalProceduresTxBodyL = - lensMemoRawType ctbrProposalProcedures (\txb x -> txb {ctbrProposalProcedures = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrProposalProcedures $ + \txb x -> txb {ctbrProposalProcedures = x} {-# INLINE proposalProceduresTxBodyL #-} currentTreasuryValueTxBodyL = - lensMemoRawType ctbrCurrentTreasuryValue (\txb x -> txb {ctbrCurrentTreasuryValue = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrCurrentTreasuryValue $ + \txb x -> txb {ctbrCurrentTreasuryValue = x} {-# INLINE currentTreasuryValueTxBodyL #-} treasuryDonationTxBodyL = - lensMemoRawType ctbrTreasuryDonation (\txb x -> txb {ctbrTreasuryDonation = x}) + lensMemoRawType (eraProtVerLow @ConwayEra) ctbrTreasuryDonation $ + \txb x -> txb {ctbrTreasuryDonation = x} {-# INLINE treasuryDonationTxBodyL #-} instance @@ -529,6 +549,7 @@ instance EqRaw (ConwayTxBody era) pattern ConwayTxBody :: + forall era. ConwayEraTxBody era => Set TxIn -> Set TxIn -> @@ -615,7 +636,7 @@ pattern ConwayTxBody proposalProcedures currentTreasuryValue treasuryDonation = - mkMemoized $ + mkMemoized (eraProtVerLow @era) $ ConwayTxBodyRaw inputsX collateralX diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs index 1ed37c3329a..c4d9a375076 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs @@ -10,6 +10,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -106,7 +107,7 @@ deriving newtype instance deriving newtype instance AllegraEraTxBody era => DecCBOR (MaryTxBodyRaw era) -newtype MaryTxBody era = TxBodyConstr (MemoBytes MaryTxBodyRaw era) +newtype MaryTxBody era = TxBodyConstr (MemoBytes (MaryTxBodyRaw era)) deriving newtype (SafeToHash, ToCBOR) -- | Encodes memoized bytes created upon construction. @@ -121,8 +122,8 @@ instance AllegraEraTxBody era => DecCBOR (Annotator (MaryTxBodyRaw era)) where deriving newtype instance (EraTxOut era, EraTxCert era) => EncCBOR (MaryTxBodyRaw era) -instance Memoized MaryTxBody where - type RawType MaryTxBody = MaryTxBodyRaw +instance Memoized (MaryTxBody era) where + type RawType (MaryTxBody era) = MaryTxBodyRaw era deriving newtype instance (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => @@ -143,17 +144,18 @@ deriving newtype instance NFData (MaryTxBody era) deriving via - Mem MaryTxBodyRaw era + Mem (MaryTxBodyRaw era) instance MaryEraTxBody era => DecCBOR (Annotator (MaryTxBody era)) -type instance MemoHashIndex MaryTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (MaryTxBodyRaw era) = EraIndependentTxBody instance Era era => HashAnnotated (MaryTxBody era) EraIndependentTxBody where hashAnnotated = getMemoSafeHash -- | A pattern to keep the newtype and the MemoBytes hidden pattern MaryTxBody :: + forall era. (EraTxOut era, EraTxCert era) => Set TxIn -> StrictSeq (TxOut era) -> @@ -202,7 +204,7 @@ pattern MaryTxBody update auxDataHash mint = - mkMemoized $ + mkMemoized (eraProtVerLow @era) $ MaryTxBodyRaw $ AllegraTxBodyRaw { atbrInputs = inputs @@ -220,12 +222,14 @@ pattern MaryTxBody -- | This is a helper Lens creator for any Memoized type. lensMaryTxBodyRaw :: + forall era a b. (EraTxOut era, EraTxCert era) => (AllegraTxBodyRaw MultiAsset era -> a) -> (AllegraTxBodyRaw MultiAsset era -> b -> AllegraTxBodyRaw MultiAsset era) -> Lens (MaryTxBody era) (MaryTxBody era) a b lensMaryTxBodyRaw getter setter = lensMemoRawType + (eraProtVerLow @era) (\(MaryTxBodyRaw atbr) -> getter atbr) (\(MaryTxBodyRaw atbr) a -> MaryTxBodyRaw (setter atbr a)) {-# INLINEABLE lensMaryTxBodyRaw #-} @@ -233,7 +237,7 @@ lensMaryTxBodyRaw getter setter = instance EraTxBody MaryEra where type TxBody MaryEra = MaryTxBody MaryEra - mkBasicTxBody = mkMemoized $ MaryTxBodyRaw emptyAllegraTxBodyRaw + mkBasicTxBody = mkMemoized (eraProtVerLow @MaryEra) $ MaryTxBodyRaw emptyAllegraTxBodyRaw inputsTxBodyL = lensMaryTxBodyRaw atbrInputs $ \txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs} diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 1d81d9bd388..3dbdae62704 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Remove `Era era` constraint from `sizeShelleyTxF` and `wireSizeShelleyTxF` * Add `MemPack` instance `ShelleyTxOut` * Deprecate `hashShelleyTxAuxData` * Stop re-exporting `ScriptHash` from `Cardano.Ledger.Shelley.Scripts`. Import it instead from `Cardano.Ledger.Hashes`. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs index bbec9ab4f24..7d44c28a344 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs @@ -11,6 +11,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -105,12 +106,12 @@ class EraScript era => ShelleyEraScript era where instance NFData (MultiSigRaw era) -newtype MultiSig era = MultiSigConstr (MemoBytes MultiSigRaw era) +newtype MultiSig era = MultiSigConstr (MemoBytes (MultiSigRaw era)) deriving (Eq, Show, Generic) deriving newtype (ToCBOR, NoThunks, SafeToHash) -instance Memoized MultiSig where - type RawType MultiSig = MultiSigRaw +instance Memoized (MultiSig era) where + type RawType (MultiSig era) = MultiSigRaw era -- | Magic number "memorialized" in the ValidateScript class under the method: -- scriptPrefixTag:: Core.Script era -> Bs.ByteString, for the Shelley Era. @@ -134,29 +135,29 @@ instance EraScript ShelleyEra where instance ShelleyEraScript ShelleyEra where mkRequireSignature kh = - MultiSigConstr $ memoBytes (Sum RequireSignature' 0 !> To kh) + MultiSigConstr $ memoBytes (eraProtVerLow @ShelleyEra) (Sum RequireSignature' 0 !> To kh) getRequireSignature (MultiSigConstr (Memo (RequireSignature' kh) _)) = Just kh getRequireSignature _ = Nothing mkRequireAllOf ms = - MultiSigConstr $ memoBytes (Sum RequireAllOf' 1 !> To ms) + MultiSigConstr $ memoBytes (eraProtVerLow @ShelleyEra) (Sum RequireAllOf' 1 !> To ms) getRequireAllOf (MultiSigConstr (Memo (RequireAllOf' ms) _)) = Just ms getRequireAllOf _ = Nothing mkRequireAnyOf ms = - MultiSigConstr $ memoBytes (Sum RequireAnyOf' 2 !> To ms) + MultiSigConstr $ memoBytes (eraProtVerLow @ShelleyEra) (Sum RequireAnyOf' 2 !> To ms) getRequireAnyOf (MultiSigConstr (Memo (RequireAnyOf' ms) _)) = Just ms getRequireAnyOf _ = Nothing mkRequireMOf n ms = - MultiSigConstr $ memoBytes (Sum RequireMOf' 3 !> To n !> To ms) + MultiSigConstr $ memoBytes (eraProtVerLow @ShelleyEra) (Sum RequireMOf' 3 !> To n !> To ms) getRequireMOf (MultiSigConstr (Memo (RequireMOf' n ms) _)) = Just (n, ms) getRequireMOf _ = Nothing deriving newtype instance NFData (MultiSig era) deriving via - Mem MultiSigRaw era + Mem (MultiSigRaw era) instance Era era => DecCBOR (Annotator (MultiSig era)) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs index e780d26e9d3..b84eb2a1359 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -134,29 +134,29 @@ instance ) => NoThunks (ShelleyTxRaw era) -newtype ShelleyTx era = TxConstr (MemoBytes ShelleyTxRaw era) +newtype ShelleyTx era = TxConstr (MemoBytes (ShelleyTxRaw era)) deriving newtype (SafeToHash, ToCBOR) deriving (Generic) -instance Memoized ShelleyTx where - type RawType ShelleyTx = ShelleyTxRaw +instance Memoized (ShelleyTx era) where + type RawType (ShelleyTx era) = ShelleyTxRaw era -- | `TxBody` setter and getter for `ShelleyTx`. The setter does update -- memoized binary representation. -bodyShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxBody era) +bodyShelleyTxL :: forall era. EraTx era => Lens' (ShelleyTx era) (TxBody era) bodyShelleyTxL = lens (\(TxConstr (Memo tx _)) -> strBody tx) $ \(TxConstr (Memo tx _)) txBody -> - TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strBody = txBody} + TxConstr $ memoBytes (eraProtVerLow @era) $ encodeShelleyTxRaw $ tx {strBody = txBody} {-# INLINEABLE bodyShelleyTxL #-} -- | `TxWits` setter and getter for `ShelleyTx`. The setter does update -- memoized binary representation. -witsShelleyTxL :: EraTx era => Lens' (ShelleyTx era) (TxWits era) +witsShelleyTxL :: forall era. EraTx era => Lens' (ShelleyTx era) (TxWits era) witsShelleyTxL = lens (\(TxConstr (Memo tx _)) -> strWits tx) $ \(TxConstr (Memo tx _)) txWits -> - TxConstr $ memoBytes $ encodeShelleyTxRaw $ tx {strWits = txWits} + TxConstr $ memoBytes (eraProtVerLow @era) $ encodeShelleyTxRaw $ tx {strWits = txWits} {-# INLINEABLE witsShelleyTxL #-} -- | `TxAuxData` setter and getter for `ShelleyTx`. The setter does update @@ -168,11 +168,11 @@ auxDataShelleyTxL = {-# INLINEABLE auxDataShelleyTxL #-} -- | Size getter for `ShelleyTx`. -sizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Integer +sizeShelleyTxF :: SimpleGetter (ShelleyTx era) Integer sizeShelleyTxF = to (\(TxConstr (Memo _ bytes)) -> fromIntegral $ SBS.length bytes) {-# INLINEABLE sizeShelleyTxF #-} -wireSizeShelleyTxF :: Era era => SimpleGetter (ShelleyTx era) Word32 +wireSizeShelleyTxF :: SimpleGetter (ShelleyTx era) Word32 wireSizeShelleyTxF = to $ \(TxConstr (Memo _ bytes)) -> let n = SBS.length bytes in if n <= fromIntegral (maxBound :: Word32) @@ -180,8 +180,8 @@ wireSizeShelleyTxF = to $ \(TxConstr (Memo _ bytes)) -> else error $ "Impossible: Size of the transaction is too big: " ++ show n {-# INLINEABLE wireSizeShelleyTxF #-} -mkShelleyTx :: EraTx era => ShelleyTxRaw era -> ShelleyTx era -mkShelleyTx = TxConstr . memoBytes . encodeShelleyTxRaw +mkShelleyTx :: forall era. EraTx era => ShelleyTxRaw era -> ShelleyTx era +mkShelleyTx = TxConstr . memoBytes (eraProtVerLow @era) . encodeShelleyTxRaw {-# INLINEABLE mkShelleyTx #-} mkBasicShelleyTx :: EraTx era => TxBody era -> ShelleyTx era @@ -324,7 +324,7 @@ instance ) deriving via - Mem ShelleyTxRaw era + Mem (ShelleyTxRaw era) instance EraTx era => DecCBOR (Annotator (ShelleyTx era)) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs index b8e422a0286..918955464a6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs @@ -75,17 +75,17 @@ deriving via NoThunks (ShelleyTxAuxData era) deriving via - (Mem ShelleyTxAuxDataRaw era) + Mem (ShelleyTxAuxDataRaw era) instance Era era => DecCBOR (Annotator (ShelleyTxAuxData era)) newtype ShelleyTxAuxData era - = AuxiliaryDataConstr (MemoBytes ShelleyTxAuxDataRaw era) + = AuxiliaryDataConstr (MemoBytes (ShelleyTxAuxDataRaw era)) deriving (Eq, Show, Generic) deriving newtype (NFData, Plain.ToCBOR, SafeToHash) -instance Memoized ShelleyTxAuxData where - type RawType ShelleyTxAuxData = ShelleyTxAuxDataRaw +instance Memoized (ShelleyTxAuxData era) where + type RawType (ShelleyTxAuxData era) = ShelleyTxAuxDataRaw era instance EraTxAuxData ShelleyEra where type TxAuxData ShelleyEra = ShelleyTxAuxData ShelleyEra @@ -93,7 +93,8 @@ instance EraTxAuxData ShelleyEra where mkBasicTxAuxData = ShelleyTxAuxData mempty metadataTxAuxDataL = - lensMemoRawType stadrMetadata $ \txAuxDataRaw md -> txAuxDataRaw {stadrMetadata = md} + lensMemoRawType (eraProtVerLow @ShelleyEra) stadrMetadata $ + \txAuxDataRaw md -> txAuxDataRaw {stadrMetadata = md} -- Calling this partial function will result in compilation error, since ByronEra has -- no instance for EraTxOut type class. @@ -116,11 +117,11 @@ pattern ShelleyTxAuxData :: forall era. Era era => Map Word64 Metadatum -> Shell pattern ShelleyTxAuxData m <- (getMemoRawType -> ShelleyTxAuxDataRaw m) where - ShelleyTxAuxData m = mkMemoized $ ShelleyTxAuxDataRaw m + ShelleyTxAuxData m = mkMemoized (eraProtVerLow @ShelleyEra) $ ShelleyTxAuxDataRaw m {-# COMPLETE ShelleyTxAuxData #-} -- | Encodes memoized bytes created upon construction. instance Era era => EncCBOR (ShelleyTxAuxData era) -type instance MemoHashIndex ShelleyTxAuxDataRaw = EraIndependentTxAuxData +type instance MemoHashIndex (ShelleyTxAuxDataRaw era) = EraIndependentTxAuxData diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index 4105ee02f05..4884c7f5e17 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -10,6 +10,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -224,12 +225,12 @@ instance -- ==================================================== -- Introduce ShelleyTxBody as a newtype around a MemoBytes -newtype ShelleyTxBody era = TxBodyConstr (MemoBytes ShelleyTxBodyRaw era) +newtype ShelleyTxBody era = TxBodyConstr (MemoBytes (ShelleyTxBodyRaw era)) deriving (Generic) deriving newtype (SafeToHash, ToCBOR) -instance Memoized ShelleyTxBody where - type RawType ShelleyTxBody = ShelleyTxBodyRaw +instance Memoized (ShelleyTxBody era) where + type RawType (ShelleyTxBody era) = ShelleyTxBodyRaw era instance (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => @@ -238,7 +239,7 @@ instance instance EraTxBody ShelleyEra where type TxBody ShelleyEra = ShelleyTxBody ShelleyEra - mkBasicTxBody = mkMemoized basicShelleyTxBodyRaw + mkBasicTxBody = mkMemoized (eraProtVerLow @ShelleyEra) basicShelleyTxBodyRaw spendableInputsTxBodyF = inputsTxBodyL {-# INLINE spendableInputsTxBodyF #-} @@ -247,27 +248,33 @@ instance EraTxBody ShelleyEra where {-# INLINE allInputsTxBodyF #-} inputsTxBodyL = - lensMemoRawType stbrInputs $ \txBodyRaw inputs -> txBodyRaw {stbrInputs = inputs} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrInputs $ + \txBodyRaw inputs -> txBodyRaw {stbrInputs = inputs} {-# INLINEABLE inputsTxBodyL #-} outputsTxBodyL = - lensMemoRawType stbrOutputs $ \txBodyRaw outputs -> txBodyRaw {stbrOutputs = outputs} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrOutputs $ + \txBodyRaw outputs -> txBodyRaw {stbrOutputs = outputs} {-# INLINEABLE outputsTxBodyL #-} feeTxBodyL = - lensMemoRawType stbrTxFee $ \txBodyRaw fee -> txBodyRaw {stbrTxFee = fee} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrTxFee $ + \txBodyRaw fee -> txBodyRaw {stbrTxFee = fee} {-# INLINEABLE feeTxBodyL #-} auxDataHashTxBodyL = - lensMemoRawType stbrMDHash $ \txBodyRaw auxDataHash -> txBodyRaw {stbrMDHash = auxDataHash} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrMDHash $ + \txBodyRaw auxDataHash -> txBodyRaw {stbrMDHash = auxDataHash} {-# INLINEABLE auxDataHashTxBodyL #-} withdrawalsTxBodyL = - lensMemoRawType stbrWithdrawals $ \txBodyRaw withdrawals -> txBodyRaw {stbrWithdrawals = withdrawals} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrWithdrawals $ + \txBodyRaw withdrawals -> txBodyRaw {stbrWithdrawals = withdrawals} {-# INLINEABLE withdrawalsTxBodyL #-} certsTxBodyL = - lensMemoRawType stbrCerts $ \txBodyRaw certs -> txBodyRaw {stbrCerts = certs} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrCerts $ + \txBodyRaw certs -> txBodyRaw {stbrCerts = certs} {-# INLINEABLE certsTxBodyL #-} getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody @@ -279,11 +286,11 @@ instance EraTxBody ShelleyEra where instance ShelleyEraTxBody ShelleyEra where ttlTxBodyL = - lensMemoRawType stbrTTL $ \txBodyRaw ttl -> txBodyRaw {stbrTTL = ttl} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrTTL $ \txBodyRaw ttl -> txBodyRaw {stbrTTL = ttl} {-# INLINEABLE ttlTxBodyL #-} updateTxBodyL = - lensMemoRawType stbrUpdate $ \txBodyRaw update -> txBodyRaw {stbrUpdate = update} + lensMemoRawType (eraProtVerLow @ShelleyEra) stbrUpdate $ \txBodyRaw update -> txBodyRaw {stbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} deriving newtype instance @@ -299,7 +306,7 @@ deriving instance Eq (ShelleyTxBody era) deriving via - Mem ShelleyTxBodyRaw era + Mem (ShelleyTxBodyRaw era) instance EraTxBody era => DecCBOR (Annotator (ShelleyTxBody era)) @@ -347,7 +354,7 @@ pattern ShelleyTxBody ttl update mDHash = - mkMemoized $ + mkMemoized (eraProtVerLow @ShelleyEra) $ ShelleyTxBodyRaw { stbrInputs = inputs , stbrOutputs = outputs @@ -363,7 +370,7 @@ pattern ShelleyTxBody -- ========================================= -type instance MemoHashIndex ShelleyTxBodyRaw = EraIndependentTxBody +type instance MemoHashIndex (ShelleyTxBodyRaw era) = EraIndependentTxBody instance Era era => HashAnnotated (ShelleyTxBody era) EraIndependentTxBody where hashAnnotated = getMemoSafeHash diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs index 039f70fb6e0..31c6146fb88 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs @@ -53,6 +53,7 @@ import Cardano.Ledger.Core ( EraScript (Script), EraTxWits (..), ScriptHash, + eraProtVerLow, hashScript, ) import Cardano.Ledger.Hashes (SafeToHash (..)) @@ -103,12 +104,12 @@ instance instance EraScript era => NoThunks (ShelleyTxWitsRaw era) -newtype ShelleyTxWits era = ShelleyTxWitsConstr (MemoBytes ShelleyTxWitsRaw era) +newtype ShelleyTxWits era = ShelleyTxWitsConstr (MemoBytes (ShelleyTxWitsRaw era)) deriving (Generic) deriving newtype (SafeToHash, Plain.ToCBOR) -instance Memoized ShelleyTxWits where - type RawType ShelleyTxWits = ShelleyTxWitsRaw +instance Memoized (ShelleyTxWits era) where + type RawType (ShelleyTxWits era) = ShelleyTxWitsRaw era deriving newtype instance EraScript era => Eq (ShelleyTxWits era) @@ -133,7 +134,7 @@ instance EraScript era => NoThunks (ShelleyTxWits era) addrShelleyTxWitsL :: EraScript era => Lens' (ShelleyTxWits era) (Set (WitVKey 'Witness)) addrShelleyTxWitsL = - lensMemoRawType addrWits' $ \witsRaw aw -> witsRaw {addrWits' = aw} + lensMemoRawType (eraProtVerLow @ShelleyEra) addrWits' $ \witsRaw aw -> witsRaw {addrWits' = aw} {-# INLINEABLE addrShelleyTxWitsL #-} -- | Bootstrap Addresses witness setter and getter for `ShelleyTxWits`. The @@ -142,7 +143,7 @@ bootAddrShelleyTxWitsL :: EraScript era => Lens' (ShelleyTxWits era) (Set BootstrapWitness) bootAddrShelleyTxWitsL = - lensMemoRawType bootWits' $ \witsRaw bw -> witsRaw {bootWits' = bw} + lensMemoRawType (eraProtVerLow @ShelleyEra) bootWits' $ \witsRaw bw -> witsRaw {bootWits' = bw} {-# INLINEABLE bootAddrShelleyTxWitsL #-} -- | Script witness setter and getter for `ShelleyTxWits`. The @@ -151,7 +152,8 @@ scriptShelleyTxWitsL :: EraScript era => Lens' (ShelleyTxWits era) (Map ScriptHash (Script era)) scriptShelleyTxWitsL = - lensMemoRawType scriptWits' $ \witsRaw sw -> witsRaw {scriptWits' = sw} + lensMemoRawType (eraProtVerLow @ShelleyEra) scriptWits' $ + \witsRaw sw -> witsRaw {scriptWits' = sw} {-# INLINEABLE scriptShelleyTxWitsL #-} instance EraTxWits ShelleyEra where @@ -205,7 +207,7 @@ pattern ShelleyTxWits {addrWits, scriptWits, bootWits} <- (getMemoRawType -> ShelleyTxWitsRaw addrWits scriptWits bootWits) where ShelleyTxWits awits scriptWitMap bootstrapWits = - mkMemoized $ ShelleyTxWitsRaw awits scriptWitMap bootstrapWits + mkMemoized (eraProtVerLow @ShelleyEra) $ ShelleyTxWitsRaw awits scriptWitMap bootstrapWits {-# COMPLETE ShelleyTxWits #-} @@ -219,7 +221,7 @@ instance EraScript era => DecCBOR (Annotator (ShelleyTxWitsRaw era)) where decCBOR = decodeWits deriving via - (Mem ShelleyTxWitsRaw era) + Mem (ShelleyTxWitsRaw era) instance EraScript era => DecCBOR (Annotator (ShelleyTxWits era)) diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 64f57c1942d..ec008f08fa0 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,24 @@ ## 1.17.0.0 +* Remove `era` type parameter from `MemoBytes` type +* Remove `Era era` constraint from: + * `Memo` pattern + * `decodeMemoBytes` + * `DecCBOR (Annotator (MemoBytes t))` instance + * `DecCBOR (MemoBytes t))` instance + * `memoBytes` + * `mkMemoized` + * `lensMemoRawType` + * `Data` pattern + * `dataToBinaryData` +* Add `Version` parameter to: + * `memoBytes` + * `mkMemoized` + * `lensMemoRawType` +* Remove `era` type parameter from `Mem` type +* Reduce the kind of `MemoHashIndex` type family parameter to a concrete type +* Reduce the kind of `RawType` type to a concrete type * Add `mbpackedByteCount`, `mbpackM` and `mbunpackM` to `MemoBytes` module * Require `MemPack` instance for `TxOut` and `CompactForm (Value era)` for `EraTxOut` type class. * Add `decodeMemoBytes` diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs index 5183e51dad0..608d1441503 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -71,6 +71,7 @@ import Cardano.Ledger.Binary ( DecCBOR (decCBOR), Decoder, EncCBOR, + Version, decodeAnnotated, decodeFullAnnotator, serialize, @@ -78,7 +79,6 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Binary.Coders (Encode, encode, runE) import qualified Cardano.Ledger.Binary.Plain as Plain -import Cardano.Ledger.Core.Era (Era, eraProtVerLow) import Cardano.Ledger.Hashes (HASH, SafeHash, SafeToHash (..)) import Control.DeepSeq (NFData (..)) import Data.ByteString (ByteString) @@ -104,15 +104,15 @@ import Prelude hiding (span) -- that were used to transmit it. Important since hashes are computed -- from the serialization of a type, and EncCBOR instances do not have unique -- serializations. -data MemoBytes t era = Memo' - { mbRawType :: !(t era) +data MemoBytes t = Memo' + { mbRawType :: !t , mbBytes :: ShortByteString , mbHash :: SafeHash (MemoHashIndex t) } deriving (Generic) - deriving (NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t era) + deriving (NoThunks) via AllowThunksIn '["mbBytes", "mbHash"] (MemoBytes t) -pattern Memo :: Era era => t era -> ShortByteString -> MemoBytes t era +pattern Memo :: t -> ShortByteString -> MemoBytes t pattern Memo memoType memoBytes <- Memo' memoType memoBytes _ where @@ -120,54 +120,53 @@ pattern Memo memoType memoBytes <- {-# COMPLETE Memo #-} -mbpackedByteCount :: MemoBytes t era -> Int +mbpackedByteCount :: MemoBytes t -> Int mbpackedByteCount = packedByteCount . mbBytes -mbpackM :: MemoBytes t era -> Pack s () +mbpackM :: MemoBytes t -> Pack s () mbpackM = packM . mbBytes mbunpackM :: - forall era t b. - (Era era, DecCBOR (Annotator (t era)), Typeable t, Buffer b) => - Unpack b (MemoBytes t era) -mbunpackM = unpackM >>= decodeMemoBytes + forall t b. + (Typeable t, DecCBOR (Annotator t), Buffer b) => + Version -> + Unpack b (MemoBytes t) +mbunpackM v = unpackM >>= decodeMemoBytes v decodeMemoBytes :: - forall t era m. - (Typeable t, Era era, DecCBOR (Annotator (t era)), MonadFail m) => - ByteString -> - m (MemoBytes t era) -decodeMemoBytes bs = + forall t m. + (Typeable t, DecCBOR (Annotator t), MonadFail m) => Version -> ByteString -> m (MemoBytes t) +decodeMemoBytes v bs = either (fail . show) pure $ decodeFullAnnotator - (eraProtVerLow @era) + v (T.pack (show (typeRep (Proxy @t)))) decCBOR (BSL.fromStrict bs) -type family MemoHashIndex (t :: Type -> Type) :: Type +type family MemoHashIndex (t :: Type) :: Type -deriving instance NFData (t era) => NFData (MemoBytes t era) +deriving instance NFData t => NFData (MemoBytes t) -instance (Typeable t, Typeable era) => Plain.ToCBOR (MemoBytes t era) where +instance Typeable t => Plain.ToCBOR (MemoBytes t) where toCBOR (Memo' _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes) instance - (Typeable t, DecCBOR (Annotator (t era)), Era era) => - DecCBOR (Annotator (MemoBytes t era)) + (Typeable t, DecCBOR (Annotator t)) => + DecCBOR (Annotator (MemoBytes t)) where decCBOR = do (Annotator getT, Annotator getBytes) <- withSlice decCBOR pure (Annotator (\fullbytes -> mkMemoBytes (getT fullbytes) (getBytes fullbytes))) -instance (Typeable t, DecCBOR (t era), Era era) => DecCBOR (MemoBytes t era) where +instance DecCBOR t => DecCBOR (MemoBytes t) where decCBOR = decodeMemoized decCBOR -- | Both binary representation and Haskell types are compared. -instance Eq (t era) => Eq (MemoBytes t era) where +instance Eq t => Eq (MemoBytes t) where x == y = mbBytes x == mbBytes y && mbRawType x == mbRawType y -instance Show (t era) => Show (MemoBytes t era) where +instance Show t => Show (MemoBytes t) where show (Memo' y _ h) = show y <> " (" @@ -176,7 +175,7 @@ instance Show (t era) => Show (MemoBytes t era) where <> show h <> ")" -instance SafeToHash (MemoBytes t era) where +instance SafeToHash (MemoBytes t) where originalBytes = fromShort . mbBytes originalBytesSize = SBS.length . mbBytes @@ -185,11 +184,11 @@ shorten :: BSL.ByteString -> ShortByteString shorten x = toShort (toStrict x) -- | Useful when deriving DecCBOR(Annotator T) --- deriving via (Mem T) instance (Era era) => DecCBOR (Annotator T) -type Mem t era = Annotator (MemoBytes t era) +-- deriving via (Mem T) instance DecCBOR (Annotator T) +type Mem t = Annotator (MemoBytes t) -- | Smart constructor -mkMemoBytes :: forall era t. t era -> BSL.ByteString -> MemoBytes t era +mkMemoBytes :: forall t. t -> BSL.ByteString -> MemoBytes t mkMemoBytes t bsl = Memo' t @@ -200,109 +199,110 @@ mkMemoBytes t bsl = -- | Turn a MemoBytes into a string, Showing both its internal structure and its original bytes. -- Useful since the Show instance of MemoBytes does not display the original bytes. -showMemo :: Show (t era) => MemoBytes t era -> String +showMemo :: Show t => MemoBytes t -> String showMemo (Memo' t b _) = "(Memo " ++ show t ++ " " ++ show b ++ ")" -printMemo :: Show (t era) => MemoBytes t era -> IO () +printMemo :: Show t => MemoBytes t -> IO () printMemo x = putStrLn (showMemo x) -- | Create MemoBytes from its CBOR encoding -memoBytes :: forall era w t. Era era => Encode w (t era) -> MemoBytes t era -memoBytes t = mkMemoBytes (runE t) (serialize (eraProtVerLow @era) (encode t)) +memoBytes :: Version -> Encode w t -> MemoBytes t +memoBytes v t = mkMemoBytes (runE t) (serialize v (encode t)) -- | Helper function. Converts a short bytestring to a lazy bytestring. shortToLazy :: ShortByteString -> BSL.ByteString shortToLazy = fromStrict . fromShort -- | Returns true if the contents of the MemoBytes are equal -contentsEq :: Eq (t era) => MemoBytes t era -> MemoBytes t era -> Bool +contentsEq :: Eq t => MemoBytes t -> MemoBytes t -> Bool contentsEq x y = mbRawType x == mbRawType y -- | Extract the inner type of the MemoBytes -getMemoBytesType :: MemoBytes t era -> t era +getMemoBytesType :: MemoBytes t -> t getMemoBytesType = mbRawType -- | Extract the hash value of the binary representation of the MemoBytes -getMemoBytesHash :: MemoBytes t era -> SafeHash (MemoHashIndex t) +getMemoBytesHash :: MemoBytes t -> SafeHash (MemoHashIndex t) getMemoBytesHash = mbHash -- | Class that relates the actual type with its raw and byte representations class Memoized t where - type RawType t = (r :: Type -> Type) | r -> t + type RawType t = (r :: Type) | r -> t -- | This is a coercion from the memoized type to the MemoBytes. This implementation -- cannot be changed since `getMemoBytes` is not exported, therefore it will only work -- on newtypes around `MemoBytes` - getMemoBytes :: t era -> MemoBytes (RawType t) era + getMemoBytes :: t -> MemoBytes (RawType t) default getMemoBytes :: - Coercible (t era) (MemoBytes (RawType t) era) => - t era -> - MemoBytes (RawType t) era + Coercible t (MemoBytes (RawType t)) => + t -> + MemoBytes (RawType t) getMemoBytes = coerce -- | This is a coercion from the MemoBytes to the momoized type. This implementation -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work -- on newtypes around `MemoBytes` - wrapMemoBytes :: MemoBytes (RawType t) era -> t era + wrapMemoBytes :: MemoBytes (RawType t) -> t default wrapMemoBytes :: - Coercible (MemoBytes (RawType t) era) (t era) => - MemoBytes (RawType t) era -> - t era + Coercible (MemoBytes (RawType t)) t => + MemoBytes (RawType t) -> + t wrapMemoBytes = coerce -- | Construct memoized type from the raw type using its EncCBOR instance -mkMemoized :: forall era t. (Era era, EncCBOR (RawType t era), Memoized t) => RawType t era -> t era -mkMemoized rawType = wrapMemoBytes (mkMemoBytes rawType (serialize (eraProtVerLow @era) rawType)) +mkMemoized :: forall t. (EncCBOR (RawType t), Memoized t) => Version -> RawType t -> t +mkMemoized v rawType = wrapMemoBytes (mkMemoBytes rawType (serialize v rawType)) -decodeMemoized :: Decoder s (t era) -> Decoder s (MemoBytes t era) +decodeMemoized :: Decoder s t -> Decoder s (MemoBytes t) decodeMemoized rawTypeDecoder = do Annotated rawType lazyBytes <- decodeAnnotated rawTypeDecoder pure $ mkMemoBytes rawType lazyBytes -- | Extract memoized SafeHash -getMemoSafeHash :: Memoized t => t era -> SafeHash (MemoHashIndex (RawType t)) +getMemoSafeHash :: Memoized t => t -> SafeHash (MemoHashIndex (RawType t)) getMemoSafeHash t = mbHash (getMemoBytes t) -- | Extract the raw type from the memoized version -getMemoRawType :: Memoized t => t era -> RawType t era +getMemoRawType :: Memoized t => t -> RawType t getMemoRawType t = mbRawType (getMemoBytes t) -- | Extract the raw bytes from the memoized version -getMemoRawBytes :: Memoized t => t era -> ShortByteString +getMemoRawBytes :: Memoized t => t -> ShortByteString getMemoRawBytes t = mbBytes (getMemoBytes t) -- | This is a helper function that operates on raw types of two memoized types. zipMemoRawType :: (Memoized t1, Memoized t2) => - (RawType t1 era -> RawType t2 era -> a) -> - t1 era -> - t2 era -> + (RawType t1 -> RawType t2 -> a) -> + t1 -> + t2 -> a zipMemoRawType f x y = f (getMemoRawType x) (getMemoRawType y) eqRawType :: - forall t era. - (Memoized t, Eq (RawType t era)) => - t era -> - t era -> + forall t. + (Memoized t, Eq (RawType t)) => + t -> + t -> Bool eqRawType = zipMemoRawType @t (==) -- | This is a helper Lens creator for any Memoized type. lensMemoRawType :: - (Era era, EncCBOR (RawType t era), Memoized t) => - (RawType t era -> a) -> - (RawType t era -> b -> RawType t era) -> - Lens (t era) (t era) a b -lensMemoRawType getter setter = - lens (getter . getMemoRawType) (\t v -> mkMemoized $ setter (getMemoRawType t) v) + (EncCBOR (RawType t), Memoized t) => + Version -> + (RawType t -> a) -> + (RawType t -> b -> RawType t) -> + Lens t t a b +lensMemoRawType v getter setter = + lens (getter . getMemoRawType) (\t b -> mkMemoized v $ setter (getMemoRawType t) b) {-# INLINEABLE lensMemoRawType #-} -- | This is a helper SimpleGetter creator for any Memoized type getterMemoRawType :: Memoized t => - (RawType t era -> a) -> - SimpleGetter (t era) a + (RawType t -> a) -> + SimpleGetter t a getterMemoRawType getter = to (getter . getMemoRawType) {-# INLINEABLE getterMemoRawType #-} @@ -311,5 +311,5 @@ getterMemoRawType getter = -- potentially memoized binary representation of the type. class EqRaw a where eqRaw :: a -> a -> Bool - default eqRaw :: (a ~ t era, Memoized t, Eq (RawType t era)) => a -> a -> Bool + default eqRaw :: (a ~ t, Memoized t, Eq (RawType t)) => a -> a -> Bool eqRaw = eqRawType diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs index 0f7bbcc60eb..219a24aa0d3 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs @@ -94,31 +94,31 @@ instance Typeable era => EncCBOR (PlutusData era) where instance Typeable era => DecCBOR (Annotator (PlutusData era)) where decCBOR = pure <$> fromPlainDecoder Cborg.decode -newtype Data era = DataConstr (MemoBytes PlutusData era) +newtype Data era = DataConstr (MemoBytes (PlutusData era)) deriving (Eq, Generic) deriving newtype (SafeToHash, ToCBOR, NFData) -- | Encodes memoized bytes created upon construction. instance Typeable era => EncCBOR (Data era) -instance Memoized Data where - type RawType Data = PlutusData +instance Memoized (Data era) where + type RawType (Data era) = PlutusData era deriving instance Show (Data era) -deriving via Mem PlutusData era instance Era era => DecCBOR (Annotator (Data era)) +deriving via Mem (PlutusData era) instance Era era => DecCBOR (Annotator (Data era)) -type instance MemoHashIndex PlutusData = EraIndependentData +type instance MemoHashIndex (PlutusData era) = EraIndependentData instance HashAnnotated (Data era) EraIndependentData where hashAnnotated = getMemoSafeHash instance Typeable era => NoThunks (Data era) -pattern Data :: Era era => PV1.Data -> Data era +pattern Data :: forall era. Era era => PV1.Data -> Data era pattern Data p <- (getMemoRawType -> PlutusData p) where - Data p = mkMemoized $ PlutusData p + Data p = mkMemoized (eraProtVerLow @era) $ PlutusData p {-# COMPLETE Data #-} @@ -179,7 +179,7 @@ binaryDataToData binaryData = error $ "Impossible: incorrectly encoded data: " ++ show errMsg Right d -> d -dataToBinaryData :: Era era => Data era -> BinaryData era +dataToBinaryData :: Data era -> BinaryData era dataToBinaryData (DataConstr (Memo _ sbs)) = BinaryData sbs hashBinaryData :: BinaryData era -> DataHash diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs index 337abacebc8..a2cfc9146d6 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs @@ -86,7 +86,7 @@ instance ToExpr PlutusBinary instance ToExpr Language -- MemoBytes -instance ToExpr (t era) => ToExpr (MemoBytes t era) +instance ToExpr t => ToExpr (MemoBytes t) -- Core diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs index 6411d506688..ff31e112e80 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances/Ledger.hs @@ -442,10 +442,10 @@ instance IsConwayUniv fn => HasSpec fn PV1.Data where conformsTo _ _ = True toPreds _ _ = toPred True -instance Era era => HasSimpleRep (Data era) where +instance forall era. Era era => HasSimpleRep (Data era) where type SimpleRep (Data era) = PV1.Data toSimpleRep = getPlutusData - fromSimpleRep = mkMemoized . PlutusData + fromSimpleRep = mkMemoized (eraProtVerLow @era) . PlutusData instance (IsConwayUniv fn, Era era) => HasSpec fn (Data era) instance Era era => HasSimpleRep (BinaryData era) where diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/Universes.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/Universes.hs index 7da3336d97e..3455fff1d5a 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/Universes.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Preds/Universes.hs @@ -214,12 +214,11 @@ bootWitness hash bootaddrs byronuniv = List.foldl' accum Set.empty bootaddrs -- Datums -- | The universe of non-empty Datums. i.e. There are no NoDatum Datums in this list -genDatums :: - Era era => UnivSize -> Int -> Map DataHash (Data era) -> Gen [Datum era] +genDatums :: UnivSize -> Int -> Map DataHash (Data era) -> Gen [Datum era] genDatums sizes n datauniv = vectorOf n (genDatum sizes datauniv) -- | Only generate non-empty Datums. I.e. There are no NoDatum Datums generated. -genDatum :: Era era => UnivSize -> Map DataHash (Data era) -> Gen (Datum era) +genDatum :: UnivSize -> Map DataHash (Data era) -> Gen (Datum era) genDatum UnivSize {usDatumFreq} datauniv = frequency [ (1, DatumHash . fst <$> genFromMap ["from genDatums DatumHash case"] datauniv)