Merge pull request #5493 from IntersectMBO/f-f/5453-map

lehins · web-flow · commit 1413d509f913 · 2026-01-04T05:31:17.000-07:00
Change all error Maps to NonEmptyMaps in predicate failures
diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md
@@ -14,6 +14,7 @@
   - `cppMinFeeB` -> `cppTxFeeFixed`
 * Changed type of `cppMinFeeA` to `CoinPerByte`
 * Change sets containing errors into `NonEmptySet` for `ConwayGovPredFailure`, `ConwayUtxoPredFailure`, `ConwayUtxowPredFailure`
+* Change all maps into `NonEmptyMap` for `ConwayGovPredFailure` and `ConwayLedgerPredFailure`
 * Change all lists into `NonEmpty` for `ConwayUtxoPredFailure`, `ConwayUtxosPredFailure`, `ConwayUtxowPredFailure`
 * Add `cddl` sub-library, and `generate-cddl` executable.
 * Re-export `UtxoEnv` from `Cardano.Ledger.Conway.Rules.Utxo`
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs
@@ -122,6 +122,7 @@ import Control.State.Transition.Extended (
   failBecause,
   failOnJust,
   failOnNonEmpty,
+  failOnNonEmptyMap,
   failOnNonEmptySet,
   failureOnNonEmpty,
   judgmentContext,
@@ -133,6 +134,7 @@ import Data.Bifunctor (bimap)
 import Data.Either (partitionEithers)
 import qualified Data.Foldable as F
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.Map.NonEmpty (NonEmptyMap)
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
 import Data.Pulse (foldlM')
@@ -189,7 +191,7 @@ data ConwayGovPredFailure era
       (NonEmptySet (Credential ColdCommitteeRole))
   | ExpirationEpochTooSmall
       -- | Members for which the expiration epoch has already been reached
-      (Map.Map (Credential ColdCommitteeRole) EpochNo)
+      (NonEmptyMap (Credential ColdCommitteeRole) EpochNo)
   | InvalidPrevGovActionId (ProposalProcedure era)
   | VotingOnExpiredGovAction (NonEmpty (Voter, GovActionId))
   | ProposalCantFollow
@@ -559,7 +561,7 @@ conwayGovTransition = do
              in failOnNonEmptySet conflicting (injectFailure . ConflictingCommitteeUpdate)
 
             let invalidMembers = Map.filter (<= currentEpoch) membersToAdd
-             in Map.null invalidMembers ?! (injectFailure . ExpirationEpochTooSmall) invalidMembers
+             in failOnNonEmptyMap invalidMembers (injectFailure . ExpirationEpochTooSmall)
           ParameterChange _ _ proposalPolicy ->
             runTest $ checkGuardrailsScriptHash @era constitutionPolicy proposalPolicy
           _ -> pure ()
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs
@@ -126,6 +126,7 @@ import Control.State.Transition.Extended (
  )
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.NonEmpty (NonEmptyMap)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (isNothing)
 import Data.Sequence (Seq)
@@ -145,7 +146,7 @@ data ConwayLedgerPredFailure era
   | ConwayTxRefScriptsSizeTooBig (Mismatch RelLTEQ Int)
   | ConwayMempoolFailure Text
   | ConwayWithdrawalsMissingAccounts Withdrawals
-  | ConwayIncompleteWithdrawals (Map.Map RewardAccount (Mismatch RelEQ Coin))
+  | ConwayIncompleteWithdrawals (NonEmptyMap RewardAccount (Mismatch RelEQ Coin))
   deriving (Generic)
 
 type instance EraRuleFailure "LEDGER" ConwayEra = ConwayLedgerPredFailure ConwayEra
diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs
@@ -18,6 +18,7 @@ import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..), ConwayLedgerPre
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..))
 import Cardano.Ledger.Val (Val (..))
+import qualified Data.Map.NonEmpty as NEM
 import Lens.Micro ((&), (.~))
 import Test.Cardano.Ledger.Conway.Arbitrary ()
 import Test.Cardano.Ledger.Conway.ImpTest
