From 464ebd161789f57b71c69c896ca39cde2b457baf Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Fri, 8 Mar 2024 09:49:15 +0100
Subject: [PATCH 1/8] Switch from hedgehog -> QuickCheck.

Hedgehog actually has a nicer interface here. But
we do this for consistency with the cardano-ledger
package.
---
 cuddle.cabal                               |   3 +-
 test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs    | 170 ++++++++++++---------
 test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs |  19 +--
 3 files changed, 110 insertions(+), 82 deletions(-)

diff --git a/cuddle.cabal b/cuddle.cabal
index a878f23..2707bc2 100644
--- a/cuddle.cabal
+++ b/cuddle.cabal
@@ -102,10 +102,9 @@ test-suite cuddle-test
     build-depends:
         , base              ^>=4.16.3.0 || ^>=4.18.1.0 || ^>=4.19.0.0
         , cuddle
-        , hedgehog
         , hspec
-        , hspec-hedgehog
         , hspec-megaparsec
         , megaparsec
         , prettyprinter
+        , QuickCheck
         , text
diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
index b044d6e..bf539bc 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
@@ -9,136 +9,143 @@ where
 
 import Codec.CBOR.Cuddle.CDDL
 import Codec.CBOR.Cuddle.CDDL.CtlOp
-import Hedgehog (MonadGen)
-import Hedgehog.Gen (sized)
-import Hedgehog.Gen qualified as Gen
-import Hedgehog.Range qualified as Range
-
-genCDDL :: (MonadGen m) => m CDDL
-genCDDL = CDDL . fmap noComment <$> Gen.nonEmpty (Range.linear 1 15) genRule
-
--- TODO Expand the range of names generated
-genName :: (MonadGen m) => m Name
-genName = Name <$> Gen.text (Range.linear 1 10) Gen.alpha
-
-genAssign :: (MonadGen m) => m Assign
-genAssign = Gen.element [AssignEq, AssignExt]
-
-genGenericParams :: (MonadGen m) => m GenericParam
-genGenericParams = GenericParam <$> Gen.nonEmpty (Range.linear 1 5) genName
-
-genGenericArg :: (MonadGen m) => m GenericArg
-genGenericArg = GenericArg <$> Gen.nonEmpty (Range.linear 1 5) genType1
-
-genRule :: (MonadGen m) => m Rule
+import Data.List.NonEmpty qualified as NE
+import Data.Text qualified as T
+import Test.QuickCheck
+import Test.QuickCheck qualified as Gen
+import Prelude hiding (maybe)
+
+genCDDL :: Gen CDDL
+genCDDL = CDDL . fmap noComment <$> nonEmpty genRule
+
+genName :: Gen Name
+genName =
+  let endChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['@', '_', '$']
+      midChars = ['1' .. '9'] <> ['-', '.']
+   in do
+        fstChar <- elements endChars
+        midChar <- listOf . elements $ endChars <> midChars
+        lastChar <- elements $ endChars <> ['1' .. '9']
+        pure $ Name . T.pack $ fstChar : midChar <> [lastChar]
+
+genAssign :: Gen Assign
+genAssign = Gen.elements [AssignEq, AssignExt]
+
+genGenericParams :: Gen GenericParam
+genGenericParams = GenericParam <$> nonEmpty genName
+
+genGenericArg :: Gen GenericArg
+genGenericArg = GenericArg <$> nonEmpty genType1
+
+genRule :: Gen Rule
 genRule =
   Rule
     <$> genName
-    <*> Gen.maybe genGenericParams
+    <*> maybe genGenericParams
     <*> genAssign
     <*> genTypeOrGroup
 
-genRangeBound :: (MonadGen m) => m RangeBound
-genRangeBound = Gen.element [ClOpen, Closed]
+genRangeBound :: Gen RangeBound
+genRangeBound = Gen.elements [ClOpen, Closed]
 
-genTyOp :: (MonadGen m) => m TyOp
+genTyOp :: Gen TyOp
 genTyOp =
-  Gen.choice
+  Gen.oneof
     [ RangeOp <$> genRangeBound,
       CtrlOp <$> genCtlOp
     ]
 
-genTypeOrGroup :: (MonadGen m) => m TypeOrGroup
+genTypeOrGroup :: Gen TypeOrGroup
 genTypeOrGroup =
-  Gen.choice
+  Gen.oneof
     [ TOGGroup <$> genGroupEntry,
       TOGType <$> genType0
     ]
 
-genType0 :: (MonadGen m) => m Type0
-genType0 = Type0 <$> Gen.nonEmpty (Range.linear 1 4) genType1
+genType0 :: Gen Type0
+genType0 = Type0 <$> nonEmpty genType1
 
-genType1 :: (MonadGen m) => m Type1
-genType1 = Type1 <$> genType2 <*> Gen.maybe ((,) <$> genTyOp <*> genType2)
+genType1 :: Gen Type1
+genType1 = Type1 <$> genType2 <*> maybe ((,) <$> genTyOp <*> genType2)
 
