From 96be79e03b12f19f8c7f2024b1726c3b614b26ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Wed, 29 Apr 2026 17:40:25 +0300 Subject: [PATCH 1/9] Add custom generator and validator to constr --- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 1 + eras/alonzo/impl/cddl/data/alonzo.cddl | 2 + .../lib/Cardano/Ledger/Alonzo/HuddleSpec.hs | 63 ++++++++++++++---- eras/babbage/impl/cddl/data/babbage.cddl | 2 + eras/conway/impl/cddl/data/conway.cddl | 2 + eras/dijkstra/impl/cddl/data/dijkstra.cddl | 2 + .../Ledger/Dijkstra/Binary/CddlSpec.hs | 9 +-- .../cddl/Cardano/Ledger/Huddle/Gen.hs | 64 ++++++++++++++++++- 8 files changed, 125 insertions(+), 20 deletions(-) diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 895417ce352..52c99f93719 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -132,6 +132,7 @@ library cddl build-depends: base, + cardano-ledger-core:cddl, cardano-ledger-alonzo, cardano-ledger-mary:cddl, heredoc, diff --git a/eras/alonzo/impl/cddl/data/alonzo.cddl b/eras/alonzo/impl/cddl/data/alonzo.cddl index 401458e37f1..9a2254b581c 100644 --- a/eras/alonzo/impl/cddl/data/alonzo.cddl +++ b/eras/alonzo/impl/cddl/data/alonzo.cddl @@ -435,6 +435,8 @@ plutus_data = / big_int / bounded_bytes +;In reality the supported tags are 121..127, 1280..1400 and 101. +;We only list some of the possible tags here. constr = #6.102([uint, [* a0]]) / #6.121([* a0]) diff --git a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs index 9356453e2ab..810bcc600c0 100644 --- a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs +++ b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs @@ -33,6 +33,18 @@ module Cardano.Ledger.Alonzo.HuddleSpec ( ) where import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Huddle.Gen ( + MonadGen (choose), + RuleTerm (..), + Term (..), + genArrayTerm, + generateFromGRef, + liftAntiGen, + listOf, + oneof, + scale, + (|!), + ) import Cardano.Ledger.Mary.HuddleSpec import Data.Proxy (Proxy (..)) import Data.Word (Word64) @@ -129,19 +141,44 @@ requiredSignersRule pname p = pname =.= huddleRule1 @"set" p (huddleRule @"addr_ constr :: IsType0 a => Proxy "constr" -> a -> GRuleCall constr pname = binding $ \x -> - pname - =.= - -- We use 'unType0 . toType0' to convert each 'Tagged ArrayChoice' to 'Choice Type2', - -- making the list homogeneous so that 'foldl1 (/)' can be used. - -- Ideally, we should have used `toChoice`, but it's not exported by `cuddle`. - foldl1 - (/) - ( fmap - (unType0 . toType0) - ( tag 102 (arr [a VUInt, a $ arr [0 <+ a x]]) - : [tag t (arr [0 <+ a x]) | t <- [121 .. 127] ++ [1280 .. 1400]] - ) - ) + comment + [str|In reality the supported tags are 121..127, 1280..1400 and 101. + |We only list some of the possible tags here. + |] + . withCBORGen (generator x) + $ pname + =.= + -- We use 'unType0 . toType0' to convert each 'Tagged ArrayChoice' to 'Choice Type2', + -- making the list homogeneous so that 'foldl1 (/)' can be used. + -- Ideally, we should have used `toChoice`, but it's not exported by `cuddle`. + foldl1 + (/) + ( fmap + (unType0 . toType0) + ( tag 102 (arr [a VUInt, a $ arr [0 <+ a x]]) + : [tag t (arr [0 <+ a x]) | t <- [121 .. 127] ++ [1280 .. 1400]] + ) + ) + where + generator ref = do + t <- + liftAntiGen $ + oneof [choose (121, 127), choose (1280, 1400)] + |! oneof [choose (0, 120), choose (128, 1279), choose (1401, 0xffffffffffffffff)] + let + unwrapElems = traverse $ \case + SingleTerm e -> pure e + _ -> error "Expected single term" + elems <- + scale (`div` 2) $ + if t == 101 + then do + uInt <- TInt <$> choose (0, 2 ^ (64 :: Int) - 1) + elems <- genArrayTerm =<< unwrapElems =<< listOf (generateFromGRef ref) + pure . SingleTerm <$> genArrayTerm [uInt, elems] + else listOf $ generateFromGRef ref + singleElems <- unwrapElems elems + SingleTerm . TTagged t <$> genArrayTerm singleElems instance HuddleGroup "operational_cert" AlonzoEra where huddleGroupNamed = shelleyOperationalCertGroup diff --git a/eras/babbage/impl/cddl/data/babbage.cddl b/eras/babbage/impl/cddl/data/babbage.cddl index 86fb9840d04..f37a3ac74b6 100644 --- a/eras/babbage/impl/cddl/data/babbage.cddl +++ b/eras/babbage/impl/cddl/data/babbage.cddl @@ -167,6 +167,8 @@ plutus_data = / big_int / bounded_bytes +;In reality the supported tags are 121..127, 1280..1400 and 101. +;We only list some of the possible tags here. constr = #6.102([uint, [* a0]]) / #6.121([* a0]) diff --git a/eras/conway/impl/cddl/data/conway.cddl b/eras/conway/impl/cddl/data/conway.cddl index f2216d9fe26..ba82b4fcf59 100644 --- a/eras/conway/impl/cddl/data/conway.cddl +++ b/eras/conway/impl/cddl/data/conway.cddl @@ -212,6 +212,8 @@ plutus_data = / big_int / bounded_bytes +;In reality the supported tags are 121..127, 1280..1400 and 101. +;We only list some of the possible tags here. constr = #6.102([uint, [* a0]]) / #6.121([* a0]) diff --git a/eras/dijkstra/impl/cddl/data/dijkstra.cddl b/eras/dijkstra/impl/cddl/data/dijkstra.cddl index 52c156080ba..259df466bd7 100644 --- a/eras/dijkstra/impl/cddl/data/dijkstra.cddl +++ b/eras/dijkstra/impl/cddl/data/dijkstra.cddl @@ -211,6 +211,8 @@ plutus_data = / big_int / bounded_bytes +;In reality the supported tags are 121..127, 1280..1400 and 101. +;We only list some of the possible tags here. constr = #6.102([uint, [* a0]]) / #6.121([* a0]) diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index 22065c2714b..36731020aac 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -49,11 +49,9 @@ spec = do -- Value fullCddlSpec @(Value DijkstraEra) v "value" -- TxBody TopTx - xdescribe "fix TxBody" $ do - fullAnnCddlSpec @(TxBody TopTx DijkstraEra) v "transaction_body" + fullAnnCddlSpec @(TxBody TopTx DijkstraEra) v "transaction_body" -- TxBody SubTx - xdescribe "fix TxBody" $ do - fullAnnCddlSpec @(TxBody SubTx DijkstraEra) v "sub_transaction_body" + fullAnnCddlSpec @(TxBody SubTx DijkstraEra) v "sub_transaction_body" -- TxAuxData fullAnnCddlSpec @(TxAuxData DijkstraEra) v "auxiliary_data" -- NativeScript @@ -76,8 +74,7 @@ spec = do -- Redeemers fullAnnGenCddlSpec @(Redeemers DijkstraEra) genNonEmptyRedeemers v "redeemers" -- Tx - xdescribe "fix Transaction" $ do - fullAnnCddlSpec @(Tx TopTx DijkstraEra) v "transaction" + fullAnnCddlSpec @(Tx TopTx DijkstraEra) v "transaction" -- VotingProcedure fullCddlSpec @(VotingProcedure DijkstraEra) v "voting_procedure" -- ProposalProcedure diff --git a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs b/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs index adbc5d9b776..b0722ef0d9b 100644 --- a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs +++ b/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Cardano.Ledger.Huddle.Gen ( -- * MonadGen @@ -14,7 +15,11 @@ module Cardano.Ledger.Huddle.Gen ( -- * Term generators module CustomGen, Term (..), + RuleTerm (..), + Name (..), genRule, + generateFromName, + generateFromGRef, genArrayTerm, genBytesTerm, genStringTerm, @@ -22,6 +27,16 @@ module Cardano.Ledger.Huddle.Gen ( -- * Term validators module CustomValidator, + validateFromName, + validateFromGRef, + validateInt, + validateUInt, + validateNInt, + validateArrayTerm, + validateBytesTerm, + validateStringTerm, + validateMapTerm, + unwrapSingle, -- * Lifted generators arbitrary, @@ -34,14 +49,17 @@ module Cardano.Ledger.Huddle.Gen ( import Cardano.Ledger.Binary (Term (..)) import Cardano.Ledger.Huddle (HuddleRule ()) -import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName) +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.CTree (nintMin, uintMax) import Codec.CBOR.Cuddle.CDDL.Custom.Core as CustomCore import Codec.CBOR.Cuddle.CDDL.Custom.Generator as CustomGen import Codec.CBOR.Cuddle.CDDL.Custom.Validator as CustomValidator import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS import Data.Proxy (Proxy (..)) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import GHC.TypeLits (symbolVal) @@ -78,3 +96,47 @@ genStringTerm t = GenT.elements [TString t, TStringI $ LT.fromStrict t] genMapTerm :: MonadGen m => [(Term, Term)] -> m Term genMapTerm m = GenT.elements [TMap m, TMapI m] + +-- Term validators + +validateInt :: Term -> Validator Integer +validateInt (TInt (toInteger -> x)) + | x >= nintMin || x <= uintMax = pure x + | otherwise = fail "Number not in int range" +validateInt _ = fail "Expected int" + +validateUInt :: Term -> Validator Integer +validateUInt (TInt (toInteger -> x)) + | x >= 0 || x <= uintMax = pure x + | otherwise = fail "Number not in uint range" +validateUInt _ = fail "Expected uint" + +validateNInt :: Term -> Validator Integer +validateNInt (TInt (toInteger -> x)) + | x >= nintMin || x < 0 = pure x + | otherwise = fail "Number not in nint range" +validateNInt _ = fail "Expected nint" + +validateArrayTerm :: Term -> Validator [Term] +validateArrayTerm (TList xs) = pure xs +validateArrayTerm (TListI xs) = pure xs +validateArrayTerm _ = fail "Expected list" + +validateBytesTerm :: Term -> Validator ByteString +validateBytesTerm (TBytes bs) = pure bs +validateBytesTerm (TBytesI bs) = pure $ LBS.toStrict bs +validateBytesTerm _ = fail "Expected bytes" + +validateStringTerm :: Term -> Validator Text +validateStringTerm (TString x) = pure x +validateStringTerm (TStringI x) = pure $ LT.toStrict x +validateStringTerm _ = fail "Expected string" + +validateMapTerm :: Term -> Validator [(Term, Term)] +validateMapTerm (TMap xs) = pure xs +validateMapTerm (TMapI xs) = pure xs +validateMapTerm _ = fail "Expected map" + +unwrapSingle :: RuleTerm -> Validator Term +unwrapSingle (SingleTerm x) = pure x +unwrapSingle _ = fail "Expected a single term" From 73e6994a2992ea58791cd532f22cd48ef0364ea1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Thu, 30 Apr 2026 14:46:07 +0300 Subject: [PATCH 2/9] Add custom generator and validator for sets --- .../lib/Cardano/Ledger/Conway/HuddleSpec.hs | 43 ++++++++++++++++++- .../impl/cardano-ledger-dijkstra.cabal | 1 + .../Ledger/Dijkstra/Binary/CddlSpec.hs | 32 ++++++-------- .../cddl/Cardano/Ledger/Huddle/Gen.hs | 21 +++++++++ .../cardano-ledger-repl-environment.cabal | 7 ++- 5 files changed, 81 insertions(+), 23 deletions(-) diff --git a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs index c2d61247a59..080745833ef 100644 --- a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs +++ b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLists #-} @@ -11,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Conway.HuddleSpec ( @@ -83,17 +85,29 @@ import Cardano.Ledger.Huddle.Gen ( MonadGen (choose, resize), RuleTerm (..), Term (..), + antiChoose, + antiVectorOfUnique, + arbitrary, + faultyNum, genArrayTerm, genMapTerm, genRule, + generateFromGRef, liftAntiGen, oneof, replicateMNorm, shuffle, + unwrapSingle, + unwrapSingleOrError, + validateArrayTerm, + validateFromGRef, withAntiGen, (|!), ) import Cardano.Ledger.Huddle.Gen qualified as Gen +import Control.Monad (unless) +import Data.Foldable (traverse_) +import Data.List (nub) import Data.Proxy (Proxy (..)) import Data.Traversable (forM) import Data.Word (Word64) @@ -707,8 +721,33 @@ conwayRedeemer pname p = ] mkMaybeTaggedSet :: - forall name a. (KnownSymbol name, IsType0 a) => Proxy name -> Word64 -> a -> GRuleCall -mkMaybeTaggedSet pname n = binding $ \x -> pname =.= tag 258 (arr [n <+ a x]) / sarr [n <+ a x] + forall name a. (KnownSymbol name, IsType0 a) => Proxy name -> Int -> a -> GRuleCall +mkMaybeTaggedSet pname n = binding $ \x -> + withCBORGen (generator x) + . withValidator (validator x) + $ pname =.= tag 258 (arr [fromIntegral n <+ a x]) / sarr [fromIntegral n <+ a x] + where + generator :: GRef -> CBORGen RuleTerm + generator ref = do + nElems <- liftAntiGen . Gen.sized $ \(fromIntegral -> sz) -> antiChoose (n, sz) (0, sz) + elems <- withAntiGen (antiVectorOfUnique nElems) $ unwrapSingleOrError <$> generateFromGRef ref + elemsArr <- genArrayTerm elems + tagged <- arbitrary + if tagged + then do + t <- liftAntiGen $ faultyNum 258 + pure . SingleTerm $ TTagged t elemsArr + else pure $ SingleTerm elemsArr + validator ref term = do + term_ <- unwrapSingle term + let + validateInner t = do + elems <- validateArrayTerm t + unless (elems == nub elems) $ fail "not all elements are unique" + traverse_ (validateFromGRef ref) elems + case term_ of + TTagged t x | t == 258 -> validateInner x + x -> validateInner x maybeTaggedSet :: IsType0 a => Proxy "set" -> a -> GRuleCall maybeTaggedSet pname = mkMaybeTaggedSet pname 0 diff --git a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal index 574a5eacfb1..6037dc9aaa3 100644 --- a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal @@ -265,6 +265,7 @@ test-suite tests build-depends: base, + cardano-data, cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, cardano-ledger-babbage:testlib, cardano-ledger-binary:testlib, diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index 36731020aac..d2f0c15666c 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -9,13 +9,20 @@ module Test.Cardano.Ledger.Dijkstra.Binary.CddlSpec (spec) where import Cardano.Ledger.Alonzo.Scripts (CostModels) import Cardano.Ledger.Alonzo.TxWits (Redeemers) -import Cardano.Ledger.Conway.Governance (GovAction, ProposalProcedure, VotingProcedure) +import Cardano.Ledger.Conway.Governance ( + GovAction, + ProposalProcedure, + VotingProcedure, + VotingProcedures, + ) import Cardano.Ledger.Core +import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.HuddleSpec (dijkstraCDDL) import Cardano.Ledger.Dijkstra.Scripts (AccountBalanceInterval, AccountBalanceIntervals) import Cardano.Ledger.Dijkstra.Tx (Tx (..)) import Cardano.Ledger.Plutus.Data (Data, Datum) +import Data.OSet.Strict (OSet) import Test.Cardano.Ledger.Alonzo.Arbitrary (genDatumPresent, genNonEmptyRedeemers) import Test.Cardano.Ledger.Binary.Cuddle ( noTwiddle, @@ -41,45 +48,30 @@ spec = do fullAnnCddlSpec @(BlockBody DijkstraEra) v "block_body" -- AccountBalanceInterval fullCddlSpec @(AccountBalanceInterval DijkstraEra) v "account_balance_interval" - -- AccountBalanceIntervals fullGenCddlSpec @(AccountBalanceIntervals DijkstraEra) genNonEmptyAccountBalanceIntervals v "account_balance_intervals" - -- Value fullCddlSpec @(Value DijkstraEra) v "value" - -- TxBody TopTx fullAnnCddlSpec @(TxBody TopTx DijkstraEra) v "transaction_body" - -- TxBody SubTx fullAnnCddlSpec @(TxBody SubTx DijkstraEra) v "sub_transaction_body" - -- TxAuxData fullAnnCddlSpec @(TxAuxData DijkstraEra) v "auxiliary_data" - -- NativeScript fullAnnCddlSpec @(NativeScript DijkstraEra) v "native_script" - -- Data fullAnnCddlSpec @(Data DijkstraEra) v "plutus_data" - -- TxOut fullCddlSpec @(TxOut DijkstraEra) v "transaction_output" - -- Script fullAnnCddlSpec @(Script DijkstraEra) v "script" - -- Datum fullGenCddlSpec @(Datum DijkstraEra) genDatumPresent v "datum_option" - -- TxWits xdescribe "fix plutus_v4_script" $ do fullAnnCddlSpec @(TxWits DijkstraEra) v "transaction_witness_set" - -- PParamsUpdate fullCddlSpec @(PParamsUpdate DijkstraEra) v "protocol_param_update" - -- CostModels fullCddlSpec @CostModels v "cost_models" - -- Redeemers fullAnnGenCddlSpec @(Redeemers DijkstraEra) genNonEmptyRedeemers v "redeemers" - -- Tx fullAnnCddlSpec @(Tx TopTx DijkstraEra) v "transaction" - -- VotingProcedure fullCddlSpec @(VotingProcedure DijkstraEra) v "voting_procedure" - -- ProposalProcedure fullCddlSpec @(ProposalProcedure DijkstraEra) v "proposal_procedure" - -- GovAction fullCddlSpec @(GovAction DijkstraEra) v "gov_action" - -- TxCert fullCddlSpec @(TxCert DijkstraEra) v "certificate" + fullCddlSpec @(OSet (TxCert DijkstraEra)) v "certificates" + fullCddlSpec @(OSet (ProposalProcedure DijkstraEra)) v "proposal_procedures" + fullCddlSpec @(OSet (Credential Guard)) v "guards" + fullCddlSpec @(VotingProcedures DijkstraEra) v "voting_procedures" diff --git a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs b/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs index b0722ef0d9b..98dc74d2da4 100644 --- a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs +++ b/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs @@ -24,6 +24,7 @@ module Cardano.Ledger.Huddle.Gen ( genBytesTerm, genStringTerm, genMapTerm, + unwrapSingleOrError, -- * Term validators module CustomValidator, @@ -45,6 +46,7 @@ module Cardano.Ledger.Huddle.Gen ( -- * Antigen module AntiGen, + antiVectorOfUnique, ) where import Cardano.Ledger.Binary (Term (..)) @@ -85,6 +87,21 @@ shuffle = liftGen . QC.shuffle -- Term generators +antiVectorOfUnique :: Eq a => Int -> AntiGen a -> AntiGen [a] +antiVectorOfUnique n gen = do + disallowDuplicates <- faultyBool True + let + triesPerElement = 10 :: Int + go _ 0 _ = QC.discard + go m tries elems + | m > 0 = do + x <- gen + if disallowDuplicates && x `elem` elems + then go m (tries - 1) elems + else go (m - 1) triesPerElement (x : elems) + | otherwise = pure elems + go n triesPerElement [] + genArrayTerm :: MonadGen m => [Term] -> m Term genArrayTerm es = GenT.elements [TList es, TListI es] @@ -140,3 +157,7 @@ validateMapTerm _ = fail "Expected map" unwrapSingle :: RuleTerm -> Validator Term unwrapSingle (SingleTerm x) = pure x unwrapSingle _ = fail "Expected a single term" + +unwrapSingleOrError :: RuleTerm -> Term +unwrapSingleOrError (SingleTerm x) = x +unwrapSingleOrError _ = error "Expected a single term" diff --git a/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal b/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal index 374f2138d5a..ecd70fba543 100644 --- a/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal +++ b/libs/cardano-ledger-repl-environment/cardano-ledger-repl-environment.cabal @@ -20,8 +20,13 @@ library cardano-ledger-alonzo, cardano-ledger-api:{cardano-ledger-api, testlib}, cardano-ledger-babbage, - cardano-ledger-binary, + cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-conformance, + cardano-ledger-dijkstra:{cardano-ledger-dijkstra, cddl}, + antigen, + cuddle, + deepseq, + text, cardano-ledger-conway:{cardano-ledger-conway, testlib}, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-mary, From 24e6d748ef65a16f96eda88d094aad7da40ad297 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Thu, 30 Apr 2026 16:32:46 +0300 Subject: [PATCH 3/9] fixed voting_procedures failure by generating correct arbitrary values --- .../lib/Cardano/Ledger/Conway/HuddleSpec.hs | 21 ++++++++------ .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 6 ++++ .../impl/cardano-ledger-dijkstra.cabal | 4 +-- .../lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs | 28 ++++++++++++++----- .../Ledger/Dijkstra/Binary/CddlSpec.hs | 3 +- 5 files changed, 43 insertions(+), 19 deletions(-) diff --git a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs index 080745833ef..f3c2fae8a70 100644 --- a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs +++ b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs @@ -67,6 +67,7 @@ module Cardano.Ledger.Conway.HuddleSpec ( maybeTaggedNonemptySet, maybeTaggedNonemptyOset, conwayCostModelsGenerator, + generateMaybeTaggedSet, ) where import Cardano.Ledger.Babbage.HuddleSpec hiding ( @@ -720,6 +721,17 @@ conwayRedeemer pname p = , "ex_units" ==> huddleRule @"ex_units" p ] +generateMaybeTaggedSet :: Int -> CBORGen Term -> CBORGen Term +generateMaybeTaggedSet nElems gen = do + elems <- withAntiGen (antiVectorOfUnique nElems) gen + elemsArr <- genArrayTerm elems + tagged <- arbitrary + if tagged + then do + t <- liftAntiGen $ faultyNum 258 + pure $ TTagged t elemsArr + else pure elemsArr + mkMaybeTaggedSet :: forall name a. (KnownSymbol name, IsType0 a) => Proxy name -> Int -> a -> GRuleCall mkMaybeTaggedSet pname n = binding $ \x -> @@ -730,14 +742,7 @@ mkMaybeTaggedSet pname n = binding $ \x -> generator :: GRef -> CBORGen RuleTerm generator ref = do nElems <- liftAntiGen . Gen.sized $ \(fromIntegral -> sz) -> antiChoose (n, sz) (0, sz) - elems <- withAntiGen (antiVectorOfUnique nElems) $ unwrapSingleOrError <$> generateFromGRef ref - elemsArr <- genArrayTerm elems - tagged <- arbitrary - if tagged - then do - t <- liftAntiGen $ faultyNum 258 - pure . SingleTerm $ TTagged t elemsArr - else pure $ SingleTerm elemsArr + fmap SingleTerm . generateMaybeTaggedSet nElems $ unwrapSingleOrError <$> generateFromGRef ref validator ref term = do term_ <- unwrapSingle term let diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index 80fe95bfe29..8010b847b55 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -31,6 +31,7 @@ module Test.Cardano.Ledger.Conway.Arbitrary ( genCommitteeGovAction, genConstitutionGovAction, genProposals, + genNonEmptyVotingProcedures, ProposalsNewActions (..), ProposalsForEnactment (..), ShuffledGovActionStates (..), @@ -897,3 +898,8 @@ instance Arbitrary (TransitionConfig ConwayEra) where deriving newtype instance Arbitrary (Tx TopTx ConwayEra) deriving newtype instance Arbitrary (ApplyTxError ConwayEra) + +genNonEmptyVotingProcedures :: Era era => Gen (VotingProcedures era) +genNonEmptyVotingProcedures = + VotingProcedures . Map.fromList <$> do + listOf1 $ (,) <$> arbitrary <*> (Map.fromList <$> listOf1 arbitrary) diff --git a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal index 6037dc9aaa3..3bcdd661b47 100644 --- a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal @@ -210,16 +210,14 @@ library cddl -Wunused-packages build-depends: - QuickCheck, antigen, base, + cardano-ledger-core:cddl, cardano-ledger-conway:cddl, cardano-ledger-core:cddl, cardano-ledger-dijkstra, cborg, - cuddle, heredoc, - quickcheck-transformer, text, executable generate-cddl diff --git a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs index 96e8dbe3a49..8da955c2f8d 100644 --- a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs +++ b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs @@ -34,8 +34,19 @@ module Cardano.Ledger.Dijkstra.HuddleSpec ( import Cardano.Ledger.Conway.HuddleSpec hiding () import Cardano.Ledger.Dijkstra (DijkstraEra) -import Cardano.Ledger.Huddle.Gen (CBORGen, RuleTerm (..), genArrayTerm, liftAntiGen, withAntiGen) -import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName) +import Cardano.Ledger.Huddle.Gen ( + CBORGen, + MonadGen (choose, liftGen), + RuleTerm (..), + genArrayTerm, + genRule, + generateFromName, + liftAntiGen, + scale, + shuffle, + withAntiGen, + ) +import Cardano.Ledger.Huddle.Gen qualified as Gen import Codec.CBOR.Term (Term (..)) import Control.Monad (zipWithM) import Data.Proxy (Proxy (..)) @@ -43,9 +54,6 @@ import Data.Text () import Data.Text qualified as T import Data.Word (Word16, Word64) import Test.AntiGen (withAnnotation, (|!)) -import Test.QuickCheck (choose, shuffle) -import Test.QuickCheck qualified as QC -import Test.QuickCheck.GenT (liftGen) import Text.Heredoc import Prelude hiding ((/)) @@ -92,7 +100,13 @@ subTransactionsRule :: Proxy era -> Rule subTransactionsRule pname p = - pname =.= huddleRule1 @"nonempty_oset" p (huddleRule @"sub_transaction" p) + withCBORGen generate $ + pname =.= huddleRule1 @"nonempty_oset" p (huddleRule @"sub_transaction" p) + where + generate = do + -- Limit the number of subtransactions generated to max 3, since they are quite large + nElems <- Gen.sized $ \sz -> choose (0, min sz 3) + SingleTerm <$> generateMaybeTaggedSet nElems (scale (`div` 2) $ genRule @"sub_transaction" @era) subTransactionRule :: forall era. @@ -890,7 +904,7 @@ instance HuddleRule "block_body" DijkstraEra where blockBodyGen :: CBORGen RuleTerm blockBodyGen = do - numTxs <- liftGen . QC.sized $ \s -> choose (0 :: Int, s) + numTxs <- liftGen . Gen.sized $ \s -> choose (0 :: Int, s) txs <- mapM (\i -> withAntiGen (withAnnotation (T.pack $ show i)) $ generateFromName "transaction") diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index d2f0c15666c..d96eae438c0 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -29,6 +29,7 @@ import Test.Cardano.Ledger.Binary.Cuddle ( specWithHuddle, ) import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary (genNonEmptyVotingProcedures) import Test.Cardano.Ledger.Core.Binary ( fullAnnCddlSpec, fullAnnGenCddlSpec, @@ -74,4 +75,4 @@ spec = do fullCddlSpec @(OSet (TxCert DijkstraEra)) v "certificates" fullCddlSpec @(OSet (ProposalProcedure DijkstraEra)) v "proposal_procedures" fullCddlSpec @(OSet (Credential Guard)) v "guards" - fullCddlSpec @(VotingProcedures DijkstraEra) v "voting_procedures" + fullGenCddlSpec @(VotingProcedures DijkstraEra) genNonEmptyVotingProcedures v "voting_procedures" From 053543c3e6e6ec93aa8943536a3bffd9a5c18121 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Thu, 30 Apr 2026 16:45:25 +0300 Subject: [PATCH 4/9] Removed guards test --- .../impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index d96eae438c0..eb3f0d108c3 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -16,7 +16,6 @@ import Cardano.Ledger.Conway.Governance ( VotingProcedures, ) import Cardano.Ledger.Core -import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.HuddleSpec (dijkstraCDDL) import Cardano.Ledger.Dijkstra.Scripts (AccountBalanceInterval, AccountBalanceIntervals) @@ -74,5 +73,4 @@ spec = do fullCddlSpec @(TxCert DijkstraEra) v "certificate" fullCddlSpec @(OSet (TxCert DijkstraEra)) v "certificates" fullCddlSpec @(OSet (ProposalProcedure DijkstraEra)) v "proposal_procedures" - fullCddlSpec @(OSet (Credential Guard)) v "guards" fullGenCddlSpec @(VotingProcedures DijkstraEra) genNonEmptyVotingProcedures v "voting_procedures" From 4d39c8bead0dfb9846fb6d4ed266f486c7952b99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 5 May 2026 17:40:06 +0300 Subject: [PATCH 5/9] Fix mkMaybeTaggedSet generator --- eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs index f3c2fae8a70..128a03e19f5 100644 --- a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs +++ b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs @@ -741,7 +741,8 @@ mkMaybeTaggedSet pname n = binding $ \x -> where generator :: GRef -> CBORGen RuleTerm generator ref = do - nElems <- liftAntiGen . Gen.sized $ \(fromIntegral -> sz) -> antiChoose (n, sz) (0, sz) + nElems <- liftAntiGen . Gen.sized $ \sz -> + let sz' = max n sz in antiChoose (n, sz') (0, sz') fmap SingleTerm . generateMaybeTaggedSet nElems $ unwrapSingleOrError <$> generateFromGRef ref validator ref term = do term_ <- unwrapSingle term From e9d010b04e7cc96b360f399c61048d3c74d1170c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 5 May 2026 19:10:14 +0300 Subject: [PATCH 6/9] Make gen*Term helpers respect the twiddle flag --- .../lib/Cardano/Ledger/Conway/HuddleSpec.hs | 4 +- .../lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs | 4 +- .../cardano-ledger-core.cabal | 1 + .../cddl/Cardano/Ledger/Huddle/Gen.hs | 66 +++++++++++++++---- 4 files changed, 61 insertions(+), 14 deletions(-) diff --git a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs b/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs index 128a03e19f5..4840d57419d 100644 --- a/eras/conway/impl/cddl/lib/Cardano/Ledger/Conway/HuddleSpec.hs +++ b/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 diff --git a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs index 8da955c2f8d..d8210687823 100644 --- a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs +++ b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs @@ -105,7 +105,7 @@ subTransactionsRule pname p = where generate = do -- Limit the number of subtransactions generated to max 3, since they are quite large - nElems <- Gen.sized $ \sz -> choose (0, min sz 3) + nElems <- Gen.sized $ \sz -> choose (1, max 1 (min sz 3)) SingleTerm <$> generateMaybeTaggedSet nElems (scale (`div` 2) $ genRule @"sub_transaction" @era) subTransactionRule :: @@ -931,7 +931,7 @@ blockBodyGen = do invalidTxIxsTerm <- genArrayTerm $ TInteger . toInteger <$> invalidIxIxs txsTerm <- withAntiGen (withAnnotation "transactions") $ genArrayTerm txs perasCertTerm <- generateFromName "peras_certificate" - SingleTerm <$> liftGen (genArrayTerm [invalidTxIxsTerm, txsTerm, perasCertTerm]) + SingleTerm <$> genArrayTerm [invalidTxIxsTerm, txsTerm, perasCertTerm] instance HuddleRule "auxiliary_scripts" DijkstraEra where huddleRuleNamed = auxiliaryScriptsRule diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index eca350c6759..c465c2fd89a 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -204,6 +204,7 @@ library cddl cuddle >=1.7, heredoc, mempack, + mtl, quickcheck-transformer, text >=2.0, diff --git a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs b/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs index 98dc74d2da4..b3683df88fe 100644 --- a/libs/cardano-ledger-core/cddl/Cardano/Ledger/Huddle/Gen.hs +++ b/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 #-} @@ -24,6 +25,7 @@ module Cardano.Ledger.Huddle.Gen ( genBytesTerm, genStringTerm, genMapTerm, + canonicalizeTerm, unwrapSingleOrError, -- * Term validators @@ -58,8 +60,11 @@ import Codec.CBOR.Cuddle.CDDL.CTree (nintMin, uintMax) import Codec.CBOR.Cuddle.CDDL.Custom.Core as CustomCore import Codec.CBOR.Cuddle.CDDL.Custom.Generator as CustomGen import Codec.CBOR.Cuddle.CDDL.Custom.Validator as CustomValidator +import Control.Monad.Reader (asks) +import Data.Bifunctor (Bifunctor (..)) 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 @@ -102,17 +107,56 @@ antiVectorOfUnique n gen = do | otherwise = pure elems go n triesPerElement [] -genArrayTerm :: MonadGen m => [Term] -> m Term -genArrayTerm es = GenT.elements [TList es, TListI es] - -genBytesTerm :: MonadGen m => ByteString -> m Term -genBytesTerm bs = GenT.elements [TBytes bs, TBytesI $ LBS.fromStrict bs] - -genStringTerm :: MonadGen m => T.Text -> m Term -genStringTerm t = GenT.elements [TString t, TStringI $ LT.fromStrict t] - -genMapTerm :: MonadGen m => [(Term, Term)] -> m Term -genMapTerm m = GenT.elements [TMap m, TMapI m] +-- | Definite-length unless twiddling is on; canonical form is required so +-- that uniqueness checks for set/map elements compare semantically. +genArrayTerm :: [Term] -> CBORGen Term +genArrayTerm es = + ifTwiddle (GenT.elements [TList es, TListI es]) (pure $ TList es) + +genBytesTerm :: ByteString -> CBORGen Term +genBytesTerm bs = + ifTwiddle (GenT.elements [TBytes bs, TBytesI $ LBS.fromStrict bs]) (pure $ TBytes bs) + +genStringTerm :: T.Text -> CBORGen Term +genStringTerm t = + ifTwiddle (GenT.elements [TString t, TStringI $ LT.fromStrict t]) (pure $ TString t) + +genMapTerm :: [(Term, Term)] -> CBORGen Term +genMapTerm m = + ifTwiddle (GenT.elements [TMap m, TMapI m]) (pure $ TMap m) + +ifTwiddle :: CBORGen a -> CBORGen a -> CBORGen a +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 From b4162e865b1e2ca217193a10f2fcf95b40427cf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Tue, 5 May 2026 20:38:47 +0300 Subject: [PATCH 7/9] Fix sub_transactions generator --- .../lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs | 25 +++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs index d8210687823..1221fcfdd37 100644 --- a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs +++ b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs @@ -49,6 +49,7 @@ import Cardano.Ledger.Huddle.Gen ( import Cardano.Ledger.Huddle.Gen qualified as Gen import Codec.CBOR.Term (Term (..)) import Control.Monad (zipWithM) +import Data.Maybe (mapMaybe) import Data.Proxy (Proxy (..)) import Data.Text () import Data.Text qualified as T @@ -103,10 +104,30 @@ subTransactionsRule pname p = withCBORGen generate $ pname =.= huddleRule1 @"nonempty_oset" p (huddleRule @"sub_transaction" p) where + -- The Haskell representation is @OMap TxId (Tx SubTx era)@: dedup is by + -- body hash, so generated sub_transactions must have distinct bodies, not + -- just distinct full @[body, witness, aux]@ tuples. generate = do - -- Limit the number of subtransactions generated to max 3, since they are quite large nElems <- Gen.sized $ \sz -> choose (1, max 1 (min sz 3)) - SingleTerm <$> generateMaybeTaggedSet nElems (scale (`div` 2) $ genRule @"sub_transaction" @era) + let subTxGen = scale (`div` 2) $ genRule @"sub_transaction" @era + txs <- uniqueByBody nElems subTxGen + elemsArr <- genArrayTerm txs + tagged <- Gen.arbitrary + pure $ SingleTerm $ if tagged then TTagged 258 elemsArr else elemsArr + uniqueByBody :: Int -> CBORGen Term -> CBORGen [Term] + uniqueByBody n gen = loop [] n + where + triesPerElement = 20 :: Int + loop acc 0 = pure acc + loop acc k = attempt triesPerElement acc k + attempt 0 acc _ = pure acc + attempt tries acc k = do + tx <- gen + case bodyOf tx of + Just b | b `notElem` mapMaybe bodyOf acc -> loop (tx : acc) (k - 1) + _ -> attempt (tries - 1) acc k + bodyOf (TList (b : _)) = Just b + bodyOf _ = Nothing subTransactionRule :: forall era. From 568a88c176f79afb8a254a1a43d4c0ceb59f6fda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Wed, 6 May 2026 16:26:43 +0300 Subject: [PATCH 8/9] bump cuddle to 1.7.0.0 --- eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs index 810bcc600c0..0617e3ca39a 100644 --- a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs +++ b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs @@ -37,6 +37,7 @@ import Cardano.Ledger.Huddle.Gen ( MonadGen (choose), RuleTerm (..), Term (..), + RuleTerm (..), genArrayTerm, generateFromGRef, liftAntiGen, From 2b2085f8f85e84333fd9f2af8c45377e011ca9f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Wed, 6 May 2026 18:18:42 +0300 Subject: [PATCH 9/9] Scale down tests to make test suites run faster --- .../lib/Cardano/Ledger/Alonzo/HuddleSpec.hs | 1 - .../lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs | 7 +++++-- .../Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs | 10 +++++----- .../Test/Cardano/Ledger/Dijkstra/Arbitrary.hs | 18 +++++++++++++++++- 4 files changed, 27 insertions(+), 9 deletions(-) diff --git a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs index 0617e3ca39a..810bcc600c0 100644 --- a/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs +++ b/eras/alonzo/impl/cddl/lib/Cardano/Ledger/Alonzo/HuddleSpec.hs @@ -37,7 +37,6 @@ import Cardano.Ledger.Huddle.Gen ( MonadGen (choose), RuleTerm (..), Term (..), - RuleTerm (..), genArrayTerm, generateFromGRef, liftAntiGen, diff --git a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs index 1221fcfdd37..d0d0261ddc5 100644 --- a/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs +++ b/eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs @@ -925,10 +925,13 @@ instance HuddleRule "block_body" DijkstraEra where blockBodyGen :: CBORGen RuleTerm blockBodyGen = do - numTxs <- liftGen . Gen.sized $ \s -> choose (0 :: Int, s) + numTxs <- liftGen . Gen.sized $ \s -> choose (0 :: Int, s `div` 15) txs <- mapM - (\i -> withAntiGen (withAnnotation (T.pack $ show i)) $ generateFromName "transaction") + ( \i -> + withAntiGen (withAnnotation (T.pack $ show i)) . scale (`div` max 1 numTxs) $ + generateFromName "transaction" + ) [0 .. numTxs - 1] invalidIxIxs <- if numTxs == 0 diff --git a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs index eb3f0d108c3..7da1742377e 100644 --- a/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs +++ b/eras/dijkstra/impl/test/Test/Cardano/Ledger/Dijkstra/Binary/CddlSpec.hs @@ -35,7 +35,10 @@ import Test.Cardano.Ledger.Core.Binary ( fullCddlSpec, fullGenCddlSpec, ) -import Test.Cardano.Ledger.Dijkstra.Arbitrary (genNonEmptyAccountBalanceIntervals) +import Test.Cardano.Ledger.Dijkstra.Arbitrary ( + genNonEmptyAccountBalanceIntervals, + genSmallDijkstraBlockBody, + ) import Test.Cardano.Ledger.Dijkstra.Binary.Annotator () spec :: Spec @@ -43,10 +46,7 @@ spec = do describe "CDDL" $ do let v = eraProtVerHigh @DijkstraEra describe "Huddle" $ specWithHuddle dijkstraCDDL . noTwiddle $ do - -- BlockBody - xdescribe "fix transaction" $ - fullAnnCddlSpec @(BlockBody DijkstraEra) v "block_body" - -- AccountBalanceInterval + fullAnnGenCddlSpec @(BlockBody DijkstraEra) genSmallDijkstraBlockBody v "block_body" fullCddlSpec @(AccountBalanceInterval DijkstraEra) v "account_balance_interval" fullGenCddlSpec @(AccountBalanceIntervals DijkstraEra) genNonEmptyAccountBalanceIntervals diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs index a4887f71399..23ffdda3c95 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs @@ -14,7 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Cardano.Ledger.Dijkstra.Arbitrary (genNonEmptyAccountBalanceIntervals) where +module Test.Cardano.Ledger.Dijkstra.Arbitrary (genNonEmptyAccountBalanceIntervals, genSmallDijkstraBlockBody) where import Cardano.Ledger.Allegra.Scripts ( pattern RequireTimeExpire, @@ -40,6 +40,7 @@ import Cardano.Ledger.Shelley.Scripts (pattern RequireSignature) import Data.Functor.Identity (Identity) import qualified Data.Map.Strict as Map import qualified Data.OMap.Strict as OMap +import qualified Data.Sequence.Strict as SSeq import Data.Typeable (Typeable) import Generic.Random (genericArbitraryU) import Test.Cardano.Ledger.Allegra.Arbitrary (maxTimelockDepth) @@ -303,6 +304,21 @@ instance where arbitrary = DijkstraBlockBody <$> arbitrary <*> arbitrary +genSmallDijkstraBlockBody :: + ( AlonzoEraTx era + , Arbitrary (Tx TopTx era) + ) => + Gen (DijkstraBlockBody era) +genSmallDijkstraBlockBody = DijkstraBlockBody <$> genFewTxs <*> arbitrary + where + genFewTxs = sized $ \sz -> do + numTxs <- + frequency + [ (99, choose (1, max 1 $ sz `div` 20)) + , (1, pure 0) + ] + SSeq.fromList <$> vectorOf numTxs (scale (`div` numTxs) arbitrary) + deriving newtype instance Arbitrary (ApplyTxError DijkstraEra) instance Arbitrary (DijkstraMempoolPredFailure DijkstraEra) where