cuddle 1.6.0.0 → 1.7.0.0

raw patch · 36 files changed

+871/−466 lines, 36 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +29/−0
• bin/Main.hs +48/−22
• cuddle.cabal +4/−2
• golden/pretty/rule_comment_appends_to_existing.txt +3/−0
• golden/pretty/rule_comment_chained.txt +3/−0
• golden/pretty/rule_comment_empty.txt +1/−0
• golden/pretty/rule_comment_multi_rule.txt +8/−0
• golden/pretty/rule_comment_multiline.txt +3/−0
• golden/pretty/rule_comment_rule.txt +2/−0
• golden/pretty/term_comment_appends_to_existing.txt +3/−0
• golden/pretty/term_comment_array_entries.txt +5/−0
• golden/pretty/term_comment_chained.txt +3/−0
• golden/pretty/term_comment_empty.txt +1/−0
• golden/pretty/term_comment_multiline.txt +3/−0
• golden/pretty/term_comment_rule.txt +2/−0
• src/Codec/CBOR/Cuddle/CBOR/Gen.hs +75/−64
• src/Codec/CBOR/Cuddle/CBOR/Validator.hs +123/−80
• src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +29/−74
• src/Codec/CBOR/Cuddle/CDDL.hs +5/−0
• src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs +0/−92
• src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs +5/−2
• src/Codec/CBOR/Cuddle/CDDL/Custom/Core.hs +25/−0
• src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs +103/−0
• src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs +76/−0
• src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +57/−24
• src/Codec/CBOR/Cuddle/Comments.hs +26/−9
• src/Codec/CBOR/Cuddle/Huddle.hs +18/−42
• src/Codec/CBOR/Cuddle/IndexMappable.hs +2/−2
• src/Codec/CBOR/Cuddle/Parser.hs +6/−3
• src/Codec/CBOR/Cuddle/Parser/Lexer.hs +2/−2
• src/Codec/CBOR/Cuddle/Pretty.hs +30/−4
• test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs +44/−3
• test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +2/−2
• test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +32/−16
• test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs +77/−9
• test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +16/−14

@@ -1,5 +1,34 @@ # Changelog for `cuddle` +## 1.7.0.0++* Rename `WrappedTerm` to `RuleTerm`+* Rename `RuleTerm` constructors:+  * `S` -> `SingleTerm`+  * `G` -> `GroupTerm`+  * `P` -> `PairTerm`+* Split `Codec.CBOR.Cuddle.CDDL.CBORGenerator` into:+  * `Codec.CBOR.Cuddle.CDDL.Custom.Generator`+  * `Codec.CBOR.Cuddle.CDDL.Custom.Validator`+  * `Codec.CBOR.Cuddle.CDDL.Custom.Core`+* Fix `--no-twiddle` argument+* Add autocompletion hints+* Add footer, improve output format failure message+* Make `(//-)` prefix each comment line with a leading space and change its fixity from `infixr 0` to `infixl 1`+* Hide the `Comment` constructor; use `toComment` or `commentLine` smart constructors instead+* Add `appendComment` for raw comment concatenation in parser combinators+* Export `GRef` constructor+* Custom generators and validators on generic rules can now refer to their+  generic argument: looking up a `GRef` resolves to the type bound at the+  enclosing rule+* Add `generateFromGRef`+* Add `validateFromName` and `validateFromGRef`+* Move `GRef` to `Codec.CBOR.Cuddle.CDDL`+* Add `MonadCddl`+* `runCBORValidator` now takes `CTreeRoot ValidatorPhase` instead of `ValidateEnv`+* Split `GenEnv` into a user-supplied `GenConfig` and a runtime `GenEnv`. `runCBORGen` now takes a `GenConfig`.+* Rename `ValidatorStage` to `ValidatorPhase`+ ## 1.6.0.0  * Remove `example` executable

@@ -15,8 +15,8 @@   prettyValidationTrace,  ) import Codec.CBOR.Cuddle.CDDL (CDDL, Name (..), fromRules, sortCDDL)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (GenEnv (..), runCBORGen) import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot)+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (GenConfig (..), runCBORGen) import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) import Codec.CBOR.Cuddle.CDDL.Resolve (   fullResolveCDDL,@@ -50,6 +50,7 @@   PageWidth (..),   defaultLayoutOptions,   layoutPretty,+  vsep,  ) import Prettyprinter.Render.Terminal qualified as Ansi import System.Exit (exitFailure, exitSuccess)@@ -102,7 +103,12 @@ pCBOROutputFormat = eitherReader $ \k ->   case Map.lookup k outputFormatOptions of     Just x -> Right x-    Nothing -> Left k+    Nothing ->+      Left $+        unlines+          [ "invalid value: " <> k+          , "expecting one of: " <> unwords (Map.keys outputFormatOptions)+          ]  data GenOpts = GenOpts   { outputFormat :: CBOROutputFormat@@ -131,6 +137,7 @@           ( long "out-file"               <> short 'o'               <> help "Write to"+              <> action "file"           )       )     <*> switch@@ -152,13 +159,14 @@     <*> switch       ( long "negative"           <> short 'n'-          <> help "Generate a negative example"-      )-    <*> option-      (not <$> auto)-      ( long "no-twiddle"-          <> help "Do not generate indefinite encodings"+          <> help "Generate a negative (zapped) example"       )+    <*> ( not+            <$> switch+              ( long "no-twiddle"+                  <> help "Do not generate indefinite encodings"+              )+        )     <*> argument       str       (metavar "RULE" <> help "Name of the CDDL rule to generate a CBOR term for")@@ -212,7 +220,7 @@       ( metavar "RULE"           <> help "Name of the CDDL rule to validate this file with"       )-    <*> argument str (metavar "CBOR_FILE")+    <*> argument str (metavar "CBOR_FILE" <> action "file")  data CBORInputFormat   = FromHex@@ -234,7 +242,12 @@ pCBORInputFormat :: ReadM CBORInputFormat pCBORInputFormat = eitherReader $ \k -> case Map.lookup k inputFormatOptions of   Just x -> Right x-  Nothing -> Left k+  Nothing ->+    Left $+      unlines+        [ "invalid value: " <> k+        , "expecting one of: " <> unwords (Map.keys inputFormatOptions)+        ]  pFormatCBOROpts :: Parser FormatCBOROpts pFormatCBOROpts =@@ -258,6 +271,7 @@           ( long "out-file"               <> short 'o'               <> help "Write to"+              <> action "file"           )       ) @@ -267,31 +281,34 @@     ( command         "format"         ( info-            (Format <$> pFormatOpts <*> argument str (metavar "CDDL_FILE") <**> helper)+            (Format <$> pFormatOpts <*> argument str (metavar "CDDL_FILE" <> action "file") <**> helper)             (progDesc "Format the provided CDDL file")         )         <> command           "validate"           ( info-              (Validate <$> pValidateOpts <*> argument str (metavar "CDDL_FILE") <**> helper)+              (Validate <$> pValidateOpts <*> argument str (metavar "CDDL_FILE" <> action "file") <**> helper)               (progDesc "Validate the provided CDDL file")           )         <> command           "gen"           ( info-              (GenerateCBOR <$> pGenOpts <*> argument str (metavar "CDDL_FILE") <**> helper)+              (GenerateCBOR <$> pGenOpts <*> argument str (metavar "CDDL_FILE" <> action "file") <**> helper)               (progDesc "Generate a CBOR term matching the schema")           )         <> command           "validate-cbor"           ( info-              (ValidateCBOR <$> pValidateCBOROpts <*> argument str (metavar "CDDL_FILE") <**> helper)+              ( ValidateCBOR+                  <$> pValidateCBOROpts+                  <*> argument str (metavar "CDDL_FILE" <> action "file") <**> helper+              )               (progDesc "Validate a CBOR file against a schema")           )         <> command           "format-cbor"           ( info-              (FormatCBOR <$> pFormatCBOROpts <*> argument str (metavar "CBOR_FILE") <**> helper)+              (FormatCBOR <$> pFormatCBOROpts <*> argument str (metavar "CBOR_FILE" <> action "file") <**> helper)               (progDesc "Output a CBOR binary in diagnostic formatting")           )     )@@ -304,7 +321,16 @@         (pCommand <**> helper <**> simpleVersioner (showVersion version))         ( fullDesc             <> progDesc "Manipulate CDDL files"-            <> header "cuddle"+            <> header "cuddle - a CDDL tool for validating, formatting, and generating CBOR"+            <> footerDoc+              ( Just $+                  vsep+                    [ "To enable shell completions, add the appropriate line to your shell config:"+                    , "  Bash: source <(cuddle --bash-completion-script cuddle)"+                    , "  Zsh:  source <(cuddle --zsh-completion-script cuddle)"+                    , "  Fish: cuddle --fish-completion-script cuddle | source"+                    ]+              )         )   run options @@ -372,12 +398,12 @@           zapN             | goNegative = 1             | otherwise = 0-          env =-            GenEnv-              { geRoot = mapIndex mt-              , geTwiddle = goTwiddle+          cfg =+            GenConfig+              { gcRoot = mapIndex mt+              , gcTwiddle = goTwiddle               }-          term = runGen seed goSize . zapAntiGen zapN . runCBORGen env $ generateFromName (Name itemName)+          term = runGen seed goSize . zapAntiGen zapN . runCBORGen cfg $ generateFromName (Name itemName)           formatted = formatTerm term outputFormat         case outputTo of           Just outputPath -> BS.writeFile outputPath formatted@@ -417,7 +443,7 @@   IO (Either (ParseErrorBundle T.Text e) a) parseFromFile p file = runParser p file <$> T.readFile file -runValidateCBOR :: BS.ByteString -> Name -> CTreeRoot ValidatorStage -> TraceOptions -> IO ()+runValidateCBOR :: BS.ByteString -> Name -> CTreeRoot ValidatorPhase -> TraceOptions -> IO () runValidateCBOR bs rule cddl traceOpts =   case validateCBOR bs rule cddl of     Evidenced validity trc -> do

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle-version: 1.6.0.0+version: 1.7.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).@@ -42,10 +42,12 @@     Codec.CBOR.Cuddle.CBOR.Validator     Codec.CBOR.Cuddle.CBOR.Validator.Trace     Codec.CBOR.Cuddle.CDDL-    Codec.CBOR.Cuddle.CDDL.CBORGenerator     Codec.CBOR.Cuddle.CDDL.CTree     Codec.CBOR.Cuddle.CDDL.CTreePhase     Codec.CBOR.Cuddle.CDDL.CtlOp+    Codec.CBOR.Cuddle.CDDL.Custom.Core+    Codec.CBOR.Cuddle.CDDL.Custom.Generator+    Codec.CBOR.Cuddle.CDDL.Custom.Validator     Codec.CBOR.Cuddle.CDDL.Postlude     Codec.CBOR.Cuddle.CDDL.Resolve     Codec.CBOR.Cuddle.Comments

@@ -0,0 +1,3 @@+;existing+; trailing+a = true

@@ -0,0 +1,3 @@+; first+; second+a = true

@@ -0,0 +1,1 @@+a = true

@@ -0,0 +1,8 @@+; the listening port+port = uint++; the host name+host = text++; TLS only+secure = true

@@ -0,0 +1,3 @@+; line one+; line two+a = true

@@ -0,0 +1,2 @@+; trailing+a = true

@@ -0,0 +1,3 @@+;existing+a =+  true ; trailing

@@ -0,0 +1,5 @@+triple =+  [ uint ; first element+  , text ; second element+  , true ; third element+  ]