-genType2 :: (MonadGen m) => m Type2
+genType2 :: Gen Type2
 genType2 =
-  Gen.recursive
-    Gen.choice
+  recursive
+    Gen.oneof
     [ T2Value <$> genValue,
       T2Map <$> genGroup,
       T2Array <$> genGroup,
       T2Enum <$> genGroup,
       T2DataItem
-        <$> Gen.int (Range.linear 0 10)
-        <*> Gen.maybe (Gen.int (Range.linear 0 10)),
+        <$> arbitrary
+        <*> maybe arbitrary,
       T2Name <$> genName <*> maybeRec genGenericArg,
       T2Unwrapped <$> genName <*> maybeRec genGenericArg,
       T2EnumRef <$> genName <*> maybeRec genGenericArg,
       pure T2Any
     ]
     [ T2Group <$> genType0,
-      T2Tag <$> Gen.maybe (Gen.int (Range.linear 0 10)) <*> genType0
+      T2Tag <$> maybe arbitrary <*> genType0
     ]
 
-genOccurrenceIndicator :: (MonadGen m) => m OccurrenceIndicator
+genOccurrenceIndicator :: Gen OccurrenceIndicator
 genOccurrenceIndicator =
-  Gen.choice
+  Gen.oneof
     [ pure OIOptional,
       pure OIZeroOrMore,
       pure OIOneOrMore,
       OIBounded
-        <$> Gen.maybe (Gen.int (Range.linear 0 5))
-        <*> Gen.maybe (Gen.int (Range.linear 5 10))
+        <$> maybe arbitrary
+        <*> maybe arbitrary
     ]
 
-genGroup :: (MonadGen m) => m Group
-genGroup = Group <$> Gen.nonEmpty (Range.linear 1 5) genGrpChoice
+genGroup :: Gen Group
+genGroup = Group <$> nonEmpty genGrpChoice
 
-genGrpChoice :: (MonadGen m) => m GrpChoice
-genGrpChoice = Gen.list (Range.linear 1 10) genGroupEntry
+genGrpChoice :: Gen GrpChoice
+genGrpChoice = Gen.listOf genGroupEntry
 
-genGroupEntry :: (MonadGen m) => m GroupEntry
+genGroupEntry :: Gen GroupEntry
 genGroupEntry =
-  Gen.recursive
-    Gen.choice
+  recursive
+    Gen.oneof
     [ GERef
-        <$> Gen.maybe genOccurrenceIndicator
+        <$> maybe genOccurrenceIndicator
         <*> genName
         <*> maybeRec genGenericArg
     ]
     [ GEType
-        <$> Gen.maybe genOccurrenceIndicator
-        <*> Gen.maybe genMemberKey
+        <$> maybe genOccurrenceIndicator
+        <*> maybe genMemberKey
         <*> genType0,
-      GEGroup <$> Gen.maybe genOccurrenceIndicator <*> genGroup
+      GEGroup <$> maybe genOccurrenceIndicator <*> genGroup
     ]
 
-genMemberKey :: (MonadGen m) => m MemberKey
+genMemberKey :: Gen MemberKey
 genMemberKey =
-  Gen.recursive
-    Gen.choice
+  recursive
+    Gen.oneof
     [ MKBareword <$> genName,
       MKValue <$> genValue
     ]
     [ MKType <$> genType1
     ]
 
-genValue :: (MonadGen m) => m Value
+genValue :: Gen Value
 genValue =
