Fix set validator

Author: Soupstraw

eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs

@@ -89,6 +89,7 @@ import Cardano.Ledger.Huddle.Gen (
   antiChoose,
   antiVectorOfUnique,
   arbitrary,
+  canonicalizeTerm,
   faultyNum,
   genArrayTerm,
   genMapTerm,
@@ -749,7 +750,8 @@ mkMaybeTaggedSet pname n = binding $ \x ->
       let
         validateInner t = do
           elems <- validateArrayTerm t
-          unless (elems == nub elems) $ fail "not all elements are unique"
+          let canon = canonicalizeTerm <$> elems
+          unless (canon == nub canon) $ fail "not all elements are unique"
           traverse_ (validateFromGRef ref) elems
       case term_ of
         TTagged t x | t == 258 -> validateInner x

libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -23,6 +24,7 @@ module Cardano.Ledger.Huddle.Gen (
   genBytesTerm,
   genStringTerm,
   genMapTerm,
+  canonicalizeTerm,
   unwrapSingleOrError,
 
   -- * Term validators
@@ -53,10 +55,11 @@ import Codec.CBOR.Cuddle.CBOR.Gen (generateFromGRef, generateFromName)
 import Codec.CBOR.Cuddle.CBOR.Validator (validateFromGRef, validateFromName)
 import Codec.CBOR.Cuddle.CDDL (Name (..))
 import Codec.CBOR.Cuddle.CDDL.CBORGenerator as CBORGen
-import Control.Monad.Reader (asks)
 import Codec.CBOR.Cuddle.CDDL.CTree (nintMin, uintMax)
+import Control.Monad.Reader (asks)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LBS
+import Data.List (sortOn)
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -65,6 +68,7 @@ import GHC.TypeLits (symbolVal)
 import Test.AntiGen as AntiGen
 import qualified Test.QuickCheck as QC
 import Test.QuickCheck.GenT as GenT
+import Data.Bifunctor (Bifunctor(..))
 
 -- | A function for generating a term from a rule. The @HuddleRule@ constraint
 -- ensures that the rule is actually defined in that era.
@@ -122,6 +126,34 @@ ifTwiddle yes no = do
   twiddle <- asks (gcTwiddle . geConfig)
   if twiddle then yes else no
 
+-- | Fold each Term to its canonical CBOR form: definite-length variants,
+-- strict bytestrings/text, sorted map keys, and Int promoted to Integer.
+-- Two Terms that round-trip to the same Haskell value should compare equal
+-- after canonicalization.
+canonicalizeTerm :: Term -> Term
+canonicalizeTerm = \case
+  TInt n -> TInteger (toInteger n)
+  TInteger n -> TInteger n
+  TBytes bs -> TBytes bs
+  TBytesI bs -> TBytes (LBS.toStrict bs)
+  TString t -> TString t
+  TStringI t -> TString (LT.toStrict t)
+  TList xs -> TList (canonicalizeTerm <$> xs)
+  TListI xs -> TList (canonicalizeTerm <$> xs)
+  TMap kvs -> TMap (canonicalizeKVs kvs)
+  TMapI kvs -> TMap (canonicalizeKVs kvs)
+  TTagged tag t -> TTagged tag (canonicalizeTerm t)
+  TBool b -> TBool b
+  TNull -> TNull
+  TSimple w -> TSimple w
+  THalf f -> THalf f
+  TFloat f -> TFloat f
+  TDouble d -> TDouble d
+  where
+    canonicalizeKVs =
+      sortOn fst
+        . fmap (bimap canonicalizeTerm canonicalizeTerm)
+
 -- Term validators
 
 validateInt :: Term -> CBORValidator Integer