diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index aa3cdf16778..fdf758141e5 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -76,6 +76,7 @@ import Cardano.Ledger.Binary ( Decoder, EncCBOR (..), EncCBORGroup (..), + Encoding, ToCBOR (..), allowTag, decodeList, @@ -275,14 +276,14 @@ isEmptyTxWitness (getMemoRawType -> AlonzoTxWitsRaw a b c d (Redeemers e)) = Set.null a && Set.null b && Map.null c && nullDats d && Map.null e -- ===================================================== -newtype TxDatsRaw era = TxDatsRaw (Map (DataHash (EraCrypto era)) (Data era)) +newtype TxDatsRaw era = TxDatsRaw {unTxDatsRaw :: Map (DataHash (EraCrypto era)) (Data era)} deriving (Generic, Typeable, Eq) deriving newtype (NoThunks, NFData) deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (TxDatsRaw era) instance (Typeable era, EncCBOR (Data era)) => EncCBOR (TxDatsRaw era) where - encCBOR (TxDatsRaw m) = encCBOR $ Map.elems m + encCBOR = encodeWithSetTag . Map.elems . unTxDatsRaw pattern TxDats' :: Map (DataHash (EraCrypto era)) (Data era) -> TxDats era pattern TxDats' m <- (getMemoRawType -> TxDatsRaw m) @@ -306,7 +307,11 @@ instance Era era => DecCBOR (Annotator (TxDatsRaw era)) where decCBOR = ifDecoderVersionAtLeast (natVersion @9) - (mapTraverseableDecoderA (decodeNonEmptyList decCBOR) (TxDatsRaw . keyBy hashData . NE.toList)) + ( allowTag setTag + >> mapTraverseableDecoderA + (decodeNonEmptyList decCBOR) + (TxDatsRaw . keyBy hashData . NE.toList) + ) (mapTraverseableDecoderA (decodeList decCBOR) (TxDatsRaw . keyBy hashData)) {-# INLINE decCBOR #-} @@ -499,7 +504,7 @@ instance AlonzoEraScript era => EncCBOR (AlonzoTxWitsRaw era) where null ( Key 1 $ E - (encCBOR . mapMaybe getNativeScript . Map.elems) + (encodeWithSetTag . mapMaybe getNativeScript . Map.elems) (Map.filter isNativeScript scripts) ) !> Omit null (Key 3 $ encodePlutus SPlutusV1) @@ -514,13 +519,7 @@ instance AlonzoEraScript era => EncCBOR (AlonzoTxWitsRaw era) where Encode ('Closed 'Dense) (Map.Map (ScriptHash (EraCrypto era)) (Plutus l)) encodePlutus slang = E - ( \m -> - let enc = encCBOR . map plutusBinary $ Map.elems m - in ifEncodingVersionAtLeast - (natVersion @9) - (encodeTag setTag <> enc) - enc - ) + (encodeWithSetTag . encCBOR . map plutusBinary . Map.elems) (Map.mapMaybe (toPlutusScript >=> toPlutusSLanguage slang) scripts) toScript :: forall l h. PlutusLanguage l => Map.Map h (Plutus l) -> Map.Map h (Script era) @@ -593,7 +592,9 @@ instance ( D $ ifDecoderVersionAtLeast (natVersion @9) - (mapTraverseableDecoderA (decodeNonEmptyList decCBOR) (Set.fromList . NE.toList)) + ( allowTag setTag + >> mapTraverseableDecoderA (decodeNonEmptyList decCBOR) (Set.fromList . NE.toList) + ) (mapTraverseableDecoderA (decodeList decCBOR) Set.fromList) ) txWitnessField 1 = @@ -606,7 +607,9 @@ instance ( D $ ifDecoderVersionAtLeast (natVersion @9) - (mapTraverseableDecoderA (decodeNonEmptyList decCBOR) (Set.fromList . NE.toList)) + ( allowTag setTag + >> mapTraverseableDecoderA (decodeNonEmptyList decCBOR) (Set.fromList . NE.toList) + ) (mapTraverseableDecoderA (decodeList decCBOR) Set.fromList) ) txWitnessField 3 = fieldA addScripts (decodePlutus SPlutusV1) @@ -624,7 +627,9 @@ instance nativeScriptsDecoder = ifDecoderVersionAtLeast (natVersion @9) - (mapTraverseableDecoderA (decodeNonEmptyList pairDecoder) (Map.fromList . NE.toList)) + ( allowTag setTag + >> mapTraverseableDecoderA (decodeNonEmptyList pairDecoder) (Map.fromList . NE.toList) + ) (mapTraverseableDecoderA (decodeList pairDecoder) Map.fromList) where pairDecoder :: Decoder s (Annotator (ScriptHash (EraCrypto era), Script era)) @@ -695,3 +700,10 @@ mapTraverseableDecoderA :: (f a -> m b) -> Decoder s (Annotator (m b)) mapTraverseableDecoderA decList transformList = fmap transformList . sequence <$> decList + +encodeWithSetTag :: EncCBOR a => a -> Encoding +encodeWithSetTag xs = + ifEncodingVersionAtLeast + (natVersion @9) + (encodeTag setTag <> encCBOR xs) + (encCBOR xs) diff --git a/eras/conway/impl/cddl-files/conway.cddl b/eras/conway/impl/cddl-files/conway.cddl index 9f737a97872..473fe95cc91 100644 --- a/eras/conway/impl/cddl-files/conway.cddl +++ b/eras/conway/impl/cddl-files/conway.cddl @@ -430,11 +430,11 @@ drep_voting_thresholds = ] transaction_witness_set = - { ? 0: [+ vkeywitness ] - , ? 1: [+ native_script ] - , ? 2: [+ bootstrap_witness ] + { ? 0: nonempty_set + , ? 1: nonempty_set + , ? 2: nonempty_set , ? 3: nonempty_set - , ? 4: [+ plutus_data ] + , ? 4: nonempty_set , ? 5: redeemers , ? 6: nonempty_set , ? 7: nonempty_set diff --git a/libs/cardano-data/CHANGELOG.md b/libs/cardano-data/CHANGELOG.md index a1799e06e7e..18ad894ff7b 100644 --- a/libs/cardano-data/CHANGELOG.md +++ b/libs/cardano-data/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.2.0.0 +* Add `toSet` +* Add `fromFoldable` * Moved `ToExpr` instances out of the main library and into the testlib. ## 1.1.2.0 diff --git a/libs/cardano-data/cardano-data.cabal b/libs/cardano-data/cardano-data.cabal index 84fbd70b2b2..a53ec20ab16 100644 --- a/libs/cardano-data/cardano-data.cabal +++ b/libs/cardano-data/cardano-data.cabal @@ -88,8 +88,8 @@ test-suite cardano-data-tests containers, hspec, cardano-data, - cardano-ledger-binary:testlib, + cardano-ledger-binary:{cardano-ledger-binary, testlib}, testlib, QuickCheck, - quickcheck-classes-base, + quickcheck-classes, microlens diff --git a/libs/cardano-data/src/Data/OSet/Strict.hs b/libs/cardano-data/src/Data/OSet/Strict.hs index bea63d96435..763509701f8 100644 --- a/libs/cardano-data/src/Data/OSet/Strict.hs +++ b/libs/cardano-data/src/Data/OSet/Strict.hs @@ -23,7 +23,9 @@ module Data.OSet.Strict ( fromStrictSeq, fromStrictSeqDuplicates, toStrictSeq, + toSet, fromSet, + fromFoldable, invariantHolds, invariantHolds', (|>), @@ -74,7 +76,7 @@ instance Ord a => Monoid (OSet a) where instance Ord a => IsList (OSet a) where type Item (OSet a) = a - fromList = fromStrictSeq . SSeq.fromList + fromList = fromFoldable toList = F.toList . osSSeq instance Foldable OSet where @@ -175,11 +177,15 @@ unsnoc (OSet seq set) = case seq of SSeq.Empty -> Nothing xs' SSeq.:|> x -> Just (OSet xs' (x `Set.delete` set), x) +-- | Using a `Foldable` instance of the source data structure convert it to an `OSet` +fromFoldable :: (Foldable f, Ord a) => f a -> OSet a +fromFoldable = F.foldl' snoc empty + -- | \(O(n \log n)\). Checks membership before snoc-ing. -- De-duplicates the StrictSeq without overwriting. -- Starts from the left or head, using `foldl'` fromStrictSeq :: Ord a => SSeq.StrictSeq a -> OSet a -fromStrictSeq = F.foldl' snoc empty +fromStrictSeq = fromFoldable -- | \(O(n \log n)\). Checks membership before snoc-ing. -- Returns a 2-tuple, with `fst` as a `Set` of duplicates found @@ -194,10 +200,14 @@ fromStrictSeqDuplicates = F.foldl' snoc' (Set.empty, empty) then (x `Set.insert` duplicates, oset) else (duplicates, OSet (seq SSeq.|> x) (x `Set.insert` set)) --- | \( O(1) \). +-- | \( O(1) \) - Extract underlying strict sequence toStrictSeq :: OSet a -> SSeq.StrictSeq a toStrictSeq = osSSeq +-- | \( O(1) \) - Extract underlying Set +toSet :: OSet a -> Set.Set a +toSet = osSet + -- | \( O(n) \). fromSet :: Set.Set a -> OSet a fromSet set = OSet (SSeq.fromList $ Set.elems set) set diff --git a/libs/cardano-data/test/Test/Cardano/Data/OMap/StrictSpec.hs b/libs/cardano-data/test/Test/Cardano/Data/OMap/StrictSpec.hs index fca3dc01529..e9cd9ca85ec 100644 --- a/libs/cardano-data/test/Test/Cardano/Data/OMap/StrictSpec.hs +++ b/libs/cardano-data/test/Test/Cardano/Data/OMap/StrictSpec.hs @@ -19,7 +19,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck (Arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary)) -import Test.QuickCheck.Classes.Base +import Test.QuickCheck.Classes import Prelude hiding (elem, filter, lookup, null) spec :: Spec @@ -148,7 +148,8 @@ spec = it "Type" $ lawsCheckOne (Proxy :: Proxy (OMap Int Int)) - [ isListLaws + [ eqLaws + , isListLaws , semigroupLaws , monoidLaws , semigroupMonoidLaws diff --git a/libs/cardano-data/test/Test/Cardano/Data/OSet/StrictSpec.hs b/libs/cardano-data/test/Test/Cardano/Data/OSet/StrictSpec.hs index 0dedd1cd537..0931968d3a6 100644 --- a/libs/cardano-data/test/Test/Cardano/Data/OSet/StrictSpec.hs +++ b/libs/cardano-data/test/Test/Cardano/Data/OSet/StrictSpec.hs @@ -1,18 +1,21 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Data.OSet.StrictSpec where +import Cardano.Ledger.Binary (natVersion) +import Control.Monad (forM_) import Data.OSet.Strict hiding (empty) import Data.Proxy import Data.Sequence.Strict (StrictSeq, fromList, (><)) import Data.Set (Set, elems, empty) import Test.Cardano.Data.Arbitrary () -import Test.Cardano.Ledger.Binary.RoundTrip (roundTripCborSpec) +import Test.Cardano.Ledger.Binary.RoundTrip (cborTrip, embedTripSpec, roundTripCborSpec) import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck.Classes.Base +import Test.QuickCheck.Classes spec :: Spec spec = @@ -82,15 +85,19 @@ spec = context "CBOR round-trip" $ do roundTripCborSpec @(OSet Int) roundTripCborSpec @(OSet (OSet Int)) + forM_ [natVersion @9 .. maxBound] $ \v -> do + embedTripSpec v v (cborTrip @(Set Word) @(OSet Word)) $ + \oset set -> set `shouldBe` toSet oset + embedTripSpec v v (cborTrip @(OSet Word) @(Set Word)) $ + \set oset -> toSet oset `shouldBe` set context "Typeclass laws" $ do it "Type" $ lawsCheckOne (Proxy :: Proxy (OSet Int)) - [ isListLaws + [ eqLaws + , ordLaws + , isListLaws , semigroupLaws , monoidLaws , semigroupMonoidLaws ] - --- it "Type -> Type" $ do --- lawsCheck $ foldableLaws (Proxy :: Proxy OSet) diff --git a/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs b/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs index c5b6872ff87..805b7e5595d 100644 --- a/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs +++ b/libs/cardano-data/testlib/Test/Cardano/Data/Arbitrary.hs @@ -13,7 +13,7 @@ import Test.Cardano.Ledger.Binary.Arbitrary () import Test.QuickCheck instance (Arbitrary a, Ord a) => Arbitrary (OSet.OSet a) where - arbitrary = fmap (OSet.fromSet . Set.fromList) . shuffle . Set.toList =<< arbitrary + arbitrary = fmap OSet.fromFoldable . shuffle . Set.toList =<< arbitrary instance (Ord v, Arbitrary v, OMap.HasOKey k v, Arbitrary k) => Arbitrary (OMap.OMap k v) where arbitrary = diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs index 2710f613789..df089d64ae5 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -6,6 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Cardano.Ledger.Binary.Decoding.Annotated ( @@ -28,11 +30,15 @@ where import Cardano.Ledger.Binary.Decoding.DecCBOR (DecCBOR (..)) import Cardano.Ledger.Binary.Decoding.Decoder ( Decoder, + allowTag, decodeList, decodeWithByteSpan, fromPlainDecoder, + setTag, + whenDecoderVersionAtLeast, ) import Cardano.Ledger.Binary.Encoding (EncCBOR, Version, serialize') +import Cardano.Ledger.Binary.Version (natVersion) import Codec.CBOR.Read (ByteOffset) import qualified Codec.Serialise as Serialise (decode) import Control.DeepSeq (NFData) @@ -192,6 +198,8 @@ withSlice dec = do -- order to enforce no duplicates. decodeAnnSet :: Ord t => Decoder s (Annotator t) -> Decoder s (Annotator (Set.Set t)) decodeAnnSet dec = do + whenDecoderVersionAtLeast (natVersion @9) $ + allowTag setTag xs <- decodeList dec pure (Set.fromList <$> sequence xs) {-# INLINE decodeAnnSet #-} diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Encoder.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Encoder.hs index 46ef12154a1..827c83b2e62 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Encoder.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Encoder.hs @@ -468,16 +468,24 @@ variableListLenEncoding len contents = -- | Encode a Set. Versions variance: -- +-- * [>= 9] - Variable length encoding for Sets larger than 23 elements, otherwise exact +-- length encoding. Prefixes with a special 258 `setTag`. +-- -- * [>= 2] - Variable length encoding for Sets larger than 23 elements, otherwise exact -- length encoding -- --- * [< 2] - Variable length encoding. Also prefixes with a special 258 tag. +-- * [< 2] - Variable length encoding. Prefixes with a special 258 `setTag`. encodeSet :: (a -> Encoding) -> Set.Set a -> Encoding encodeSet encodeValue f = let foldableEncoding = foldMap' encodeValue f + varLenSetEncoding = variableListLenEncoding (Set.size f) foldableEncoding in ifEncodingVersionAtLeast (natVersion @2) - (variableListLenEncoding (Set.size f) foldableEncoding) + ( ifEncodingVersionAtLeast + (natVersion @9) + (encodeTag setTag <> varLenSetEncoding) + varLenSetEncoding + ) (encodeTag setTag <> exactListLenEncoding (Set.size f) foldableEncoding) {-# INLINE encodeSet #-} diff --git a/libs/cardano-ledger-binary/test/Test/Cardano/Ledger/Binary/RoundTripSpec.hs b/libs/cardano-ledger-binary/test/Test/Cardano/Ledger/Binary/RoundTripSpec.hs index e868bc71ea1..fdd4709260b 100644 --- a/libs/cardano-ledger-binary/test/Test/Cardano/Ledger/Binary/RoundTripSpec.hs +++ b/libs/cardano-ledger-binary/test/Test/Cardano/Ledger/Binary/RoundTripSpec.hs @@ -42,6 +42,7 @@ import Cardano.Slotting.Slot (EpochNo, EpochSize, SlotNo, WithOrigin) import Cardano.Slotting.Time (SystemStart) import Codec.CBOR.ByteArray (ByteArray (..)) import Codec.CBOR.ByteArray.Sliced (SlicedByteArray (..)) +import Control.Monad (when) import Data.Fixed (Nano, Pico) import Data.Foldable as F import Data.IP (IPv4, IPv6) @@ -310,8 +311,11 @@ spec = do \xs sxs -> xs `shouldBe` F.toList sxs embedTripSpec v v (cborTrip @(SSeq.StrictSeq Word) @[Word]) $ \xs sxs -> xs `shouldBe` F.toList sxs - embedTripSpec v v (cborTrip @(Set.Set Word) @[Word]) $ - \xs sxs -> xs `shouldBe` Set.toList sxs + when (v < natVersion @9) $ do + -- Starting with version 9 Set is prefixed with tag 258, which prevents it from + -- being deserialized into a list. + embedTripSpec v v (cborTrip @(Set.Set Word) @[Word]) $ + \xs sxs -> xs `shouldBe` Set.toList sxs embedTripSpec v v (cborTrip @(VMap.VMap VMap.VP VMap.VP Word Int) @(Map.Map Word Int)) $ \xs sxs -> xs `shouldBe` VMap.toMap sxs forM_ [minBound .. natVersion @8] $ \v ->