-  Gen.choice
-    [ VUInt <$> Gen.word64 (Range.linear 0 255),
-      VNInt <$> Gen.word64 (Range.linear 0 255),
-      VFloat16 <$> Gen.float (Range.linearFrac 0.0 10.0),
-      VFloat32 <$> Gen.float (Range.linearFrac 0.0 10.0),
-      VFloat64 <$> Gen.double (Range.linearFrac 0.0 200),
-      VText <$> Gen.text (Range.linear 0 1000) Gen.alphaNum
+  Gen.oneof
+    [ VUInt <$> arbitrary,
+      VNInt <$> arbitrary,
+      VFloat16 <$> arbitrary,
+      VFloat32 <$> arbitrary,
+      VFloat64 <$> arbitrary,
+      VText . T.pack <$> listOf (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> [' '])
       -- VBytes <$> Gen.bytes (Range.linear 0 1100)
     ]
 
-genCtlOp :: (MonadGen m) => m CtlOp
+genCtlOp :: Gen CtlOp
 genCtlOp =
-  Gen.element
+  Gen.elements
     [ Size,
       Bits,
       Regexp,
@@ -159,10 +166,23 @@ genCtlOp =
 -- Utility
 --------------------------------------------------------------------------------
 
+-- | Generate a non-empty list, whose maximum length depends on the size
+-- parameter.
+nonEmpty :: Gen a -> Gen (NE.NonEmpty a)
+nonEmpty f = do
+  sing <- f
+  n <- getSize
+  k <- choose (0, n)
+  (sing NE.:|) <$> vectorOf k f
+
+-- | Generates 'Nothing' some of the time
+maybe :: Gen a -> Gen (Maybe a)
+maybe f = Gen.oneof [Just <$> f, pure Nothing]
+
 -- | Variant on maybe which shrinks the size whenever it selects the 'Just'
 -- option. When the size gets to one or less, the Just constructor is no longer
 -- called, ensuring termination.
-maybeRec :: (MonadGen m) => m a -> m (Maybe a)
+maybeRec :: Gen a -> Gen (Maybe a)
 maybeRec gen =
   sized $ \n ->
     if n <= 1
@@ -170,5 +190,17 @@ maybeRec gen =
       else
         Gen.frequency
           [ (2, pure Nothing),
-            (1 + fromIntegral n, Just <$> Gen.small gen)
+            (1 + fromIntegral n, Just <$> Gen.scale golden gen)
           ]
+
+-- | Choose from a set of non-recursive generators and a set of recursive
+-- generators, decreasing the size parameter whenever we pick one of the
+-- recursive generators.
+recursive :: ([Gen a] -> Gen a) -> [Gen a] -> [Gen a] -> Gen a
+recursive f nonrec rec = sized $ \n ->
+  if n <= 1
+    then f nonrec
+    else f $ nonrec ++ fmap (scale golden) rec
+
+golden :: Int -> Int
+golden x = round (fromIntegral x * 0.61803398875 :: Double)
diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
index 8674480..65bbcd7 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
@@ -12,8 +12,8 @@ import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)
 import Prettyprinter.Render.Text (renderStrict)
 import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen
 import Test.Hspec
-import Test.Hspec.Hedgehog (Gen, PropertyT, failure, footnote, footnoteShow, forAll, hedgehog, (===))
 import Test.Hspec.Megaparsec
+import Test.QuickCheck
 import Text.Megaparsec (errorBundlePretty, parse)
 
 parserSpec :: Spec
@@ -38,18 +38,15 @@ roundtripSpec = describe "Roundtripping should be id" $ do
     -- that we do not show that parse (print p) is p for a given generated
     -- 'CDDL' doc, since CDDL contains some statements that allow multiple
     -- parsings.
-    trip :: (Show a, Pretty a) => Gen a -> Parser a -> PropertyT IO ()
-    trip g pa = hedgehog $ do
-      x <- forAll g
+    trip :: (Show a, Pretty a) => Gen a -> Parser a -> Property
+    trip g pa = property . forAll g $ \x -> do
       let printed = printText x
-      footnoteShow printed
       case parse pa "" printed of
-        Left e -> do
-          footnote $ errorBundlePretty e
-          failure
-        Right parsed -> do
-          footnoteShow parsed
-          printed === printText parsed
+        Left e ->
+          counterexample (errorBundlePretty e) $ property False
+        Right parsed ->
+          counterexample (show parsed) $
+            printed === printText parsed
     printText :: (Pretty a) => a -> T.Text
     printText = renderStrict . layoutPretty defaultLayoutOptions . pretty
 

From bf5fb15717fc698ff7d33d5e85f1dd1c6102ab14 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Fri, 8 Mar 2024 09:59:00 +0100
Subject: [PATCH 2/8] Fix parsing of signed floats.

---
 src/Codec/CBOR/Cuddle/Parser.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs
index eccc345..b07ee1d 100644
--- a/src/Codec/CBOR/Cuddle/Parser.hs
+++ b/src/Codec/CBOR/Cuddle/Parser.hs
@@ -212,7 +212,7 @@ pValue =
     -- value.
     pUInt = VUInt <$> L.decimal <* notFollowedBy (oneOf ['*', '.'])
     pNInt = VNInt <$> (char '-' *> L.decimal <* notFollowedBy (oneOf ['*', '.']))
-    pFloat = VFloat64 <$> L.float
+    pFloat = VFloat64 <$> L.signed hspace L.float
     pText = VText <$> (char '"' *> pSChar <* char '"')
     -- Currently this doesn't allow string escaping
     pSChar :: Parser Text

From e17be22bfd521f813d821dfe21d6826ee5b2e663 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Fri, 8 Mar 2024 10:10:29 +0100
Subject: [PATCH 3/8] Occurrence bounds should be non-negative!

---
 src/Codec/CBOR/Cuddle/CBOR/Gen.hs |  5 +++--
 src/Codec/CBOR/Cuddle/CDDL.hs     |  2 +-
 src/Codec/CBOR/Cuddle/Huddle.hs   | 10 +++++-----
 3 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs
index 3737215..0c8b1bd 100644
--- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs
+++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs
@@ -38,6 +38,7 @@ import Data.Functor.Identity (Identity (runIdentity))
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe)
+import Data.Word (Word64)
 import GHC.Generics (Generic)
 import System.Random.Stateful
   ( Random,
@@ -340,8 +341,8 @@ applyOccurenceIndicator OIOneOrMore oldGen =
   genUniformRM (0 :: Int, 10) >>= \i ->
     G <$> replicateM i oldGen
 applyOccurenceIndicator (OIBounded mlb mub) oldGen =
-  genUniformRM (fromMaybe 0 mlb :: Int, fromMaybe 10 mub)
-    >>= \i -> G <$> replicateM i oldGen
+  genUniformRM (fromMaybe 0 mlb :: Word64, fromMaybe 10 mub)
+    >>= \i -> G <$> replicateM (fromIntegral i) oldGen
 
 genValue :: Value -> Gen Term
 genValue (VUInt i) = pure . TInt $ fromIntegral i
diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs
index 7296e97..d1fd015 100644
--- a/src/Codec/CBOR/Cuddle/CDDL.hs
+++ b/src/Codec/CBOR/Cuddle/CDDL.hs
@@ -253,7 +253,7 @@ data OccurrenceIndicator
   = OIOptional
   | OIZeroOrMore
   | OIOneOrMore
-  | OIBounded (Maybe Int) (Maybe Int)
+  | OIBounded (Maybe Word64) (Maybe Word64)
   deriving (Eq, Generic, Show)
 
 instance Hashable OccurrenceIndicator
diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs
index 84fe44f..24d1999 100644
--- a/src/Codec/CBOR/Cuddle/Huddle.hs
+++ b/src/Codec/CBOR/Cuddle/Huddle.hs
@@ -98,8 +98,8 @@ import Data.String (IsString (fromString))
 import Data.Text qualified as T
 import Data.Tuple.Optics (Field1 (..), Field2 (..), Field3 (..))
 import Data.Void (Void)
-import GHC.Exts (IsList (Item, fromList, toList))
 import Data.Word (Word64)
+import GHC.Exts (IsList (Item, fromList, toList))
 import GHC.Generics (Generic)
 import Optics.Core (over, view, (%~), (&), (.~))
 import Prelude hiding ((/))
@@ -252,8 +252,8 @@ instance Num Type0 where
 
 -- | Occurrence bounds.
 data Occurs = Occurs
-  { lb :: Maybe Int,
-    ub :: Maybe Int
+  { lb :: Maybe Word64,
+    ub :: Maybe Word64
   }
   deriving (Eq, Generic, Show)
 
@@ -495,10 +495,10 @@ instance (IsType0 a) => IsType0 (Tagged a) where
 
 class CanQuantify a where
   -- | Apply a lower bound
-  (<+) :: Int -> a -> a
+  (<+) :: Word64 -> a -> a
 
   -- | Apply an upper bound
-  (+>) :: a -> Int -> a
+  (+>) :: a -> Word64 -> a
 
 infixl 8 <+
 

From e9b1665113a22a64189f1691244ac7602a673d99 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Fri, 8 Mar 2024 10:17:07 +0100
Subject: [PATCH 4/8] CBOR tags should be non-negative.

---
 src/Codec/CBOR/Cuddle/CDDL.hs   | 6 +++---
 src/Codec/CBOR/Cuddle/Huddle.hs | 4 ++--
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs
index d1fd015..89e274f 100644
--- a/src/Codec/CBOR/Cuddle/CDDL.hs
+++ b/src/Codec/CBOR/Cuddle/CDDL.hs
@@ -7,7 +7,7 @@ import Data.ByteString qualified as B
 import Data.Hashable (Hashable)
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
-import Data.Word (Word64)
+import Data.Word (Word64, Word8)
 import GHC.Generics (Generic)
 
 newtype CDDL = CDDL (NE.NonEmpty (WithComments Rule))
@@ -227,10 +227,10 @@ data Type2
   | T2EnumRef Name (Maybe GenericArg)
   | -- | a tagged data item, tagged with the "uint" given and containing the
     --  type given as the tagged value, or
-    T2Tag (Maybe Int) Type0
+    T2Tag (Maybe Word64) Type0
   | -- | a data item of a major type (given by the DIGIT), optionally
     --  constrained to the additional information given by the uint, or
-    T2DataItem Int (Maybe Int)
+    T2DataItem Word8 (Maybe Word64)
   | -- | Any data item
     T2Any
   deriving (Eq, Generic, Show)
diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs
index 24d1999..e9f418b 100644
--- a/src/Codec/CBOR/Cuddle/Huddle.hs
+++ b/src/Codec/CBOR/Cuddle/Huddle.hs
@@ -699,12 +699,12 @@ ae / rt = ae & field @"value" %~ (// toType0 rt)
 --------------------------------------------------------------------------------
 
 -- | A tagged type carries an optional tag
-data Tagged a = Tagged (Maybe Int) a
+data Tagged a = Tagged (Maybe Word64) a
   deriving (Show, Functor)
 
 -- | Tag a CBOR item with a CDDL minor type. Thus, `tag n x` is equivalent to
 -- `#6.n(x)` in CDDL.
-tag :: Int -> a -> Tagged a
+tag :: Word64 -> a -> Tagged a
 tag mi = Tagged (Just mi)
 
 --------------------------------------------------------------------------------

From 7dca507c938ae5d22ca17d55327400a33e486459 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Mon, 11 Mar 2024 12:34:40 +0100
Subject: [PATCH 5/8] Add QC shrinking.

---
 test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs    | 94 ++++++++++++++++++++--
 test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs | 43 ++++++++--
 2 files changed, 124 insertions(+), 13 deletions(-)

diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
index bf539bc..5ad843c 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
@@ -1,15 +1,23 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 -- | Hedgehog generators for CDDL
 module Test.Codec.CBOR.Cuddle.CDDL.Gen
   ( genCDDL,
     genRule,
     genName,
     genValue,
+    --
+    genType0,
+    genGroupEntry,
   )
 where
 
 import Codec.CBOR.Cuddle.CDDL
 import Codec.CBOR.Cuddle.CDDL.CtlOp
+import Data.List (inits)
 import Data.List.NonEmpty qualified as NE
+import Data.Maybe (mapMaybe)
 import Data.Text qualified as T
 import Test.QuickCheck
 import Test.QuickCheck qualified as Gen
@@ -22,21 +30,41 @@ genName :: Gen Name
 genName =
   let endChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['@', '_', '$']
       midChars = ['1' .. '9'] <> ['-', '.']
+      shortListOf = resize 3 . listOf
    in do
         fstChar <- elements endChars
-        midChar <- listOf . elements $ endChars <> midChars
+        midChar <- shortListOf . elements $ endChars <> midChars
         lastChar <- elements $ endChars <> ['1' .. '9']
         pure $ Name . T.pack $ fstChar : midChar <> [lastChar]
 
+instance Arbitrary Name where
+  arbitrary = genName
+
+  shrink (Name (T.unpack -> t)) = case t of
+    [_] -> []
+    xs -> Name . T.pack <$> drop 1 (inits xs)
+
 genAssign :: Gen Assign
 genAssign = Gen.elements [AssignEq, AssignExt]
 
+instance Arbitrary Assign where
+  arbitrary = genAssign
+  shrink = genericShrink
+
 genGenericParams :: Gen GenericParam
 genGenericParams = GenericParam <$> nonEmpty genName
 
+instance Arbitrary GenericParam where
+  arbitrary = genGenericParams
+  shrink (GenericParam neName) = GenericParam <$> shrinkNE neName
+
 genGenericArg :: Gen GenericArg
 genGenericArg = GenericArg <$> nonEmpty genType1
 
+instance Arbitrary GenericArg where
+  arbitrary = genGenericArg
+  shrink (GenericArg neArg) = GenericArg <$> shrinkNE neArg
+
 genRule :: Gen Rule
 genRule =
   Rule
@@ -45,9 +73,17 @@ genRule =
     <*> genAssign
     <*> genTypeOrGroup
 
+instance Arbitrary Rule where
+  arbitrary = genRule
+  shrink = genericShrink
+
 genRangeBound :: Gen RangeBound
 genRangeBound = Gen.elements [ClOpen, Closed]
 
+instance Arbitrary RangeBound where
+  arbitrary = genRangeBound
+  shrink = genericShrink
+
 genTyOp :: Gen TyOp
 genTyOp =
   Gen.oneof
@@ -55,6 +91,10 @@ genTyOp =
       CtrlOp <$> genCtlOp
     ]
 
+instance Arbitrary TyOp where
+  arbitrary = genTyOp
+  shrink = genericShrink
+
 genTypeOrGroup :: Gen TypeOrGroup
 genTypeOrGroup =
   Gen.oneof
@@ -62,12 +102,24 @@ genTypeOrGroup =
       TOGType <$> genType0
     ]
 
+instance Arbitrary TypeOrGroup where
+  arbitrary = genTypeOrGroup
+  shrink = genericShrink
+
 genType0 :: Gen Type0
 genType0 = Type0 <$> nonEmpty genType1
 
+instance Arbitrary Type0 where
+  arbitrary = genType0
+  shrink (Type0 neType1) = Type0 <$> shrinkNE neType1
+
 genType1 :: Gen Type1
 genType1 = Type1 <$> genType2 <*> maybe ((,) <$> genTyOp <*> genType2)
 
+instance Arbitrary Type1 where
+  arbitrary = genType1
+  shrink = genericShrink
+
 genType2 :: Gen Type2
 genType2 =
   recursive
@@ -77,8 +129,8 @@ genType2 =
       T2Array <$> genGroup,
       T2Enum <$> genGroup,
       T2DataItem
-        <$> arbitrary
-        <*> maybe arbitrary,
+        <$> elements [0 .. 7]
+        <*> maybe Gen.arbitrarySizedBoundedIntegral,
       T2Name <$> genName <*> maybeRec genGenericArg,
       T2Unwrapped <$> genName <*> maybeRec genGenericArg,
       T2EnumRef <$> genName <*> maybeRec genGenericArg,
@@ -88,6 +140,10 @@ genType2 =
       T2Tag <$> maybe arbitrary <*> genType0
     ]
 
