Merge pull request #4003 from IntersectMBO/lehins/switch-to-using-set…

…-tag-in-conway

Prefix Set encoding with tag 258

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)

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<vkeywitness>
+  , ? 1: nonempty_set<native_script>
+  , ? 2: nonempty_set<bootstrap_witness>
   , ? 3: nonempty_set<plutus_v1_script>
-  , ? 4: [+ plutus_data ]
+  , ? 4: nonempty_set<plutus_data>
   , ? 5: redeemers
   , ? 6: nonempty_set<plutus_v2_script>
   , ? 7: nonempty_set<plutus_v3_script>

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

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

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

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

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)

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 =

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

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

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