diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 8ca46934b68..0e20732f200 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -105,6 +105,7 @@ library deepseq, mempack, microlens, + mtl, nothunks, plutus-ledger-api >=1.37, set-algebra, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index dcd0d91a609..778c6e51a0e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -190,14 +190,12 @@ import Cardano.Ledger.Binary ( Interns, ToCBOR (..), decNoShareCBOR, + decodeRecordNamedT, ) import Cardano.Ledger.Binary.Coders ( - Decode (..), Encode (..), - decode, encode, (!>), - ( DecShareCBOR (ConwayGovState era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR is = - decode $ - RecD ConwayGovState - DecCBOR (ConwayGovState era) where decCBOR = decNoShareCBOR diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index ce61c0763d9..844c32c760d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -98,15 +98,15 @@ import Cardano.Ledger.Binary ( ToCBOR (toCBOR), decNoShareCBOR, decodeEnumBounded, - decodeMap, decodeMapByKey, decodeNullStrictMaybe, decodeRecordNamed, + decodeRecordNamedT, encodeEnum, encodeListLen, encodeNullStrictMaybe, encodeWord8, - interns, + internsFromMap, invalidKey, ) import Cardano.Ledger.Binary.Coders ( @@ -125,6 +125,8 @@ import Cardano.Ledger.TxIn (TxId (..)) import Cardano.Slotting.Slot (EpochNo) import Control.DeepSeq (NFData (..), deepseq) import Control.Monad (when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State.Strict (get, put) import Data.Aeson ( FromJSON (..), KeyValue (..), @@ -293,16 +295,22 @@ instance EraPParams era => DecShareCBOR (GovActionState era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR (cs, ks, cd, ch) = - decode $ - RecD GovActionState - decCBOR) decCBOR) - decCBOR) decCBOR) - decCBOR) decCBOR) - internsFromMap gasStakePoolVotes, cd, ch <> internsFromMap gasCommitteeVotes) + + gasProposalProcedure <- lift decCBOR + gasProposedIn <- lift decCBOR + gasExpiresAfter <- lift decCBOR + pure GovActionState {..} instance EraPParams era => DecCBOR (GovActionState era) where decCBOR = decNoShareCBOR @@ -319,7 +327,6 @@ instance EraPParams era => EncCBOR (GovActionState era) where !> To gasProposedIn !> To gasExpiresAfter --- Ref: https://gitlab.haskell.org/ghc/ghc/-/issues/14046 instance OMap.HasOKey GovActionId (GovActionState era) where okeyL = lens gasId $ \gas gi -> gas {gasId = gi} diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs index 350516cb5dc..d09b3cc093b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs @@ -127,7 +127,9 @@ import Cardano.Ledger.Binary ( DecShareCBOR (..), EncCBOR (..), Interns, - decodeListLenOf, + decodeListLenOrIndef, + decodeListLikeWithCountT, + decodeRecordNamedT, ) import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin)) import Cardano.Ledger.Conway.Governance.Procedures @@ -137,6 +139,7 @@ import Cardano.Ledger.UMap (addCompact, toCompact) import Control.DeepSeq (NFData) import Control.Exception (assert) import Control.Monad (unless) +import Control.Monad.Trans (lift) import Data.Aeson (ToJSON (..)) import Data.Default (Default (..)) import Data.Either (partitionEithers) @@ -370,11 +373,12 @@ instance EraPParams era => DecShareCBOR (Proposals era) where , Interns (Credential 'DRepRole) , Interns (Credential 'HotCommitteeRole) ) - decShareCBOR is = do - decodeListLenOf 2 - gaid <- decCBOR - omap <- OMap.decodeOMap (decShareCBOR is) - mkProposals gaid omap + decSharePlusCBOR = do + decodeRecordNamedT "Proposals" (const 2) $ do + gaid <- lift decCBOR + (_, omap) <- decodeListLikeWithCountT (lift decodeListLenOrIndef) (flip (OMap.|>)) $ \_ -> + decSharePlusCBOR + mkProposals gaid omap -- | Add a vote to an existing `GovActionState`. This is a no-op if the -- provided `GovActionId` does not already exist diff --git a/libs/cardano-data/src/Data/OMap/Strict.hs b/libs/cardano-data/src/Data/OMap/Strict.hs index 11535d3099e..f9235a6a596 100644 --- a/libs/cardano-data/src/Data/OMap/Strict.hs +++ b/libs/cardano-data/src/Data/OMap/Strict.hs @@ -173,6 +173,8 @@ cons' v (OMap sseq kv) infixr 5 <|| +-- TODO: export along with others that are hidden or remove them completely. + -- | \(O(\log n)\). Checks membership before snoc'ing. snoc :: HasOKey k v => OMap k v -> v -> OMap k v snoc omap@(OMap sseq kv) v diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index ca1fdcf4a9e..3378c858c60 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.6.0.0 +* Add `decodeListLikeWithCountT` * Add `encodeMemPack` and `decodeMemPack` helper functions. * Remove `encodeSignKeyKES` and `decodeSignKeyKES` * Remove `EncCBOR` and `DecCBOR` instances for `SignKeyKES` diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs index dd14a7b4d83..f4af27ecfa2 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs @@ -74,6 +74,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder ( decodeStrictSeq, decodeSetTag, decodeListLikeWithCount, + decodeListLikeWithCountT, decodeSetLikeEnforceNoDuplicates, decodeListLikeEnforceNoDuplicates, decodeMapContents, @@ -907,6 +908,10 @@ decodeListLikeWithCount :: -- | Decoder for the values. Current accumulator is supplied as an argument (b -> Decoder s a) -> Decoder s (Int, b) +-- TODO: define as +-- decodeListLikeWithCount decodeLenOrIndef insert decodeElement = +-- runIndentityT $ decodeListLikeWithCountT (lift decodeLenOrIndef) insert (lift decodeElement) +-- and add a SPECIALIZE pragma decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do decodeLenOrIndef >>= \case Just len -> loop (\x -> pure (x >= len)) 0 mempty @@ -925,6 +930,34 @@ decodeListLikeWithCount decodeLenOrIndef insert decodeElement = do {-# INLINE loop #-} {-# INLINE decodeListLikeWithCount #-} +decodeListLikeWithCountT :: + forall t s a b. + (MonadTrans t, Monad (t (Decoder s)), Monoid b) => + -- | Length decoder that produces the expected number of elements. When `Nothing` is + -- decoded the `decodeBreakOr` will be used as termination indicator. + t (Decoder s) (Maybe Int) -> + -- | Add an element into the decoded List like data structure + (a -> b -> b) -> + -- | Decoder for the values. Current accumulator is supplied as an argument + (b -> t (Decoder s) a) -> + t (Decoder s) (Int, b) +decodeListLikeWithCountT decodeLenOrIndef insert decodeElement = do + decodeLenOrIndef >>= \case + Just len -> loop (\x -> pure (x >= len)) 0 mempty + Nothing -> loop (\_ -> lift decodeBreakOr) 0 mempty + where + loop condition = go + where + go !count !acc = do + shouldStop <- condition count + if shouldStop + then pure (count, acc) + else do + element <- decodeElement acc + go (count + 1) (insert element acc) + {-# INLINE loop #-} +{-# INLINE decodeListLikeWithCountT #-} + -- | Decode a collection of values with ability to supply length decoder. Duplicates are not -- allowed. decodeListLikeEnforceNoDuplicates :: diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs index 27fcf2bc2c7..32ffc42c286 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs @@ -66,6 +66,17 @@ data Intern a = Intern newtype Interns a = Interns [Intern a] deriving (Monoid) +instance Semigroup (Interns a) where + (<>) is1 (Interns []) = is1 + (<>) (Interns []) is2 = is2 + (<>) (Interns is1) (Interns is2) = + Interns (F.foldr insertIntoSortedInterns is2 is1) + where + insertIntoSortedInterns i [] = [i] + insertIntoSortedInterns i (a : as) + | internWeight a > internWeight i = a : insertIntoSortedInterns i as + | otherwise = i : a : as + interns :: Interns k -> k -> k interns (Interns []) !k = k -- optimize for common case when there are no interns interns (Interns is) !k = go is @@ -98,42 +109,37 @@ internSet k = go EQ -> Just kx internsFromSet :: Ord k => Set.Set k -> Interns k -internsFromSet m = - Interns - [ Intern - { internMaybe = (`internSet` m) - , internWeight = Set.size m - } - ] +internsFromSet s + | Set.size s == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = (`internSet` s) + , internWeight = Set.size s + } + ] internsFromMap :: Ord k => Map k a -> Interns k -internsFromMap m = - Interns - [ Intern - { internMaybe = (`internMap` m) - , internWeight = Map.size m - } - ] +internsFromMap m + | Map.size m == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = (`internMap` m) + , internWeight = Map.size m + } + ] internsFromVMap :: Ord k => VMap VB kv k a -> Interns k -internsFromVMap m = - Interns - [ Intern - { internMaybe = \k -> VMap.internMaybe k m - , internWeight = VMap.size m - } - ] - -instance Semigroup (Interns a) where - (<>) is1 (Interns []) = is1 - (<>) (Interns []) is2 = is2 - (<>) (Interns is1) (Interns is2) = - Interns (F.foldr insertIntoSortedInterns is2 is1) - where - insertIntoSortedInterns i [] = [i] - insertIntoSortedInterns i (a : as) - | internWeight a > internWeight i = a : insertIntoSortedInterns i as - | otherwise = i : a : as +internsFromVMap m + | VMap.size m == 0 = mempty + | otherwise = + Interns + [ Intern + { internMaybe = \k -> VMap.internMaybe k m + , internWeight = VMap.size m + } + ] class Monoid (Share a) => DecShareCBOR a where {-# MINIMAL (decShareCBOR | decSharePlusCBOR) #-} diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs index 6dd70affb9f..a16df48c1ce 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -17,8 +17,8 @@ module Cardano.Ledger.State.Schema where import Cardano.Ledger.Babbage.TxOut (BabbageTxOut) import Cardano.Ledger.BaseTypes (TxIx (..)) import Cardano.Ledger.Coin -import Cardano.Ledger.Core (PParams) import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Core (PParams) import qualified Cardano.Ledger.Credential as Credential import qualified Cardano.Ledger.Keys as Keys import qualified Cardano.Ledger.PoolParams as Shelley diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs index fdc8d9985e2..8254bc22488 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs @@ -14,10 +14,10 @@ module Cardano.Ledger.State.UTxO where import Cardano.Ledger.Address import Cardano.Ledger.Alonzo.TxBody -import Cardano.Ledger.Conway import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Coin +import Cardano.Ledger.Conway import Cardano.Ledger.Core import Cardano.Ledger.Credential import Cardano.Ledger.EpochBoundary