cuddle 1.2.0.0 → 1.3.0.0

raw patch · 26 files changed

+937/−257 lines, 26 filesdep ~antigenPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: antigen

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• bin/Main.hs +3/−1
• cuddle.cabal +10/−2
• golden/cborControlBad.txt +2/−0
• golden/deeplyNestedRefVsRealProgress.txt +10/−0
• golden/huddleRangeArrayTwoStrings.txt +2/−1
• golden/listSkippedRule.txt +7/−0
• golden/listSkippedRuleNested.txt +10/−0
• golden/listTooShort.txt +4/−0
• golden/listZeroOrMore.txt +5/−0
• golden/mapLeftoverKV.txt +8/−0
• golden/mapNestedValue.txt +12/−0
• golden/mapNoMatchingKey.txt +2/−0
• golden/refTermTooLong.txt +1/−1
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +306/−132
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +54/−20
• src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +83/−33
• src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs +48/−7
• src/Codec/CBOR/Cuddle/CDDL/CTree.hs +14/−1
• src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs +2/−2
• src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +6/−5
• src/Codec/CBOR/Cuddle/Huddle.hs +16/−6
• test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs +143/−15
• test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +44/−14
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +54/−17
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator/Golden.hs +81/−0

@@ -1,5 +1,15 @@ # Changelog for `cuddle` +## 1.3.0.0++* Replace `Int` progress measure with lexicographic `Progress` type for more accurate trace comparison+* Rewrite map generation to produce unique keys+* Add `withTwiddle`+* `generateFromName` now enables twiddling by default (`geTwiddle = True`), which can change the shape of generated terms (e.g. `TBytes` vs `TBytesI`, `TList` vs `TListI`)+* Replace `CBORGenerator` with `CBORGen`+* Add `withCBORGen`+* Deprecate `withGenerator` and `withAntiGen`+ ## 1.2.0.0  * Add `Pretty` instance for `PTerm` 

