Remove era type parameter from MemoBytes type

And adjust usages accordingly
IntersectMBO · Jan 21, 2025 · aa2624e · aa2624e
1 parent 2c6a3ee
commit aa2624e
Show file tree

Hide file tree

Showing 22 changed files with 432 additions and 318 deletions.
diff --git 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
@@ -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
@@ -9,7 +9,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -96,32 +98,36 @@ 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)
 
 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
@@ -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 #-}