@@ -108,7 +109,9 @@ spec = do
         [ if hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule pv
             then
               injectFailure $
-                ConwayIncompleteWithdrawals @era [(rwdAccount1, Mismatch (reward1 <+> Coin 1) reward1)]
+                ConwayIncompleteWithdrawals @era $
+                  NEM.singleton rwdAccount1 $
+                    Mismatch (reward1 <+> Coin 1) reward1
             else
               injectFailure . WithdrawalsNotInRewardsCERTS @era $ Withdrawals [(rwdAccount1, reward1 <+> Coin 1)]
         ]
@@ -122,7 +125,7 @@ spec = do
         )
         [ if hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule pv
             then
-              injectFailure . ConwayIncompleteWithdrawals @era $ [(rwdAccount1, Mismatch zero reward1)]
+              injectFailure . ConwayIncompleteWithdrawals @era $ NEM.singleton rwdAccount1 $ Mismatch zero reward1
             else injectFailure . WithdrawalsNotInRewardsCERTS @era $ Withdrawals [(rwdAccount1, zero)]
         ]
   where
diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs
@@ -30,6 +30,7 @@ import Cardano.Ledger.Shelley.Scripts (
 import Cardano.Ledger.Val (zero, (<->))
 import Data.Default (Default (..))
 import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map.NonEmpty as NEM
 import qualified Data.Map.Strict as Map
 import qualified Data.OMap.Strict as OMap
 import qualified Data.Sequence.Strict as SSeq
@@ -106,7 +107,7 @@ predicateFailuresSpec =
               (0 %! 1)
       passEpoch
       let expectedFailure =
-            injectFailure $ ExpirationEpochTooSmall $ Map.singleton committeeC expiration
+            injectFailure $ ExpirationEpochTooSmall $ NEM.singleton committeeC expiration
       proposal <- mkProposal action
       submitBootstrapAwareFailingProposal_ proposal $
         FailBootstrapAndPostBootstrap
diff --git a/eras/dijkstra/impl/CHANGELOG.md b/eras/dijkstra/impl/CHANGELOG.md
@@ -38,6 +38,7 @@
   - `dppMinFeeB` -> `dppTxFeeFixed`
 * Changed type of `dppMinFeeA` to `CoinPerByte`
 * Change sets containing errors into `NonEmptySet` for `DijkstraGovPredFailure`, `DijkstraUtxoPredFailure`, `DijkstraUtxowPredFailure`
+* Change all maps into `NonEmptyMap` for `DijkstraGovPredFailure` and `DijkstraLedgerPredFailure`
 * Change Dijkstra BBODY rule to validate Peras certificates when present
 * Add new block body predicate falures for Dijkstra:
   - `PrevEpochNonceNotPresent` for missing optional nonce needed for validation
diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Gov.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Gov.hs
@@ -76,7 +76,7 @@ import Control.State.Transition.Extended (
   STS (..),
  )
 import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.Map.Strict as Map
+import Data.Map.NonEmpty (NonEmptyMap)
 import Data.Set.NonEmpty (NonEmptySet)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
@@ -96,7 +96,7 @@ data DijkstraGovPredFailure era
       (NonEmptySet (Credential ColdCommitteeRole))
   | ExpirationEpochTooSmall
       -- | Members for which the expiration epoch has already been reached
-      (Map.Map (Credential ColdCommitteeRole) EpochNo)
+      (NonEmptyMap (Credential ColdCommitteeRole) EpochNo)
   | InvalidPrevGovActionId (ProposalProcedure era)
   | VotingOnExpiredGovAction (NonEmpty (Voter, GovActionId))
   | ProposalCantFollow
diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs
@@ -117,7 +117,7 @@ import Cardano.Ledger.Shelley.Rules (
 import Control.DeepSeq (NFData)
 import Control.State.Transition.Extended
 import Data.List.NonEmpty (NonEmpty)
-import qualified Data.Map.Strict as Map
+import Data.Map.NonEmpty (NonEmptyMap)
 import Data.Sequence (Seq)
 import Data.Void (absurd)
 import GHC.Generics (Generic (..))
@@ -132,7 +132,7 @@ data DijkstraLedgerPredFailure era
   | DijkstraTreasuryValueMismatch (Mismatch RelEQ Coin)
   | DijkstraTxRefScriptsSizeTooBig (Mismatch RelLTEQ Int)
   | DijkstraWithdrawalsMissingAccounts Withdrawals
-  | DijkstraIncompleteWithdrawals (Map.Map RewardAccount (Mismatch RelEQ Coin))
+  | DijkstraIncompleteWithdrawals (NonEmptyMap RewardAccount (Mismatch RelEQ Coin))
   | DijkstraSubLedgersFailure (PredicateFailure (EraRule "SUBLEDGERS" era))
   deriving (Generic)
 
diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md
@@ -10,6 +10,7 @@
   - `ppMinFeeB` -> `ppTxFeeFixed`
 * Changed type of `sppMinFeeA` to `CoinPerByte`:
 * Change sets containing errors into `NonEmptySet` for `ShelleyUtxoPredFailure`, `ShelleyUtxowPredFailure`
+* Change all maps into `NonEmptyMap` for `ShelleyLedgerPredFailure`
 * Change all lists into `NonEmpty` for `ShelleyUtxoPredFailure`, `ShelleyUtxowPredFailure`
 * Changed the type of the following fields to `CompactForm Coin` in `ShelleyPParams`:
   - `sppMinFeeB`
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs
@@ -80,11 +80,13 @@ import Control.State.Transition (
   STS (..),
   TRC (..),
   TransitionRule,
-  failOnJust,
+  failOnNonEmptyMap,
   judgmentContext,
   liftSTS,
   trans,
  )
+import Data.Map.NonEmpty (NonEmptyMap)
+import qualified Data.Map.NonEmpty as NEM
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq)
@@ -127,7 +129,7 @@ data ShelleyLedgerPredFailure era
   = UtxowFailure (PredicateFailure (EraRule "UTXOW" era)) -- Subtransition Failures
   | DelegsFailure (PredicateFailure (EraRule "DELEGS" era)) -- Subtransition Failures
   | ShelleyWithdrawalsMissingAccounts Withdrawals
-  | ShelleyIncompleteWithdrawals (Map RewardAccount (Mismatch RelEQ Coin))
+  | ShelleyIncompleteWithdrawals (NonEmptyMap RewardAccount (Mismatch RelEQ Coin))
   deriving (Generic)
 
 ledgerSlotNoL :: Lens' (LedgerEnv era) SlotNo
@@ -361,13 +363,11 @@ testIncompleteAndMissingWithdrawals accounts withdrawals = do
   network <- liftSTS $ asks networkId
   let (missingWithdrawals, incompleteWithdrawals) =
         case withdrawalsThatDoNotDrainAccounts withdrawals network accounts of
-          Nothing -> (Nothing, Nothing)
-          Just (missing, incomplete) ->
-            ( if null (unWithdrawals missing) then Nothing else Just missing
-            , if null incomplete then Nothing else Just incomplete
-            )
-  failOnJust missingWithdrawals $ injectFailure . ShelleyWithdrawalsMissingAccounts
-  failOnJust incompleteWithdrawals $ injectFailure . ShelleyIncompleteWithdrawals
+          Nothing -> (Map.empty, Map.empty)
+          Just (missing, incomplete) -> (unWithdrawals missing, incomplete)
+  failOnNonEmptyMap missingWithdrawals $
+    injectFailure . ShelleyWithdrawalsMissingAccounts . Withdrawals . NEM.toMap
+  failOnNonEmptyMap incompleteWithdrawals $ injectFailure . ShelleyIncompleteWithdrawals
 
 instance
   ( Era era
diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs
@@ -52,6 +52,7 @@ import Control.State.Transition.Extended (PredicateFailure, TRC (..))
 import qualified Data.ByteString.Char8 as BS (pack)
 import Data.Default (def)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Map.NonEmpty as NEM
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust)
 import Data.Proxy (Proxy (..))
@@ -561,8 +562,9 @@ testWithdrawalWrongAmt =
       dpState' = addReward dpState (raCredential rAccount) (Coin 10)
       tx = MkShelleyTx $ ShelleyTx @ShelleyEra txb txwits SNothing
       errs =
-        [ ShelleyIncompleteWithdrawals
-            [(rAccount, Mismatch (Coin 11) (Coin 10))]
+        [ ShelleyIncompleteWithdrawals $
+            NEM.singleton rAccount $
+              Mismatch (Coin 11) (Coin 10)
         ]
    in testLEDGER (LedgerState utxoState dpState') tx ledgerEnv (Left errs)
 
diff --git a/libs/cardano-data/CHANGELOG.md b/libs/cardano-data/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 1.3.0.0
 
+* Add `Data.Map.NonEmpty`
 * Add `Data.Set.NonEmpty`
 * Add `lookupInternMap`
 * Replace `okeyL` with `toOKey`
diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal
@@ -19,6 +19,7 @@ library
   exposed-modules:
     Data.CanonicalMaps
     Data.ListMap
+    Data.Map.NonEmpty
     Data.MapExtras
     Data.MonoTuple
     Data.OMap.Strict
diff --git a/libs/cardano-data/src/Data/Map/NonEmpty.hs b/libs/cardano-data/src/Data/Map/NonEmpty.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Data.Map.NonEmpty (
+  NonEmptyMap,
+  fromFoldable,
+  fromMap,
+  singleton,
+  toList,
+  toMap,
+) where
+
+import Cardano.Ledger.Binary (DecCBOR (decCBOR), EncCBOR)
+import Control.DeepSeq (NFData)
+import qualified Data.Foldable as Foldable
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import NoThunks.Class (NoThunks)
+import Prelude hiding (map)
+
+newtype NonEmptyMap k v = NonEmptyMap (Map k v)
+  deriving stock (Show, Eq)
+  deriving newtype (EncCBOR, NoThunks, NFData)
+
+instance (Ord k, DecCBOR k, DecCBOR v) => DecCBOR (NonEmptyMap k v) where
+  decCBOR = do
+    m <- decCBOR
+    case fromMap m of
+      Nothing -> fail "Empty map found, expected non-empty"
+      Just nem -> pure nem
+  {-# INLINE decCBOR #-}
+
+-- | \(O(1)\).
+singleton :: forall k v. k -> v -> NonEmptyMap k v
+singleton k v = NonEmptyMap $ Map.singleton k v
+
+-- | \(O(1)\).
+fromMap :: forall k v. Map k v -> Maybe (NonEmptyMap k v)
+fromMap set = if Map.null set then Nothing else Just (NonEmptyMap set)
+
+-- | \(O(1)\).
+toMap :: forall k v. NonEmptyMap k v -> Map k v
+toMap (NonEmptyMap set) = set
+
+-- | \(O(n \log n)\).
+fromFoldable :: forall f k v. (Foldable f, Ord k) => f (k, v) -> Maybe (NonEmptyMap k v)
+fromFoldable = fromMap . Foldable.foldl' (flip (uncurry Map.insert)) Map.empty
+
+-- | \(O(n)\).
+toList :: forall k v. NonEmptyMap k v -> [(k, v)]
+toList (NonEmptyMap set) = Map.toList set
diff --git a/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs b/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs
@@ -5,6 +5,8 @@
 
 module Test.Cardano.Data.Arbitrary (genOSet) where
 
+import Data.Map.NonEmpty as NEM
+import Data.Map.Strict as Map
 import Data.Maybe (fromJust)
 import Data.OMap.Strict qualified as OMap
 import Data.OSet.Strict qualified as OSet
@@ -33,3 +35,15 @@ instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where
     | xs' <- shrink $ NES.toSet nes
     , not (Set.null xs')
     ]
+
+instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (NonEmptyMap k v) where
+  arbitrary = do
+    k <- arbitrary
+    v <- arbitrary
+    fromJust . NEM.fromMap . Map.insert k v <$> arbitrary
+
+  shrink nem =
+    [ fromJust $ NEM.fromMap xs'
+    | xs' <- shrink $ NEM.toMap nem
+    , not (Map.null xs')
+    ]
diff --git a/libs/cardano-data/testlib/Test/Cardano/Data/TreeDiff.hs b/libs/cardano-data/testlib/Test/Cardano/Data/TreeDiff.hs
@@ -7,6 +7,8 @@ module Test.Cardano.Data.TreeDiff where
 
 import Data.Foldable (Foldable (..))
 import Data.Foldable qualified as F
+import Data.Map.NonEmpty (NonEmptyMap)
+import Data.Map.NonEmpty qualified as NEM
 import Data.OMap.Strict
 import Data.OSet.Strict
 import Data.Set.NonEmpty (NonEmptySet)
@@ -22,3 +24,7 @@ instance (HasOKey k v, ToExpr v) => ToExpr (OMap k v) where
 
 instance ToExpr a => ToExpr (NonEmptySet a) where
   toExpr = toExpr . NES.toList
+
+instance (Ord k, ToExpr k, ToExpr v) => ToExpr (NonEmptyMap k v) where
+  listToExpr = listToExpr . F.toList
+  toExpr = toExpr . NEM.toList
diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal
@@ -226,6 +226,7 @@ library testlib
     bytestring,
     cardano-crypto-class,
     cardano-crypto-wrapper:{cardano-crypto-wrapper, testlib},
+    cardano-data:testlib,
     cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.5,
     cardano-ledger-byron:{cardano-ledger-byron, testlib},
     cardano-ledger-core,
diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs
@@ -36,6 +36,7 @@ import Cardano.Ledger.TxIn
 import Data.Functor.Identity
 import Data.TreeDiff.OMap
 import GHC.TypeLits
+import Test.Cardano.Data.TreeDiff ()
 import Test.Cardano.Ledger.Binary.TreeDiff
 import Test.Data.VMap.TreeDiff ()
 
diff --git a/libs/small-steps/CHANGELOG.md b/libs/small-steps/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 1.1.3.0
 
+* Add `failOnNonEmptyMap` and `failureOnNonEmptyMap`
 * Add `failOnNonEmptySet` and `failureOnNonEmptySet`
 
 ## 1.1.2.0
diff --git a/libs/small-steps/src/Control/State/Transition/Extended.hs b/libs/small-steps/src/Control/State/Transition/Extended.hs
@@ -56,9 +56,11 @@ module Control.State.Transition.Extended (
   failOnJust,
   failOnNonEmpty,
   failOnNonEmptySet,
+  failOnNonEmptyMap,
   failureOnJust,
   failureOnNonEmpty,
   failureOnNonEmptySet,
+  failureOnNonEmptyMap,
   judgmentContext,
   trans,
   liftSTS,
@@ -109,6 +111,9 @@ import Data.Functor (($>), (<&>))
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
+import Data.Map.NonEmpty (NonEmptyMap)
+import qualified Data.Map.NonEmpty as NEM
+import Data.Map.Strict (Map)
 import Data.Set.NonEmpty (NonEmptySet)
 import qualified Data.Set.NonEmpty as NES
 import Data.Typeable (typeRep)
@@ -431,6 +436,16 @@ failureOnNonEmptySet ::
   (Foldable f, Ord a) => f a -> (NonEmptySet a -> e) -> Validation (NonEmpty e) ()
 failureOnNonEmptySet cond = failureOnJust (NES.fromFoldable cond)
 
+-- | Produce a predicate failure when supplied foldable is not an empty Map, contents of which
+-- will be converted to a NonEmptyMap and can be used inside the predicate failure.
+failOnNonEmptyMap :: Map k v -> (NonEmptyMap k v -> PredicateFailure sts) -> Rule sts ctx ()
+failOnNonEmptyMap cond onNonEmpty = liftF $ Predicate (failureOnNonEmptyMap cond onNonEmpty) id ()
+
+-- | Produce a failure when supplied foldable is not an empty Map, contents of which will be
+-- converted to a NonEmptyMap and can then be used inside the failure constructor.
+failureOnNonEmptyMap :: Map k v -> (NonEmptyMap k v -> e) -> Validation (NonEmpty e) ()
+failureOnNonEmptyMap cond = failureOnJust (NEM.fromMap cond)
+
 -- | Oh noes with an explanation
 --
 --   We interpret this as "What?" "No!" "Because:"