+instance Arbitrary Type2 where
+  arbitrary = genType2
+  shrink = genericShrink
+
 genOccurrenceIndicator :: Gen OccurrenceIndicator
 genOccurrenceIndicator =
   Gen.oneof
@@ -99,9 +155,17 @@ genOccurrenceIndicator =
         <*> maybe arbitrary
     ]
 
+instance Arbitrary OccurrenceIndicator where
+  arbitrary = genOccurrenceIndicator
+  shrink = genericShrink
+
 genGroup :: Gen Group
 genGroup = Group <$> nonEmpty genGrpChoice
 
+instance Arbitrary Group where
+  arbitrary = genGroup
+  shrink (Group gr) = Group <$> shrinkNE gr
+
 genGrpChoice :: Gen GrpChoice
 genGrpChoice = Gen.listOf genGroupEntry
 
@@ -121,6 +185,10 @@ genGroupEntry =
       GEGroup <$> maybe genOccurrenceIndicator <*> genGroup
     ]
 
+instance Arbitrary GroupEntry where
+  arbitrary = genGroupEntry
+  shrink = genericShrink
+
 genMemberKey :: Gen MemberKey
 genMemberKey =
   recursive
@@ -131,6 +199,10 @@ genMemberKey =
     [ MKType <$> genType1
     ]
 
