From 216225be23b1a2d94eb924adbc2502a93cbd1b59 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Fri, 31 Oct 2025 12:43:36 +0200 Subject: [PATCH] Remove listLenBound from EncCBORGroup class --- .../Ledger/Alonzo/BlockBody/Internal.hs | 1 - .../impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 1 - .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 9 ++++++--- .../Cardano/Ledger/Alonzo/Binary/Annotator.hs | 4 +++- .../impl/src/Cardano/Ledger/Conway/Scripts.hs | 1 - .../src/Cardano/Ledger/Dijkstra/Scripts.hs | 1 - .../Ledger/Shelley/BlockBody/Internal.hs | 1 - .../impl/src/Cardano/Ledger/Shelley/TxCert.hs | 2 +- libs/cardano-ledger-binary/CHANGELOG.md | 2 ++ .../Cardano/Ledger/Binary/Decoding/Coders.hs | 4 ++-- .../Cardano/Ledger/Binary/Encoding/Coders.hs | 6 ++++-- .../src/Cardano/Ledger/Binary/Group.hs | 20 +++++++++---------- .../src/Cardano/Ledger/BaseTypes.hs | 2 -- .../src/Cardano/Ledger/Block.hs | 2 +- .../src/Cardano/Ledger/Core.hs | 4 ++++ .../src/Cardano/Ledger/Credential.hs | 1 - .../src/Cardano/Ledger/State/StakePool.hs | 1 - .../src/Cardano/Protocol/TPraos/BHeader.hs | 3 ++- .../src/Cardano/Protocol/TPraos/OCert.hs | 7 ++++--- 19 files changed, 38 insertions(+), 34 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs index f9fa4f5d769..0bbd6028fd7 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs @@ -177,7 +177,6 @@ instance Era era => EncCBORGroup (AlonzoBlockBody era) where BSL.toStrict $ bodyBytes <> witsBytes <> metadataBytes <> invalidBytes listLen _ = 4 - listLenBound _ = 4 hashAlonzoSegWits :: BSL.ByteString -> diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index da557880a57..26faec2520a 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -336,7 +336,6 @@ instance EncCBORGroup (AlonzoPlutusPurpose f era) where listLen _ = 2 - listLenBound _ = 2 encCBORGroup = \case AlonzoSpending p -> encodeWord8 0 <> encCBOR p AlonzoMinting p -> encodeWord8 1 <> encCBOR p diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index f916747ff7a..c441f15e42a 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -7,7 +8,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -85,6 +85,7 @@ import Cardano.Ledger.Binary ( encodeTag, ifDecoderVersionAtLeast, ifEncodingVersionAtLeast, + listLenInt, natVersion, peekTokenType, setTag, @@ -152,8 +153,9 @@ instance AlonzoEraScript era => EncCBOR (RedeemersRaw era) where (encCBOR rs) (encodeFoldableEncoder keyValueEncoder $ Map.toAscList rs) where + keyValueEncoder :: (PlutusPurpose AsIx era, (Data era, ExUnits)) -> Encoding keyValueEncoder (ptr, (dats, exs)) = - encodeListLen (listLen ptr + 2) + encodeListLen (listLen (toProxy ptr) + 2) <> encCBORGroup ptr <> encCBOR dats <> encCBOR exs @@ -556,7 +558,8 @@ instance AlonzoEraScript era => DecCBOR (Annotator (RedeemersRaw era)) where decodeElement :: forall s. Decoder s (PlutusPurpose AsIx era, Annotator (Data era), ExUnits) decodeElement = do - decodeRecordNamed "Redeemer" (\(rdmrPtr, _, _) -> fromIntegral (listLen rdmrPtr) + 2) $ do + let redeemerLen (redeemerPtr, _, _) = listLenInt redeemerPtr + 2 + decodeRecordNamed "Redeemer" redeemerLen do !redeemerPtr <- decCBORGroup !redeemerData <- decCBOR !redeemerExUnits <- decCBOR diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs index 6c9c4b56dbf..ec96280b035 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -235,7 +236,8 @@ instance AlonzoEraScript era => DecCBOR (RedeemersRaw era) where {-# INLINE decodeListRedeemers #-} decodeElement :: Decoder s (PlutusPurpose AsIx era, (Data era, ExUnits)) decodeElement = do - decodeRecordNamed "Redeemer" (\(redeemerPtr, _) -> fromIntegral (listLen redeemerPtr) + 2) $ do + let redeemerLen (redeemerPtr, _) = listLenInt redeemerPtr + 2 + decodeRecordNamed "Redeemer" redeemerLen do !redeemerPtr <- decCBORGroup !redeemerData <- decCBOR !redeemerExUnits <- decCBOR diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs index 71f49af77c0..08c3e3f1c71 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs @@ -270,7 +270,6 @@ instance EncCBORGroup (ConwayPlutusPurpose f era) where listLen _ = 2 - listLenBound _ = 2 encCBORGroup = \case ConwaySpending p -> encodeWord8 0 <> encCBOR p ConwayMinting p -> encodeWord8 1 <> encCBOR p diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs index 07377e3673b..e92b2c3bd14 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs @@ -157,7 +157,6 @@ instance EncCBORGroup (DijkstraPlutusPurpose f era) where listLen _ = 2 - listLenBound _ = 2 encCBORGroup = \case DijkstraSpending p -> encodeWord8 0 <> encCBOR p DijkstraMinting p -> encodeWord8 1 <> encCBOR p diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs index 84f308b9538..d82d0de0dfe 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockBody/Internal.hs @@ -198,7 +198,6 @@ instance Era era => EncCBORGroup (ShelleyBlockBody era) where BSL.toStrict $ bodyBytes <> witsBytes <> metadataBytes listLen _ = 3 - listLenBound _ = 3 hashShelleySegWits :: BSL.ByteString -> diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs index 50d96727475..b7e0c96d7d7 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs @@ -435,7 +435,7 @@ encodeShelleyDelegCert = \case encodePoolCert :: PoolCert -> Encoding encodePoolCert = \case RegPool poolParams -> - encodeListLen (1 + listLen poolParams) + encodeListLen (1 + listLen (toProxy poolParams)) <> encodeWord8 3 <> encCBORGroup poolParams RetirePool vk epoch -> diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index d9516693bd6..3d171c9cf98 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.8.0.0 +* Remove `listLenBound` from `EncCBORGroup` +* Change type of `listLen` in `EncCBORGroup` to accept a `Proxy` instead of a concrete value * Change `Density` type to only be available at the type level * Change `Wrapped` type to only be available at the type level * Make `decodeAnnSet` fail when there are duplicates, starting with protocol version `12`. diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs index e00cbe9beee..e66f9f2b508 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs @@ -77,7 +77,7 @@ import Data.Maybe.Strict (StrictMaybe (..)) import Data.Set (Set, insert, member) import qualified Data.Set as Set import qualified Data.Text as Text -import Data.Typeable (Proxy (..), Typeable, typeOf) +import Data.Typeable (Proxy (Proxy), Typeable, typeOf) import Data.Void (Void) -- ==================================================================== @@ -426,7 +426,7 @@ hsize (SumD _) = 0 hsize (RecD _) = 0 hsize (KeyedD _) = 0 hsize From = 1 -hsize FromGroup = fromIntegral $ listLenBound $ Proxy @t +hsize FromGroup = fromIntegral $ listLen $ Proxy @t hsize (D _) = 1 hsize (ApplyD f x) = hsize f + hsize x hsize (Invalid _) = 0 diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs index 92eddad9af8..eaab4b4d1f0 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -69,6 +70,7 @@ import Cardano.Ledger.Binary.Encoding.Encoder ( ) import Cardano.Ledger.Binary.Group (EncCBORGroup (..)) import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) +import Data.Typeable (Proxy (Proxy)) -- ==================================================================== @@ -172,11 +174,11 @@ runE (Tag _ x) = runE x runE (Key _ x) = runE x runE (Keyed cn) = cn -gsize :: Encode w t -> Word +gsize :: forall w t. Encode w t -> Word gsize (Sum _ _) = 0 gsize (Rec _) = 0 gsize (To _) = 1 -gsize (ToGroup x) = listLen x +gsize (ToGroup _) = listLen $ Proxy @t gsize (E _ _) = 1 gsize (MapE _ x) = gsize x gsize (ApplyE f x) = gsize f + gsize x diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs index 32488476549..eb741f881b2 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Ledger.Binary.Group ( CBORGroup (..), @@ -12,8 +14,7 @@ module Cardano.Ledger.Binary.Group ( import Cardano.Ledger.Binary.Decoding import Cardano.Ledger.Binary.Encoding -import Data.Proxy -import Data.Typeable +import Data.Typeable (Proxy (..), Typeable) -------------------------------------------------------------------------------- -- CBORGroup @@ -26,10 +27,11 @@ instance (DecCBORGroup a, EncCBORGroup a) => DecCBOR (CBORGroup a) where decCBOR = CBORGroup <$> groupRecord instance EncCBORGroup a => EncCBOR (CBORGroup a) where - encCBOR (CBORGroup x) = encodeListLen (listLen x) <> encCBORGroup x + encCBOR (CBORGroup x) = encodeListLen (listLen $ Proxy @a) <> encCBORGroup x groupRecord :: forall a s. (EncCBORGroup a, DecCBORGroup a) => Decoder s a -groupRecord = decodeRecordNamed "CBORGroup" (fromIntegral . toInteger . listLen) decCBORGroup +groupRecord = + decodeRecordNamed "CBORGroup" (fromIntegral . toInteger . const (listLen $ Proxy @a)) decCBORGroup -------------------------------------------------------------------------------- -- EncCBORGroup @@ -38,13 +40,10 @@ groupRecord = decodeRecordNamed "CBORGroup" (fromIntegral . toInteger . listLen) class EncCBORGroup a where encCBORGroup :: a -> Encoding - listLen :: a -> Word + listLen :: Proxy a -> Word - -- | an upper bound for 'listLen', used in 'Size' expressions. - listLenBound :: Proxy a -> Word - -listLenInt :: EncCBORGroup a => a -> Int -listLenInt x = fromIntegral (listLen x) +listLenInt :: forall a. EncCBORGroup a => a -> Int +listLenInt _ = fromIntegral $ listLen $ Proxy @a -------------------------------------------------------------------------------- -- DecCBORGroup @@ -57,7 +56,6 @@ instance EncCBOR a => EncCBORGroup (a, a) where encCBORGroup (x, y) = encCBOR x <> encCBOR y listLen _ = 2 - listLenBound _ = 2 instance DecCBOR a => DecCBORGroup (a, a) where decCBORGroup = do diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index fa58865b0c1..e93e66160c8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -225,7 +225,6 @@ instance EncCBORGroup ProtVer where encCBORGroup (ProtVer x y) = encCBOR x <> encCBOR y listLen _ = 2 - listLenBound _ = 2 instance DecCBORGroup ProtVer where decCBORGroup = ProtVer <$> decCBOR <*> decCBOR @@ -794,7 +793,6 @@ instance (DecCBOR a, Typeable r) => DecCBOR (Mismatch r a) where instance EncCBOR a => EncCBORGroup (Mismatch r a) where encCBORGroup Mismatch {..} = encCBOR mismatchSupplied <> encCBOR mismatchExpected listLen _ = 2 - listLenBound _ = 2 instance (Typeable r, DecCBOR a) => DecCBORGroup (Mismatch r a) where decCBORGroup = do diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 0618b0d84a0..20c2a3a9b2d 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -69,7 +69,7 @@ instance EncCBOR (Block h era) where encCBOR (Block h txns) = - encodeListLen (1 + listLen txns) <> encCBOR h <> encCBORGroup txns + encodeListLen (1 + listLen (toProxy txns)) <> encCBOR h <> encCBORGroup txns instance forall era h. diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index c0e9b967f36..b98fb289f29 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -57,6 +57,7 @@ module Cardano.Ledger.Core ( binaryUpgradeTxAuxData, fromStrictMaybeL, toStrictMaybeL, + toProxy, -- * Era module Cardano.Ledger.Core.Era, @@ -683,3 +684,6 @@ fromStrictMaybeL = lens strictMaybeToMaybe (const maybeToStrictMaybe) instance EraTx era => HasOKey TxId (Tx l era) where toOKey = txIdTx + +toProxy :: forall a. a -> Proxy a +toProxy _ = Proxy diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs index dbb010091a1..51040295aee 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs @@ -307,7 +307,6 @@ instance EncCBORGroup Ptr where <> encCBOR txIx <> encCBOR certIx listLen _ = 3 - listLenBound _ = 3 instance DecCBORGroup Ptr where decCBORGroup = do diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs index 219f1b43b26..f5e4ad342fd 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs @@ -536,7 +536,6 @@ instance EncCBORGroup StakePoolParams where <> encCBOR (sppRelays poolParams) <> encodeNullStrictMaybe encCBOR (sppMetadata poolParams) listLen _ = 9 - listLenBound _ = 9 instance DecCBORGroup StakePoolParams where decCBORGroup = do diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs index a203e49378b..f454bb9c95a 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs @@ -76,6 +76,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Binary.Crypto import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Core (toProxy) import Cardano.Ledger.Hashes ( EraIndependentBlockBody, EraIndependentBlockHeader, @@ -168,7 +169,7 @@ instance Crypto c => NoThunks (BHBody c) instance Crypto c => EncCBOR (BHBody c) where encCBOR bhBody = - encodeListLen (9 + listLen oc + listLen pv) + encodeListLen (9 + listLen (toProxy oc) + listLen (toProxy pv)) <> encCBOR (bheaderBlockNo bhBody) <> encCBOR (bheaderSlotNo bhBody) <> encCBOR (bheaderPrev bhBody) diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/OCert.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/OCert.hs index 22c78f818bf..8b8cde8e55b 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/OCert.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/OCert.hs @@ -33,9 +33,11 @@ import Cardano.Ledger.Binary ( ToCBOR (..), fromPlainDecoder, fromPlainEncoding, + listLenInt, runByteBuilder, ) import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Core (toProxy) import Cardano.Ledger.Keys ( DSIGN, KeyHash, @@ -106,17 +108,16 @@ instance Crypto c => NoThunks (OCert c) instance Crypto c => EncCBORGroup (OCert c) where encCBORGroup = fromPlainEncoding . encodeOCertFields listLen _ = 4 - listLenBound _ = 4 instance Crypto c => DecCBORGroup (OCert c) where decCBORGroup = fromPlainDecoder decodeOCertFields instance Crypto c => ToCBOR (OCert c) where - toCBOR ocert = Plain.encodeListLen (listLen ocert) <> encodeOCertFields ocert + toCBOR ocert = Plain.encodeListLen (listLen (toProxy ocert)) <> encodeOCertFields ocert instance Crypto c => FromCBOR (OCert c) where fromCBOR = - Plain.decodeRecordNamed "OCert" (fromIntegral . listLen) decodeOCertFields + Plain.decodeRecordNamed "OCert" listLenInt decodeOCertFields encodeOCertFields :: Crypto c => OCert c -> Plain.Encoding encodeOCertFields ocert =