Implement and confirm sharing for decoding GovActions

eras/conway/impl/cardano-ledger-conway.cabal

@@ -105,6 +105,7 @@ library
     deepseq,
     mempack,
     microlens,
+    mtl,
     nothunks,
     plutus-ledger-api >=1.37,
     set-algebra,

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,
   (!>),
-  (<!),
  )
 import Cardano.Ledger.CertState (
   CommitteeAuthorization (..),
@@ -244,6 +242,7 @@ import Cardano.Ledger.UMap
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData (..))
 import Control.Monad (guard)
+import Control.Monad.Trans
 import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import Data.Default (Default (..))
@@ -357,16 +356,16 @@ instance EraPParams era => DecShareCBOR (ConwayGovState era) where
       , Interns (Credential 'DRepRole)
       , Interns (Credential 'HotCommitteeRole)
       )
-  decShareCBOR is =
-    decode $
-      RecD ConwayGovState
-        <! D (decShareCBOR is)
-        <! From
-        <! From
-        <! From
-        <! From
-        <! From
-        <! D (decShareCBOR is)
+  decSharePlusCBOR =
+    decodeRecordNamedT "ConwayGovState" (const 7) $ do
+      cgsProposals <- decSharePlusCBOR
+      cgsCommittee <- lift decCBOR
+      cgsConstitution <- lift decCBOR
+      cgsCurPParams <- lift decCBOR
+      cgsPrevPParams <- lift decCBOR
+      cgsFuturePParams <- lift decCBOR
+      cgsDRepPulsingState <- decSharePlusCBOR
+      pure ConwayGovState {..}
 
 instance EraPParams era => DecCBOR (ConwayGovState era) where
   decCBOR = decNoShareCBOR

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
-        <! From
-        <! D (decodeMap (interns ch <$> decCBOR) decCBOR)
-        <! D (decodeMap (interns cd <$> decCBOR) decCBOR)
-        <! D (decodeMap (interns ks <$> decCBOR) decCBOR)
-        <! From
-        <! From
-        <! From
+  decSharePlusCBOR =
+    decodeRecordNamedT "GovActionState" (const 7) $ do
+      gasId <- lift decCBOR
+
+      (cs, ks, cd, ch) <- get
+      gasCommitteeVotes <- lift $ decShareCBOR (ch, mempty)
+      gasDRepVotes <- lift $ decShareCBOR (cd, mempty)
+      gasStakePoolVotes <- lift $ decShareCBOR (ks, mempty)
+
+      -- DRep votes do not contain any new credentials, thus only additon of interns for SPOs and CCs
+      put (cs, ks <> 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}
 

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

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

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`

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 ::

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) #-}

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

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