+instance Arbitrary MemberKey where
+  arbitrary = genMemberKey
+  shrink = genericShrink
+
 genValue :: Gen Value
 genValue =
   Gen.oneof
@@ -143,6 +215,9 @@ genValue =
       -- VBytes <$> Gen.bytes (Range.linear 0 1100)
     ]
 
+instance Arbitrary Value where
+  arbitrary = genValue
+
 genCtlOp :: Gen CtlOp
 genCtlOp =
   Gen.elements
@@ -162,6 +237,10 @@ genCtlOp =
       Default
     ]
 
+instance Arbitrary CtlOp where
+  arbitrary = genCtlOp
+  shrink = genericShrink
+
 --------------------------------------------------------------------------------
 -- Utility
 --------------------------------------------------------------------------------
@@ -180,12 +259,12 @@ maybe :: Gen a -> Gen (Maybe a)
 maybe f = Gen.oneof [Just <$> f, pure Nothing]
 
 -- | Variant on maybe which shrinks the size whenever it selects the 'Just'
--- option. When the size gets to one or less, the Just constructor is no longer
+-- option. When the size gets to five or less, the Just constructor is no longer
 -- called, ensuring termination.
 maybeRec :: Gen a -> Gen (Maybe a)
 maybeRec gen =
   sized $ \n ->
