diff --git a/cuddle.cabal b/cuddle.cabal index aadaecc..4c148e3 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -139,6 +139,7 @@ test-suite cuddle-test Test.Codec.CBOR.Cuddle.CDDL.Gen Test.Codec.CBOR.Cuddle.CDDL.Parser Test.Codec.CBOR.Cuddle.CDDL.Pretty + Test.Codec.CBOR.Cuddle.CBOR.Validator Test.Codec.CBOR.Cuddle.Huddle type: exitcode-stdio-1.0 @@ -149,11 +150,13 @@ test-suite cuddle-test QuickCheck ^>=2.15, base, bytestring, + containers, cuddle, data-default-class, hspec ^>=2.11, hspec-megaparsec ^>=2.2, megaparsec, + mtl ^>=2.3.1, prettyprinter, string-qq ^>=0.0.6, text, diff --git a/flake.lock b/flake.lock index cbf5a37..fc719d3 100644 --- a/flake.lock +++ b/flake.lock @@ -6,11 +6,11 @@ "rust-analyzer-src": "rust-analyzer-src" }, "locked": { - "lastModified": 1745303921, - "narHash": "sha256-zYucemS2QvJUR5GKJ/u3eZAoe82AKhcxMtNVZDERXsw=", + "lastModified": 1749105720, + "narHash": "sha256-R3mjXc+LF74COXMDfJLuKEUPliXqOqe0wgErgTOFovI=", "owner": "nix-community", "repo": "fenix", - "rev": "14850d5984f3696a2972f85f19085e5fb46daa95", + "rev": "fd217600040e0e7c7ea844af027f3dc1f4b35e6c", "type": "github" }, "original": { @@ -55,11 +55,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1744932701, - "narHash": "sha256-fusHbZCyv126cyArUwwKrLdCkgVAIaa/fQJYFlCEqiU=", + "lastModified": 1748929857, + "narHash": "sha256-lcZQ8RhsmhsK8u7LIFsJhsLh/pzR9yZ8yqpTzyGdj+Q=", "owner": "nixos", "repo": "nixpkgs", - "rev": "b024ced1aac25639f8ca8fdfc2f8c4fbd66c48ef", + "rev": "c2a03962b8e24e669fb37b7df10e7c79531ff1a4", "type": "github" }, "original": { @@ -71,11 +71,11 @@ }, "nixpkgs_2": { "locked": { - "lastModified": 1744932701, - "narHash": "sha256-fusHbZCyv126cyArUwwKrLdCkgVAIaa/fQJYFlCEqiU=", + "lastModified": 1748929857, + "narHash": "sha256-lcZQ8RhsmhsK8u7LIFsJhsLh/pzR9yZ8yqpTzyGdj+Q=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b024ced1aac25639f8ca8fdfc2f8c4fbd66c48ef", + "rev": "c2a03962b8e24e669fb37b7df10e7c79531ff1a4", "type": "github" }, "original": { @@ -129,11 +129,11 @@ "rust-analyzer-src": { "flake": false, "locked": { - "lastModified": 1745247864, - "narHash": "sha256-QA1Ba8Flz5K+0GbG03HwiX9t46mh/jjKgwavbuKtwMg=", + "lastModified": 1749033758, + "narHash": "sha256-Ie003Weeg3Lsly9QuFJtw8W1JXnxoYD3FeV9KIxE+Ss=", "owner": "rust-lang", "repo": "rust-analyzer", - "rev": "31dbec70c68e97060916d4754c687a3e93c2440f", + "rev": "55b733103efa59f3504e308629b59d49da69bd9a", "type": "github" }, "original": { diff --git a/project.ncl b/project.ncl index 0e16988..f608240 100644 --- a/project.ncl +++ b/project.ncl @@ -10,8 +10,8 @@ let shellFor = fun ghcver => haskell-language-server = hspkg "haskell-language-server", fourmolu = hspkg "fourmolu", ghc = organist.import_nix "nixpkgs#haskell.compiler.%{ghcver}", - cabal-install = hspkg "cabal-install", - cabal-fmt = hspkg "cabal-fmt", + # cabal-install = hspkg "cabal-install", + # cabal-fmt = hspkg "cabal-fmt", cddl = organist.import_nix "nixpkgs#cddl", }, } in @@ -24,7 +24,7 @@ let shellFor = fun ghcver => packages = {}, }, - shells.dev = shellFor "ghc964", + shells.dev = shellFor "ghc967", } } | organist.OrganistExpression diff --git a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs index f80884a..fbcaba4 100644 --- a/src/Codec/CBOR/Cuddle/CBOR/Validator.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -13,12 +13,13 @@ import Codec.CBOR.Cuddle.CDDL.Resolve import Codec.CBOR.Read import Codec.CBOR.Term import Control.Exception -import Control.Monad ((>=>)) +import Control.Monad ((>=>), join) import Control.Monad.Reader import Data.Bifunctor import Data.Bits hiding (And) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL +import Data.Either (lefts, rights) import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Identity @@ -33,6 +34,7 @@ import GHC.Float import System.Exit import System.IO import Text.Regex.TDFA +import Data.Foldable (Foldable(..)) type CDDL = CTreeRoot' Identity MonoRef type Rule = Node MonoRef @@ -60,9 +62,9 @@ data CDDLResult -- | Rule we are trying Rule -- | List of expansions of rules - [[Rule]] + ExpansionTree -- | For each expansion, for each of the rules in the expansion, the result - [[(Rule, CBORTermResult)]] + (ExpansionTree' (Rule, CBORTermResult)) | -- | All expansions failed -- -- An expansion is: Given a CBOR @TMap@ of @N@ elements, we will expand the @@ -71,7 +73,7 @@ data CDDLResult -- | Rule we are trying Rule -- | List of expansions - [[Rule]] + ExpansionTree -- | A list of matched items @(key, value, rule)@ and the unmatched item [([AMatchedItem], ANonMatchedItem)] | -- | The rule was valid but the control failed @@ -655,58 +657,205 @@ flattenGroup cddl nodes = | rule <- nodes ] +-- | A filter on a subtree in an expansion. How this is used will depend on the +-- contenxt in which this expansion is used. For maps, we filter based on the +-- key, which can be in any position. For arrays, we filter based on the first +-- value. +data Filter r + = ArrayFilter {arrayFilter :: r} + | MapFilter {mapFilter :: r, arrayFilter :: r} + deriving (Eq, Functor, Show) + +-- | A tree of possible expansions of a rule matching the size of a container to +-- validate. This tree contains filters at each node, such that we can +-- short-circuit the branch. +-- +-- Note that, for simplicity's sake, the gates do not actually consume tokens, +-- so once we reach a leaf we must match it entire against the input. +-- +-- The leaves of an expansion tree may be of different lengths until we merge +-- them. +data ExpansionTree' r + = -- | A leaf represents the full sequence of rules which must be matched + Leaf [r] + | -- | Multiple possibilities for matching + Branch [ExpansionTree' r] + | -- | Set of possibilities guarded by a filter + FilterBranch (Filter r) (ExpansionTree' r) + deriving (Eq, Show) + +-- | Merge trees +-- +-- We merge from the left, folding a copy of the second tree into each interior +-- node in the first. +-- +-- The trees to be merged are the expansions of each item in the top-level +-- group to be matched. Thus the resulting tree should match a group +-- containing all the argument trees. +mergeTrees :: [ExpansionTree' a] -> ExpansionTree' a +mergeTrees [] = Branch [] +mergeTrees (a : as) = foldl' go a as + where + go (Leaf xs) b = prependRules xs b + go (Branch xs) b = Branch $ fmap (flip go b) xs + go (FilterBranch f x) b = FilterBranch f $ go x b + +-- | Normalise a tree +-- +-- - Remove single node branches +-- - Inline subbranches into higher branches +normaliseTree :: ExpansionTree' a -> ExpansionTree' a +normaliseTree (Branch [a]) = normaliseTree a +normaliseTree (Branch xs) = Branch . join $ unwindBranches <$> xs + where + unwindBranches (Branch xs') = normaliseTree <$> xs' + unwindBranches a = [normaliseTree a] +normaliseTree (FilterBranch f a) = FilterBranch f $ normaliseTree a +normaliseTree a = a + +-- | Merge two trees by adding them as choices at the top-level using the +-- `Branch` constructor. +mergeTopBranch :: ExpansionTree' a -> ExpansionTree' a -> ExpansionTree' a +mergeTopBranch (Branch t1) (Branch t2) = Branch $ t1 <> t2 +mergeTopBranch (Branch t1) t2 = Branch (t1 <> [t2]) +mergeTopBranch t1 (Branch t2) = Branch (t1 : t2) +mergeTopBranch t1 t2 = Branch [t1, t2] + +-- | Clamp a tree to contain only expressions with a fixed number of elements. +clampTree :: Int -> ExpansionTree' a -> ExpansionTree' a +clampTree sz a = maybe (Branch []) id (go a) + where + go l@(Leaf x) = if length x == sz then Just l else Nothing + go (Branch xs) = case catMaybes (go <$> xs) of + [] -> Nothing + ys -> Just $ Branch ys + go (FilterBranch f x) = FilterBranch f <$> go x + +-- | Prepend the given rules atop each leaf node in the tree +prependRules :: [r] -> ExpansionTree' r -> ExpansionTree' r +prependRules rs t = case t of + Leaf a -> Leaf $ rs <> a + Branch xs -> Branch $ fmap (prependRules rs) xs + FilterBranch f x -> FilterBranch f $ prependRules rs x + +type ExpansionTree = ExpansionTree' Rule + +filterOn :: Rule -> Reader CDDL (Filter Rule) +filterOn rule = + getRule rule >>= \case + KV k v _ -> pure $ MapFilter k v + _ -> pure $ ArrayFilter rule + -- | Expand rules to reach exactly the wanted length, which must be the number -- of items in the container. For example, if we want to validate 3 elements, -- and we have the following CDDL: -- -- > a = [* int, * bool] -- --- this will be expanded to `[int, int, int], [int, int, bool], [int, bool, --- bool], [bool, bool, bool]`. +-- this will be expanded to +-- ``` +-- [int, int, bool] +-- int +-- [int, int, int] +-- int +-- bool +-- [int, bool, bool] +-- * +-- bool +-- [bool, bool, bool] +-- +-- ``` -- -- Essentially the rules we will parse is the choice among the expansions of the -- original rules. -expandRules :: Int -> [Rule] -> Reader CDDL [[Rule]] +-- +-- Important: the "rules" here are the various elements of a list, +-- not true top-level rules. +expandRules :: Int -> [Rule] -> Reader CDDL ExpansionTree expandRules remainingLen [] - | remainingLen /= 0 = pure [] -expandRules _ [] = pure [[]] + | remainingLen /= 0 = pure $ Branch [] +expandRules _ [] = pure $ Branch [] expandRules remainingLen _ - | remainingLen < 0 = pure [] - | remainingLen == 0 = pure [[]] -expandRules remainingLen (x : xs) = do - y <- expandRule remainingLen x - concat - <$> mapM - ( \y' -> do - suffixes <- expandRules (remainingLen - length y') xs - pure [y' ++ ys' | ys' <- suffixes] - ) - y - -expandRule :: Int -> Rule -> Reader CDDL [[Rule]] -expandRule maxLen _ - | maxLen < 0 = pure [] -expandRule maxLen rule = - getRule rule >>= \case - Occur o OIOptional -> pure $ [] : [[o] | maxLen > 0] - Occur o OIZeroOrMore -> ([] :) <$> expandRule maxLen (MIt (Occur o OIOneOrMore)) - Occur o OIOneOrMore -> - if maxLen > 0 - then ([o] :) . map (o :) <$> expandRule (maxLen - 1) (MIt (Occur o OIOneOrMore)) - else pure [] - Occur o (OIBounded low high) -> case (low, high) of - (Nothing, Nothing) -> expandRule maxLen (MIt (Occur o OIZeroOrMore)) - (Just (fromIntegral -> low'), Nothing) -> - if maxLen >= low' - then map (replicate low' o ++) <$> expandRule (maxLen - low') (MIt (Occur o OIZeroOrMore)) - else pure [] - (Nothing, Just (fromIntegral -> high')) -> - pure [replicate n o | n <- [0 .. min maxLen high']] - (Just (fromIntegral -> low'), Just (fromIntegral -> high')) -> - if maxLen >= low' - then pure [replicate n o | n <- [low' .. min maxLen high']] - else pure [] - _ -> pure [[rule | maxLen > 0]] + | remainingLen <= 0 = pure $ Branch [] +expandRules remainingLen xs = do + ys <- traverse (\a -> expandRule remainingLen a) xs + let ms = mergeTrees ys + pure . normaliseTree . clampTree remainingLen $ ms + +expandRule :: Int -> Rule -> Reader CDDL ExpansionTree +expandRule = go [] + where + go acc maxLen _ | maxLen <= 0 = pure $ Leaf $ reverse acc + go acc maxLen rule = + getRule rule >>= \case + Occur o OIOptional -> + -- If the rule is optional, then we have two cases - one just the acc, + -- and one with the new element as well. But there's little point guarding + -- that second branch with a filter. + pure $ Branch [Leaf (reverse $ o : acc), Leaf (reverse acc)] + Occur o OIZeroOrMore -> do + -- In the zero or more case, we allow the acc, and then another branch - + -- guarded by the element - which recurses decreasing the maxLen + rest <- go (o : acc) (maxLen - 1) rule + f <- filterOn o + pure $ + Branch + [ FilterBranch f rest + , Leaf (reverse acc) + ] + Occur o OIOneOrMore -> do + -- In the one or more case, we filter directly on the element and then + -- recurse with a ZeroOrMore + f <- filterOn o + FilterBranch f <$> go (o : acc) (maxLen - 1) (MIt (Occur o OIZeroOrMore)) + Occur o (OIBounded low high) -> case (low, high) of + (Nothing, Nothing) -> + -- This is basically the zero or more case again + go acc maxLen (MIt (Occur o OIZeroOrMore)) + (Just (fromIntegral -> low'), Nothing) -> + -- We have a lower bound, so things must show up at least that number + -- of times. + if maxLen < low' + then + -- No way for this to work, so we yield an empty branch + pure $ Branch [] + else do + -- We'll gate a single branch + let acc' = replicate low' o <> acc + f <- filterOn o + rest <- go acc' (maxLen - low') (MIt (Occur o OIZeroOrMore)) + pure $ FilterBranch f rest + (Nothing, Just (fromIntegral -> high')) -> do + -- We have an upper bound but no lower bound. That's fine - we yield + -- a branch with just the acc and a branch where we consume one element + -- and decrease the upper bound. + rest <- + go + (o : acc) + (maxLen - 1) + (MIt (Occur o (OIBounded Nothing (Just $ high' - 1)))) + f <- filterOn o + pure $ + Branch + [ FilterBranch f rest + , Leaf (reverse acc) + ] + (Just (fromIntegral -> low'), Just (fromIntegral -> high')) -> do + -- Upper and lower bounds. + if maxLen < low' + then + -- No way for this to work, so we yield an empty branch + pure $ Branch [] + else do + -- We'll gate a single branch + let acc' = replicate low' o <> acc + f <- filterOn o + rest <- go acc' (maxLen - low') + (MIt (Occur o (OIBounded Nothing (Just $ high' - fromIntegral low')))) + pure $ FilterBranch f rest + _ -> + -- This is a rule without an occurence indicator, so it must be included + pure $ Leaf $ reverse (rule : acc) -- | Which rules are optional? isOptional :: MonadReader CDDL m => Rule -> m Bool @@ -725,9 +874,9 @@ isOptional rule = validateListWithExpandedRules :: forall m. MonadReader CDDL m => - [Term] -> [Rule] -> m [(Rule, CBORTermResult)] + NE.NonEmpty Term -> [Rule] -> m [(Rule, CBORTermResult)] validateListWithExpandedRules terms rules = - go (zip terms rules) + go (zip (NE.toList terms) rules) where go :: [(Term, Rule)] -> m [(Rule, CBORTermResult)] @@ -751,26 +900,37 @@ validateListWithExpandedRules terms rules = validateExpandedList :: forall m. MonadReader CDDL m => - [Term] -> - [[Rule]] -> + NE.NonEmpty Term -> + ExpansionTree -> m (Rule -> CDDLResult) validateExpandedList terms rules = go rules where - go :: [[Rule]] -> m (Rule -> CDDLResult) - go [] = pure $ \r -> ListExpansionFail r rules [] - go (choice : choices) = do + go :: ExpansionTree -> m (Rule -> CDDLResult) + go (Leaf choice) = do res <- validateListWithExpandedRules terms choice case res of [] -> pure Valid _ -> case last res of (_, CBORTermResult _ (Valid _)) -> pure Valid - _ -> - go choices - >>= ( \case - Valid _ -> pure Valid - ListExpansionFail _ _ errors -> pure $ \r -> ListExpansionFail r rules (res : errors) - ) - . ($ dummyRule) + _ -> pure $ \r -> ListExpansionFail r rules (Leaf res) + go (FilterBranch f x) = + validateTerm (NE.head terms) (arrayFilter f) >>= \case + (CBORTermResult _ (Valid _)) -> go x + -- In this case we insert a leaf since we haven't actually validated the + -- subnodes. + err -> pure $ \r -> ListExpansionFail r rules $ FilterBranch ((,err) <$> f) $ Leaf [(r, err)] + go (Branch xs) = goBranch xs + + goBranch [] = pure $ \r -> ListExpansionFail r rules $ Branch [] + goBranch (x : xs) = + go x <&> ($ dummyRule) >>= \case + Valid _ -> pure Valid + ListExpansionFail _ _ errors -> prependBranchErrors errors <$> goBranch xs + + prependBranchErrors errors res = case res dummyRule of + Valid _ -> Valid + ListExpansionFail _ _ errors2 -> \r -> + ListExpansionFail r rules $ mergeTopBranch errors errors2 validateList :: MonadReader CDDL m => [Term] -> Rule -> m CDDLResult @@ -781,17 +941,39 @@ validateList terms rule = Array rules -> case terms of [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule) - _ -> + t : ts -> ask >>= \cddl -> let sequencesOfRules = runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl - in validateExpandedList terms sequencesOfRules + in validateExpandedList (t NE.:| ts) sequencesOfRules Choice opts -> validateChoice (validateList terms) opts _ -> pure UnapplicableRule -------------------------------------------------------------------------------- -- Maps +-- | Does the map comtain a key matching this rule? +-- +-- If so, return the matching term. Otherwise, return the list of all the terms +-- that failed to match +containsMatchingKey :: + forall m. + MonadReader CDDL m => + NE.NonEmpty (Term, Term) -> + Rule -> + m (Either [ANonMatchedItem] AMatchedItem) +containsMatchingKey terms rule = do + let tryKey (k, v) = do + result <- validateTerm k rule + case result of + CBORTermResult _ (Valid _) -> pure $ Right (AMatchedItem k v rule) + CBORTermResult _ res -> pure $ Left (ANonMatchedItem k v [Left (rule, res)]) + + results <- traverse tryKey (NE.toList terms) + case rights results of + (m : _) -> pure $ Right m + [] -> pure $ Left $ lefts results + validateMapWithExpandedRules :: forall m. MonadReader CDDL m => @@ -831,25 +1013,40 @@ validateMapWithExpandedRules = validateExpandedMap :: forall m. MonadReader CDDL m => - [(Term, Term)] -> - [[Rule]] -> + NE.NonEmpty (Term, Term) -> + ExpansionTree -> m (Rule -> CDDLResult) validateExpandedMap terms rules = go rules where - go :: [[Rule]] -> m (Rule -> CDDLResult) - go [] = pure $ \r -> MapExpansionFail r rules [] - go (choice : choices) = do - res <- validateMapWithExpandedRules terms choice + go :: ExpansionTree -> m (Rule -> CDDLResult) + go (Leaf choice) = do + res <- validateMapWithExpandedRules (NE.toList terms) choice case res of (_, Nothing) -> pure Valid - (matches, Just notMatched) -> - go choices - >>= ( \case - Valid _ -> pure Valid - MapExpansionFail _ _ errors -> - pure $ \r -> MapExpansionFail r rules ((matches, notMatched) : errors) - ) - . ($ dummyRule) + (matches, Just notMatched) -> pure $ \r -> + MapExpansionFail r rules [(matches, notMatched)] + go (FilterBranch f x) = + case f of + MapFilter kf _ -> + containsMatchingKey terms kf >>= \case + Right _ -> go x + Left errs -> pure $ \r -> MapExpansionFail r rules $ ([],) <$> errs + ArrayFilter _ -> + -- We cannot really work with this. Ignore the filter and let the code + -- below blow up when it tries to match a map with an array + go x + go (Branch xs) = goBranch xs + + goBranch [] = pure $ \r -> MapExpansionFail r rules [] + goBranch (x : xs) = + go x <&> ($ dummyRule) >>= \case + Valid _ -> pure Valid + MapExpansionFail _ _ errors -> prependBranchErrors errors <$> goBranch xs + + prependBranchErrors errors res = case res dummyRule of + Valid _ -> Valid + MapExpansionFail _ _ errors2 -> \r -> + MapExpansionFail r rules $ errors <> errors2 validateMap :: MonadReader CDDL m => @@ -861,11 +1058,11 @@ validateMap terms rule = Map rules -> case terms of [] -> ifM (and <$> mapM isOptional rules) (pure Valid) (pure InvalidRule) - _ -> + x : xs -> ask >>= \cddl -> let sequencesOfRules = runReader (expandRules (length terms) $ flattenGroup cddl rules) cddl - in validateExpandedMap terms sequencesOfRules + in validateExpandedMap (x NE.:| xs) sequencesOfRules Choice opts -> validateChoice (validateMap terms) opts _ -> pure UnapplicableRule diff --git a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs index 176c147..0765771 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/CTree.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/CTree.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} module Codec.CBOR.Cuddle.CDDL.CTree where @@ -46,6 +47,8 @@ data CTree f | Tag Word64 (Node f) deriving (Generic) +deriving instance Eq (Node f) => Eq (CTree f) + -- | Traverse the CTree, carrying out the given operation at each node traverseCTree :: Monad m => (Node f -> m (Node g)) -> CTree f -> m (CTree g) traverseCTree _ (Literal a) = pure $ Literal a diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs index 96a0f9a..0e5a72f 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -342,8 +342,6 @@ instance Hashable a => Hashable (DistRef a) deriving instance Show (CTree DistRef) -deriving instance Eq (CTree DistRef) - instance Hashable (CTree DistRef) deriving instance Show (CTreeRoot DistRef) @@ -398,7 +396,7 @@ buildResolvedCTree (CTreeRoot ct) = CTreeRoot <$> traverse go ct data MonoRef a = MIt a | MRuleRef Name - deriving (Functor, Show) + deriving (Eq, Functor, Show) deriving instance Show (CTree MonoRef) diff --git a/test/Main.hs b/test/Main.hs index cecc028..d5a406e 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ module Main (main) where import System.IO (BufferMode (..), hSetBuffering, hSetEncoding, stdout, utf8) +import Test.Codec.CBOR.Cuddle.CBOR.Validator (cborValidatorSpec) import Test.Codec.CBOR.Cuddle.CDDL.Examples qualified as Examples import Test.Codec.CBOR.Cuddle.CDDL.Parser (parserSpec) import Test.Codec.CBOR.Cuddle.Huddle (huddleSpec) @@ -21,3 +22,4 @@ main = do describe "cddlParser" parserSpec describe "Huddle" huddleSpec describe "Examples" Examples.spec + describe "CBOR Validation" cborValidatorSpec diff --git a/test/Test/Codec/CBOR/Cuddle/CBOR/Validator.hs b/test/Test/Codec/CBOR/Cuddle/CBOR/Validator.hs new file mode 100644 index 0000000..013d069 --- /dev/null +++ b/test/Test/Codec/CBOR/Cuddle/CBOR/Validator.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Test.Codec.CBOR.Cuddle.CBOR.Validator where + +import Codec.CBOR.Cuddle.CBOR.Validator qualified as CV +import Codec.CBOR.Cuddle.CDDL (Name) +import Codec.CBOR.Cuddle.CDDL.CTree +import Codec.CBOR.Cuddle.CDDL.Resolve (MonoRef (MIt), fullResolveCDDL) +import Codec.CBOR.Cuddle.Huddle +import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm(PTInt, PTBool)) +import Control.Monad.Reader +import Data.Functor.Identity +import Data.Map.Strict qualified as Map +import Test.Hspec + +cborValidatorSpec :: Spec +cborValidatorSpec = do + utilitySpec + expandRuleSpec + +utilitySpec :: Spec +utilitySpec = describe "Utility functions should work" $ do + describe "mergeTrees" $ do + it "Should prepend things to a leaf" $ + CV.mergeTrees @Bool + [ CV.Leaf [True] + , CV.Leaf [False] + ] + `shouldBe` CV.Leaf [True, False] + it "Should nest things" $ + CV.mergeTrees @Bool + [ CV.FilterBranch (CV.ArrayFilter True) (CV.Leaf [True]) + , CV.FilterBranch (CV.ArrayFilter False) (CV.Leaf [False]) + ] + `shouldBe` CV.FilterBranch + (CV.ArrayFilter True) + (CV.FilterBranch (CV.ArrayFilter False) (CV.Leaf [True, False])) + it "Should work 2 levels deep" $ + CV.mergeTrees @Bool + [ F (AF True) (B [L [True], F (AF True) (L [True, True])]) + , F (AF False) (B [L [False], F (AF False) (L [False, False])]) + ] + `shouldBe` F + (AF True) + ( B + [ F (AF False) (B [L [True, False], F (AF False) (L [True, False, False])]) + , F (AF True) (F (AF False) (B [L [True, True, False], F (AF False) (L [True, True, False, False])])) + ] + ) + describe "clampTree" $ do + it "Should exclude too long possibilities" $ + CV.clampTree 2 (L [1 :: Int .. 10]) `shouldBe` B [] + it "Should work within branches" $ + CV.clampTree 2 (B [L [1 :: Int, 2], L [2, 3, 4], L [3, 4]]) + `shouldBe` B [L [1, 2], L [3, 4]] + +expandRuleSpec :: Spec +expandRuleSpec = describe "Expand Rule should generate appropriate expansion trees" $ do + it "should expand a simple rule" $ do + let rule = arr [0 <+ a VInt] + expandedRules = + withHuddleRule ["test" =:= rule] "test" $ + CV.expandRules 1 + expandedRules `shouldBe` + F (AF (MIt (Postlude PTInt))) (L [MIt (Postlude PTInt)]) + it "should expand a rule with multiple productions" $ do + -- Test expanding a rule [* int, * bool] + -- Should generate an expansion tree that allows: + -- - Zero or more integers followed by zero or more booleans + -- - Each element can appear 0 to unbounded times + -- - The total length, however, must be 3 + let rule = arr [0 <+ a VInt, 0 <+ a VBool] + expandedRules = + withHuddleRule ["test" =:= rule] "test" $ + CV.expandRules 3 + mI = (MIt (Postlude PTInt)) + mB = (MIt (Postlude PTBool)) + expandedRules `shouldBe` + B [ + F (AF mI) (B [ + F (AF mI) (B [ + F (AF mI) (L [mI, mI, mI]) + , F (AF mB) (L [mI, mI, mB]) + ]) + , F (AF mB) (F (AF mB) (L [mI, mB, mB])) + ]) + , F (AF mB) (F (AF mB) (F (AF mB) (L [mB, mB, mB]))) + ] + +-------------------------------------------------------------------------------- +-- Utility +-- + +withHuddleRule :: Huddle -> Name -> ([CV.Rule] -> Reader CV.CDDL a) -> a +withHuddleRule hdl n rdr = runReader (rdr groupProductions) cddl + where + cddl@(CTreeRoot tree) = case fullResolveCDDL (toCDDLNoRoot hdl) of + Left e -> error $ show e + Right c -> c + groupProductions = case runIdentity $ tree Map.! n of + MIt (Array elts) -> elts + MIt (Map elts) -> elts + _ -> error "Rule does not identify an array or map" + +pattern F :: forall {r}. CV.Filter r -> CV.ExpansionTree' r -> CV.ExpansionTree' r +pattern F f e = CV.FilterBranch f e +pattern L :: forall {r}. [r] -> CV.ExpansionTree' r +pattern L rs = CV.Leaf rs +pattern B :: forall {r}. [CV.ExpansionTree' r] -> CV.ExpansionTree' r +pattern B xs = CV.Branch xs +pattern AF :: forall {r}. r -> CV.Filter r +pattern AF f = CV.ArrayFilter f