@@ -41,7 +41,9 @@ import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.IO qualified as T+import Data.Version (showVersion) import Options.Applicative+import Paths_cuddle (version) import Prettyprinter (   LayoutOptions (..),   PageWidth (..),@@ -295,7 +297,7 @@   options <-     execParser $       info-        (pCommand <**> helper)+        (pCommand <**> helper <**> simpleVersioner (showVersion version))         ( fullDesc             <> progDesc "Manipulate CDDL files"             <> header "cuddle"

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.2.0.0+version: 1.3.0.0 synopsis: CDDL Generator and test utilities description:   Cuddle is a library for generating and manipulating [CDDL](https://datatracker.ietf.org/doc/html/rfc8610).@@ -63,7 +63,7 @@    build-depends:     QuickCheck >=2.14.3 && <2.18,-    antigen >=0.3.1 && <0.4,+    antigen ^>=0.4,     base >=4.18 && <5,     base16-bytestring >=1.0.2,     boxes >=0.1.5,@@ -74,6 +74,7 @@     data-default-class >=0.2,     foldable1-classes-compat >=0.1.1,     generic-optics >=2.2.1,+    generic-random,     half,     hashable >=1.4,     megaparsec >=9.5,@@ -140,6 +141,12 @@     random,     text, +  autogen-modules:+    Paths_cuddle++  other-modules:+    Paths_cuddle+ test-suite cuddle-test   import: warnings   default-language: GHC2021@@ -181,6 +188,7 @@     pretty-simple,     prettyprinter,     prettyprinter-ansi-terminal,+    quickcheck-transformer,     random,     string-qq >=0.0.6,     text,

@@ -0,0 +1,2 @@+[0;91munsatisfied control:+  .cbor simpleRule[0m

@@ -0,0 +1,10 @@+array+└ app: [0;92mint[0m+  [0;91mleftover elements, closest matching rule:[0m+    [0;92m? list_rule[0m+    └ ref: [0;94mlist_rule[0m+      └ array+        └ app: [0;92mint[0m+          [0;91mfailed to apply required rule:[0m+          └ [0;91mfailed to apply: +              int[0m

@@ -3,4 +3,5 @@   app: [0;92mint[0m   app: [0;92mtext[0m   app: [0;92mtext[0m-  [0;91mnot all required rules have been applied[0m+  [0;91mrequired rule not satisfied:[0m+    1* text

@@ -0,0 +1,7 @@+array+└ app: [0;92mint[0m+  [0;91mleftover elements, closest matching rule:[0m+    [0;92m? bar[0m+    └ ref: [0;94mbar[0m+      └ [0;91mfailed to apply: +          text[0m

@@ -0,0 +1,10 @@+array+└ app: [0;92mint[0m+  [0;91mleftover elements, closest matching rule:[0m+    [0;92m? baz[0m+    └ ref: [0;94mbaz[0m+      └ array+        └ app: [0;92mint[0m+          [0;91mfailed to apply required rule:[0m+          └ [0;91mfailed to apply: +              text[0m

@@ -0,0 +1,4 @@+array+└ app: [0;92mint[0m+  [0;91mrequired rule not satisfied:[0m+    text

@@ -0,0 +1,5 @@+array+└ app: [0;92mint[0m+  app: [0;92mint[0m+  app: [0;92mtext[0m+  [0;91mleftover elements not matched by any rule[0m

@@ -0,0 +1,8 @@+map+└ [0;91mleftover key-value pairs, closest matching rule:[0m+    [0;92m? 2 ==> int[0m+    └ key:+      └ app: [0;92m2[0m+      value: [0;91m(fail)[0m+      └ [0;91mfailed to apply: +          int[0m

@@ -0,0 +1,12 @@+map+└ [0;91mleftover key-value pairs, closest matching rule:[0m+    [0;92m? 1 ==> bar[0m+    └ key:+      └ app: [0;92m1[0m+      value: [0;91m(fail)[0m+      └ ref: [0;94mbar[0m+        └ array+          └ app: [0;92mint[0m+            [0;91mfailed to apply required rule:[0m+            └ [0;91mfailed to apply: +                text[0m

@@ -0,0 +1,2 @@+map+└ [0;91mleftover key-value pairs not matched by any rule[0m

@@ -6,4 +6,4 @@       └ app: [0;92m1[0m         app: [0;92m2[0m         app: [0;92m3[0m-        [0;91mleftover elements after all rules have been applied[0m+        [0;91mleftover elements not matched by any rule[0m

@@ -31,12 +31,25 @@   ValueVariant (..),  ) import Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGenerator (..),+  CBORGen (..),+  GenEnv (..),   GenPhase,   WrappedTerm (..),   XXCTree (..),+  liftAntiGen,+  lookupCddl,+  runCBORGen,+  withAntiGen,+  withTwiddle,  )-import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), PTerm (..), foldCTree)+import Codec.CBOR.Cuddle.CDDL.CTree (+  CTree (..),+  CTreeRoot (..),+  PTerm (..),+  foldCTree,+  nintMin,+  uintMax,+ ) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..))@@ -44,15 +57,17 @@ import Codec.CBOR.Term (Term (..)) import Codec.CBOR.Term qualified as CBOR import Codec.CBOR.Write qualified as CBOR-import Control.Monad ((<=<))+import Control.Monad (zipWithM, (<=<))+import Control.Monad.Reader (asks) import Data.ByteString (ByteString)-import Data.ByteString.Lazy qualified as BSL+import Data.ByteString.Lazy qualified as LBS import Data.Char (chr)-import Data.Containers.ListUtils (nubOrdOn) import Data.Functor ((<&>))+import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe)+import Data.Ord (Down (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Internal.Encoding.Utf8 (utf8Length)@@ -61,17 +76,18 @@ import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder qualified as LB import Data.Word (Word64, Word8)-import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Numeric.Half (Half (..), fromHalf)+import Prettyprinter (Pretty (..), layoutCompact)+import Prettyprinter.Render.Text (renderStrict) import System.Random.Stateful (Random, StatefulGen (..), runStateGen_, uniformByteStringM) import Test.AntiGen (   AntiGen,   antiChoose,-  antiNonNegative,-  antiNonPositive,   faultyNum,+  reweigh,   runAntiGen,+  withAnnotation,   (|!),  ) import Test.QuickCheck (@@ -80,7 +96,7 @@  ) import Test.QuickCheck qualified as QC import Test.QuickCheck.Gen (Gen (..), getSize)-import Test.QuickCheck.GenT (MonadGen (..), elements, listOf, oneof, suchThat, vectorOf)+import Test.QuickCheck.GenT (MonadGen (..), elements, frequency, listOf, oneof, suchThat, vectorOf)  -- TODO remove this once QuickCheck gets QC data QC = QC@@ -125,12 +141,6 @@ -- Generator infrastructure -------------------------------------------------------------------------------- --- | Generator context, parametrised over the type of the random seed-newtype GenEnv = GenEnv-  { cddl :: CTreeRoot GenPhase-  }-  deriving (Generic)- -------------------------------------------------------------------------------- -- Postlude --------------------------------------------------------------------------------@@ -145,11 +155,39 @@ genHalf :: MonadGen m => m Float genHalf = do   half <- Half <$> arbitrary-  if isInfinite half || isDenormalized half || isNaN half+  if isDenormalized half     then genHalf     else pure $ fromHalf half -genTerm :: AntiGen Term+twiddleString :: Text -> CBORGen Term+twiddleString t = do+  twiddle <- asks geTwiddle+  if twiddle+    then ($ t) <$> elements [TString, TStringI . TL.fromStrict]+    else pure $ TString t++twiddleList :: [Term] -> CBORGen Term+twiddleList t = do+  twiddle <- asks geTwiddle+  if twiddle+    then ($ t) <$> elements [TList, TListI]+    else pure $ TList t++twiddleBytes :: ByteString -> CBORGen Term+twiddleBytes t = do+  twiddle <- asks geTwiddle+  if twiddle+    then ($ t) <$> elements [TBytes, TBytesI . LBS.fromStrict]+    else pure $ TBytes t++twiddleMap :: [(Term, Term)] -> CBORGen Term+twiddleMap t = do+  twiddle <- asks geTwiddle+  if twiddle+    then ($ t) <$> elements [TMap, TMapI]+    else pure $ TMap t++genTerm :: CBORGen Term genTerm =   oneof     [ TInt <$> choose (minBound, maxBound)@@ -158,14 +196,10 @@           [ choose (toInteger (maxBound :: Int) + 1, toInteger (maxBound :: Word64))           , choose (negate (toInteger (maxBound :: Word64)), toInteger (minBound :: Int) - 1)           ]-    , TBytes <$> (genNBytes . getNonNegative =<< arbitrary)-    , TBytesI <$> (genNLazyBytes . getNonNegative =<< arbitrary)-    , TString . T.pack <$> arbitrary-    , TStringI . TL.pack <$> arbitrary-    , TList <$> listOf smallerTerm-    , TListI <$> listOf smallerTerm-    , TMap <$> listOf ((,) <$> smallerTerm <*> smallerTerm)-    , TMapI <$> listOf ((,) <$> smallerTerm <*> smallerTerm)+    , twiddleBytes =<< genNBytes . getNonNegative =<< arbitrary+    , twiddleString . T.pack =<< arbitrary+    , twiddleList =<< listOf smallerTerm+    , twiddleMap =<< listOf ((,) <$> smallerTerm <*> smallerTerm)     , TTagged <$> choose (6, maxBound :: Word64) <*> smallerTerm     , TBool <$> arbitrary     , pure TNull@@ -175,7 +209,7 @@     , TDouble <$> arbitrary     ]   where-    smallerTerm :: AntiGen Term+    smallerTerm :: CBORGen Term     smallerTerm = scale (`div` 5) genTerm  genNBytes :: MonadGen m => Int -> m ByteString@@ -186,9 +220,6 @@   numElems <- choose (0, sz)   genNBytes numElems -genNLazyBytes :: MonadGen m => Int -> m BSL.ByteString-genNLazyBytes n = BSL.fromStrict <$> genNBytes n- genCharAtMostBytes :: MonadGen m => Int -> m Char genCharAtMostBytes 1 = chr <$> choose (0x00, 0x7F) genCharAtMostBytes 2 = chr <$> choose (0x00, 0x7FF)@@ -212,20 +243,41 @@ genText = sized $ \sz -> genNBytesText =<< choose (0, sz)  -- | Primitive types defined by the CDDL specification, with their generators-genPostlude :: PTerm -> AntiGen Term-genPostlude pt = case pt of-  PTBool -> TBool <$> arbitrary-  PTUInt -> TInteger <$> antiNonNegative-  PTNInt -> TInteger <$> antiNonPositive-  PTInt -> TInteger . fromIntegral <$> choose (minBound :: Int, maxBound)-  PTHalf -> THalf <$> choose (-65504, 65504)-  PTFloat -> TFloat <$> arbitrary-  PTDouble -> TDouble <$> arbitrary-  PTBytes -> TBytes <$> genBytes-  PTText -> TString <$> genText-  PTAny -> genTerm-  PTNil -> pure TNull-  PTUndefined -> pure $ TSimple 23+genPostlude :: PTerm -> CBORGen Term+genPostlude pt = genPTerm =<< liftAntiGen (faultyPTerm pt)+  where+    genExcluding ls =+      elements (filter (`notElem` ls) [minBound .. maxBound])+    nonPInteger p =+      pure p |! genExcluding [PTUInt, PTNInt, PTInt, PTAny]+    -- \| Introduces a decision point that can change the type of the CBOR term that is generated+    faultyPTerm t = reweigh 0.1 $+      case t of+        PTAny -> pure PTAny+        p@PTUInt -> nonPInteger p+        p@PTNInt -> nonPInteger p+        p@PTInt -> nonPInteger p+        p -> pure p |! genExcluding [PTAny, p]+    genUInt = choose (0, uintMax)+    genNInt = choose (nintMin, -1)+    genAboveUInt = choose (uintMax + 1, 2 * uintMax)+    genBelowNInt = choose (2 * nintMin, nintMin - 1)+    -- \| Given a CDDL postlude type, generates a value of that type+    genPTerm = \case+      PTBool -> TBool <$> arbitrary+      -- For integers, introduce decision points that sometimes generate+      -- out-of-bounds values+      PTUInt -> TInteger <$> liftAntiGen (genUInt |! oneof [genNInt, genBelowNInt, genAboveUInt])+      PTNInt -> TInteger <$> liftAntiGen (genNInt |! oneof [genUInt, genBelowNInt, genAboveUInt])+      PTInt -> TInteger <$> choose (nintMin, uintMax)+      PTHalf -> THalf <$> genHalf+      PTFloat -> TFloat <$> arbitrary+      PTDouble -> TDouble <$> arbitrary+      PTBytes -> twiddleBytes =<< genBytes+      PTText -> twiddleString =<< genText+      PTAny -> genTerm+      PTNil -> pure TNull+      PTUndefined -> pure $ TSimple 23  -------------------------------------------------------------------------------- -- Kinds of terms@@ -247,13 +299,6 @@ singleTermList (P _ y : xs) = (y :) <$> singleTermList xs singleTermList _ = Nothing --- | Convert a list of wrapped terms to a list of pairs of terms, or fail if any--- 'SingleTerm's are present.-pairTermList :: [WrappedTerm] -> Maybe [(Term, Term)]-pairTermList [] = Just []-pairTermList (P x y : xs) = ((x, y) :) <$> pairTermList xs-pairTermList _ = Nothing- showSimple :: CTree GenPhase -> String showSimple = show . mapIndex @_ @_ @GenSimple @@ -265,55 +310,161 @@ -- Generator functions -------------------------------------------------------------------------------- -genSized :: HasCallStack => Word64 -> CTree i -> AntiGen WrappedTerm-genSized s target = do-  case target of-    CTree.Postlude PTText -> S . TString <$> genNBytesText (fromIntegral s)-    CTree.Postlude PTBytes -> S . TBytes <$> genNBytes (fromIntegral s)-    CTree.Postlude PTUInt -> S . TInteger <$> choose (0, 256 ^ s - 1)-    _ -> error "Cannot apply size operator to target "+genSized :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen WrappedTerm+genSized s target = annotateTerm target $ case target of+  CTree.Postlude PTText -> fmap S . twiddleString =<< genNBytesText (fromIntegral s)+  CTree.Postlude PTBytes -> fmap S . twiddleBytes =<< genNBytes (fromIntegral s)+  CTree.Postlude PTUInt -> S . TInteger <$> choose (0, 256 ^ s - 1)+  _ -> error "Cannot apply size operator to target "  range :: Enum a => RangeBound -> a -> a -> (a, a) range ClOpen x y = (x, pred y) range Closed x y = (x, y) -genBetween :: (Integral a, Random a) => (a, a) -> AntiGen a-genBetween rng = do+genBetween :: (Integral a, Random a) => (a, a) -> CBORGen a+genBetween rng = liftAntiGen $ do   size <- liftGen getSize   let     sizeBounds :: Integral a => (a, a)     sizeBounds = (0, fromIntegral size)   antiChoose rng sizeBounds -genForCTree ::-  HasCallStack => CTreeRoot GenPhase -> CTree GenPhase -> AntiGen WrappedTerm-genForCTree _ (CTree.Literal v) = pure . S $ valueToTerm v-genForCTree _ (CTree.Postlude pt) = S <$> genPostlude pt-genForCTree cddl (CTree.Map nodes) = do-  items <- pairTermList . flattenWrappedList <$> traverse (genForCTree cddl) nodes-  case items of-    Just ts ->+annotate :: Text -> CBORGen b -> CBORGen b+annotate ann = withAntiGen $ withAnnotation ann++-- | Annotate a generator with the label derived from a CTree node.+-- Control nodes are transparent — the annotation comes from the target inside.+annotateTerm :: CTree GenPhase -> CBORGen a -> CBORGen a+annotateTerm = \case+  CTree.Literal _ -> annotate "literal"+  CTree.Postlude pt -> annotate $ renderStrict . layoutCompact $ pretty pt+  CTree.Map _ -> annotate "map"+  CTree.Array _ -> annotate "array"+  CTree.Choice _ -> id+  CTree.Group _ -> annotate "group"+  CTree.KV {} -> annotate "kv"+  CTree.Occur {} -> id+  CTree.Range {} -> annotate "range"+  CTree.Control {} -> id+  CTree.Enum _ -> annotate "enum"+  CTree.Unwrap _ -> annotate "unwrap"+  CTree.Tag {} -> annotate "tag"+  CTree.CTreeE (GenRef n) -> annotate (unName n)+  CTree.CTreeE (GenGenerator _ _) -> annotate "custom_generator"++genForCTree :: HasCallStack => CTree GenPhase -> CBORGen WrappedTerm+genForCTree node = annotateTerm node $ case node of+  CTree.Literal v -> S <$> valueToTerm v+  CTree.Postlude pt -> S <$> genPostlude pt+  CTree.Map nodes -> genMap nodes+  CTree.Array nodes -> genArray nodes+  CTree.Choice (NE.toList -> nodes) -> do+    ix <- choose (0, length nodes - 1)+    genForCTree $ nodes !! ix+  CTree.Group nodes -> G <$> traverse genForCTree nodes+  CTree.KV key value _cut -> genKV key value+  CTree.Occur item occurs ->+    applyOccurenceIndicator occurs (genForCTree item)+  CTree.Range from to bounds -> genRange from to bounds+  CTree.Control op target controller -> genControl op target controller+  CTree.Enum tree -> genEnum tree+  CTree.Unwrap n -> genForCTree n+  CTree.Tag t n -> genTag t n+  CTree.CTreeE (GenRef n) -> genForNode n+  CTree.CTreeE (GenGenerator gen _) -> gen++-- | Generate a map from a list of nodes+genMap ::+  HasCallStack => [CTree GenPhase] -> CBORGen WrappedTerm+genMap nodes = do+  let+    elemsNeeded KV {} = 1+    elemsNeeded (Occur _ OIOneOrMore) = 1+    elemsNeeded (Occur _ (OIBounded (Just lo) _)) = lo+    elemsNeeded _ = 0++    tryGenKV ::+      Int -> Map.Map Term a -> CTree GenPhase -> CTree GenPhase -> CBORGen (Maybe (Term, Term))+    tryGenKV nTries m kNode vNode = go nTries+      where+        unS (S x) = x+        unS x = error $ "Expected single, got " <> show x+        go !n+          | n > 0 = do+              k <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "key") $ genForCTree kNode)+              if Map.notMember k m+                then do+                  v <- unS <$> scale (`div` 2) (withAntiGen (withAnnotation "value") $ genForCTree vNode)+                  pure $ Just (k, v)+                else go (n - 1)+          | otherwise = pure Nothing++    genNodes :: Int -> Map.Map Term Term -> [CTree GenPhase] -> CBORGen (Maybe (Map.Map Term Term))+    genNodes _ m [] = pure $ Just m+    genNodes !i !m (n : ns) =       let-        -- De-duplicate keys in the map.-        -- Per RFC7049:-        -- >> A map that has duplicate keys may be well-formed, but it is not-        -- >> valid, and thus it causes indeterminate decoding-        tsNodup = nubOrdOn fst ts+        ann = withAntiGen (withAnnotation (T.pack $ show i))+        cont x y = scale (\s -> max 0 (s - 1)) $ genNodes (i + 1) x y+        optGenKV kNode vNode = sized $ \sz ->+          frequency [(100, pure Nothing), (max 0 sz, ann $ tryGenKV 10 m kNode vNode)]        in-        pure . S $ TMap tsNodup-    Nothing -> error "Single terms in map context"-genForCTree cddl (CTree.Array nodes) = do-  items <- singleTermList . flattenWrappedList <$> traverse (genForCTree cddl) nodes+        case n of+          KV kNode vNode _ -> do+            mKV <- ann $ tryGenKV 100 m kNode vNode+            case mKV of+              Just (k, v) -> cont (Map.insert k v m) ns+              Nothing -> pure Nothing+          Occur kv@(KV kNode vNode _) oi -> case oi of+            OIOptional -> do+              mt <- optGenKV kNode vNode+              case mt of+                Just (k, v) -> cont (Map.insert k v m) ns+                Nothing -> cont m ns+            OIZeroOrMore -> do+              mt <- optGenKV kNode vNode+              case mt of+                Just (k, v) -> cont (Map.insert k v m) (n : ns)+                Nothing -> cont m ns+            OIOneOrMore -> genNodes i m (kv : Occur kv OIZeroOrMore : ns)+            OIBounded mlb mub -> do+              let+                clampedPred 0 = 0+                clampedPred x = x - 1+                newLow = clampedPred <$> mlb+                newHigh = clampedPred <$> mub+                res+                  | maybe False (> 0) mlb = genNodes i m (kv : Occur kv (OIBounded newLow newHigh) : ns)+                  | maybe False (< 1) mub = genNodes i m ns+                  | otherwise = do+                      mt <- optGenKV kNode vNode+                      case mt of+                        Just (k, v) -> cont (Map.insert k v m) (Occur kv (OIBounded newLow newHigh) : ns)+                        Nothing -> genNodes i m ns+              res+          node -> error $ "Unexpected node: " <> showSimple node+  mItems <- genNodes 0 Map.empty $ sortOn (Down . elemsNeeded) nodes+  case mItems of+    Just items -> S <$> twiddleMap (Map.toList items)+    Nothing -> error "Failed to generate unique keys for map after max retries"++-- | Generate an array from a list of nodes+genArray :: HasCallStack => [CTree GenPhase] -> CBORGen WrappedTerm+genArray nodes = do+  items <-+    singleTermList . flattenWrappedList+      <$> zipWithM+        (\i node -> withAntiGen (withAnnotation (T.pack $ show i)) $ genForCTree node)+        [0 :: Int ..]+        nodes   case items of-    Just ts -> pure . S $ TList ts+    Just ts -> S <$> twiddleList ts     Nothing -> error "Something weird happened which shouldn't be possible"-genForCTree cddl (CTree.Choice (NE.toList -> nodes)) = do-  ix <- choose (0, length nodes - 1)-  genForCTree cddl $ nodes !! ix-genForCTree cddl (CTree.Group nodes) = G <$> traverse (genForCTree cddl) nodes-genForCTree cddl (CTree.KV key value _cut) = do-  kg <- genForCTree cddl key-  vg <- genForCTree cddl value++-- | Generate a key-value pair+genKV :: HasCallStack => CTree GenPhase -> CTree GenPhase -> CBORGen WrappedTerm+genKV key value = do+  kg <- withAntiGen (withAnnotation "key") $ genForCTree key+  vg <- withAntiGen (withAnnotation "value") $ genForCTree value   case (kg, vg) of     (S k, S v) -> pure $ P k v     _ ->@@ -322,11 +473,17 @@           <> showSimple key           <> " => "           <> showSimple value-genForCTree cddl (CTree.Occur item occurs) =-  applyOccurenceIndicator occurs (genForCTree cddl item)-genForCTree cddl (CTree.Range from to bounds) = do-  term1 <- dropNegativeGen $ genForCTree cddl from-  term2 <- dropNegativeGen $ genForCTree cddl to++-- | Generate a value from a range+genRange ::+  HasCallStack =>+  CTree GenPhase ->+  CTree GenPhase ->+  RangeBound ->+  CBORGen WrappedTerm+genRange from to bounds = do+  term1 <- withAntiGen dropNegativeGen $ genForCTree from+  term2 <- withAntiGen dropNegativeGen $ genForCTree to   case (term1, term2) of     (S (TInt a), S (TInt b))       | a <= b -> genBetween (range bounds a b) <&> S . TInt@@ -342,9 +499,17 @@     (S (TDouble a), S (TDouble b))       | a <= b -> choose (range bounds a b) <&> S . TDouble     (a, b) -> error $ "invalid range (a = " <> show a <> ", b = " <> show b <> ")"-genForCTree cddl (CTree.Control op target controller) = do++-- | Generate a value with a control operator applied+genControl ::+  HasCallStack =>+  CtlOp.CtlOp ->+  CTree GenPhase ->+  CTree GenPhase ->+  CBORGen WrappedTerm+genControl op target controller = annotateTerm target $ do   resolvedController <- case controller of-    CTreeE (GenRef n) -> dropNegativeGen $ resolveRef cddl n+    CTreeE (GenRef n) -> withAntiGen dropNegativeGen $ resolveRef n     x -> pure x   case (op, resolvedController) of     (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case target of@@ -356,12 +521,12 @@       _ -> error "Cannot apply lt operator to target"     (CtlOp.Lt, _) -> error $ "Invalid controller for .lt operator: " <> showSimple controller     (CtlOp.Size, CTree.Literal (Value (VUInt s) _)) -> do-      s' <- pure s |! sized (\sz -> choose (0, fromIntegral sz) `suchThat` (/= s))+      s' <- liftAntiGen $ pure s |! sized (\sz -> choose (0, fromIntegral sz) `suchThat` (/= s))       genSized s' target-    (CtlOp.Size, CTree.Range {CTree.from, CTree.to}) -> do+    (CtlOp.Size, CTree.Range {CTree.from, CTree.to}) ->       case (from, to) of         (CTree.Literal (Value (VUInt f) _), CTree.Literal (Value (VUInt t) _)) -> do-          s <- sized $ \sz ->+          s <- liftAntiGen $ sized $ \sz ->             antiChoose               (fromIntegral f, fromIntegral t)               (0, max (succ t) $ fromIntegral sz)@@ -375,37 +540,45 @@         "Invalid controller for .size operator: "           <> showSimple controller     (CtlOp.Cbor, _) -> do-      enc <- genForCTree cddl controller+      enc <- genForCTree controller       case enc of-        S x -> pure . S . TBytes . CBOR.toStrictByteString $ CBOR.encodeTerm x+        S x -> fmap S . twiddleBytes $ CBOR.toStrictByteString (CBOR.encodeTerm x)         _ -> error "Controller does not correspond to a single term"     (c, _) -> error $ "Controller not yet implemented: " <> show c-genForCTree cddl (CTree.Enum tree) = do-  case tree of-    CTree.Group trees -> do-      ix <- choose (0, length trees - 1)-      genForCTree cddl $ trees !! ix-    _ -> error "Attempt to form an enum from something other than a group"-genForCTree cddl (CTree.Unwrap node) = genForCTree cddl node-genForCTree cddl (CTree.Tag t node) = do-  tag <- faultyNum t-  enc <- genForCTree cddl node++-- | Generate a value from an enum+genEnum :: HasCallStack => CTree GenPhase -> CBORGen WrappedTerm+genEnum tree = case tree of+  CTree.Group trees -> do+    ix <- choose (0, length trees - 1)+    genForCTree $ trees !! ix+  _ -> error "Attempt to form an enum from something other than a group"++-- | Generate a tagged value+genTag :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen WrappedTerm+genTag t node = do+  tag <- liftAntiGen $ faultyNum t+  enc <- case tag of+    n+      | n == 2 || n == 3 ->+          -- TODO remove this once `cborg` can decode indefinite bytes in bignums+          withTwiddle False $ genForCTree node+    _ -> genForCTree node   case enc of     S x -> pure $ S $ TTagged tag x     _ -> error "Tag controller does not correspond to a single term"-genForCTree cddl (CTree.CTreeE (GenRef n)) = genForNode cddl n-genForCTree cddl (CTree.CTreeE (GenGenerator (CBORGenerator gen) _)) = gen cddl -genForNode :: HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen WrappedTerm-genForNode cddl = genForCTree cddl <=< resolveRef cddl+genForNode :: HasCallStack => Name -> CBORGen WrappedTerm+genForNode = genForCTree <=< resolveRef  -- | Take a reference and resolve it to the relevant Tree, following multiple -- links if necessary.-resolveRef :: MonadGen m => CTreeRoot GenPhase -> Name -> m (CTree GenPhase)-resolveRef (CTreeRoot cddl) n = do+resolveRef :: Name -> CBORGen (CTree GenPhase)+resolveRef n = do+  mRule <- lookupCddl n   -- Since we follow a reference, we decrease the 'size' of the Gen monad.   scale (\x -> max 0 $ x - 1) $-    case Map.lookup n cddl of+    case mRule of       Nothing -> error $ "Unbound reference: " <> show n       Just val -> pure val @@ -418,11 +591,12 @@ -- single CBOR term (e.g. if the name resolves to a group, which cannot be -- generated outside a context). generateFromName :: HasCallStack => CTreeRoot GenPhase -> Name -> AntiGen Term-generateFromName root@(CTreeRoot cddl) n = do-  case Map.lookup n cddl of+generateFromName root@(CTreeRoot cddlMap) n = do+  let env = GenEnv {geRoot = root, geTwiddle = True}+  case Map.lookup n cddlMap of     Nothing -> error $ "Unbound reference: " <> show n     Just val ->-      genForCTree root val >>= \case+      runCBORGen env (genForCTree val) >>= \case         S x -> pure x         _ ->           error $@@ -446,8 +620,8 @@ -- | Apply an occurence indicator to a group entry applyOccurenceIndicator ::   OccurrenceIndicator ->-  AntiGen WrappedTerm ->-  AntiGen WrappedTerm+  CBORGen WrappedTerm ->+  CBORGen WrappedTerm applyOccurenceIndicator OIOptional oldGen =   sizeBiasedBool >>= \case     False -> pure $ G mempty@@ -455,7 +629,7 @@ applyOccurenceIndicator OIZeroOrMore oldGen =   G <$> listOfScaled oldGen applyOccurenceIndicator OIOneOrMore oldGen =-  G <$> listOfScaled1 oldGen+  withAntiGen (\g -> G <$> listOfScaled1 g) oldGen applyOccurenceIndicator (OIBounded mlb mub) oldGen =   sized $ \sz -> do     let@@ -464,20 +638,20 @@     i <- fromIntegral <$> genBetween (lb, ub)     G <$> vectorOf i (scale (`div` (i + 1)) oldGen) -valueToTerm :: Value -> Term+valueToTerm :: Value -> CBORGen Term valueToTerm (Value x _) = valueVariantToTerm x -valueVariantToTerm :: ValueVariant -> Term+valueVariantToTerm :: ValueVariant -> CBORGen Term valueVariantToTerm (VUInt i)-  | toInteger i <= toInteger (maxBound :: Int) = TInt (fromIntegral i)-  | otherwise = TInteger (fromIntegral i)+  | toInteger i <= toInteger (maxBound :: Int) = pure $ TInt (fromIntegral i)+  | otherwise = pure $ TInteger (fromIntegral i) valueVariantToTerm (VNInt i)-  | -toInteger i >= toInteger (minBound :: Int) = TInt (-fromIntegral i)-  | otherwise = TInteger (-fromIntegral i)-valueVariantToTerm (VBignum i) = TInteger i-valueVariantToTerm (VFloat16 i) = THalf i-valueVariantToTerm (VFloat32 i) = TFloat i-valueVariantToTerm (VFloat64 i) = TDouble i-valueVariantToTerm (VText t) = TString t-valueVariantToTerm (VBytes b) = TBytes b-valueVariantToTerm (VBool b) = TBool b+  | -toInteger i >= toInteger (minBound :: Int) = pure $ TInt (-fromIntegral i)+  | otherwise = pure $ TInteger (-fromIntegral i)+valueVariantToTerm (VBignum i) = pure $ TInteger i+valueVariantToTerm (VFloat16 i) = pure $ THalf i+valueVariantToTerm (VFloat32 i) = pure $ TFloat i+valueVariantToTerm (VFloat64 i) = pure $ TDouble i+valueVariantToTerm (VText t) = twiddleString t+valueVariantToTerm (VBytes b) = twiddleBytes b+valueVariantToTerm (VBool b) = pure $ TBool b

@@ -11,6 +11,7 @@ import Codec.CBOR.Cuddle.CBOR.Validator.Trace (   ControlInfo (..),   Evidenced (..),+  IsValidationTrace (..),   ListValidationTrace (..),   MapValidationTrace (..),   SValidity (..),@@ -34,8 +35,9 @@ import Data.Bits hiding (And) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL-import Data.Function ((&))+import Data.Function (on, (&)) import Data.IntSet qualified as IS+import Data.List (maximumBy) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map@@ -145,12 +147,14 @@     -- a = any     Postlude PTAny -> terminal rule     -- a = int-    Postlude PTInt -> terminal rule+    Postlude PTInt+      | i >= nintMin && i <= uintMax -> terminal rule     -- a = uint     Postlude PTUInt-      | i >= 0 -> terminal rule+      | i >= 0 && i <= uintMax -> terminal rule     -- a = nint-    Postlude PTNInt | i <= 0 -> terminal rule+    Postlude PTNInt+      | i >= nintMin && i <= -1 -> terminal rule     -- a = x     Literal (Value (VUInt i') _) | i == fromIntegral i' -> terminal rule     -- a = -x@@ -624,7 +628,7 @@ controlBytes cddl bs Cbor ctrl =   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of     Right (BSL.null -> True, term) -> isValid $ validateTerm cddl term ctrl-    _ -> error "Not yet implemented"+    _ -> False controlBytes cddl bs Cborseq ctrl =   case deserialiseFromBytes decodeTerm (BSL.fromStrict (BS.snoc (BS.cons 0x9f bs) 0xff)) of     Right (BSL.null -> True, TListI terms) -> isValid $ validateTerm cddl (TList terms) (Array [Occur ctrl OIZeroOrMore])@@ -756,29 +760,43 @@ validateList cddl terms rule =   case rule of     Postlude PTAny -> terminal rule-    Array rules -> mapTrace ListTrace . fst $ validate finalize terms rules+    Array rules -> mapTrace ListTrace . fst $ validate finalize [] terms rules       where-        finalize [] = evidence ListValidationDone-        finalize (x : xs) = evidence . ListValidationLeftoverTerms $ x :| xs+        finalize _ [] = evidence ListValidationDone+        finalize skipped (x : xs) =+          let leftovers = x :| xs+              unwrapOccur (Occur ct _) = ct+              unwrapOccur ct = ct+              attempts =+                [ (mapIndex r, trc)+                | r <- skipped+                , Evidenced SInvalid trc <- [validateTerm cddl x (unwrapOccur r)]+                , measureProgress trc > mempty+                ]+              bestAttempt = case attempts of+                [] -> Nothing+                _ -> Just $ maximumBy (compare `on` (measureProgress . snd)) attempts+           in evidence $ ListValidationLeftoverTerms leftovers bestAttempt     Choice opts -> validateChoice (validateList cddl terms) opts     _ -> unapplicable rule   where     validate ::-      ([Term] -> Evidenced ListValidationTrace) ->+      ([CTree ValidatorStage] -> [Term] -> Evidenced ListValidationTrace) ->+      [CTree ValidatorStage] ->       [Term] ->       [CTree ValidatorStage] ->       (Evidenced ListValidationTrace, [Term])-    validate f tss [] = (f tss, tss)-    validate f [] (r : rs)-      | isOptional r = validate f [] rs-      | otherwise = (evidence $ ListValidationUnappliedRules (mapIndex <$> r :| rs), [])-    validate f tss@(t : ts) (r : rs) =+    validate f skipped tss [] = (f skipped tss, tss)+    validate f skipped [] (r : rs)+      | isOptional r = validate f skipped [] rs+      | otherwise = (evidence . ListValidationUnappliedRule $ mapIndex r, [])+    validate f skipped tss@(t : ts) (r : rs) =       let         consumeTerm ct g = case validateTerm cddl t ct of           Evidenced SValid trc -> first (mapTrace $ ListValidationConsume (mapIndex r) trc) $ g ts           Evidenced SInvalid trc -> (evidence $ ListValidationMissingRequired (mapIndex ct) trc, tss) -        consumeGroup ns gp g = case validate (const $ evidence ListValidationDone) tss gp of+        consumeGroup ns gp g = case validate (\_ _ -> evidence ListValidationDone) [] tss gp of           (Evidenced SValid trc, leftover) -> first (mapTrace $ ListValidationConsumeGroup (reverse ns) trc) $ g leftover           (Evidenced SInvalid trc, leftover) -> (evidence $ ListValidationBadGroup (reverse ns) trc, leftover) @@ -792,9 +810,9 @@         consume (Group gp) g = consumeGroup [] gp g         consume (KV _ v _) g = consume v g         consume ct g = consumeTerm ct g-        continue l = validate f l rs-        skipRule = validate f tss rs-        rewriteRule newRule l = validate f l (newRule : rs)+        continue l = validate f skipped l rs+        skipRule = validate f (r : skipped) tss rs+        rewriteRule newRule l = validate f skipped l (newRule : rs)         validateRule =           \case             Occur ct oi -> case oi of@@ -833,8 +851,24 @@   where     validate ::       [CTree ValidatorStage] -> [(Term, Term)] -> [CTree ValidatorStage] -> Evidenced MapValidationTrace-    validate [] [] [] = evidence MapValidationDone-    validate _ kvs [] = evidence $ MapValidationLeftoverKVs kvs+    validate _ [] [] = evidence MapValidationDone+    validate exhausted (kv : _) [] =+      let+        unwrapOccur (Occur ct _) = ct+        unwrapOccur ct = ct+        attempts =+          [ (mapIndex r, MapValidationInvalidValue (mapIndex r) kTrc vTrc)+          | r <- exhausted+          , KV k v _ <- [unwrapOccur r]+          , Evidenced SValid kTrc <- [validateTerm cddl (fst kv) k]+          , Evidenced SInvalid vTrc <- [validateTerm cddl (snd kv) v]+          , measureProgress (MapValidationInvalidValue (mapIndex r) kTrc vTrc) > mempty+          ]+        bestAttempt = case attempts of+          [] -> Nothing+          _ -> Just $ maximumBy (compare `on` (measureProgress . snd)) attempts+       in+        evidence $ MapValidationLeftoverKVs kv bestAttempt     validate [] [] rs =       case NE.nonEmpty $ filter (not . isOptional) rs of         Nothing -> evidence MapValidationDone

@@ -19,11 +19,12 @@   ListValidationTrace (..),   MapValidationTrace (..),   Evidenced (..),+  IsValidationTrace (..),   ControlInfo (..),   TraceOptions (..),+  Progress (..),   defaultTraceOptions,   showSimple,-  traceValidity,   isValid,   prettyValidationTrace,   showValidationTrace,@@ -184,16 +185,22 @@  data ListValidationTrace (v :: Validity) where   ListValidationDone :: ListValidationTrace IsValid-  ListValidationLeftoverTerms :: NonEmpty Term -> ListValidationTrace IsInvalid-  ListValidationUnappliedRules ::-    NonEmpty (CTree ValidatorStageSimple) -> ListValidationTrace IsInvalid+  ListValidationLeftoverTerms ::+    NonEmpty Term ->+    Maybe (CTree ValidatorStageSimple, ValidationTrace IsInvalid) ->+    ListValidationTrace IsInvalid+  ListValidationUnappliedRule ::+    CTree ValidatorStageSimple ->+    ListValidationTrace IsInvalid   ListValidationConsume ::     CTree ValidatorStageSimple ->     ValidationTrace IsValid ->     ListValidationTrace v ->     ListValidationTrace v   ListValidationMissingRequired ::-    CTree ValidatorStageSimple -> ValidationTrace IsInvalid -> ListValidationTrace IsInvalid+    CTree ValidatorStageSimple ->+    ValidationTrace IsInvalid ->+    ListValidationTrace IsInvalid   ListValidationConsumeGroup ::     [Name] ->     ListValidationTrace IsValid ->@@ -208,7 +215,10 @@  data MapValidationTrace (v :: Validity) where   MapValidationDone :: MapValidationTrace IsValid-  MapValidationLeftoverKVs :: [(Term, Term)] -> MapValidationTrace IsInvalid+  MapValidationLeftoverKVs ::+    (Term, Term) ->+    Maybe (CTree ValidatorStageSimple, MapValidationTrace IsInvalid) ->+    MapValidationTrace IsInvalid   MapValidationUnappliedRules :: NonEmpty (CTree ValidatorStageSimple) -> MapValidationTrace IsInvalid   MapValidationInvalidValue ::     CTree ValidatorStageSimple ->@@ -250,9 +260,24 @@       GT -> x       _ -> y +data Progress = Progress {termProgress :: !Int, refProgress :: !Int}+  deriving (Eq, Ord)++instance Semigroup Progress where+  Progress t1 r1 <> Progress t2 r2 = Progress (t1 + t2) (r1 + r2)++instance Monoid Progress where+  mempty = Progress 0 0++increaseTermProgress :: Progress -> Progress+increaseTermProgress p = p <> Progress 1 0++increaseRefProgress :: Progress -> Progress+increaseRefProgress p = p <> Progress 0 1+ class IsValidationTrace (t :: Validity -> Type) where   traceValidity :: t v -> SValidity v-  measureProgress :: t v -> Int+  measureProgress :: t v -> Progress  instance IsValidationTrace ValidationTrace where   traceValidity = \case@@ -269,51 +294,55 @@     TagTrace _ x -> traceValidity x    measureProgress = \case-    TerminalRule {} -> 1-    CustomSuccess -> 1-    ChoiceBranch {} -> 1-    UnapplicableRule {} -> 0-    CustomFailure {} -> 0-    UnsatisfiedControl {} -> 0-    InvalidTag {} -> 0-    ReferenceRule _ x -> succ $ measureProgress x+    TerminalRule {} -> Progress 1 0+    CustomSuccess -> Progress 1 0+    ChoiceBranch _ x -> measureProgress x+    UnapplicableRule {} -> mempty+    CustomFailure {} -> mempty+    UnsatisfiedControl {} -> mempty+    InvalidTag {} -> mempty+    ReferenceRule _ x -> increaseRefProgress $ measureProgress x     ListTrace x -> measureProgress x     MapTrace x -> measureProgress x-    TagTrace _ x -> succ $ measureProgress x+    TagTrace _ x -> increaseTermProgress $ measureProgress x  instance IsValidationTrace ListValidationTrace where   traceValidity = \case     ListValidationDone -> SValid     ListValidationLeftoverTerms {} -> SInvalid-    ListValidationUnappliedRules {} -> SInvalid+    ListValidationUnappliedRule {} -> SInvalid     ListValidationMissingRequired {} -> SInvalid     ListValidationBadGroup _ _ -> SInvalid     ListValidationConsume _ _ x -> traceValidity x     ListValidationConsumeGroup _ _ x -> traceValidity x    measureProgress = \case-    ListValidationDone -> 10-    ListValidationConsume _ _ x -> succ $ measureProgress x-    ListValidationLeftoverTerms _ -> 0-    ListValidationMissingRequired _ _ -> 0-    ListValidationUnappliedRules _ -> 0-    ListValidationConsumeGroup _ g x -> measureProgress g + measureProgress x-    ListValidationBadGroup _ x -> measureProgress x+    ListValidationDone -> Progress 1 0+    ListValidationConsume _ _ x -> increaseTermProgress $ measureProgress x+    ListValidationLeftoverTerms _ Nothing -> mempty+    ListValidationLeftoverTerms _ (Just (_, trc)) -> measureProgress trc+    ListValidationMissingRequired _ _ -> mempty+    ListValidationUnappliedRule _ -> mempty+    ListValidationConsumeGroup rs g x -> Progress 0 (length rs) <> measureProgress g <> measureProgress x+    ListValidationBadGroup rs x -> Progress 0 (length rs) <> measureProgress x  instance IsValidationTrace MapValidationTrace where   traceValidity = \case     MapValidationDone -> SValid-    MapValidationLeftoverKVs _ -> SInvalid+    MapValidationLeftoverKVs _ _ -> SInvalid     MapValidationUnappliedRules _ -> SInvalid     MapValidationInvalidValue {} -> SInvalid     MapValidationConsume _ _ _ x -> traceValidity x    measureProgress = \case-    MapValidationDone -> 10-    MapValidationLeftoverKVs _ -> 0-    MapValidationUnappliedRules _ -> 0-    MapValidationConsume _ _ _ x -> 3 + measureProgress x-    MapValidationInvalidValue {} -> 2+    MapValidationDone -> Progress 1 0+    MapValidationLeftoverKVs _ Nothing -> mempty+    MapValidationLeftoverKVs _ (Just (_, trc)) -> measureProgress trc+    MapValidationUnappliedRules _ -> mempty+    MapValidationConsume _ kTrc vTrc x ->+      measureProgress kTrc <> measureProgress vTrc <> measureProgress x+    MapValidationInvalidValue _ kTrc vTrc ->+      measureProgress kTrc <> measureProgress vTrc  evidence :: (Show (t v), IsValidationTrace t) => t v -> Evidenced t evidence x = Evidenced (traceValidity x) x@@ -345,8 +374,21 @@ prettyListValidationResult :: TraceOptions -> ListValidationTrace v -> Doc AnsiStyle prettyListValidationResult opts@TraceOptions {..} = \case   ListValidationDone -> mempty-  ListValidationLeftoverTerms _ -> annotate (color Red) "leftover elements after all rules have been applied"-  ListValidationUnappliedRules _ -> annotate (color Red) "not all required rules have been applied"+  ListValidationLeftoverTerms _ Nothing ->+    annotate (color Red) "leftover elements not matched by any rule"+  ListValidationLeftoverTerms _ (Just (rule, trc)) ->+    hang 2 $+      vsep+        [ annotate (color Red) "leftover elements, closest matching rule:"+        , annotate (color Green) $ pretty rule+        , nestContainer $ prettyValidationTrace opts trc+        ]+  ListValidationUnappliedRule r ->+    hang 2 $+      vsep+        [ annotate (color Red) "required rule not satisfied:"+        , pretty r+        ]   ListValidationConsume _ t c     | toFoldValid -> foldValid 1 c     | otherwise -> vsep $ continue c [prettyValidationTrace opts t]@@ -383,7 +425,15 @@ prettyMapValidationResult :: TraceOptions -> MapValidationTrace v -> Doc AnsiStyle prettyMapValidationResult opts@TraceOptions {..} = \case   MapValidationDone -> mempty-  MapValidationLeftoverKVs _ -> annotate (color Red) "no more rules left to apply"+  MapValidationLeftoverKVs _ Nothing ->+    annotate (color Red) "leftover key-value pairs not matched by any rule"+  MapValidationLeftoverKVs _ (Just (rule, trc)) ->+    hang 2 $+      vsep+        [ annotate (color Red) "leftover key-value pairs, closest matching rule:"+        , annotate (color Green) $ pretty rule+        , nestContainer $ prettyMapValidationResult opts trc+        ]   MapValidationUnappliedRules rs ->     hang 2 $       vsep

@@ -2,7 +2,8 @@ {-# LANGUAGE TypeFamilies #-}  module Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGenerator (..),+  CBORGen (..),+  GenEnv (..),   HasGenerator (..),   WrappedTerm (..),   CBORValidator (..),@@ -10,21 +11,63 @@   GenPhase,   XXCTree (..),   CustomValidatorResult (..),+  liftAntiGen,+  runCBORGen,+  lookupCddl,+  withAntiGen,+  withTwiddle, ) where  import Codec.CBOR.Cuddle.CDDL (Name)-import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot, XXCTree)+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), XXCTree) import Codec.CBOR.Term (Term)+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, mapReaderT)+import Data.Map.Strict qualified as Map import Data.Text (Text) import GHC.Generics (Generic) import Optics.Core (Lens') import Test.AntiGen (AntiGen)+import Test.QuickCheck.GenT (MonadGen (..))  type data GenPhase +data GenEnv = GenEnv+  { geRoot :: CTreeRoot GenPhase+  , geTwiddle :: Bool+  }+  deriving (Generic)++newtype CBORGen a = CBORGen (ReaderT GenEnv AntiGen a)+  deriving (Functor, Applicative, Monad, MonadReader GenEnv)++instance MonadGen CBORGen where+  liftGen g = CBORGen $ ReaderT $ \_ -> liftGen g+  variant n (CBORGen m) = CBORGen $ mapReaderT (variant n) m+  sized f = CBORGen . ReaderT $ \env -> sized $ \n ->+    let CBORGen m = f n in runReaderT m env+  resize n (CBORGen m) = CBORGen $ mapReaderT (resize n) m+  choose rng = CBORGen . ReaderT $ \_ -> choose rng++liftAntiGen :: AntiGen a -> CBORGen a+liftAntiGen m = CBORGen . ReaderT $ const m++runCBORGen :: GenEnv -> CBORGen a -> AntiGen a+runCBORGen env (CBORGen m) = runReaderT m env++lookupCddl :: Name -> CBORGen (Maybe (CTree GenPhase))+lookupCddl n = do+  CTreeRoot root <- asks geRoot+  pure $ Map.lookup n root++withAntiGen :: (AntiGen a -> AntiGen b) -> CBORGen a -> CBORGen b+withAntiGen f (CBORGen m) = CBORGen $ ReaderT $ \env -> f (runReaderT m env)++withTwiddle :: Bool -> CBORGen a -> CBORGen a+withTwiddle t = local (\x -> x {geTwiddle = t})+ data instance XXCTree GenPhase   = GenRef Name-  | GenGenerator CBORGenerator (CTree GenPhase)+  | GenGenerator (CBORGen WrappedTerm) (CTree GenPhase)  data WrappedTerm   = -- | Single term@@ -33,12 +76,10 @@     P Term Term   | -- | Group term     G [WrappedTerm]-  deriving (Eq, Show)--newtype CBORGenerator = CBORGenerator (CTreeRoot GenPhase -> AntiGen WrappedTerm)+  deriving (Eq, Ord, Show)  class HasGenerator a where-  generatorL :: Lens' a (Maybe CBORGenerator)+  generatorL :: Lens' a (Maybe (CBORGen WrappedTerm))  class HasValidator a where   validatorL :: Lens' a (Maybe CBORValidator)

@@ -13,6 +13,8 @@ import Data.Map.Strict qualified as Map import Data.Word (Word64) import GHC.Generics (Generic)+import Generic.Random (genericArbitraryU)+import Test.QuickCheck (Arbitrary (..))  -------------------------------------------------------------------------------- @@ -137,6 +139,17 @@   | PTAny   | PTNil   | PTUndefined-  deriving (Eq, Generic, Ord, Show)+  deriving (Eq, Generic, Ord, Show, Enum, Bounded) +instance Arbitrary PTerm where+  arbitrary = genericArbitraryU+ instance Hashable PTerm++-- Bounds++uintMax :: Integer+uintMax = 2 ^ (64 :: Int) - 1++nintMin :: Integer+nintMin = -(2 ^ (64 :: Int))

@@ -12,7 +12,7 @@ ) where  import Codec.CBOR.Cuddle.CDDL (XCddl, XRule, XTerm, XXTopLevel, XXType2)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGenerator, CBORValidator)+import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORGen, CBORValidator, WrappedTerm) import Data.Default.Class (Default) import Data.Hashable (Hashable) import GHC.Generics (Generic)@@ -29,7 +29,7 @@ data instance XCddl CTreePhase = CTreeXCddl   deriving (Generic, Show, Eq, Ord) -data instance XRule CTreePhase = CTreeXRule (Maybe CBORGenerator) (Maybe CBORValidator)+data instance XRule CTreePhase = CTreeXRule (Maybe (CBORGen WrappedTerm)) (Maybe CBORValidator)   deriving (Generic)  data instance XXType2 CTreePhase

@@ -66,9 +66,10 @@ import Data.List (foldl') #endif import Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGenerator,+  CBORGen,   CBORValidator,   GenPhase,+  WrappedTerm,   XXCTree (..),  ) import Codec.CBOR.Cuddle.CDDL.CTreePhase (CTreePhase, XRule (..))@@ -96,7 +97,7 @@  data CDDLMapEntry = CDDLMapEntry   { cmeProvidedParameters :: ProvidedParameters (TypeOrGroup CTreePhase)-  , cmeCustomGenerator :: Maybe CBORGenerator+  , cmeCustomGenerator :: Maybe (CBORGen WrappedTerm)   , cmeCustomValidator :: Maybe CBORValidator   }   deriving (Generic)@@ -158,7 +159,7 @@ data instance XXCTree OrReferenced   = -- | Reference to another node with possible generic arguments supplied     OrRef Name [CTree OrReferenced]-  | OGenerator CBORGenerator (CTree OrReferenced)+  | OGenerator (CBORGen WrappedTerm) (CTree OrReferenced)   | OValidator CBORValidator (CTree OrReferenced)  type data OrReferencedSimple@@ -393,7 +394,7 @@  data instance XXCTree DistReferenced   = DRef (DistRef DistReferenced)-  | DGenerator CBORGenerator (CTree DistReferenced)+  | DGenerator (CBORGen WrappedTerm) (CTree DistReferenced)   | DValidator CBORValidator (CTree DistReferenced)  type data DistReferencedNoGen@@ -448,7 +449,7 @@  data instance XXCTree MonoReferenced   = MRuleRef Name-  | MGenerator CBORGenerator (CTree MonoReferenced)+  | MGenerator (CBORGen WrappedTerm) (CTree MonoReferenced)   | MValidator CBORValidator (CTree MonoReferenced)  type MonoEnv = BindingEnv DistReferenced MonoReferenced

@@ -91,8 +91,9 @@   callToDef,    -- * Generators-  withGenerator,   withAntiGen,+  withGenerator,+  withCBORGen,    -- * Validators   withValidator,@@ -111,9 +112,10 @@ import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), HasName (..), Name (..), XRule) import Codec.CBOR.Cuddle.CDDL qualified as C import Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGenerator (..),+  CBORGen (..),   CBORValidator (..),   CustomValidatorResult,+  GenEnv (..),   GenPhase,   HasGenerator (..),   HasValidator (..),@@ -125,6 +127,7 @@ import Codec.CBOR.Cuddle.Comments qualified as C import Codec.CBOR.Term (Term) import Control.Monad (when)+import Control.Monad.Reader (ReaderT (..)) import Control.Monad.State (MonadState (get), State, execState, modify) import Data.ByteString (ByteString) import Data.ByteString.Base16 qualified as Base16@@ -146,7 +149,7 @@ import Optics.Core (lens, view, (%), (%~), (&)) import Optics.Core qualified as L import Test.AntiGen (AntiGen)-import Test.QuickCheck (Gen)+import Test.QuickCheck.Gen (Gen) import Test.QuickCheck.GenT (MonadGen (liftGen)) import Prelude hiding ((/)) @@ -160,7 +163,7 @@  data instance C.XRule HuddleStage = HuddleXRule   { hxrComment :: C.Comment-  , hxrGenerator :: Maybe CBORGenerator+  , hxrGenerator :: Maybe (CBORGen WrappedTerm)   , hxrValidator :: Maybe CBORValidator   }   deriving (Generic)@@ -1377,13 +1380,20 @@ -- | Use a custom `QuickCheck` generator to generate the term. Will override -- the generator passed via `withAntiGen` withGenerator :: HasGenerator a => (CTreeRoot GenPhase -> Gen WrappedTerm) -> a -> a-withGenerator f = L.set generatorL (Just . CBORGenerator $ liftGen . f)+withGenerator f = L.set generatorL (Just . CBORGen . ReaderT $ \GenEnv {geRoot} -> liftGen $ f geRoot)+{-# DEPRECATED withGenerator "Use withCBORGen instead" #-}  -- | Use a custom `AntiGen` generator to generate the term. Will override -- the custom generator passed via `withGenerator`. The advantage of using -- `AntiGen` generator is that it can also be used to generate negative examples. withAntiGen :: HasGenerator a => (CTreeRoot GenPhase -> AntiGen WrappedTerm) -> a -> a-withAntiGen f = L.set generatorL (Just $ CBORGenerator f)+withAntiGen f = L.set generatorL (Just . CBORGen . ReaderT $ \GenEnv {geRoot} -> f geRoot)+{-# DEPRECATED withAntiGen "Use withCBORGen instead" #-}++-- | Use a custom `CBORGen` generator to generate the term. Will override+-- the custom generator passed via `withGenerator`.+withCBORGen :: HasGenerator a => CBORGen WrappedTerm -> a -> a+withCBORGen gen = L.set generatorL (Just gen)  withValidator :: HasValidator a => (Term -> CustomValidatorResult) -> a -> a withValidator p = L.set validatorL . Just $ CBORValidator p

@@ -6,8 +6,8 @@   huddleArray,   huddleMap,   huddleRangeMap,-  simpleRule,-  simpleTermExample,+  customGenRule,+  customGenExample,   refTermExample,   bytesExample,   opCertExample,@@ -17,6 +17,15 @@   rangeMapExample,   optionalMapExample,   choicesExample,+  cborControlExample,+  listTooShortExample,+  listSkippedRuleExample,+  listSkippedRuleNestedExample,+  mapLeftoverKVExample,+  mapNoMatchingKeyExample,+  listZeroOrMoreExample,+  mapNestedValueExample,+  deeplyNestedRefExample, ) where  import Codec.CBOR.Cuddle.CDDL (Name)@@ -34,8 +43,7 @@   idx,   mp,   opt,-  sized,-  withGenerator,+  withCBORGen,   (...),   (=:=),   (==>),@@ -43,7 +51,7 @@ import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Term qualified as C import Data.Word (Word64)-import Test.QuickCheck.Gen (choose)+import Test.QuickCheck.GenT (MonadGen (..))  huddleRangeArray :: Huddle huddleRangeArray =@@ -95,18 +103,21 @@     ]  simpleRule :: Name -> Rule-simpleRule n = withGenerator (\_ -> S . C.TInt <$> choose (4, 6)) $ n =:= arr [1, 2, 3]+simpleRule n = n =:= arr [1, 2, 3] -simpleTermExample :: Huddle-simpleTermExample =+customGenRule :: Name -> Rule+customGenRule = withCBORGen (S . C.TInt <$> choose (4, 6)) . simpleRule++customGenExample :: Huddle+customGenExample =   collectFrom-    [ HIRule $ simpleRule "root"+    [ HIRule $ customGenRule "root"     ]  refTermExample :: Huddle refTermExample =   collectFrom-    [ HIRule $ "root" =:= arr [0, a $ simpleRule "bar"]+    [ HIRule $ "root" =:= arr [0, a $ customGenRule "bar"]     ]  bytesExample :: Huddle@@ -121,22 +132,22 @@     [ HIRule $         "root"           =:= arr-            [ a (VBytes `sized` (32 :: Word64))+            [ a (VBytes `H.sized` (32 :: Word64))             , a VUInt             , a VUInt-            , a (VBytes `sized` (64 :: Word64))+            , a (VBytes `H.sized` (64 :: Word64))             ]     ]  sizeTextExample :: Huddle sizeTextExample =   collectFrom-    [HIRule $ "root" =:= VText `sized` (0 :: Word64, 32 :: Word64)]+    [HIRule $ "root" =:= VText `H.sized` (0 :: Word64, 32 :: Word64)]  sizeBytesExample :: Huddle sizeBytesExample =   collectFrom-    [HIRule $ "root" =:= VBytes `sized` (0 :: Word64, 32 :: Word64)]+    [HIRule $ "root" =:= VBytes `H.sized` (0 :: Word64, 32 :: Word64)]  rangeListExample :: Huddle rangeListExample =@@ -164,7 +175,7 @@     [ HIRule $         "root"           =:= mp-            [ 10 <+ asKey ((0 :: Integer) ... (10 :: Integer)) ==> VBool+            [ 10 <+ asKey ((1 :: Integer) ... (10 :: Integer)) ==> VBool             ]     ] @@ -177,3 +188,120 @@           H./ arr [1, a VBool, 6]           H./ arr [1, a VText]     ]++cborControlExample :: Huddle+cborControlExample =+  collectFrom+    [ HIRule $+        "root"+          =:= VBytes+          `H.cbor` simpleRule "simpleRule"+    ]++listTooShortExample :: Huddle+listTooShortExample =+  collectFrom+    [ HIRule $+        "root"+          =:= arr+            [ a VInt+            , a VText+            , a VBool+            ]+    ]++listSkippedRuleExample :: Huddle+listSkippedRuleExample =+  let bar = "bar" =:= VText+   in collectFrom+        [ HIRule $+            "root"+              =:= arr+                [ a VInt+                , opt $ a bar+                ]+        , HIRule bar+        ]++listSkippedRuleNestedExample :: Huddle+listSkippedRuleNestedExample =+  let baz = "baz" =:= arr [a VInt, a VText]+      qux = "qux" =:= VText+      quux = "quux" =:= VInt+   in collectFrom+        [ HIRule $+            "root"+              =:= arr+                [ a VInt+                , opt $ a qux+                , opt $ a baz+                , opt $ a quux+                ]+        , HIRule baz+        , HIRule qux+        , HIRule quux+        ]++mapLeftoverKVExample :: Huddle+mapLeftoverKVExample =+  collectFrom+    [ HIRule $+        "root"+          =:= mp+            [ opt $ idx 1 ==> VText+            , opt $ idx 2 ==> VInt+            , opt $ idx 3 ==> VBool+            ]+    ]++mapNoMatchingKeyExample :: Huddle+mapNoMatchingKeyExample =+  collectFrom+    [ HIRule $+        "root"+          =:= mp+            [ opt $ idx 1 ==> VText+            , opt $ idx 2 ==> VInt+            ]+    ]++listZeroOrMoreExample :: Huddle+listZeroOrMoreExample =+  collectFrom+    [ HIRule $+        "root"+          =:= arr+            [ 0 <+ a VInt+            , a VText+            ]+    ]++mapNestedValueExample :: Huddle+mapNestedValueExample =+  let bar = "bar" =:= arr [a VInt, a VText]+   in collectFrom+        [ HIRule $+            "root"+              =:= mp+                [ opt $ idx 1 ==> bar+                ]+        , HIRule bar+        ]++-- | A rule with deeply nested references competing against a rule that makes+-- actual term progress. Used to test that stacked references don't incorrectly+-- beat rules with real progress.+deeplyNestedRefExample :: Huddle+deeplyNestedRefExample =+  collectFrom+    [ HIRule $ "root" =:= arr [a VInt, opt $ a aRef, opt $ a listRule]+    , HIRule aRef+    , HIRule barRef+    , HIRule bazRef+    , HIRule listRule+    ]+  where+    bazRef = "baz" =:= VText+    barRef = "bar" =:= bazRef+    aRef = "a_ref" =:= barRef+    listRule = "list_rule" =:= arr [a VInt, a VInt]

@@ -16,21 +16,22 @@ import Codec.CBOR.Term (Term (..), decodeTerm, encodeTerm) import Codec.CBOR.Write (toStrictByteString) import Data.ByteString.Lazy qualified as LBS+import Data.Text qualified as T import Data.Text.Lazy qualified as TL-import Test.AntiGen (runAntiGen, zapAntiGen)+import Test.AntiGen (ZapResult (..), prettyZapResult, runAntiGen, zapAntiGenResult) import Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (   bytesExample,+  customGenExample,   opCertExample,   optionalMapExample,   rangeListExample,   rangeMapExample,   refTermExample,-  simpleTermExample,   sizeBytesExample,   sizeTextExample,  )-import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid)-import Test.Hspec (HasCallStack, Spec, describe, runIO, shouldBe, shouldSatisfy)+import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid, genAndValidateRule)+import Test.Hspec (HasCallStack, Spec, describe, runIO, shouldSatisfy, xdescribe) import Test.Hspec.Core.Spec (SpecM) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Gen, Property, Testable (..), counterexample)@@ -47,13 +48,18 @@  expectZapInvalidates :: CTreeRoot MonoReferenced -> Name -> Property expectZapInvalidates cddl name = property $ do-  value <- zapAntiGen 1 $ generateFromName (mapIndex cddl) name+  res@ZapResult {zrValue} <- zapAntiGenResult 1 $ generateFromName (mapIndex cddl) name   let-    bs = toStrictByteString $ encodeTerm value+    bs = toStrictByteString $ encodeTerm zrValue     validationRes = validateCBOR bs name $ mapIndex cddl-    failMsg = case deserialiseFromBytes decodeTerm (LBS.fromStrict bs) of-      Right (_, t) -> prettyHexEnc (encodeTerm t)-      Left _ -> mempty+    failMsg =+      unlines+        [ case deserialiseFromBytes decodeTerm (LBS.fromStrict bs) of+            Right (_, t) -> prettyHexEnc (encodeTerm t)+            Left _ -> mempty+        , mempty+        , T.unpack $ prettyZapResult res+        ]   pure . counterexample failMsg $ expectInvalid validationRes  zapInvalidatesHuddle :: String -> Huddle -> Spec@@ -62,24 +68,43 @@   prop n . counterexample (TL.unpack . pShow $ mapIndex @_ @_ @MonoSimple cddl) $     expectZapInvalidates cddl "root" +-- | Test that generated values are valid for a Huddle schema+genAndValidateHuddle :: String -> Huddle -> Spec+genAndValidateHuddle n huddle = do+  cddl <- tryResolveHuddle huddle+  genAndValidateRule n "root" cddl+ spec :: Spec spec = do+  describe "Positive generator" $ do+    describe "Generated value validates" $ do+      -- Note: simpleTermExample and refTermExample use custom generators+      -- that intentionally produce type-mismatched values, so they're excluded+      genAndValidateHuddle "opCert" opCertExample+      genAndValidateHuddle "sizeText" sizeTextExample+      genAndValidateHuddle "sizeBytes" sizeBytesExample+      genAndValidateHuddle "rangeList" rangeListExample+      genAndValidateHuddle "rangeMap" rangeMapExample+      xdescribe "Generator cannot reliably produce unique keys for maps" $ do+        genAndValidateHuddle "optionalMapExample" optionalMapExample+   describe "Negative generator" $ do     describe "Zapped value fails to validate" $ do-      zapInvalidatesHuddle "simpleTerm" simpleTermExample+      zapInvalidatesHuddle "customGen" customGenExample       zapInvalidatesHuddle "refTerm" refTermExample       zapInvalidatesHuddle "opCert" opCertExample       zapInvalidatesHuddle "sizeText" sizeTextExample       zapInvalidatesHuddle "sizeBytes" sizeBytesExample       zapInvalidatesHuddle "rangeList" rangeListExample       zapInvalidatesHuddle "rangeMap" rangeMapExample-      zapInvalidatesHuddle "optionalMapExample" optionalMapExample+      xdescribe "Generator cannot reliably produce unique keys for maps" $ do+        zapInvalidatesHuddle "optionalMapExample" optionalMapExample    describe "Custom generators" $ do     describe "Huddle" $ do-      simpleTermExampleCddl <- tryResolveHuddle simpleTermExample+      customGenExampleCddl <- tryResolveHuddle customGenExample       prop "If a term has a custom generator then it is used" $ do-        res <- generateCDDL $ mapIndex simpleTermExampleCddl+        res <- generateCDDL $ mapIndex customGenExampleCddl         pure $           res `shouldSatisfy` \case             TInt i -> i > 3 && i < 7@@ -90,8 +115,13 @@         pure $           res `shouldSatisfy` \case             TList [TInt 0, TInt i] -> i > 3 && i < 7+            TListI [TInt 0, TInt i] -> i > 3 && i < 7             _ -> False       bytesExampleCddl <- tryResolveHuddle bytesExample       prop "Bytes are generated correctly" $ do         res <- generateCDDL $ mapIndex bytesExampleCddl-        pure $ res `shouldBe` TBytes "\x01\x02\x03\xff"+        pure $+          res `shouldSatisfy` \case+            TBytes "\x01\x02\x03\xff" -> True+            TBytesI "\x01\x02\x03\xff" -> True+            _ -> False

@@ -6,6 +6,8 @@   spec,   expectValid,   expectInvalid,+  genAndValidateCddl,+  genAndValidateRule, ) where  import Codec.CBOR.Cuddle.CBOR.Gen (generateFromName)@@ -24,7 +26,7 @@ import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude)-import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL)+import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, fullResolveCDDL) import Codec.CBOR.Cuddle.Huddle (   Huddle,   HuddleItem (..),@@ -69,6 +71,7 @@   Spec,   describe,   expectationFailure,+  it,   runIO,  ) import Test.Hspec.QuickCheck@@ -90,6 +93,31 @@  ) import Text.Megaparsec (runParser) +-- | Test that a specific rule in a resolved CDDL generates valid values+genAndValidateRule :: String -> Name -> CTreeRoot MonoReferenced -> Spec+genAndValidateRule description name resolvedCddl =+  prop description $ do+    cborTerm <- runAntiGen $ generateFromName (mapIndex resolvedCddl) name+    let+      generatedCbor = toStrictByteString $ encodeTerm cborTerm+      res = validateCBOR generatedCbor name (mapIndex resolvedCddl)+      extraInfo =+        unlines+          [ "CBOR term:"+          , prettyHexEnc $ encodeTerm cborTerm+          ]+    pure . counterexample extraInfo $ expectValid res++-- | Test that all rules in a resolved CDDL generate valid values+genAndValidateCddl :: String -> CTreeRoot MonoReferenced -> Spec+genAndValidateCddl description resolvedCddl@(CTreeRoot m) = do+  let+    isRule CTree.Group {} = False+    isRule _ = True+  describe description $ do+    forM_ (Map.keys $ Map.filter isRule m) $ \name@(Name n) ->+      genAndValidateRule (T.unpack n) name resolvedCddl+ genAndValidateFromFile :: FilePath -> Spec genAndValidateFromFile path = do   contents <- runIO $ T.readFile =<< getDataFileName path@@ -97,24 +125,10 @@     cddl = fromRight (error "Failed to parse CDDL") $ runParser pCDDL path contents     resolverError x =       error $ "Failed to resolve the CDDL from file " <> show path <> ":\n" <> show x-    resolvedCddl@(CTreeRoot m) =+    resolvedCddl =       either resolverError id . fullResolveCDDL . appendPostlude $         mapCDDLDropExt cddl-    isRule CTree.Group {} = False-    isRule _ = True-  describe path $ do-    forM_ (Map.keys $ Map.filter isRule m) $ \name@(Name n) ->-      prop (T.unpack n) $ do-        cborTerm <- runAntiGen $ generateFromName (mapIndex resolvedCddl) name-        let-          generatedCbor = toStrictByteString $ encodeTerm cborTerm-          res = validateCBOR generatedCbor name (mapIndex resolvedCddl)-          extraInfo =-            unlines-              [ "CBOR term:"-              , prettyHexEnc $ encodeTerm cborTerm-              ]-        pure . counterexample extraInfo $ expectValid res+  genAndValidateCddl path resolvedCddl  genInfiniteUniqueList :: Ord a => Gen a -> Gen [a] genInfiniteUniqueList = fmap nubOrd . infiniteListOf@@ -307,6 +321,29 @@         prop "Fails to validate map with too many range elements"           . forAll (genHuddleRangeMap (11, 20))           $ expectInvalid . validateHuddle huddleRangeMap "a"++    describe "Bignums" $ do+      let+        bignum = 2 ^ (64 :: Int) :: Integer+        bignumCBOR = toStrictByteString . encodeTerm $ TInteger bignum+        resolveCDDL cddlText =+          let cddl = fromRight (error "Failed to parse CDDL") $ runParser pCDDL "" cddlText+           in either (error . show) id . fullResolveCDDL . appendPostlude $ mapCDDLDropExt cddl+      it "Validates a bignum >= 2^64 against biguint" $+        expectValid $+          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = biguint")+      it "Validates a bignum >= 2^64 against bigint" $+        expectValid $+          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = bigint")+      it "Validates a bignum >= 2^64 against integer" $+        expectValid $+          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = integer")+      it "Rejects a bignum >= 2^64 against int" $+        expectInvalid $+          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = int")+      it "Rejects a bignum >= 2^64 against uint" $+        expectInvalid $+          validateCBOR bignumCBOR "a" (mapIndex $ resolveCDDL "a = uint")    describe "Custom validator" $ do     describe "Positive" $ do

@@ -14,6 +14,7 @@ import Codec.CBOR.Cuddle.Huddle (Huddle, toCDDL) import Codec.CBOR.Cuddle.IndexMappable (mapCDDLDropExt, mapIndex) import Codec.CBOR.Term (Term (..), encodeTerm)+import Codec.CBOR.Write (toStrictByteString) import Codec.CBOR.Write qualified as CBOR import Control.Monad ((<=<)) import Data.Either (fromRight)@@ -24,13 +25,25 @@ import Prettyprinter.Render.Terminal qualified as Ansi import System.FilePath ((</>)) import Test.Codec.CBOR.Cuddle.CDDL.Examples.Huddle (+  cborControlExample,   choicesExample,+  deeplyNestedRefExample,   huddleRangeArray,+  listSkippedRuleExample,+  listSkippedRuleNestedExample,+  listTooShortExample,+  listZeroOrMoreExample,+  mapLeftoverKVExample,+  mapNestedValueExample,+  mapNoMatchingKeyExample,   refTermExample,  ) import Test.Hspec (Spec, describe, it) import Test.Hspec.Golden (Golden (..)) +listTooShortTerm :: Term+listTooShortTerm = TList [TInt 42]+ huddleRangeArrayTermTwoStrings :: Term huddleRangeArrayTermTwoStrings =   TList@@ -60,6 +73,27 @@     , TInt 1     ] +listSkippedRuleTerm :: Term+listSkippedRuleTerm = TList [TInt 1, TInt 2]++listSkippedRuleNestedTerm :: Term+listSkippedRuleNestedTerm = TList [TInt 1, TList [TInt 2, TInt 3]]++mapLeftoverKVTerm :: Term+mapLeftoverKVTerm = TMap [(TInt 2, TString "hello")]++mapNoMatchingKeyTerm :: Term+mapNoMatchingKeyTerm = TMap [(TInt 99, TString "hello")]++listZeroOrMoreTerm :: Term+listZeroOrMoreTerm = TList [TInt 1, TInt 2, TString "hello", TBool True]++mapNestedValueTerm :: Term+mapNestedValueTerm = TMap [(TInt 1, TList [TInt 2, TInt 3])]++cborControlBad :: Term+cborControlBad = TBytes . toStrictByteString $ encodeTerm (TList [TInt 1, TInt 2, TInt 4])+ validatorPrettyGolden :: String -> Huddle -> Name -> Term -> Spec validatorPrettyGolden testName huddle n term =   it testName $@@ -102,3 +136,50 @@       choicesExample       "root"       choiceAlmostSecond+    validatorPrettyGolden+      "cborControlBad"+      cborControlExample+      "root"+      cborControlBad+    validatorPrettyGolden+      "listTooShort"+      listTooShortExample+      "root"+      listTooShortTerm+    validatorPrettyGolden+      "listSkippedRule"+      listSkippedRuleExample+      "root"+      listSkippedRuleTerm+    validatorPrettyGolden+      "listSkippedRuleNested"+      listSkippedRuleNestedExample+      "root"+      listSkippedRuleNestedTerm+    validatorPrettyGolden+      "mapLeftoverKV"+      mapLeftoverKVExample+      "root"+      mapLeftoverKVTerm+    validatorPrettyGolden+      "mapNoMatchingKey"+      mapNoMatchingKeyExample+      "root"+      mapNoMatchingKeyTerm+    validatorPrettyGolden+      "listZeroOrMore"+      listZeroOrMoreExample+      "root"+      listZeroOrMoreTerm+    validatorPrettyGolden+      "mapNestedValue"+      mapNestedValueExample+      "root"+      mapNestedValueTerm+    -- Deeply nested refs competing against a rule that makes actual term+    -- progress. The stacked refs should NOT win over real term progress.+    validatorPrettyGolden+      "deeplyNestedRefVsRealProgress"+      deeplyNestedRefExample+      "root"+      (TList [TInt 1, TList [TInt 1, TString "hello"]])