-    if n <= 1
+    if n <= 5
       then pure Nothing
       else
         Gen.frequency
@@ -198,9 +277,12 @@ maybeRec gen =
 -- recursive generators.
 recursive :: ([Gen a] -> Gen a) -> [Gen a] -> [Gen a] -> Gen a
 recursive f nonrec rec = sized $ \n ->
-  if n <= 1
+  if n <= 5
     then f nonrec
     else f $ nonrec ++ fmap (scale golden) rec
 
 golden :: Int -> Int
 golden x = round (fromIntegral x * 0.61803398875 :: Double)
+
+shrinkNE :: (Arbitrary a) => NE.NonEmpty a -> [NE.NonEmpty a]
+shrinkNE (NE.toList -> l) = mapMaybe NE.nonEmpty (shrink l)
diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
index 65bbcd7..3e88e69 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
@@ -10,7 +10,7 @@ import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
 import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)
 import Prettyprinter.Render.Text (renderStrict)
-import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen
+import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()
 import Test.Hspec
 import Test.Hspec.Megaparsec
 import Test.QuickCheck
@@ -27,23 +27,28 @@ parserSpec = do
   grpChoiceSpec
   genericSpec
   roundtripSpec
+  qcFoundSpec
 
 roundtripSpec :: Spec
 roundtripSpec = describe "Roundtripping should be id" $ do
-  it "Trip Name" $ trip Gen.genName pName
-  it "Trip Value" $ trip Gen.genValue pValue
-  it "Trip Rule" $ trip Gen.genRule pRule
+  it "Trip Name" $ trip pName
+  it "Trip Value" $ trip pValue
+  it "Trip Type0" $ trip pType0
+  it "Trip GroupEntry" $ trip pGrpEntry
+  it "Trip Rule" $ trip pRule
   where
     -- We show that, for a printed CDDL document p, print (parse p) == p. Note
     -- that we do not show that parse (print p) is p for a given generated
     -- 'CDDL' doc, since CDDL contains some statements that allow multiple
     -- parsings.
-    trip :: (Show a, Pretty a) => Gen a -> Parser a -> Property
-    trip g pa = property . forAll g $ \x -> do
+    trip :: forall a. (Show a, Pretty a, Arbitrary a) => Parser a -> Property
+    trip pa = property $ \(x :: a) -> do
       let printed = printText x
       case parse pa "" printed of
         Left e ->
