Fix various issues in Dijkstra CddlSpec to make all the tests pass

cabal.project

@@ -104,8 +104,8 @@ source-repository-package
   type: git
   location: https://github.com/tweag/cardano-cls.git
   subdir: merkle-tree-incremental mempack-scls scls-cbor scls-cardano scls-format scls-core
-  --sha256: sha256-XY9e1iqr8Kc7PXNKw1KPyJpEOIqIll+1ZrTg6WWhcJU=
-  tag: 310a407f572fd227020b598db5926e44a7365a1b
+  --sha256: sha256-3rAc99T2/MZk7Rd2gb9zq7iUM9hMDOzNvehOq/8hpfs=
+  tag: 8e2bba9442cb388089f53d708cc4aedcb47726ea
 
 constraints:
   -- Happy version 2.2.1 fails to compile haskell-src-exts

eras/alonzo/impl/cardano-ledger-alonzo.cabal

@@ -133,6 +133,7 @@ library cddl
   build-depends:
     base,
     cardano-ledger-alonzo,
+    cardano-ledger-core:cddl,
     cardano-ledger-mary:cddl,
     heredoc,
 

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,40 @@ 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]]
-            )
-        )
+    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 == 102
+            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

eras/conway/impl/CHANGELOG.md

@@ -43,10 +43,13 @@
 
 ### cddl
 
+* Change the second argument of `mkMaybeTaggedSet` to `Int`
+* Add `generateMaybeTaggedSet`
 * Extend `constr` CDDL rule to include tags 1280–1400 for Plutus `Data` constructor indexes
 
 ### `testlib`
 
+* Add `genNonEmptyVotingProcedures`
 * Add to `Test.Cardano.Ledger.Conway.Examples`:
   - `exampleConwayOnwardsEraPParams`
   - `exampleConwayOnwardsEraPParamsUpdate`

eras/conway/impl/cardano-ledger-conway.cabal

@@ -152,10 +152,12 @@ library cddl
     -Wunused-packages
 
   build-depends:
+    QuickCheck,
     base,
     cardano-ledger-babbage:cddl,
     cardano-ledger-conway,
     cardano-ledger-core:cddl,
+    containers,
     heredoc,
 
 executable generate-cddl

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 (
@@ -65,6 +67,7 @@ module Cardano.Ledger.Conway.HuddleSpec (
   maybeTaggedNonemptySet,
   maybeTaggedNonemptyOset,
   conwayCostModelsGenerator,
+  generateMaybeTaggedSet,
 ) where
 
 import Cardano.Ledger.Babbage.HuddleSpec hiding (
@@ -83,21 +86,35 @@ 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.Containers.ListUtils (nubOrd)
+import Data.Foldable (traverse_)
+import Data.Maybe (fromMaybe)
 import Data.Proxy (Proxy (..))
 import Data.Traversable (forM)
 import Data.Word (Word64)
 import GHC.TypeLits (KnownSymbol)
+import Test.QuickCheck qualified as QC
 import Text.Heredoc
 import Prelude hiding ((/))
 
@@ -706,9 +723,41 @@ conwayRedeemer pname p =
       , "ex_units" ==> huddleRule @"ex_units" p
       ]
 
+generateMaybeTaggedSet :: Int -> CBORGen Term -> CBORGen Term
+generateMaybeTaggedSet nElems gen = do
+  elems <- fromMaybe QC.discard <$> 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 -> 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 $ \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
+      let
+        validateInner t = do
+          elems <- validateArrayTerm t
+          unless (length elems == length (nubOrd 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

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)

eras/dijkstra/impl/CHANGELOG.md

@@ -72,6 +72,7 @@
 
 ### testlib
 
+* Add `genSmallDijkstraBlockBody`
 * Add to `Test.Cardano.Ledger.Dijkstra.Examples`:
   - `exampleDijkstraOnwardsEraPParams`
   - `exampleDijkstraOnwardsEraPParamsUpdate`

eras/dijkstra/impl/cardano-ledger-dijkstra.cabal

@@ -212,16 +212,13 @@ library cddl
     -Wunused-packages
 
   build-depends:
-    QuickCheck,
     antigen,
     base,
     cardano-ledger-conway:cddl,
     cardano-ledger-core:cddl,
     cardano-ledger-dijkstra,
     cborg,
-    cuddle,
     heredoc,
-    quickcheck-transformer,
     text,
 
 executable generate-cddl
@@ -285,6 +282,7 @@ test-suite tests
 
   build-depends:
     base,
+    cardano-data,
     cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib},
     cardano-ledger-babbage:testlib,
     cardano-ledger-binary:testlib,

eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs

@@ -34,18 +34,33 @@ 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),
+  Name (..),
+  RuleTerm (..),
+  genArrayTerm,
+  genRule,
+  generateFromName,
+  liftAntiGen,
+  scale,
+  shuffle,
+  unwrapSingle,
+  validateArrayTerm,
+  validateFromName,
+  withAntiGen,
+ )
+import Cardano.Ledger.Huddle.Gen qualified as Gen
 import Codec.CBOR.Term (Term (..))
-import Control.Monad (zipWithM)
+import Control.Monad (unless, zipWithM)
+import Data.Foldable (traverse_)
+import Data.List (nub)
+import Data.Maybe (mapMaybe)
 import Data.Proxy (Proxy (..))
 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 ((/))
 
@@ -93,7 +108,51 @@ subTransactionsRule ::
   Proxy era ->
   Rule
 subTransactionsRule pname p =
-  pname =.= huddleRule1 @"nonempty_oset" p (huddleRule @"sub_transaction" p)
+  withCBORGen generate
+    . withValidator validator
+    $ 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 both the generator and the validator must work in terms
+    -- of body equality, not full-element equality (which is what the generic
+    -- @nonempty_oset@ validator checks).
+    validator term = do
+      term_ <- unwrapSingle term
+      let
+        bodyOf (TList (b : _)) = Just b
+        bodyOf (TListI (b : _)) = Just b
+        bodyOf _ = Nothing
+        validateInner t = do
+          elems <- validateArrayTerm t
+          let bodies = mapMaybe bodyOf elems
+          unless (length bodies == length (nub bodies)) $
+            fail "duplicate sub_transaction bodies"
+          traverse_ (validateFromName (Name "sub_transaction")) elems
+      case term_ of
+        TTagged 258 x -> validateInner x
+        x -> validateInner x
+    generate = do
+      nElems <- Gen.sized $ \sz -> choose (1, max 1 (min sz 3))
+      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 (TListI (b : _)) = Just b
+        bodyOf _ = Nothing
 
 subTransactionRule ::
   forall era.
@@ -917,10 +976,13 @@ 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 `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
@@ -941,10 +1003,13 @@ blockBodyGen = do
         liftAntiGen $
           withAnnotation "invalid_transactions" $
             zipWithM faultyIndex [0 :: Int ..] txIndicesWithOverflow
-  invalidTxIxsTerm <- genArrayTerm $ TInteger . toInteger <$> invalidIxIxs
+  invalidTxIxsTerm <-
+    if null invalidIxIxs
+      then pure TNull
+      else 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