@@ -0,0 +1,3 @@+a =+  true ; first+       ; second

@@ -0,0 +1,1 @@+a = true

@@ -0,0 +1,3 @@+a =+  true ; line one+       ; line two

@@ -0,0 +1,2 @@+a =+  true ; trailing

@@ -16,6 +16,7 @@ -- | Generate example CBOR given a CDDL specification module Codec.CBOR.Cuddle.CBOR.Gen (   generateFromName,+  generateFromGRef,   GenPhase,   GenSimple,   XXCTree (..),@@ -24,23 +25,13 @@ #if MIN_VERSION_random(1,3,0) #endif import Codec.CBOR.Cuddle.CDDL (+  GRef (..),   Name (..),   OccurrenceIndicator (..),   RangeBound (..),   Value (..),   ValueVariant (..),  )-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGen (..),-  GenEnv (..),-  GenPhase,-  WrappedTerm (..),-  XXCTree (..),-  liftAntiGen,-  lookupCddl,-  withAntiGen,-  withTwiddle,- ) import Codec.CBOR.Cuddle.CDDL.CTree (   CTree (..),   PTerm (..),@@ -50,6 +41,16 @@  ) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp+import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (+  CBORGen,+  GenConfig (..),+  GenEnv (..),+  GenPhase,+  disableTwiddle,+  liftAntiGen,+  withAntiGen,+ ) import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..)) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Term (Term (..))@@ -160,28 +161,28 @@  twiddleString :: Text -> CBORGen Term twiddleString t = do-  twiddle <- asks geTwiddle+  twiddle <- asks (gcTwiddle . geConfig)   if twiddle     then ($ t) <$> elements [TString, TStringI . TL.fromStrict]     else pure $ TString t  twiddleList :: [Term] -> CBORGen Term twiddleList t = do-  twiddle <- asks geTwiddle+  twiddle <- asks (gcTwiddle . geConfig)   if twiddle     then ($ t) <$> elements [TList, TListI]     else pure $ TList t  twiddleBytes :: ByteString -> CBORGen Term twiddleBytes t = do-  twiddle <- asks geTwiddle+  twiddle <- asks (gcTwiddle . geConfig)   if twiddle     then ($ t) <$> elements [TBytes, TBytesI . LBS.fromStrict]     else pure $ TBytes t  twiddleMap :: [(Term, Term)] -> CBORGen Term twiddleMap t = do-  twiddle <- asks geTwiddle+  twiddle <- asks (gcTwiddle . geConfig)   if twiddle     then ($ t) <$> elements [TMap, TMapI]     else pure $ TMap t@@ -284,18 +285,18 @@  -- | Recursively flatten wrapped list. That is, expand any groups out to their -- individual entries.-flattenWrappedList :: [WrappedTerm] -> [WrappedTerm]+flattenWrappedList :: [RuleTerm] -> [RuleTerm] flattenWrappedList [] = []-flattenWrappedList (G xxs : xs) =+flattenWrappedList (GroupTerm xxs : xs) =   flattenWrappedList xxs <> flattenWrappedList xs flattenWrappedList (y : xs) = y : flattenWrappedList xs  -- | Convert a list of wrapped terms to a list of terms. If any 'PairTerm's are -- present, we just take their "value" part.-singleTermList :: [WrappedTerm] -> Maybe [Term]+singleTermList :: [RuleTerm] -> Maybe [Term] singleTermList [] = Just []-singleTermList (S x : xs) = (x :) <$> singleTermList xs-singleTermList (P _ y : xs) = (y :) <$> singleTermList xs+singleTermList (SingleTerm x : xs) = (x :) <$> singleTermList xs+singleTermList (PairTerm _ y : xs) = (y :) <$> singleTermList xs singleTermList _ = Nothing  showSimple :: CTree GenPhase -> String@@ -309,11 +310,11 @@ -- Generator functions -------------------------------------------------------------------------------- -genSized :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen WrappedTerm+genSized :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen RuleTerm 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)+  CTree.Postlude PTText -> fmap SingleTerm . twiddleString =<< genNBytesText (fromIntegral s)+  CTree.Postlude PTBytes -> fmap SingleTerm . twiddleBytes =<< genNBytes (fromIntegral s)+  CTree.Postlude PTUInt -> SingleTerm . TInteger <$> choose (0, 256 ^ s - 1)   _ -> error "Cannot apply size operator to target "  range :: Enum a => RangeBound -> a -> a -> (a, a)@@ -351,16 +352,16 @@   CTree.CTreeE (GenRef n) -> annotate (unName n)   CTree.CTreeE (GenGenerator _ _) -> annotate "custom_generator" -genForCTree :: HasCallStack => CTree GenPhase -> CBORGen WrappedTerm+genForCTree :: HasCallStack => CTree GenPhase -> CBORGen RuleTerm genForCTree node = annotateTerm node $ case node of-  CTree.Literal v -> S <$> valueToTerm v-  CTree.Postlude pt -> S <$> genPostlude pt+  CTree.Literal v -> SingleTerm <$> valueToTerm v+  CTree.Postlude pt -> SingleTerm <$> 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.Group nodes -> GroupTerm <$> traverse genForCTree nodes   CTree.KV key value _cut -> genKV key value   CTree.Occur item occurs ->     applyOccurenceIndicator occurs (genForCTree item)@@ -374,7 +375,7 @@  -- | Generate a map from a list of nodes genMap ::-  HasCallStack => [CTree GenPhase] -> CBORGen WrappedTerm+  HasCallStack => [CTree GenPhase] -> CBORGen RuleTerm genMap nodes = do   let     elemsNeeded KV {} = 1@@ -386,7 +387,7 @@       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 (SingleTerm x) = x         unS x = error $ "Expected single, got " <> show x         go !n           | n > 0 = do@@ -446,11 +447,11 @@           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)+    Just items -> SingleTerm <$> 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 :: HasCallStack => [CTree GenPhase] -> CBORGen RuleTerm genArray nodes = do   items <-     singleTermList . flattenWrappedList@@ -459,16 +460,16 @@         [0 :: Int ..]         nodes   case items of-    Just ts -> S <$> twiddleList ts+    Just ts -> SingleTerm <$> twiddleList ts     Nothing -> error "Something weird happened which shouldn't be possible"  -- | Generate a key-value pair-genKV :: HasCallStack => CTree GenPhase -> CTree GenPhase -> CBORGen WrappedTerm+genKV :: HasCallStack => CTree GenPhase -> CTree GenPhase -> CBORGen RuleTerm 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+    (SingleTerm k, SingleTerm v) -> pure $ PairTerm k v     _ ->       error $         "Non single-term generated outside of group context: "@@ -482,24 +483,24 @@   CTree GenPhase ->   CTree GenPhase ->   RangeBound ->-  CBORGen WrappedTerm+  CBORGen RuleTerm 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-    (S (TInt a), S (TInteger b))+    (SingleTerm (TInt a), SingleTerm (TInt b))+      | a <= b -> genBetween (range bounds a b) <&> SingleTerm . TInt+    (SingleTerm (TInt a), SingleTerm (TInteger b))       | fromIntegral a <= b ->-          genBetween (range bounds (fromIntegral a) b) <&> S . TInteger-    (S (TInteger a), S (TInteger b))-      | a <= b -> genBetween (range bounds a b) <&> S . TInteger-    (S (THalf a), S (THalf b))-      | a <= b -> choose (range bounds a b) <&> S . THalf-    (S (TFloat a), S (TFloat b))-      | a <= b -> choose (range bounds a b) <&> S . TFloat-    (S (TDouble a), S (TDouble b))-      | a <= b -> choose (range bounds a b) <&> S . TDouble+          genBetween (range bounds (fromIntegral a) b) <&> SingleTerm . TInteger+    (SingleTerm (TInteger a), SingleTerm (TInteger b))+      | a <= b -> genBetween (range bounds a b) <&> SingleTerm . TInteger+    (SingleTerm (THalf a), SingleTerm (THalf b))+      | a <= b -> choose (range bounds a b) <&> SingleTerm . THalf+    (SingleTerm (TFloat a), SingleTerm (TFloat b))+      | a <= b -> choose (range bounds a b) <&> SingleTerm . TFloat+    (SingleTerm (TDouble a), SingleTerm (TDouble b))+      | a <= b -> choose (range bounds a b) <&> SingleTerm . TDouble     (a, b) -> error $ "invalid range (a = " <> show a <> ", b = " <> show b <> ")"  -- | Generate a value with a control operator applied@@ -508,18 +509,18 @@   CtlOp.CtlOp ->   CTree GenPhase ->   CTree GenPhase ->-  CBORGen WrappedTerm+  CBORGen RuleTerm genControl op target controller = annotateTerm target $ do   resolvedController <- case controller of     CTreeE (GenRef n) -> withAntiGen dropNegativeGen $ resolveRef n     x -> pure x   case (op, resolvedController) of     (CtlOp.Le, CTree.Literal (Value (VUInt n) _)) -> case target of-      CTree.Postlude PTUInt -> S . TInteger <$> choose (0, fromIntegral n)+      CTree.Postlude PTUInt -> SingleTerm . TInteger <$> choose (0, fromIntegral n)       _ -> error "Cannot apply le operator to target"     (CtlOp.Le, _) -> error $ "Invalid controller for .le operator: " <> showSimple controller     (CtlOp.Lt, CTree.Literal (Value (VUInt n) _)) -> case target of-      CTree.Postlude PTUInt -> S . TInteger <$> choose (0, fromIntegral n - 1)+      CTree.Postlude PTUInt -> SingleTerm . TInteger <$> choose (0, fromIntegral n - 1)       _ -> 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@@ -544,12 +545,12 @@     (CtlOp.Cbor, _) -> do       enc <- genForCTree controller       case enc of-        S x -> fmap S . twiddleBytes $ CBOR.toStrictByteString (CBOR.encodeTerm x)+        SingleTerm x -> fmap SingleTerm . twiddleBytes $ CBOR.toStrictByteString (CBOR.encodeTerm x)         _ -> error "Controller does not correspond to a single term"     (c, _) -> error $ "Controller not yet implemented: " <> show c  -- | Generate a value from an enum-genEnum :: HasCallStack => CTree GenPhase -> CBORGen WrappedTerm+genEnum :: HasCallStack => CTree GenPhase -> CBORGen RuleTerm genEnum tree = case tree of   CTree.Group trees -> do     ix <- choose (0, length trees - 1)@@ -557,7 +558,7 @@   _ -> error "Attempt to form an enum from something other than a group"  -- | Generate a tagged value-genTag :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen WrappedTerm+genTag :: HasCallStack => Word64 -> CTree GenPhase -> CBORGen RuleTerm genTag t node = do   omitTag <- liftAntiGen $ faultyBool False   if omitTag@@ -568,13 +569,13 @@         n           | n == 2 || n == 3 ->               -- TODO remove this once `cborg` can decode indefinite bytes in bignums-              withTwiddle False $ genForCTree node+              disableTwiddle $ genForCTree node         _ -> genForCTree node       case enc of-        S x -> pure $ S $ TTagged tag x+        SingleTerm x -> pure $ SingleTerm $ TTagged tag x         _ -> error "Tag controller does not correspond to a single term" -genForNode :: HasCallStack => Name -> CBORGen WrappedTerm+genForNode :: HasCallStack => Name -> CBORGen RuleTerm genForNode = genForCTree <=< resolveRef  -- | Take a reference and resolve it to the relevant Tree, following multiple@@ -603,13 +604,23 @@     Nothing -> error $ "Unbound reference: " <> show n     Just val ->       genForCTree val >>= \case-        S x -> pure x+        SingleTerm x -> pure x         _ ->           error $             "Tried to generate a top-level term for "               <> show n               <> ", but it does not correspond to a single term." +-- | Generate a 'RuleTerm' for the type bound to the given generic+-- parameter at the enclosing rule. Use this from inside a custom generator+-- attached to a generic rule.+generateFromGRef :: HasCallStack => GRef -> CBORGen RuleTerm+generateFromGRef ref = do+  mRule <- lookupGRef ref+  case mRule of+    Nothing -> error $ "Unbound generic reference: " <> show ref+    Just val -> genForCTree val+ sizeBiasedBool :: MonadGen m => m Bool sizeBiasedBool = sized $ \sz -> (> 1) <$> choose (0, sz) @@ -626,23 +637,23 @@ -- | Apply an occurence indicator to a group entry applyOccurenceIndicator ::   OccurrenceIndicator ->-  CBORGen WrappedTerm ->-  CBORGen WrappedTerm+  CBORGen RuleTerm ->+  CBORGen RuleTerm applyOccurenceIndicator OIOptional oldGen =   sizeBiasedBool >>= \case-    False -> pure $ G mempty+    False -> pure $ GroupTerm mempty     True -> oldGen applyOccurenceIndicator OIZeroOrMore oldGen =-  G <$> listOfScaled oldGen+  GroupTerm <$> listOfScaled oldGen applyOccurenceIndicator OIOneOrMore oldGen =-  withAntiGen (\g -> G <$> listOfScaled1 g) oldGen+  withAntiGen (fmap GroupTerm . listOfScaled1) oldGen applyOccurenceIndicator (OIBounded mlb mub) oldGen =   sized $ \sz -> do     let       lb = fromMaybe 0 mlb       ub = fromMaybe (lb + fromIntegral sz) mub     i <- fromIntegral <$> genBetween (lb, ub)-    G <$> vectorOf i (scale (`div` (i + 1)) oldGen)+    GroupTerm <$> vectorOf i (scale (`div` (i + 1)) oldGen)  valueToTerm :: Value -> CBORGen Term valueToTerm (Value x _) = valueVariantToTerm x

@@ -5,7 +5,9 @@  module Codec.CBOR.Cuddle.CBOR.Validator (   validateCBOR,-  ValidatorStage,+  validateFromName,+  validateFromGRef,+  ValidatorPhase, ) where  import Codec.CBOR.Cuddle.CBOR.Validator.Trace (@@ -16,7 +18,6 @@   MapValidationTrace (..),   SValidity (..),   ValidationTrace (..),-  ValidatorStage,   XXCTree (..),   evidence,   isValid,@@ -24,12 +25,21 @@   showSimple,  ) import Codec.CBOR.Cuddle.CDDL hiding (CDDL, Group, Rule)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORValidator (..), CustomValidatorResult (..)) import Codec.CBOR.Cuddle.CDDL.CTree import Codec.CBOR.Cuddle.CDDL.CtlOp+import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (+  CustomValidatorResult (..),+  TermValidator,+  ValidateEnv (..),+  Validator,+  ValidatorPhase,+  runValidator,+ ) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Read import Codec.CBOR.Term+import Control.Monad.Reader (asks) import Data.Bifunctor (Bifunctor (..)) import Data.Bits hiding (And) import Data.ByteString qualified as BS@@ -56,7 +66,7 @@   HasCallStack =>   BS.ByteString ->   Name ->-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Evidenced ValidationTrace validateCBOR bs rule cddl@(CTreeRoot tree) =   case deserialiseFromBytes decodeTerm (BSL.fromStrict bs) of@@ -65,21 +75,50 @@       | BSL.null rest -> validateTerm cddl term (tree Map.! rule)       | otherwise -> error $ "Leftover bytes in CBOR: " <> show rest +-- | Validate a CBOR 'Term' against a top-level rule from inside a custom+-- validator.+validateFromName ::+  HasCallStack => Name -> Term -> Validator ()+validateFromName n term = do+  mRule <- lookupCddl n+  case mRule of+    Nothing -> fail $ "Unbound name: " <> show n+    Just rule -> validateAgainst term rule++-- | Validate a CBOR 'Term' against the type bound to the given generic+-- parameter at the enclosing rule. Use this from inside a custom validator+-- attached to a generic rule.+validateFromGRef ::+  HasCallStack => GRef -> Term -> Validator ()+validateFromGRef ref term = do+  mRule <- lookupGRef ref+  case mRule of+    Nothing -> fail $ "Unbound generic reference: " <> show ref+    Just rule -> validateAgainst term rule++validateAgainst :: Term -> CTree ValidatorPhase -> Validator ()+validateAgainst term rule = do+  cddl <- asks veRoot+  let res = validateTerm cddl term rule+  if isValid res+    then pure ()+    else fail $ "Validation failed for term: " <> show term+ -------------------------------------------------------------------------------- -- Terms  -- | Core function that validates a CBOR term to a particular rule of the CDDL -- spec validateTerm ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Term ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateTerm cddl term rule   | CTreeE (VRuleRef n) <- rule =       dereferenceAndValidate cddl n (validateTerm cddl term)   | CTreeE (VValidator v _) <- rule =-      runCustomValidator term v+      runCustomValidator cddl (SingleTerm term) v   | otherwise =       case term of         TInt i -> validateInteger cddl (fromIntegral i) rule@@ -100,18 +139,22 @@         TFloat h -> validateFloat cddl h rule         TDouble d -> validateDouble cddl d rule -terminal :: CTree ValidatorStage -> Evidenced ValidationTrace+terminal :: CTree ValidatorPhase -> Evidenced ValidationTrace terminal = evidence . TerminalRule . mapIndex  -- | Run a custom validator on a term. This is used by type-specific validators -- when they encounter a 'VValidator' node after dereferencing a rule reference.-runCustomValidator :: Term -> CBORValidator -> Evidenced ValidationTrace-runCustomValidator term (CBORValidator validator) =-  case validator term of+runCustomValidator ::+  CTreeRoot ValidatorPhase ->+  RuleTerm ->+  TermValidator ->+  Evidenced ValidationTrace+runCustomValidator cddl term validator =+  case runValidator (validator term) cddl of     CustomValidatorSuccess -> evidence CustomSuccess     CustomValidatorFailure err -> evidence $ CustomFailure err -unapplicable :: CTree ValidatorStage -> Evidenced ValidationTrace+unapplicable :: CTree ValidatorPhase -> Evidenced ValidationTrace unapplicable = evidence . UnapplicableRule . mapIndex  --------------------------------------------------------------------------------@@ -130,14 +173,14 @@ -- Ints, so we convert everything to Integer. validateInteger ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Integer ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateInteger cddl i rule =   case rule of     CTreeE (VRuleRef n) -> dereferenceAndValidate cddl n $ validateInteger cddl i-    CTreeE (VValidator v _) -> runCustomValidator (TInteger i) v+    CTreeE (VValidator v _) -> runCustomValidator cddl (SingleTerm $ TInteger i) v     -- echo "C24101" | xxd -r -p - example.cbor     -- echo "foo = int" > a.cddl     -- cddl a.cddl validate example.cbor@@ -229,10 +272,10 @@ -- | Controls for an Integer controlInteger ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Integer ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlInteger cddl i op (CTreeE (VRuleRef n)) =   controlInteger cddl i op $ dereference cddl n@@ -302,12 +345,12 @@ -- | Validating a `Float16` validateHalf ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Float ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateHalf cddl f (CTreeE (VRuleRef n)) = dereferenceAndValidate cddl n $ validateHalf cddl f-validateHalf _ f (CTreeE (VValidator v _)) = runCustomValidator (THalf f) v+validateHalf cddl f (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ THalf f) v validateHalf cddl f rule =   case rule of     -- a = any@@ -332,10 +375,10 @@ -- | Controls for `Float16` controlHalf ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Float ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlHalf cddl f op (CTreeE (VRuleRef n)) =   controlHalf cddl f op $ dereference cddl n@@ -352,13 +395,13 @@ -- | Validating a `Float32` validateFloat ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Float ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateFloat cddl f (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateFloat cddl f-validateFloat _ f (CTreeE (VValidator v _)) = runCustomValidator (TFloat f) v+validateFloat cddl f (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TFloat f) v validateFloat cddl f rule =   case rule of     -- a = any@@ -392,10 +435,10 @@ -- | Controls for `Float32` controlFloat ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Float ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlFloat cddl f op (CTreeE (VRuleRef n)) =   controlFloat cddl f op $ dereference cddl n@@ -414,13 +457,13 @@ -- | Validating a `Float64` validateDouble ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Double ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateDouble cddl f (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateDouble cddl f-validateDouble _ f (CTreeE (VValidator v _)) = runCustomValidator (TDouble f) v+validateDouble cddl f (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TDouble f) v validateDouble cddl f rule =   case rule of     -- a = any@@ -458,10 +501,10 @@ -- | Controls for `Float64` controlDouble ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Double ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlDouble cddl f op (CTreeE (VRuleRef n)) =   controlDouble cddl f op $ dereference cddl n@@ -484,13 +527,13 @@  -- | Validating a boolean validateBool ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Bool ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateBool cddl b (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateBool cddl b-validateBool _ b (CTreeE (VValidator v _)) = runCustomValidator (TBool b) v+validateBool cddl b (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TBool b) v validateBool cddl b rule =   case rule of     -- a = any@@ -508,10 +551,10 @@ -- | Controls for `Bool` controlBool ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Bool ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlBool cddl b op (CTreeE (VRuleRef n)) =   controlBool cddl b op $ dereference cddl n@@ -530,13 +573,13 @@  -- | Validating a `TSimple`. It is unclear if this is used for anything else than `undefined`. validateSimple ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Word8 ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateSimple cddl i (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateSimple cddl i-validateSimple _ i (CTreeE (VValidator v _)) = runCustomValidator (TSimple i) v+validateSimple cddl i (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TSimple i) v validateSimple cddl 23 rule =   case rule of     -- a = any@@ -552,10 +595,10 @@ -- Null/nil  -- | Validating nil-validateNull :: CTreeRoot ValidatorStage -> CTree ValidatorStage -> Evidenced ValidationTrace+validateNull :: CTreeRoot ValidatorPhase -> CTree ValidatorPhase -> Evidenced ValidationTrace validateNull cddl (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateNull cddl-validateNull _ (CTreeE (VValidator v _)) = runCustomValidator TNull v+validateNull cddl (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm TNull) v validateNull cddl rule =   case rule of     -- a = any@@ -570,10 +613,10 @@  -- | Validating a byte sequence validateBytes ::-  CTreeRoot ValidatorStage -> BS.ByteString -> CTree ValidatorStage -> Evidenced ValidationTrace+  CTreeRoot ValidatorPhase -> BS.ByteString -> CTree ValidatorPhase -> Evidenced ValidationTrace validateBytes cddl bs (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateBytes cddl bs-validateBytes _ bs (CTreeE (VValidator v _)) = runCustomValidator (TBytes bs) v+validateBytes cddl bs (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TBytes bs) v validateBytes cddl bs rule =   case rule of     -- a = any@@ -591,10 +634,10 @@ -- | Controls for byte strings controlBytes ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   BS.ByteString ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlBytes cddl bs op (CTreeE (VRuleRef n)) =   controlBytes cddl bs op $ dereference cddl n@@ -653,13 +696,13 @@  -- | Validating text strings validateText ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   T.Text ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateText cddl txt (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateText cddl txt-validateText _ txt (CTreeE (VValidator v _)) = runCustomValidator (TString txt) v+validateText cddl txt (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TString txt) v validateText cddl txt rule =   case rule of     -- a = any@@ -677,10 +720,10 @@ -- | Controls for text strings controlText ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   T.Text ->   CtlOp ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Bool controlText cddl bs op (CTreeE (VRuleRef n)) =   controlText cddl bs op $ dereference cddl n@@ -715,10 +758,10 @@  -- | Validating a `TTagged` validateTagged ::-  CTreeRoot ValidatorStage -> Word64 -> Term -> CTree ValidatorStage -> Evidenced ValidationTrace+  CTreeRoot ValidatorPhase -> Word64 -> Term -> CTree ValidatorPhase -> Evidenced ValidationTrace validateTagged cddl tag term (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateTagged cddl tag term-validateTagged _ tag term (CTreeE (VValidator v _)) = runCustomValidator (TTagged tag term) v+validateTagged cddl tag term (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TTagged tag term) v validateTagged cddl tag term rule =   case rule of     Postlude PTAny -> terminal rule@@ -766,13 +809,13 @@     clampedPred x = pred x  validateList ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   [Term] ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateList cddl terms (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateList cddl terms-validateList _ terms (CTreeE (VValidator v _)) = runCustomValidator (TList terms) v+validateList cddl terms (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TList terms) v validateList cddl terms rule =   case rule of     Postlude PTAny -> terminal rule@@ -797,10 +840,10 @@     _ -> unapplicable rule   where     validate ::-      ([CTree ValidatorStage] -> [Term] -> Evidenced ListValidationTrace) ->-      [CTree ValidatorStage] ->+      ([CTree ValidatorPhase] -> [Term] -> Evidenced ListValidationTrace) ->+      [CTree ValidatorPhase] ->       [Term] ->-      [CTree ValidatorStage] ->+      [CTree ValidatorPhase] ->       (Evidenced ListValidationTrace, [Term])     validate f skipped tss [] = (f skipped tss, tss)     validate f skipped [] (r : rs)@@ -852,13 +895,13 @@  validateMap ::   HasCallStack =>-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   [(Term, Term)] ->-  CTree ValidatorStage ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace validateMap cddl terms (CTreeE (VRuleRef n)) =   dereferenceAndValidate cddl n $ validateMap cddl terms-validateMap _ terms (CTreeE (VValidator v _)) = runCustomValidator (TMap terms) v+validateMap cddl terms (CTreeE (VValidator v _)) = runCustomValidator cddl (SingleTerm $ TMap terms) v validateMap cddl terms rule =   case rule of     Postlude PTAny -> terminal rule@@ -867,7 +910,7 @@     _ -> unapplicable rule   where     validate ::-      [CTree ValidatorStage] -> [(Term, Term)] -> [CTree ValidatorStage] -> Evidenced MapValidationTrace+      [CTree ValidatorPhase] -> [(Term, Term)] -> [CTree ValidatorPhase] -> Evidenced MapValidationTrace     validate _ [] [] = evidence MapValidationDone     validate exhausted (kv : _) [] =       let@@ -930,12 +973,12 @@ -- Choices  validateChoice ::-  (CTree ValidatorStage -> Evidenced ValidationTrace) ->-  NE.NonEmpty (CTree ValidatorStage) ->+  (CTree ValidatorPhase -> Evidenced ValidationTrace) ->+  NE.NonEmpty (CTree ValidatorPhase) ->   Evidenced ValidationTrace validateChoice v = go 0   where-    go :: Int -> NE.NonEmpty (CTree ValidatorStage) -> Evidenced ValidationTrace+    go :: Int -> NE.NonEmpty (CTree ValidatorPhase) -> Evidenced ValidationTrace     go i (choice NE.:| xs) = do       case v choice of         Evidenced SValid trc -> evidence $ ChoiceBranch i trc@@ -948,9 +991,9 @@  -- | Validate both rules ctrlAnd ::-  (CTree ValidatorStage -> Evidenced ValidationTrace) ->-  CTree ValidatorStage ->-  CTree ValidatorStage ->+  (CTree ValidatorPhase -> Evidenced ValidationTrace) ->+  CTree ValidatorPhase ->+  CTree ValidatorPhase ->   Evidenced ValidationTrace ctrlAnd v tgt ctrl =   case v tgt of@@ -959,11 +1002,11 @@  -- | Dispatch to the appropriate control ctrlDispatch ::-  (CTree ValidatorStage -> Evidenced ValidationTrace) ->+  (CTree ValidatorPhase -> Evidenced ValidationTrace) ->   CtlOp ->-  CTree ValidatorStage ->-  CTree ValidatorStage ->-  (CtlOp -> CTree ValidatorStage -> Bool) ->+  CTree ValidatorPhase ->+  CTree ValidatorPhase ->+  (CtlOp -> CTree ValidatorPhase -> Bool) ->   Evidenced ValidationTrace ctrlDispatch v And tgt ctrl _ = ctrlAnd v tgt ctrl ctrlDispatch v Within tgt ctrl _ = ctrlAnd v tgt ctrl@@ -979,7 +1022,7 @@ -------------------------------------------------------------------------------- -- Bits control -getIndicesOfChoice :: CTreeRoot ValidatorStage -> NE.NonEmpty (CTree ValidatorStage) -> [Word64]+getIndicesOfChoice :: CTreeRoot ValidatorPhase -> NE.NonEmpty (CTree ValidatorPhase) -> [Word64] getIndicesOfChoice cddl = concatMap go   where     go = \case@@ -1000,7 +1043,7 @@             <> showSimple somethingElse  getIndicesOfRange ::-  CTreeRoot ValidatorStage -> CTree ValidatorStage -> CTree ValidatorStage -> RangeBound -> [Word64]+  CTreeRoot ValidatorPhase -> CTree ValidatorPhase -> CTree ValidatorPhase -> RangeBound -> [Word64] getIndicesOfRange cddl (CTreeE (VRuleRef n)) tt incl =   dereference cddl n & \ff -> getIndicesOfRange cddl ff tt incl getIndicesOfRange cddl ff (CTreeE (VRuleRef n)) incl =@@ -1015,7 +1058,7 @@         rng = [ff' .. tt']     (lo, hi) -> error $ "Malformed range in .bits: (" <> showSimple lo <> ", " <> showSimple hi <> ")" -getIndicesOfEnum :: CTreeRoot ValidatorStage -> CTree ValidatorStage -> [Word64]+getIndicesOfEnum :: CTreeRoot ValidatorPhase -> CTree ValidatorPhase -> [Word64] getIndicesOfEnum cddl (CTreeE (VRuleRef n)) = getIndicesOfEnum cddl $ dereference cddl n getIndicesOfEnum cddl g =   case g of@@ -1023,18 +1066,18 @@     somethingElse -> error $ "Malformed enum in .bits: " <> showSimple somethingElse  dereference ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Name ->-  CTree ValidatorStage+  CTree ValidatorPhase dereference (CTreeRoot m) n =   case Map.lookup n m of     Just r -> r     Nothing -> error $ "Nonexistent rule referenced: " <> T.unpack (unName n)  dereferenceAndValidate ::-  CTreeRoot ValidatorStage ->+  CTreeRoot ValidatorPhase ->   Name ->-  (CTree ValidatorStage -> Evidenced ValidationTrace) ->+  (CTree ValidatorPhase -> Evidenced ValidationTrace) ->   Evidenced ValidationTrace dereferenceAndValidate cddl n f =   mapTrace (ReferenceRule n) . f $ dereference cddl n

@@ -10,8 +10,7 @@ {-# LANGUAGE UndecidableInstances #-}  module Codec.CBOR.Cuddle.CBOR.Validator.Trace (-  ValidatorStage,-  ValidatorStageSimple,+  ValidatorPhaseSimple,   XXCTree (..),   SValidity (..),   Validity (..),@@ -34,11 +33,11 @@   foldEvidenced, ) where -import Codec.CBOR.Cuddle.CDDL (Name (..), OccurrenceIndicator (..), RangeBound (..), XTerm)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CBORValidator)+import Codec.CBOR.Cuddle.CDDL (Name (..)) import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot (..), Node, XXCTree, foldCTree) import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)-import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, XXCTree (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (ValidatorPhase)+import Codec.CBOR.Cuddle.CDDL.Resolve (XXCTree (..)) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Codec.CBOR.Term (Term) import Data.Foldable (Foldable (..))@@ -54,14 +53,9 @@   Pretty (..),   annotate,   defaultLayoutOptions,-  encloseSep,-  group,   hang,   indent,   layoutPretty,-  list,-  punctuate,-  tupled,   vsep,   (<+>),  )@@ -69,73 +63,34 @@ import Prettyprinter.Render.Terminal qualified as Ansi  ----------------------------------------------------------------------------------- ValidatorStage--type data ValidatorStage--data instance XTerm ValidatorStage = ValidatorXTerm-  deriving (Show, Eq)--data instance XXCTree ValidatorStage-  = VRuleRef Name-  | VValidator CBORValidator (CTree ValidatorStage)--instance IndexMappable CTreeRoot MonoReferenced ValidatorStage where-  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m+-- ValidatorPhase -instance IndexMappable CTree MonoReferenced ValidatorStage where-  mapIndex = foldCTree mapExt mapIndex-    where-      mapExt (MRuleRef n) = CTreeE $ VRuleRef n-      mapExt (MGenerator _ x) = mapIndex x-      mapExt (MValidator v x) = CTreeE . VValidator v $ mapIndex x+type data ValidatorPhaseSimple -type data ValidatorStageSimple+newtype instance XXCTree ValidatorPhaseSimple = VRuleRefSimple Name -newtype instance XXCTree ValidatorStageSimple = VRuleRefSimple Name+instance Pretty (XXCTree ValidatorPhaseSimple) where+  pretty (VRuleRefSimple n) = pretty n -instance IndexMappable CTreeRoot ValidatorStage ValidatorStageSimple where+instance IndexMappable CTreeRoot ValidatorPhase ValidatorPhaseSimple where   mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m -instance IndexMappable CTree ValidatorStage ValidatorStageSimple where+instance IndexMappable CTree ValidatorPhase ValidatorPhaseSimple where   mapIndex = foldCTree mapExt mapIndex     where       mapExt (VRuleRef n) = CTreeE $ VRuleRefSimple n       mapExt (VValidator _ x) = mapIndex x -instance Pretty (CTree ValidatorStageSimple) where-  pretty = \case-    Literal v -> pretty v-    Postlude v -> pretty v-    Range lo hi ClOpen -> pretty lo <+> "..." <+> pretty hi-    Range lo hi Closed -> pretty lo <+> ".." <+> pretty hi-    KV k v _ -> pretty k <+> "==>" <+> pretty v-    CTreeE (VRuleRefSimple (Name n)) -> pretty n-    Occur v oi ->-      case oi of-        OIOptional -> "?" <+> pretty v-        OIZeroOrMore -> "*" <+> pretty v-        OIOneOrMore -> "+" <+> pretty v-        OIBounded lo hi -> foldMap pretty lo <> "*" <> foldMap pretty hi <+> pretty v-    Map m -> encloseSep "{" "}" "," $ pretty <$> m-    Array e -> list $ pretty <$> e-    Choice c -> group . vsep . punctuate "//" $ pretty <$> toList c-    Group g -> tupled $ pretty <$> g-    Control op tgt ctl -> pretty tgt <+> pretty op <+> pretty ctl-    Enum e -> "&" <> pretty e-    Unwrap x -> "~" <> pretty x-    Tag t x -> "#6." <> pretty t <> "(" <> pretty x <> ")"- showSimple ::-  ( IndexMappable a ValidatorStage ValidatorStageSimple-  , Show (a ValidatorStageSimple)+  ( IndexMappable a ValidatorPhase ValidatorPhaseSimple+  , Show (a ValidatorPhaseSimple)   ) =>-  a ValidatorStage -> String-showSimple = show . mapIndex @_ @_ @ValidatorStageSimple+  a ValidatorPhase -> String+showSimple = show . mapIndex @_ @_ @ValidatorPhaseSimple -deriving instance Eq (Node ValidatorStageSimple)+deriving instance Eq (Node ValidatorPhaseSimple) -deriving instance Show (Node ValidatorStageSimple)+deriving instance Show (Node ValidatorPhaseSimple)  -------------------------------------------------------------------------------- -- Validation result@@ -161,7 +116,7 @@  data ControlInfo = ControlInfo   { ciOp :: CtlOp-  , ciRule :: CTree ValidatorStageSimple+  , ciRule :: CTree ValidatorPhaseSimple   }   deriving (Show) @@ -169,13 +124,13 @@   pretty ControlInfo {..} = pretty ciOp <+> pretty ciRule  data ValidationTrace (v :: Validity) where-  UnapplicableRule :: CTree ValidatorStageSimple -> ValidationTrace IsInvalid-  TerminalRule :: CTree ValidatorStageSimple -> ValidationTrace IsValid+  UnapplicableRule :: CTree ValidatorPhaseSimple -> ValidationTrace IsInvalid+  TerminalRule :: CTree ValidatorPhaseSimple -> ValidationTrace IsValid   ControlTrace :: ControlInfo -> ValidationTrace IsValid -> ValidationTrace IsValid   ReferenceRule :: Name -> ValidationTrace v -> ValidationTrace v   CustomFailure :: Text -> ValidationTrace IsInvalid   CustomSuccess :: ValidationTrace IsValid-  UnsatisfiedControl :: CtlOp -> CTree ValidatorStageSimple -> ValidationTrace IsInvalid+  UnsatisfiedControl :: CtlOp -> CTree ValidatorPhaseSimple -> ValidationTrace IsInvalid   ChoiceBranch :: Int -> ValidationTrace IsValid -> ValidationTrace IsValid   ListTrace :: ListValidationTrace v -> ValidationTrace v   MapTrace :: MapValidationTrace v -> ValidationTrace v@@ -188,18 +143,18 @@   ListValidationDone :: ListValidationTrace IsValid   ListValidationLeftoverTerms ::     NonEmpty Term ->-    Maybe (CTree ValidatorStageSimple, ValidationTrace IsInvalid) ->+    Maybe (CTree ValidatorPhaseSimple, ValidationTrace IsInvalid) ->     ListValidationTrace IsInvalid   ListValidationUnappliedRule ::-    CTree ValidatorStageSimple ->+    CTree ValidatorPhaseSimple ->     ListValidationTrace IsInvalid   ListValidationConsume ::-    CTree ValidatorStageSimple ->+    CTree ValidatorPhaseSimple ->     ValidationTrace IsValid ->     ListValidationTrace v ->     ListValidationTrace v   ListValidationMissingRequired ::-    CTree ValidatorStageSimple ->+    CTree ValidatorPhaseSimple ->     ValidationTrace IsInvalid ->     ListValidationTrace IsInvalid   ListValidationConsumeGroup ::@@ -218,16 +173,16 @@   MapValidationDone :: MapValidationTrace IsValid   MapValidationLeftoverKVs ::     (Term, Term) ->-    Maybe (CTree ValidatorStageSimple, MapValidationTrace IsInvalid) ->+    Maybe (CTree ValidatorPhaseSimple, MapValidationTrace IsInvalid) ->     MapValidationTrace IsInvalid-  MapValidationUnappliedRules :: NonEmpty (CTree ValidatorStageSimple) -> MapValidationTrace IsInvalid+  MapValidationUnappliedRules :: NonEmpty (CTree ValidatorPhaseSimple) -> MapValidationTrace IsInvalid   MapValidationInvalidValue ::-    CTree ValidatorStageSimple ->+    CTree ValidatorPhaseSimple ->     ValidationTrace IsValid ->     ValidationTrace IsInvalid ->     MapValidationTrace IsInvalid   MapValidationConsume ::-    CTree ValidatorStageSimple ->+    CTree ValidatorPhaseSimple ->     ValidationTrace IsValid ->     ValidationTrace IsValid ->     MapValidationTrace v ->

@@ -39,6 +39,7 @@   unwrap,   compareRuleName,   HasName (..),+  GRef (..),   -- Extension   ForAllExtensions,   XCddl,@@ -160,6 +161,10 @@   deriving (Generic)   deriving (Eq, Ord, Show)   deriving newtype (Semigroup, Monoid)++-- | A reference to a generic parameter inside the body of a generic rule.+newtype GRef = GRef T.Text+  deriving (Show)  deriving anyclass instance ToExpr Name 

@@ -1,92 +0,0 @@-{-# LANGUAGE TypeData #-}-{-# LANGUAGE TypeFamilies #-}--module Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGen (..),-  GenEnv (..),-  HasGenerator (..),-  WrappedTerm (..),-  CBORValidator (..),-  HasValidator (..),-  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.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 (CBORGen WrappedTerm) (CTree GenPhase)--data WrappedTerm-  = -- | Single term-    S Term-  | -- | Pair term-    P Term Term-  | -- | Group term-    G [WrappedTerm]-  deriving (Eq, Ord, Show)--class HasGenerator a where-  generatorL :: Lens' a (Maybe (CBORGen WrappedTerm))--class HasValidator a where-  validatorL :: Lens' a (Maybe CBORValidator)--data CustomValidatorResult-  = CustomValidatorSuccess-  | CustomValidatorFailure Text-  deriving (Generic, Show, Eq)--newtype CBORValidator = CBORValidator (Term -> CustomValidatorResult)

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

@@ -0,0 +1,25 @@+{-# LANGUAGE TypeFamilies #-}++module Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm (..)) where++import Codec.CBOR.Cuddle.CDDL (GRef, Name)+import Codec.CBOR.Cuddle.CDDL.CTree (CTree)+import Codec.CBOR.Term (Term)+import Data.Kind (Type)++class MonadCddl m where+  type Phase m :: Type++  -- | Look up a top-level rule by name.+  lookupCddl :: Name -> m (Maybe (CTree (Phase m)))++  -- | Look up the rule bound to a generic parameter at the enclosing rule.+  -- Returns 'Nothing' outside of a custom generator/validator that was+  -- attached to a generic rule.+  lookupGRef :: GRef -> m (Maybe (CTree (Phase m)))++data RuleTerm+  = SingleTerm Term+  | PairTerm Term Term+  | GroupTerm [RuleTerm]+  deriving (Eq, Ord, Show)

@@ -0,0 +1,103 @@+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}++module Codec.CBOR.Cuddle.CDDL.Custom.Generator (+  GenPhase,+  CBORGen,+  XXCTree (..),+  HasGenerator (..),+  GenConfig (..),+  GenEnv (..),+  liftAntiGen,+  runCBORGen,+  withAntiGen,+  withLocalGenBindings,+  disableTwiddle,+  enableTwiddle,+) where++import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..))+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..), XXCTree)+import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm)+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, mapReaderT)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import GHC.Generics (Generic)+import Optics.Lens (Lens')+import Test.AntiGen (AntiGen)+import Test.QuickCheck.GenT (MonadGen (..))++type data GenPhase++-- | User-supplied configuration for the generator monad. Set once at the+-- top level when calling 'runCBORGen'.+data GenConfig = GenConfig+  { gcRoot :: CTreeRoot GenPhase+  , gcTwiddle :: !Bool+  }+  deriving (Generic)++-- | Runtime environment for the generator monad: the user-supplied+-- 'GenConfig' plus the bindings active at the current point.+data GenEnv = GenEnv+  { geConfig :: GenConfig+  , geLocal :: Map Name (CTree GenPhase)+  }+  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 :: GenConfig -> CBORGen a -> AntiGen a+runCBORGen cfg (CBORGen m) =+  runReaderT m GenEnv {geConfig = cfg, geLocal = Map.empty}++instance MonadCddl CBORGen where+  type Phase CBORGen = GenPhase++  lookupCddl n = do+    CTreeRoot root <- asks (gcRoot . geConfig)+    pure $ Map.lookup n root++  lookupGRef (GRef t) = do+    binds <- asks geLocal+    pure $ Map.lookup (Name t) binds++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 (\env -> env {geConfig = (geConfig env) {gcTwiddle = t}})++disableTwiddle :: CBORGen a -> CBORGen a+disableTwiddle = withTwiddle False++enableTwiddle :: CBORGen a -> CBORGen a+enableTwiddle = withTwiddle True++-- | Run an action with the given local generic bindings installed.+-- Used to wrap custom generators attached to generic rules so that+-- 'lookupGRef' resolves to the type bound at the enclosing rule.+withLocalGenBindings ::+  Map Name (CTree GenPhase) -> CBORGen a -> CBORGen a+withLocalGenBindings binds =+  local (\env -> env {geLocal = binds `Map.union` geLocal env})++data instance XXCTree GenPhase+  = GenRef Name+  | GenGenerator (CBORGen RuleTerm) (CTree GenPhase)++class HasGenerator a where+  generatorL :: Lens' a (Maybe (CBORGen RuleTerm))

@@ -0,0 +1,76 @@+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}++module Codec.CBOR.Cuddle.CDDL.Custom.Validator (+  TermValidator,+  ValidatorPhase,+  Validator,+  CustomValidatorResult (..),+  XXCTree (..),+  HasValidator (..),+  ValidateEnv (..),+  withLocalValidateBindings,+  runValidator,+) where++import Codec.CBOR.Cuddle.CDDL (GRef (..), Name (..))+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, CTreeRoot (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Core (MonadCddl (..), RuleTerm)+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (XXCTree)+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Optics.Lens (Lens')++type data ValidatorPhase++data instance XXCTree ValidatorPhase+  = VRuleRef Name+  | VValidator TermValidator (CTree ValidatorPhase)++class HasValidator a where+  validatorL :: Lens' a (Maybe TermValidator)++data CustomValidatorResult+  = CustomValidatorSuccess+  | CustomValidatorFailure Text+  deriving (Generic, Show, Eq)++data ValidateEnv = ValidateEnv+  { veRoot :: CTreeRoot ValidatorPhase+  , veLocal :: Map Name (CTree ValidatorPhase)+  }++newtype Validator a = Validator (ReaderT ValidateEnv (Either Text) a)+  deriving (Functor, Applicative, Monad, MonadReader ValidateEnv)++type TermValidator = RuleTerm -> Validator ()++instance MonadCddl Validator where+  type Phase Validator = ValidatorPhase++  lookupCddl n = do+    CTreeRoot root <- asks veRoot+    pure $ Map.lookup n root++  lookupGRef (GRef t) = do+    binds <- asks veLocal+    pure $ Map.lookup (Name t) binds++instance MonadFail Validator where+  fail msg = Validator . ReaderT $ \_ -> Left $ T.pack msg++-- | Run an action with the given local generic bindings installed.+withLocalValidateBindings ::+  Map Name (CTree ValidatorPhase) -> Validator a -> Validator a+withLocalValidateBindings binds =+  local (\env -> env {veLocal = binds `Map.union` veLocal env})++runValidator ::+  Validator () -> CTreeRoot ValidatorPhase -> CustomValidatorResult+runValidator (Validator m) cddl =+  either CustomValidatorFailure (const CustomValidatorSuccess) $+    runReaderT m ValidateEnv {veRoot = cddl, veLocal = Map.empty}

@@ -65,20 +65,28 @@ #if __GLASGOW_HASKELL__ < 910 import Data.List (foldl') #endif-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (+import Codec.CBOR.Cuddle.CDDL.CTreePhase (CTreePhase, XRule (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Core (RuleTerm)+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (   CBORGen,-  CBORValidator,   GenPhase,-  WrappedTerm,   XXCTree (..),+  withLocalGenBindings,  )-import Codec.CBOR.Cuddle.CDDL.CTreePhase (CTreePhase, XRule (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (+  TermValidator,+  ValidatorPhase,+  XXCTree (..),+  withLocalValidateBindings,+ ) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map import Data.Text qualified as T import GHC.Generics (Generic) import Optics.Core+import Prettyprinter (Pretty (..), encloseSep, layoutCompact)+import Prettyprinter.Render.Text (renderStrict)  data ProvidedParameters a = ProvidedParameters   { parameters :: [Name]@@ -97,8 +105,8 @@  data CDDLMapEntry = CDDLMapEntry   { cmeProvidedParameters :: ProvidedParameters (TypeOrGroup CTreePhase)-  , cmeCustomGenerator :: Maybe (CBORGen WrappedTerm)-  , cmeCustomValidator :: Maybe CBORValidator+  , cmeCustomGenerator :: Maybe (CBORGen RuleTerm)+  , cmeCustomValidator :: Maybe TermValidator   }   deriving (Generic) @@ -159,8 +167,8 @@ data instance XXCTree OrReferenced   = -- | Reference to another node with possible generic arguments supplied     OrRef Name [CTree OrReferenced]-  | OGenerator (CBORGen WrappedTerm) (CTree OrReferenced)-  | OValidator CBORValidator (CTree OrReferenced)+  | OGenerator (CBORGen RuleTerm) (CTree OrReferenced)+  | OValidator TermValidator (CTree OrReferenced)  type data OrReferencedSimple @@ -170,7 +178,7 @@ instance IndexMappable CTree OrReferenced OrReferencedSimple where   mapIndex = foldCTree mapExt mapIndex     where-      mapExt (OrRef n xs) = CTreeE . DGOrRef n $ mapIndex <$> xs+      mapExt (OrRef n xs) = CTreeE $ DGOrRef n (mapIndex <$> xs)       mapExt (OGenerator _ x) = mapIndex x       mapExt (OValidator _ x) = mapIndex x @@ -178,12 +186,22 @@   mapIndex = foldCTree mapExt mapIndex     where       mapExt (MRuleRef n) = CTreeE $ GenRef n-      mapExt (MGenerator g x) = CTreeE . GenGenerator g $ mapIndex x+      mapExt (MGenerator g x) = CTreeE $ GenGenerator g (mapIndex x)       mapExt (MValidator _ x) = mapIndex x  instance IndexMappable CTreeRoot MonoReferenced GenPhase where   mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m +instance IndexMappable CTree MonoReferenced ValidatorPhase where+  mapIndex = foldCTree mapExt mapIndex+    where+      mapExt (MRuleRef n) = CTreeE $ VRuleRef n+      mapExt (MGenerator _ x) = mapIndex x+      mapExt (MValidator v x) = CTreeE $ VValidator v (mapIndex x)++instance IndexMappable CTreeRoot MonoReferenced ValidatorPhase where+  mapIndex (CTreeRoot m) = CTreeRoot $ mapIndex <$> m+ -- | Build a CTree incorporating references. -- -- This translation cannot fail.@@ -192,9 +210,7 @@   where     toCTreeRule :: CDDLMapEntry -> ProvidedParameters (CTree OrReferenced)     toCTreeRule CDDLMapEntry {..} =-      fmap-        (applyValidator . applyGenerator . toCTreeTOG)-        cmeProvidedParameters+      applyValidator . applyGenerator . toCTreeTOG <$> cmeProvidedParameters       where         applyGenerator = case cmeCustomGenerator of           Just g -> CTreeE . OGenerator g@@ -392,15 +408,21 @@  instance Hashable (CTree.Node i) => Hashable (DistRef i) +instance Pretty (XXCTree i) => Pretty (DistRef i) where+  pretty (GenericRef n) = pretty n+  pretty (RuleRef rule []) = pretty rule+  pretty (RuleRef rule args) = pretty rule <> encloseSep "<" ">" "," (pretty <$> args)+ data instance XXCTree DistReferenced   = DRef (DistRef DistReferenced)-  | DGenerator (CBORGen WrappedTerm) (CTree DistReferenced)-  | DValidator CBORValidator (CTree DistReferenced)+  | DGenerator (CBORGen RuleTerm) (CTree DistReferenced)+  | DValidator TermValidator (CTree DistReferenced)  type data DistReferencedNoGen  newtype instance XXCTree DistReferencedNoGen = DHRef (DistRef DistReferencedNoGen)-  deriving (Eq, Hashable)+  deriving (Eq, Hashable, Show)+  deriving newtype (Pretty)  resolveRef ::   BindingEnv OrReferenced OrReferenced ->@@ -449,8 +471,8 @@  data instance XXCTree MonoReferenced   = MRuleRef Name-  | MGenerator (CBORGen WrappedTerm) (CTree MonoReferenced)-  | MValidator CBORValidator (CTree MonoReferenced)+  | MGenerator (CBORGen RuleTerm) (CTree MonoReferenced)+  | MValidator TermValidator (CTree MonoReferenced)  type MonoEnv = BindingEnv DistReferenced MonoReferenced @@ -540,10 +562,11 @@ -- | Synthesize a monomorphic rule definition, returning the name synthMono :: Name -> [CTree DistReferenced] -> MonoM Name synthMono origName args =-  let dropGenerator = fmap $ mapIndex @_ @_ @DistReferencedNoGen-      fresh =-        -- % is not a valid CBOR name, so this should avoid conflict-        origName <> "%" <> Name (T.pack (show . hash $ dropGenerator args))+  let dropGenerator = fmap $ mapIndex @_ @DistReferenced @DistReferencedNoGen+      argsName = Name (T.intercalate "," $ renderStrict . layoutCompact . pretty <$> dropGenerator args)+      -- We use % to mark a monomorphised generic rule, '%' is not allowed in+      -- CDDL names, so there should be no conflicts+      fresh = "%" <> origName <> "<" <> argsName <> ">"    in do         -- Lookup the original name in the global bindings         globalBinds <- ask @"global"@@ -573,8 +596,18 @@   case Map.lookup n localBinds of     Just node -> pure node     Nothing -> throwNR $ UnboundReference n-resolveGenericRef (DGenerator g x) = CTreeE . MGenerator g <$> resolveGenericCTree x-resolveGenericRef (DValidator v x) = CTreeE . MValidator v <$> resolveGenericCTree x+resolveGenericRef (DGenerator g x) = do+  binds <- ask @"local"+  body <- resolveGenericCTree x+  let bindsGen = mapIndex @CTree @MonoReferenced @GenPhase <$> binds+      g' = withLocalGenBindings bindsGen g+  pure . CTreeE $ MGenerator g' body+resolveGenericRef (DValidator v x) = do+  binds <- ask @"local"+  body <- resolveGenericCTree x+  let bindsVal = mapIndex @CTree @MonoReferenced @ValidatorPhase <$> binds+      v' = withLocalValidateBindings bindsVal . v+  pure . CTreeE $ MValidator v' body  resolveGenericCTree ::   CTree DistReferenced ->

@@ -10,12 +10,15 @@   CollectComments (..),   hasComment,   (//-),+  appendComment,   (<*!),   (!*>),   WithComment (..),   (!$>),-  Comment (..),+  Comment,   unComment,+  toComment,+  commentLine,   withComment, ) where @@ -31,14 +34,23 @@ import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), V1, (:*:) (..), (:+:) (..)) import Optics.Core (Lens', lens, view, (%~), (&), (.~), (^.)) -newtype Comment = Comment T.Text+newtype Comment = Comment [T.Text]   deriving (Eq, Ord, Generic, Show)   deriving newtype (Semigroup, Monoid)   deriving anyclass (ToExpr, Hashable)  unComment :: Comment -> [T.Text]-unComment (Comment c) = T.lines c+unComment (Comment c) = c +toComment :: T.Text -> Comment+toComment = Comment . T.lines++-- | Wrap a single line of text (possibly empty) as a one-line comment.+-- Unlike 'toComment', this does not split on newlines and preserves an empty+-- input as a single empty comment line.+commentLine :: T.Text -> Comment+commentLine t = Comment [t]+ instance Default Comment where def = mempty  class HasComment a where@@ -126,19 +138,24 @@ -- arr [0, 1] //- "This is an array with two values" -- ``` (//-) :: HasComment a => a -> Comment -> a-x //- c = x & commentL %~ (<> c)+x //- c = x & commentL %~ (<> Comment ((" " <>) <$> unComment c)) -infixr 0 //-+infixl 1 //- +-- | Raw comment append without adding space or newline. Used by parser+-- combinators where the comment text is already formatted.+appendComment :: HasComment a => a -> Comment -> a+appendComment x c = x & commentL %~ (<> c)+ -- | This operator will parse the values from left to right and then append the -- parsed comment on the right to the parsed value on the left. (<*!) :: (HasComment a, Applicative m) => m a -> m Comment -> m a-(<*!) x c = (//-) <$> x <*> c+(<*!) x c = appendComment <$> x <*> c  -- | This operator will parse the values from left to right and then append the -- parsed comment on the left to the parsed value on the right. (!*>) :: (HasComment a, Applicative m) => m Comment -> m a -> m a-(!*>) c x = flip (//-) <$> c <*> x+(!*>) c x = flip appendComment <$> c <*> x  data WithComment a = WithComment   { unWithComment :: Comment@@ -168,7 +185,7 @@ -- (\x -> LInt x "a") !$> WithComment "b" (1 :: Integer) == Literal (LInt 1) "a\nb" -- ``` (!$>) :: (HasComment b, Functor f) => (a -> b) -> f (WithComment a) -> f b-f !$> wc = fmap (\(WithComment c x) -> f x //- c) wc+f !$> wc = fmap (\(WithComment c x) -> appendComment (f x) c) wc  instance HasComment a => HasComment (NonEmpty a) where   commentL = lens (\(x :| _) -> x ^. commentL) (\(x :| xs) y -> (x & commentL .~ y) :| xs)@@ -177,4 +194,4 @@   commentL = lens id const  instance IsString Comment where-  fromString s = Comment $ T.pack s+  fromString = toComment . T.pack

@@ -91,8 +91,6 @@   callToDef,    -- * Generators-  withAntiGen,-  withGenerator,   withCBORGen,    -- * Validators@@ -109,25 +107,22 @@ ) where -import Codec.CBOR.Cuddle.CDDL (CDDL, GenericParameter (..), HasName (..), Name (..), XRule)-import Codec.CBOR.Cuddle.CDDL qualified as C-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (-  CBORGen (..),-  CBORValidator (..),-  CustomValidatorResult,-  GenEnv (..),-  GenPhase,-  HasGenerator (..),-  HasValidator (..),-  WrappedTerm,+import Codec.CBOR.Cuddle.CDDL (+  CDDL,+  GRef (..),+  GenericParameter (..),+  HasName (..),+  Name (..),+  XRule,  )-import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot)+import Codec.CBOR.Cuddle.CDDL qualified as C import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp-import Codec.CBOR.Cuddle.Comments (Comment (..), HasComment (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Core (RuleTerm)+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (CBORGen, HasGenerator (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (HasValidator (..), TermValidator)+import Codec.CBOR.Cuddle.Comments (Comment, HasComment (..)) 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@@ -148,9 +143,6 @@ import GHC.Generics (Generic) import Optics.Core (lens, view, (%), (%~), (&)) import Optics.Core qualified as L-import Test.AntiGen (AntiGen)-import Test.QuickCheck.Gen (Gen)-import Test.QuickCheck.GenT (MonadGen (liftGen)) import Prelude hiding ((/))  type data HuddleStage@@ -163,8 +155,8 @@  data instance C.XRule HuddleStage = HuddleXRule   { hxrComment :: C.Comment-  , hxrGenerator :: Maybe (CBORGen WrappedTerm)-  , hxrValidator :: Maybe CBORValidator+  , hxrGenerator :: Maybe (CBORGen RuleTerm)+  , hxrValidator :: Maybe TermValidator   }   deriving (Generic) @@ -1005,9 +997,6 @@ -- Generics -------------------------------------------------------------------------------- -newtype GRef = GRef T.Text-  deriving (Show)- freshName :: Int -> GRef freshName ix =   GRef $@@ -1377,23 +1366,10 @@           C.GenericParameters $             fmap (\(GRef t) -> GenericParameter (C.Name t) $ HuddleXTerm mempty) (args gr) --- | 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 . 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 . 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)+withCBORGen :: HasGenerator a => CBORGen RuleTerm -> a -> a+withCBORGen gen = L.set generatorL $ Just gen -withValidator :: HasValidator a => (Term -> CustomValidatorResult) -> a -> a-withValidator p = L.set validatorL . Just $ CBORValidator p+withValidator :: HasValidator a => TermValidator -> a -> a+withValidator p = L.set validatorL $ Just p

@@ -201,7 +201,7 @@   where   mapIndex (GrpChoice gs e) = GrpChoice (mapIndex <$> gs) $ mapIndex e --- ParserStage -> PrettyStage+-- ParserStage ~ PrettyStage  instance IndexMappable XCddl ParserStage PrettyStage where   mapIndex (ParserXCddl c) = PrettyXCddl c@@ -277,7 +277,7 @@ instance IndexMappable XRule HuddleStage PrettyStage where   mapIndex (HuddleXRule c _ _) = PrettyXRule c --- ParserStage -> ParserStage+-- ParserStage ~ ParserStage  instance IndexMappable XCddl ParserStage ParserStage 

@@ -13,9 +13,9 @@   Comment,   HasComment (..),   WithComment (..),+  appendComment,   withComment,   (!*>),-  (//-),   (<*!),  ) import Codec.CBOR.Cuddle.Parser.Lexer (@@ -75,7 +75,10 @@   initialRule <- pRule   cddlTail <- many $ pTopLevel <* C.space   eof-    $> CDDL (initialRule //- fold initialRuleComment) cddlTail (ParserXXTopLevel <$> initialComments)+    $> CDDL+      (appendComment initialRule (fold initialRuleComment))+      cddlTail+      (ParserXXTopLevel <$> initialComments)  pTopLevel :: Parser (TopLevel ParserStage) pTopLevel = try tlRule <|> tlComment@@ -83,7 +86,7 @@     tlRule = do       mCmt <- optional pCommentBlock       rule <- pRule-      pure . TopLevelRule $ rule //- fold mCmt+      pure . TopLevelRule $ appendComment rule (fold mCmt)     tlComment = XXTopLevel . ParserXXTopLevel <$> pCommentBlock  pRule :: Parser (Rule ParserStage)

@@ -10,7 +10,7 @@   pCommentBlock, ) where -import Codec.CBOR.Cuddle.Comments (Comment (..))+import Codec.CBOR.Cuddle.Comments (Comment, commentLine) import Control.Applicative.Combinators.NonEmpty qualified as NE import Data.Foldable1 (Foldable1 (..)) import Data.Text (Text)@@ -35,7 +35,7 @@  pComment :: Parser Comment pComment =-  Comment . (<> "\n") <$> label "comment" (char ';' *> takeWhileP Nothing validChar <* eol)+  commentLine <$> label "comment" (char ';' *> takeWhileP Nothing validChar <* eol)   where     validChar = charInRange '\x20' '\x7e' ||| charInRange '\x80' '\x10fffd' 

@@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -19,9 +20,10 @@ ) where  import Codec.CBOR.Cuddle.CDDL-import Codec.CBOR.Cuddle.CDDL.CTree (PTerm (..))+import Codec.CBOR.Cuddle.CDDL.CTree (CTree, PTerm (..), XXCTree)+import Codec.CBOR.Cuddle.CDDL.CTree qualified as CT import Codec.CBOR.Cuddle.CDDL.CtlOp (CtlOp)-import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment (..), HasComment (..), unComment)+import Codec.CBOR.Cuddle.Comments (CollectComments (..), Comment, HasComment (..), unComment) import Codec.CBOR.Cuddle.Pretty.Columnar (   Cell (..),   CellAlign (..),@@ -97,8 +99,9 @@   | otherwise = space <> prettyCommentNoBreak cmt  instance Pretty Comment where-  pretty (Comment "") = mempty-  pretty c = prettyCommentNoBreak c <> hardline+  pretty c+    | c == mempty = mempty+    | otherwise = prettyCommentNoBreak c <> hardline  type0Def :: Type0 PrettyStage -> Doc ann type0Def t = nest 2 $ line' <> pretty t@@ -279,3 +282,26 @@ renderCDDL :: LayoutOptions -> CDDL PrettyStage -> Text renderCDDL opts =   PT.renderStrict . removeTrailingWhitespace . layoutPretty opts . pretty++instance Pretty (XXCTree p) => Pretty (CTree p) where+  pretty = \case+    CT.Literal v -> pretty v+    CT.Postlude v -> pretty v+    CT.Range lo hi ClOpen -> pretty lo <+> "..." <+> pretty hi+    CT.Range lo hi Closed -> pretty lo <+> ".." <+> pretty hi+    CT.KV k v _ -> pretty k <+> "==>" <+> pretty v+    CT.CTreeE x -> pretty x+    CT.Occur v oi ->+      case oi of+        OIOptional -> "?" <+> pretty v+        OIZeroOrMore -> "*" <+> pretty v+        OIOneOrMore -> "+" <+> pretty v+        OIBounded lo hi -> foldMap pretty lo <> "*" <> foldMap pretty hi <+> pretty v+    CT.Map m -> encloseSep "{" "}" "," $ pretty <$> m+    CT.Array e -> list $ pretty <$> e+    CT.Choice c -> group . vsep . punctuate "//" $ pretty <$> toList c+    CT.Group g -> tupled $ pretty <$> g+    CT.Control op tgt ctl -> pretty tgt <+> pretty op <+> pretty ctl+    CT.Enum e -> "&" <> pretty e+    CT.Unwrap x -> "~" <> pretty x+    CT.Tag t x -> "#6." <> pretty t <> "(" <> pretty x <> ")"

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -27,10 +28,13 @@   mapNestedValueExample,   deeplyNestedRefExample,   taggedUintExample,+  tagRangeExample, ) where +import Codec.CBOR.Cuddle.CBOR.Gen (generateFromGRef)+import Codec.CBOR.Cuddle.CBOR.Validator (validateFromGRef) import Codec.CBOR.Cuddle.CDDL (Name)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (WrappedTerm (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Core (RuleTerm (..)) import Codec.CBOR.Cuddle.Huddle (   CanQuantify (..),   Huddle,@@ -40,12 +44,14 @@   a,   arr,   asKey,+  binding,   collectFrom,   idx,   mp,   opt,   tag,   withCBORGen,+  withValidator,   (...),   (=:=),   (==>),@@ -53,7 +59,7 @@ import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Term qualified as C import Data.Word (Word64)-import Test.QuickCheck.GenT (MonadGen (..))+import Test.QuickCheck.GenT (MonadGen (..), frequency)  huddleRangeArray :: Huddle huddleRangeArray =@@ -108,7 +114,7 @@ simpleRule n = n =:= arr [1, 2, 3]  customGenRule :: Name -> Rule-customGenRule = withCBORGen (S . C.TInt <$> choose (4, 6)) . simpleRule+customGenRule = withCBORGen (SingleTerm . C.TInt <$> choose (4, 6)) . simpleRule  customGenExample :: Huddle customGenExample =@@ -313,3 +319,38 @@   collectFrom     [ HIRule $ "root" =:= tag 42 VBytes     ]++-- | @foo<a> = #6.1280(a) / #6.1400(a)@ with a custom generator that picks+-- any tag in @1280..1400@ (broader than what the schema literally allows)+-- and a custom validator that accepts the same range. Exercised at two+-- different generic instantiations to make sure the bound type is+-- resolved correctly per call.+tagRangeExample :: Huddle+tagRangeExample =+  collectFrom+    [ HIRule $+        "root" =:= arr [a (fooTagRange VUInt), a (fooTagRange VNInt)]+    ]+  where+    fooTagRange :: H.IsType0 t0 => t0 -> H.GRuleCall+    fooTagRange = binding $ \x ->+      withCBORGen (generator x)+        . withValidator (validator x)+        $ "foo" =:= tag 1280 x H./ tag 1400 x+      where+        generator x = do+          tagN <-+            frequency+              [ (1, pure 1280)+              , (1, pure 1400)+              , (4, choose (1281, 1399))+              ]+          generateFromGRef x >>= \case+            SingleTerm inner -> pure $ SingleTerm (C.TTagged tagN inner)+            _ -> error "tagRangeExample: generic argument must be a single term"++        validator x = \case+          SingleTerm (C.TTagged t inner)+            | t >= 1280 && t <= 1400 -> validateFromGRef x inner+            | otherwise -> fail $ "Tag out of range 1280..1400: " <> show t+          wt -> fail $ "Expected a tagged term, got: " <> show wt

@@ -8,7 +8,7 @@  import Codec.CBOR.Cuddle.CDDL import Codec.CBOR.Cuddle.CDDL.CtlOp-import Codec.CBOR.Cuddle.Comments (Comment (..))+import Codec.CBOR.Cuddle.Comments (Comment, toComment) import Codec.CBOR.Cuddle.Parser (ParserStage, XTerm (..)) import Codec.CBOR.Cuddle.Pretty (PrettyStage, XRule (..), XTerm (..), XXTopLevel (..)) import Data.ByteString (ByteString)@@ -48,7 +48,7 @@   shrink = fmap BS.pack . shrink . BS.unpack  instance Arbitrary Comment where-  arbitrary = Comment <$> arbitrary+  arbitrary = toComment <$> arbitrary   shrink = genericShrink  nameFstChars :: [Char]

@@ -7,8 +7,8 @@ import Codec.CBOR.Cuddle.CBOR.Gen (GenPhase, generateFromName) import Codec.CBOR.Cuddle.CBOR.Validator (validateCBOR) import Codec.CBOR.Cuddle.CDDL (Name)-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (GenEnv (..), runCBORGen) import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (GenConfig (..), runCBORGen) import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, MonoSimple, fullResolveCDDL) import Codec.CBOR.Cuddle.Huddle (Huddle, toCDDL) import Codec.CBOR.Cuddle.IndexMappable (IndexMappable (..), mapCDDLDropExt)@@ -30,6 +30,7 @@   refTermExample,   sizeBytesExample,   sizeTextExample,+  tagRangeExample,   taggedUintExample,  ) import Test.Codec.CBOR.Cuddle.CDDL.Validator (expectInvalid, genAndValidateRule)@@ -40,12 +41,12 @@ import Text.Pretty.Simple (pShow)  generateCDDL :: CTreeRoot GenPhase -> Gen Term-generateCDDL cddl = runAntiGen . runCBORGen env $ generateFromName "root"+generateCDDL cddl = runAntiGen . runCBORGen cfg $ generateFromName "root"   where-    env =-      GenEnv-        { geRoot = cddl-        , geTwiddle = True+    cfg =+      GenConfig+        { gcRoot = cddl+        , gcTwiddle = True         }  tryResolveHuddle :: HasCallStack => Huddle -> SpecM () (CTreeRoot MonoReferenced)@@ -57,12 +58,12 @@ expectZapInvalidates :: CTreeRoot MonoReferenced -> Name -> Property expectZapInvalidates cddl name = property $ do   let-    env =-      GenEnv-        { geRoot = mapIndex cddl-        , geTwiddle = True+    cfg =+      GenConfig+        { gcRoot = mapIndex cddl+        , gcTwiddle = True         }-  res@ZapResult {zrValue} <- zapAntiGenResult 1 . runCBORGen env $ generateFromName name+  res@ZapResult {zrValue} <- zapAntiGenResult 1 . runCBORGen cfg $ generateFromName name   let     bs = toStrictByteString $ encodeTerm zrValue     validationRes = validateCBOR bs name $ mapIndex cddl@@ -99,6 +100,7 @@       genAndValidateHuddle "sizeBytes" sizeBytesExample       genAndValidateHuddle "rangeList" rangeListExample       genAndValidateHuddle "rangeMap" rangeMapExample+      genAndValidateHuddle "tagRange" tagRangeExample       xdescribe "Generator cannot reliably produce unique keys for maps" $ do         genAndValidateHuddle "optionalMapExample" optionalMapExample @@ -139,17 +141,31 @@             TBytes "\x01\x02\x03\xff" -> True             TBytesI "\x01\x02\x03\xff" -> True             _ -> False+      tagRangeExampleCddl <- tryResolveHuddle tagRangeExample+      prop "tagRange generator covers edges and middle" $ do+        res <- generateCDDL $ mapIndex tagRangeExampleCddl+        let tags = case res of+              TList xs -> [t | TTagged t _ <- xs]+              TListI xs -> [t | TTagged t _ <- xs]+              _ -> []+            classifyTag t p =+              classify (t == 1280 || t == 1400) "edge tag (1280 or 1400)" $+                classify (t > 1280 && t < 1400) "middle tag (1281..1399)" p+            base =+              counterexample ("tags: " <> show tags) $+                all (\t -> t >= 1280 && t <= 1400) tags+        pure $ foldr classifyTag (property base) tags    describe "Tagged bytes zapping" $ do     taggedBytesCddl <- tryResolveHuddle taggedUintExample-    let env =-          GenEnv-            { geRoot = mapIndex taggedBytesCddl-            , geTwiddle = True+    let cfg =+          GenConfig+            { gcRoot = mapIndex taggedBytesCddl+            , gcTwiddle = True             }     prop "labels zapped result" $ do       ZapResult {zrValue} <--        zapAntiGenResult 1 . runCBORGen env $ generateFromName "root"+        zapAntiGenResult 1 . runCBORGen cfg $ generateFromName "root"       let         isBytes TBytes {} = True         isBytes TBytesI {} = True

@@ -1,11 +1,16 @@+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}  module Test.Codec.CBOR.Cuddle.CDDL.Pretty.Golden (spec) where +import Codec.CBOR.Cuddle.Comments ((//-))+import Codec.CBOR.Cuddle.Huddle (HuddleItem (..), a, (=:=))+import Codec.CBOR.Cuddle.Huddle qualified as H import Codec.CBOR.Cuddle.IndexMappable (mapIndex) import Codec.CBOR.Cuddle.Parser (pCDDL) import Codec.CBOR.Cuddle.Pretty (PrettyStage, renderCDDL) import Control.Monad ((<=<))+import Data.Text (Text) import Data.Text.IO qualified as T import Paths_cuddle (getDataFileName) import Prettyprinter (defaultLayoutOptions)@@ -15,6 +20,18 @@ import Text.Megaparsec (parse) import Text.Megaparsec.Error (errorBundlePretty) +mkGolden :: String -> Text -> Golden Text+mkGolden testName rendered =+  Golden+    { goldenFile = "golden" </> "pretty" </> testName <> ".txt"+    , readFromFile = T.readFile <=< getDataFileName+    , writeToFile = \fp txt -> getDataFileName fp >>= (`T.writeFile` txt)+    , actualFile = Nothing+    , output = rendered+    , encodePretty = show+    , failFirstTime = False+    }+ prettyPrintGolden :: String -> FilePath -> Spec prettyPrintGolden testName cddlPath = do   cddl <- runIO $ do@@ -24,16 +41,19 @@       Left err -> fail $ "Failed to parse CDDL:\n" <> errorBundlePretty err       Right x -> pure x   it testName $-    Golden-      { goldenFile = "golden" </> "pretty" </> testName <> ".txt"-      , readFromFile = T.readFile <=< getDataFileName-      , writeToFile = \fp txt -> getDataFileName fp >>= (`T.writeFile` txt)-      , actualFile = Nothing-      , output = renderCDDL defaultLayoutOptions $ mapIndex @_ @_ @PrettyStage cddl-      , encodePretty = show-      , failFirstTime = False-      }+    mkGolden testName $+      renderCDDL defaultLayoutOptions $+        mapIndex @_ @_ @PrettyStage cddl +huddleGolden :: String -> [HuddleItem] -> Spec+huddleGolden testName items =+  it testName $+    mkGolden testName $+      renderCDDL defaultLayoutOptions $+        mapIndex @_ @_ @PrettyStage $+          H.toCDDLNoRoot $+            H.collectFrom items+ spec :: Spec spec = describe "golden" $ do   prettyPrintGolden "basic_assign" "cddl/basic_assign.cddl"@@ -41,3 +61,51 @@   prettyPrintGolden "costmdls_min" "cddl/costmdls_min.cddl"   prettyPrintGolden "issue80-min" "cddl/issue80-min.cddl"   prettyPrintGolden "conway" "cddl/conway.cddl"+  describe "(//-) on a term" $ do+    huddleGolden+      "term_comment_rule"+      [HIRule $ "a" =:= (H.bool True //- "trailing")]+    huddleGolden+      "term_comment_appends_to_existing"+      [HIRule $ H.comment "existing" $ "a" =:= (H.bool True //- "trailing")]+    huddleGolden+      "term_comment_chained"+      [HIRule $ "a" =:= (H.bool True //- "first" //- "second")]+    huddleGolden+      "term_comment_empty"+      [HIRule $ "a" =:= (H.bool True //- "")]+    huddleGolden+      "term_comment_multiline"+      [HIRule $ "a" =:= (H.bool True //- "line one\nline two")]+    huddleGolden+      "term_comment_array_entries"+      [ HIRule $+          "triple"+            =:= H.arr+              [ a H.VUInt //- "first element"+              , a H.VText //- "second element"+              , a (H.bool True) //- "third element"+              ]+      ]+  describe "(//-) on a rule" $ do+    huddleGolden+      "rule_comment_rule"+      [HIRule $ "a" =:= H.bool True //- "trailing"]+    huddleGolden+      "rule_comment_appends_to_existing"+      [HIRule $ H.comment "existing" ("a" =:= H.bool True) //- "trailing"]+    huddleGolden+      "rule_comment_chained"+      [HIRule $ "a" =:= H.bool True //- "first" //- "second"]+    huddleGolden+      "rule_comment_empty"+      [HIRule $ "a" =:= H.bool True //- ""]+    huddleGolden+      "rule_comment_multiline"+      [HIRule $ "a" =:= H.bool True //- "line one\nline two"]+    huddleGolden+      "rule_comment_multi_rule"+      [ HIRule $ "port" =:= H.VUInt //- "the listening port"+      , HIRule $ "host" =:= H.VText //- "the host name"+      , HIRule $ "secure" =:= H.bool True //- "TLS only"+      ]

@@ -22,9 +22,11 @@   prettyValidationTrace,  ) import Codec.CBOR.Cuddle.CDDL (Name (..))-import Codec.CBOR.Cuddle.CDDL.CBORGenerator (CustomValidatorResult (..), GenEnv (..), runCBORGen) import Codec.CBOR.Cuddle.CDDL.CTree (CTreeRoot (..)) import Codec.CBOR.Cuddle.CDDL.CTree qualified as CTree+import Codec.CBOR.Cuddle.CDDL.Custom.Core (RuleTerm (..))+import Codec.CBOR.Cuddle.CDDL.Custom.Generator (GenConfig (..), runCBORGen)+import Codec.CBOR.Cuddle.CDDL.Custom.Validator (TermValidator) import Codec.CBOR.Cuddle.CDDL.Postlude (appendPostlude) import Codec.CBOR.Cuddle.CDDL.Resolve (MonoReferenced, fullResolveCDDL) import Codec.CBOR.Cuddle.Huddle (@@ -99,12 +101,12 @@ genAndValidateRule description name resolvedCddl =   prop description $ do     let-      genEnv =-        GenEnv-          { geRoot = mapIndex resolvedCddl-          , geTwiddle = True+      genCfg =+        GenConfig+          { gcRoot = mapIndex resolvedCddl+          , gcTwiddle = True           }-    cborTerm <- runAntiGen . runCBORGen genEnv $ generateFromName name+    cborTerm <- runAntiGen . runCBORGen genCfg $ generateFromName name     let       generatedCbor = toStrictByteString $ encodeTerm cborTerm       res = validateCBOR generatedCbor name (mapIndex resolvedCddl)@@ -281,15 +283,15 @@       <> renderStrict (layoutPretty defaultLayoutOptions $ prettyValidationTrace defaultTraceOptions t) expectInvalid _ = pure () -stringValidator :: Term -> CustomValidatorResult-stringValidator (TString _) = CustomValidatorSuccess-stringValidator (TStringI _) = CustomValidatorSuccess-stringValidator t = CustomValidatorFailure $ "Expected a string, got\n" <> T.pack (show t)+stringValidator :: TermValidator+stringValidator (SingleTerm (TString _)) = pure ()+stringValidator (SingleTerm (TStringI _)) = pure ()+stringValidator t = fail $ "Expected a string, got\n" <> show t -bytesValidator :: Term -> CustomValidatorResult-bytesValidator (TBytes _) = CustomValidatorSuccess-bytesValidator (TBytesI _) = CustomValidatorSuccess-bytesValidator t = CustomValidatorFailure $ "Expected bytes, got\n" <> T.pack (show t)+bytesValidator :: TermValidator+bytesValidator (SingleTerm (TBytes _)) = pure ()+bytesValidator (SingleTerm (TBytesI _)) = pure ()+bytesValidator t = fail $ "Expected bytes, got\n" <> show t  spec :: Spec spec = describe "Validator" $ do