-          counterexample (errorBundlePretty e) $ property False
+          counterexample (show printed) $
+            counterexample (errorBundlePretty e) $
+              property False
         Right parsed ->
           counterexample (show parsed) $
             printed === printText parsed
@@ -319,3 +324,27 @@ type1Spec = describe "Type1" $ do
         `shouldParse` Type1
           (T2Value (VUInt 0))
           (Just (RangeOp ClOpen, T2Value (VUInt 3)))
+
+-- | A bunch of cases found by hedgehog/QC
+qcFoundSpec :: Spec
+qcFoundSpec =
+  describe "Generated test cases" $
+    it "1083150867" $
+      parse pType1 "" "{} .ge & i<{}, 3>"
+        `shouldParse` Type1
+          (T2Map (Group ([] NE.:| [])))
+          ( Just
+              ( CtrlOp CtlOp.Ge,
+                T2EnumRef
+                  (Name "i")
+                  ( Just
+                      ( GenericArg
+                          ( Type1
+                              (T2Map (Group ([] NE.:| [])))
+                              Nothing
+                              NE.:| [Type1 (T2Value (VUInt 3)) Nothing]
+                          )
+                      )
+                  )
+              )
+          )

From 0736dcbfe37f9c2dfd36ef7fe5bced25a7eddc42 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Tue, 12 Mar 2024 11:43:06 +0100
Subject: [PATCH 6/8] Modify recursive generators to avoid blow-up.

Since we have multiple nested lists, even relatively small sizes were
generating large blow-up in test case size. We work around this by
scaling the size parameter according to the size of lists generated,
thus bounding the total size.

In addition, add a timeout for test processing, just in case.
---
 test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs    | 30 ++++++++++++++++------
 test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs |  4 +--
 2 files changed, 24 insertions(+), 10 deletions(-)

diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
index 5ad843c..d0e3494 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs
@@ -30,10 +30,10 @@ genName :: Gen Name
 genName =
   let endChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['@', '_', '$']
       midChars = ['1' .. '9'] <> ['-', '.']
-      shortListOf = resize 3 . listOf
+      veryShortListOf = resize 3 . listOf
    in do
         fstChar <- elements endChars
-        midChar <- shortListOf . elements $ endChars <> midChars
+        midChar <- veryShortListOf . elements $ endChars <> midChars
         lastChar <- elements $ endChars <> ['1' .. '9']
         pure $ Name . T.pack $ fstChar : midChar <> [lastChar]
 
@@ -167,7 +167,7 @@ instance Arbitrary Group where
   shrink (Group gr) = Group <$> shrinkNE gr
 
 genGrpChoice :: Gen GrpChoice
-genGrpChoice = Gen.listOf genGroupEntry
+genGrpChoice = listOf' genGroupEntry
 
 genGroupEntry :: Gen GroupEntry
 genGroupEntry =
@@ -245,14 +245,14 @@ instance Arbitrary CtlOp where
 -- Utility
 --------------------------------------------------------------------------------
 
--- | Generate a non-empty list, whose maximum length depends on the size
--- parameter.
+-- | Generate a non-empty list. This function applies similar recursive scaling
+-- to @listOf'@ - see the comment there for details.
 nonEmpty :: Gen a -> Gen (NE.NonEmpty a)
 nonEmpty f = do
   sing <- f
   n <- getSize
   k <- choose (0, n)
-  (sing NE.:|) <$> vectorOf k f
+  (sing NE.:|) <$> vectorOf k (scale (scaleBy k) f)
 
 -- | Generates 'Nothing' some of the time
 maybe :: Gen a -> Gen (Maybe a)
@@ -262,8 +262,8 @@ maybe f = Gen.oneof [Just <$> f, pure Nothing]
 -- option. When the size gets to five or less, the Just constructor is no longer
 -- called, ensuring termination.
 maybeRec :: Gen a -> Gen (Maybe a)
-maybeRec gen =
-  sized $ \n ->
+maybeRec gen = sized $
+  \n ->
     if n <= 5
       then pure Nothing
       else
@@ -284,5 +284,19 @@ recursive f nonrec rec = sized $ \n ->
 golden :: Int -> Int
 golden x = round (fromIntegral x * 0.61803398875 :: Double)
 
+scaleBy :: Int -> Int -> Int
+scaleBy k x = round (fromIntegral x * ((1 :: Double) / fromIntegral k))
+
 shrinkNE :: (Arbitrary a) => NE.NonEmpty a -> [NE.NonEmpty a]
 shrinkNE (NE.toList -> l) = mapMaybe NE.nonEmpty (shrink l)
