diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/bin/Main.hs b/bin/Main.hs --- a/bin/Main.hs +++ b/bin/Main.hs @@ -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 diff --git a/cuddle.cabal b/cuddle.cabal --- a/cuddle.cabal +++ b/cuddle.cabal @@ -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 diff --git a/golden/pretty/rule_comment_appends_to_existing.txt b/golden/pretty/rule_comment_appends_to_existing.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_appends_to_existing.txt @@ -0,0 +1,3 @@ +;existing +; trailing +a = true diff --git a/golden/pretty/rule_comment_chained.txt b/golden/pretty/rule_comment_chained.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_chained.txt @@ -0,0 +1,3 @@ +; first +; second +a = true diff --git a/golden/pretty/rule_comment_empty.txt b/golden/pretty/rule_comment_empty.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_empty.txt @@ -0,0 +1,1 @@ +a = true diff --git a/golden/pretty/rule_comment_multi_rule.txt b/golden/pretty/rule_comment_multi_rule.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_multi_rule.txt @@ -0,0 +1,8 @@ +; the listening port +port = uint + +; the host name +host = text + +; TLS only +secure = true diff --git a/golden/pretty/rule_comment_multiline.txt b/golden/pretty/rule_comment_multiline.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_multiline.txt @@ -0,0 +1,3 @@ +; line one +; line two +a = true diff --git a/golden/pretty/rule_comment_rule.txt b/golden/pretty/rule_comment_rule.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/rule_comment_rule.txt @@ -0,0 +1,2 @@ +; trailing +a = true diff --git a/golden/pretty/term_comment_appends_to_existing.txt b/golden/pretty/term_comment_appends_to_existing.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_appends_to_existing.txt @@ -0,0 +1,3 @@ +;existing +a = + true ; trailing diff --git a/golden/pretty/term_comment_array_entries.txt b/golden/pretty/term_comment_array_entries.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_array_entries.txt @@ -0,0 +1,5 @@ +triple = + [ uint ; first element + , text ; second element + , true ; third element + ] diff --git a/golden/pretty/term_comment_chained.txt b/golden/pretty/term_comment_chained.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_chained.txt @@ -0,0 +1,3 @@ +a = + true ; first + ; second diff --git a/golden/pretty/term_comment_empty.txt b/golden/pretty/term_comment_empty.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_empty.txt @@ -0,0 +1,1 @@ +a = true diff --git a/golden/pretty/term_comment_multiline.txt b/golden/pretty/term_comment_multiline.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_multiline.txt @@ -0,0 +1,3 @@ +a = + true ; line one + ; line two diff --git a/golden/pretty/term_comment_rule.txt b/golden/pretty/term_comment_rule.txt new file mode 100644 --- /dev/null +++ b/golden/pretty/term_comment_rule.txt @@ -0,0 +1,2 @@ +a = + true ; trailing diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs --- a/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator/Trace.hs @@ -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 -> diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs b/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs deleted file mode 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/CBORGenerator.hs +++ /dev/null @@ -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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs b/src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs --- a/src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/CTreePhase.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Core.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Core.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Core.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Generator.hs @@ -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)) diff --git a/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Codec/CBOR/Cuddle/CDDL/Custom/Validator.hs @@ -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} diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -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 -> diff --git a/src/Codec/CBOR/Cuddle/Comments.hs b/src/Codec/CBOR/Cuddle/Comments.hs --- a/src/Codec/CBOR/Cuddle/Comments.hs +++ b/src/Codec/CBOR/Cuddle/Comments.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/IndexMappable.hs b/src/Codec/CBOR/Cuddle/IndexMappable.hs --- a/src/Codec/CBOR/Cuddle/IndexMappable.hs +++ b/src/Codec/CBOR/Cuddle/IndexMappable.hs @@ -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 diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -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) diff --git a/src/Codec/CBOR/Cuddle/Parser/Lexer.hs b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs --- a/src/Codec/CBOR/Cuddle/Parser/Lexer.hs +++ b/src/Codec/CBOR/Cuddle/Parser/Lexer.hs @@ -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' diff --git a/src/Codec/CBOR/Cuddle/Pretty.hs b/src/Codec/CBOR/Cuddle/Pretty.hs --- a/src/Codec/CBOR/Cuddle/Pretty.hs +++ b/src/Codec/CBOR/Cuddle/Pretty.hs @@ -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 <> ")" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples/Huddle.hs @@ -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 = #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 diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -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] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/GeneratorSpec.hs @@ -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 diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Pretty/Golden.hs @@ -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" + ] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Validator.hs @@ -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