diff --git a/example/cddl-files/basic_assign.cddl b/example/cddl-files/basic_assign.cddl index 59833b6..6c56da4 100644 --- a/example/cddl-files/basic_assign.cddl +++ b/example/cddl-files/basic_assign.cddl @@ -44,9 +44,3 @@ big_group = ( 5 ...10, h'11aaff3351bc' ) - -test = ~ aaaa .. "j" / -# / -{xco, lhXH // // } .cborseq # / -& (* kkhw // // ) / -"b" diff --git a/example/cddl-files/pretty.cddl b/example/cddl-files/pretty.cddl index c1e5172..0e9f0b5 100644 --- a/example/cddl-files/pretty.cddl +++ b/example/cddl-files/pretty.cddl @@ -1,3 +1,5 @@ +set = [* a] + a = [ 2*30 2 : uint , ? 33 : bytes , 4444 : set @@ -6,6 +8,6 @@ a = [ 2*30 2 : uint b = [1,uint,(3,4)] -c = { x -, y ; hello +c = { a +, b ; hello } diff --git a/example/cddl-files/validator/negative/args-to-postlude.cddl b/example/cddl-files/validator/negative/args-to-postlude.cddl new file mode 100644 index 0000000..c7e725d --- /dev/null +++ b/example/cddl-files/validator/negative/args-to-postlude.cddl @@ -0,0 +1 @@ +x = uint<3> diff --git a/example/cddl-files/validator/negative/too-few-args.cddl b/example/cddl-files/validator/negative/too-few-args.cddl new file mode 100644 index 0000000..3e6abfe --- /dev/null +++ b/example/cddl-files/validator/negative/too-few-args.cddl @@ -0,0 +1,3 @@ +foo = [a, b] + +x = foo diff --git a/example/cddl-files/validator/negative/too-many-args.cddl b/example/cddl-files/validator/negative/too-many-args.cddl new file mode 100644 index 0000000..0c71547 --- /dev/null +++ b/example/cddl-files/validator/negative/too-many-args.cddl @@ -0,0 +1,3 @@ +foo = [a] + +x = foo diff --git a/example/cddl-files/validator/negative/unknown-name.cddl b/example/cddl-files/validator/negative/unknown-name.cddl new file mode 100644 index 0000000..9c863ac --- /dev/null +++ b/example/cddl-files/validator/negative/unknown-name.cddl @@ -0,0 +1 @@ +x = a 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..3985c94 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -30,6 +30,7 @@ module Codec.CBOR.Cuddle.CDDL.Resolve ( buildMonoCTree, fullResolveCDDL, MonoRef (..), + OrRef (..), NameResolutionFailure (..), ) where @@ -128,7 +129,7 @@ data OrRef a It a | -- | Reference to another node with possible generic arguments supplied Ref Name [CTree.Node OrRef] - deriving (Show, Functor) + deriving (Eq, Show, Functor) type RefCTree = CTreeRoot OrRef @@ -303,6 +304,8 @@ data NameResolutionFailure | ArgsToPostlude PTerm [CTree.Node OrRef] deriving (Show) +deriving instance Eq (OrRef (CTree OrRef)) => Eq NameResolutionFailure + postludeBinding :: Map.Map Name PTerm postludeBinding = Map.fromList @@ -342,8 +345,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) diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs index d0dc8cc..2f53405 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Examples.hs @@ -1,27 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test.Codec.CBOR.Cuddle.CDDL.Examples (spec) where +import Codec.CBOR.Cuddle.CDDL (Value (..), ValueVariant (..)) +import Codec.CBOR.Cuddle.CDDL.CTree (CTree (..), CTreeRoot') +import Codec.CBOR.Cuddle.CDDL.Postlude (PTerm (..)) import Codec.CBOR.Cuddle.CDDL.Prelude (prependPrelude) -import Codec.CBOR.Cuddle.CDDL.Resolve (fullResolveCDDL) +import Codec.CBOR.Cuddle.CDDL.Resolve ( + MonoRef, + NameResolutionFailure (..), + OrRef (..), + fullResolveCDDL, + ) import Codec.CBOR.Cuddle.Parser (pCDDL) -import Data.Either (isRight) +import Data.Functor.Identity (Identity) import Data.Text.IO qualified as T +import Test.HUnit (assertFailure) import Test.Hspec import Text.Megaparsec (parse) import Text.Megaparsec.Error (errorBundlePretty) -validateFile :: FilePath -> Spec -validateFile filePath = it ("Successfully validates " <> filePath) $ do +tryValidateFile :: FilePath -> IO (Either NameResolutionFailure (CTreeRoot' Identity MonoRef)) +tryValidateFile filePath = do contents <- T.readFile filePath cddl <- case parse pCDDL "" contents of Right x -> pure $ prependPrelude x Left x -> fail $ "Failed to parse the file:\n" <> errorBundlePretty x - fullResolveCDDL cddl `shouldSatisfy` isRight + pure $ fullResolveCDDL cddl + +validateExpectSuccess :: FilePath -> Spec +validateExpectSuccess filePath = it ("Successfully validates " <> filePath) $ do + res <- tryValidateFile filePath + case res of + Right _ -> pure () + Left err -> assertFailure $ "Failed to validate:\n" <> show err + +validateExpectFailure :: FilePath -> NameResolutionFailure -> Spec +validateExpectFailure filePath expectedFailure = it ("Fails to validate " <> filePath) $ do + res <- tryValidateFile filePath + case res of + Right _ -> assertFailure "Expected a failure, but succeeded instead" + Left e -> e `shouldBe` expectedFailure spec :: Spec spec = do - validateFile "example/cddl-files/byron.cddl" - validateFile "example/cddl-files/conway.cddl" - validateFile "example/cddl-files/shelley.cddl" - --- TODO this one does not seem to terminate --- validateFile "example/cddl-files/basic_assign.cddl" + describe "Validator" $ do + describe "Positive" $ do + validateExpectSuccess "example/cddl-files/byron.cddl" + validateExpectSuccess "example/cddl-files/conway.cddl" + validateExpectSuccess "example/cddl-files/shelley.cddl" + validateExpectSuccess "example/cddl-files/basic_assign.cddl" + validateExpectSuccess "example/cddl-files/issue80-min.cddl" + validateExpectSuccess "example/cddl-files/pretty.cddl" + describe "Negative" $ do + validateExpectFailure "example/cddl-files/validator/negative/unknown-name.cddl" $ + UnboundReference "a" + validateExpectFailure "example/cddl-files/validator/negative/too-few-args.cddl" $ + MismatchingArgs "foo" ["a", "b"] + validateExpectFailure "example/cddl-files/validator/negative/too-many-args.cddl" $ + MismatchingArgs "foo" ["a"] + validateExpectFailure "example/cddl-files/validator/negative/args-to-postlude.cddl" $ + ArgsToPostlude PTUInt [It (Literal (Value (VUInt 3) mempty))]