+
+-- | Variant on 'listOf' that tries to constrain the ultimate size of the
+-- generated tree by scaling recursive generators according to the size of the
+-- generated list - that is, short lists will result in minimal size scaling,
+-- whereas long lists will give significant scaling. Overall, the flattened size
+-- should therefore remain roughly constant.
+listOf' :: Gen a -> Gen [a]
+listOf' f = do
+  n <- getSize
+  k <- choose (0, n)
+  vectorOf k $ scale (scaleBy k) f
diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
index 3e88e69..f3046bb 100644
--- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
+++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
@@ -41,8 +41,8 @@ roundtripSpec = describe "Roundtripping should be id" $ do
     -- that we do not show that parse (print p) is p for a given generated
     -- 'CDDL' doc, since CDDL contains some statements that allow multiple
     -- parsings.
-    trip :: forall a. (Show a, Pretty a, Arbitrary a) => Parser a -> Property
-    trip pa = property $ \(x :: a) -> do
+    trip :: forall a. (Eq a, Show a, Pretty a, Arbitrary a) => Parser a -> Property
+    trip pa = property $ \(x :: a) -> within 1000000 $ do
       let printed = printText x
       case parse pa "" printed of
         Left e ->

From 00d84b79cd4b07eece9346ffae503f69cc598802 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Tue, 12 Mar 2024 11:47:29 +0100
Subject: [PATCH 7/8] Try to only parse trailing spaces.

This was recommended by @mkarpov.
---
 src/Codec/CBOR/Cuddle/Parser.hs | 22 +++++++++++-----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs
index b07ee1d..25f42da 100644
--- a/src/Codec/CBOR/Cuddle/Parser.hs
+++ b/src/Codec/CBOR/Cuddle/Parser.hs
@@ -73,20 +73,20 @@ pGenericParam :: Parser GenericParam
 pGenericParam =
   GenericParam
     <$> between
-      (char '<')
+      (char '<' <* space)
       (char '>')
-      (NE.sepBy1 (space *> pName <* space) (char ','))
+      (NE.sepBy1 (pName <* space) (char ',' <* space))
 
 pGenericArg :: Parser GenericArg
 pGenericArg =
   GenericArg
     <$> between
-      (char '<')
+      (char '<' <* space)
       (char '>')
-      (NE.sepBy1 (space *> pType1 <* space) (char ','))
+      (NE.sepBy1 (pType1 <* space) (char ',' <* space))
 
 pType0 :: Parser Type0
-pType0 = Type0 <$> sepBy1' (space *> pType1 <* space) (char '/')
+pType0 = Type0 <$> sepBy1' (pType1 <* space) (char '/' <* space)
 
 pType1 :: Parser Type1
 pType1 = Type1 <$> pType2 <*> optcomp ((,) <$> (space *> pTyOp <* space) <*> pType2)
@@ -96,24 +96,24 @@ pType2 =
   choice
     [ try $ T2Value <$> pValue,
       try $ T2Name <$> pName <*> optional pGenericArg,
-      try $ T2Group <$> between (char '(') (char ')') (space *> pType0 <* space),
-      try $ T2Map <$> between (char '{') (char '}') (space *> pGroup <* space),
-      try $ T2Array <$> between (char '[') (char ']') (space *> pGroup <* space),
+      try $ T2Group <$> between (char '(' <* space) (char ')' <* space) (pType0 <* space),
+      try $ T2Map <$> between (char '{' <* space) (char '}' <* space) (pGroup <* space),
+      try $ T2Array <$> between (char '[' <* space) (char ']' <* space) (pGroup <* space),
       try $ T2Unwrapped <$> (char '~' *> space *> pName) <*> optional pGenericArg,
       try $
         T2Enum
           <$> ( char '&'
                   *> space
                   *> between
-                    (char '(')
+                    (char '(' <* space)
                     (char ')')
-                    (space *> pGroup <* space)
+                    (pGroup <* space)
               ),
       try $ T2EnumRef <$> (char '&' *> space *> pName) <*> optional pGenericArg,
       try $
         T2Tag
           <$> (string "#6" *> optcomp (char '.' *> L.decimal))
-          <*> between (char '(') (char ')') (space *> pType0 <* space),
+          <*> between (char '(' <* space) (char ')') (pType0 <* space),
       try $ T2DataItem <$> (char '#' *> L.decimal) <*> optcomp (char '.' *> L.decimal),
       T2Any <$ char '#'
     ]

From f4840d57226d062ad451bcdeab2b9fc4eeac4529 Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nick@topos.org.uk>
Date: Tue, 16 Apr 2024 15:20:10 +0200
Subject: [PATCH 8/8] Ensure that the rule parser is greedy.

Otherwise we get various situations where the
parser matches a rule by discarding the tail.
---
 src/Codec/CBOR/Cuddle/Parser.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs
index 25f42da..da9f4ec 100644
--- a/src/Codec/CBOR/Cuddle/Parser.hs
+++ b/src/Codec/CBOR/Cuddle/Parser.hs
@@ -31,7 +31,7 @@ pRule =
           <$> pName
           <*> optcomp pGenericParam
           <*> (space *> pAssignT <* space)
-          <*> (TOGType <$> pType0),
+          <*> (TOGType <$> pType0 <* notFollowedBy (void (char ':') <|> void (string "=>"))),
       Rule
         <$> pName
         <*> optcomp pGenericParam