cuddle-0.5.0.0: test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Codec.CBOR.Cuddle.CDDL.Parser where
import Codec.CBOR.Cuddle.CDDL
import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
import Codec.CBOR.Cuddle.Comments (Comment (..))
import Codec.CBOR.Cuddle.Parser
import Codec.CBOR.Cuddle.Parser.Lexer (Parser)
import Codec.CBOR.Cuddle.Pretty ()
import Data.Default.Class (Default (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Text qualified as T
import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff)
import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)
import Prettyprinter.Render.String (renderString)
import Prettyprinter.Render.Text (renderStrict)
import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.QuickCheck
import Text.Megaparsec (MonadParsec (..), errorBundlePretty, parse)
parserSpec :: Spec
parserSpec = do
valueSpec
occurSpec
nameSpec
type1Spec
type2Spec
grpEntrySpec
grpChoiceSpec
genericSpec
roundtripSpec
qcFoundSpec
roundtripSpec :: Spec
roundtripSpec = describe "Roundtripping should be id" $ do
it "Trip Name" $ trip pName
xit "Trip Value" $ trip pValue
xit "Trip Type0" $ trip pType0
xit "Trip GroupEntry" $ trip pGrpEntry
xit "Trip Rule" $ trip pRule
where
-- We show that, for a printed CDDL document p, print (parse p) == p. Note
-- that we do not show that parse (print p) is p for a given generated
-- 'CDDL' doc, since CDDL contains some statements that allow multiple
-- parsings.
trip :: forall a. (Eq a, ToExpr a, Show a, Pretty a, Arbitrary a) => Parser a -> Property
trip pa = property $ \(x :: a) -> within 1000000 $ do
let printed = printText x
case parse (pa <* eof) "" printed of
Left e ->
counterexample (show printed) $
counterexample (errorBundlePretty e) $
property False
Right parsed ->
counterexample
( renderString . layoutPretty defaultLayoutOptions . ansiWlBgEditExprCompact $
toExpr x `exprDiff` toExpr parsed
)
$ printed `shouldBe` printText parsed
printText :: Pretty a => a -> T.Text
printText = renderStrict . layoutPretty defaultLayoutOptions . pretty
valueSpec :: Spec
valueSpec = describe "pValue" $ do
it "Parses integer" $
parse pValue "" "123" `shouldParse` value (VUInt 123)
it "Parses negative integer" $
parse pValue "" "-123" `shouldParse` value (VNInt 123)
it "Parses float" $
parse pValue "" "3.1415" `shouldParse` value (VFloat64 3.1415)
it "Parses text" $
parse pValue "" "\"Hello World\"" `shouldParse` value (VText "Hello World")
occurSpec :: Spec
occurSpec = describe "pOccur" $ do
it "Parses OneOrMore" $
parse pOccur "" "+" `shouldParse` OIOneOrMore
it "Parses ZeroOrMore" $
parse pOccur "" "*" `shouldParse` OIZeroOrMore
it "Parses Optional" $
parse pOccur "" "?" `shouldParse` OIOptional
it "Parses Lower Bounded" $
parse pOccur "" "3*" `shouldParse` OIBounded (Just 3) Nothing
it "Parses Upper Bounded" $
parse pOccur "" "*9" `shouldParse` OIBounded Nothing (Just 9)
it "Parses bounded on both sides" $
parse pOccur "" "3*9" `shouldParse` OIBounded (Just 3) (Just 9)
-- it "result of parsing satisfies what it should" $
-- parse myParser "" "aaaa" `parseSatisfies` ((== 4) . length)
nameSpec :: SpecWith ()
nameSpec = describe "pName" $ do
it "Parses a boring name" $
parse pName "" "coin" `shouldParse` Name "coin" mempty
it "Allows . in the middle" $
parse pName "" "coin.me" `shouldParse` Name "coin.me" mempty
it "Allows $ as the last character" $
parse pName "" "coin.me$" `shouldParse` Name "coin.me$" mempty
it "Doesn't allow . as a last character" $
parse pName "" "coin." `shouldFailWith` err 5 ueof
genericSpec :: Spec
genericSpec = describe "generics" $ do
it "Parses a simple value generic" $
parse pRule "" "a = b<0>"
`shouldParse` Rule
(Name "a" mempty)
Nothing
AssignEq
( TOGType
( Type0
( Type1
( T2Name
(Name "b" mempty)
( Just
( GenericArg
( Type1
(T2Value (value $ VUInt 0))
Nothing
mempty
:| []
)
)
)
)
Nothing
mempty
:| []
)
)
)
mempty
it "Parses a range as a generic" $
parse pRule "" "a = b<0 ... 1>"
`shouldParse` Rule
(Name "a" mempty)
Nothing
AssignEq
( TOGType
( Type0
( Type1
( T2Name
(Name "b" mempty)
( Just
( GenericArg
( Type1
(T2Value (value $ VUInt 0))
(Just (RangeOp ClOpen, T2Value (value $ VUInt 1)))
mempty
:| []
)
)
)
)
Nothing
mempty
:| []
)
)
)
mempty
type2Spec :: SpecWith ()
type2Spec = describe "type2" $ do
describe "Value" $ do
it "Parses a value" $
parse pType2 "" "123" `shouldParse` T2Value (value $ VUInt 123)
describe "Map" $ do
it "Parses a basic group" $
parse pType2 "" "{ int => string }"
`shouldParse` T2Map
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
( Just
( MKType
( Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
)
)
)
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
:| []
}
)
it "Parses a table" $
parse pType2 "" "{ * int => string }"
`shouldParse` T2Map
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Just OIZeroOrMore
, geComment = Comment mempty
, geVariant =
GEType
( Just
( MKType
( Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
)
)
)
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
:| []
}
)
it "Commas are optional" $
parse pType2 "" "{ 1 => string, 2 => int 3 => bytes}"
`shouldParse` T2Map
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
( Just
(MKType (Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty}))
)
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
, GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
( Just
(MKType (Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty}))
)
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
, GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
( Just
(MKType (Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty}))
)
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "bytes", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
:| []
}
)
describe "Array" $ do
it "Parses an array with an alternative" $
parse pType2 "" "[int // string]"
`shouldParse` T2Array
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
:| [ GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "string", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
]
}
)
it "Parses an array with a value alternative" $
parse pType2 "" "[0 // 1]"
`shouldParse` T2Array
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| []
}
)
}
]
, gcComment = Comment mempty
}
:| [ GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| []
}
)
}
]
, gcComment = Comment mempty
}
]
}
)
it "Trailing commas permitted" $
parse pType2 "" "[ 1 , ]"
`shouldParse` T2Array
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1 {t1Main = T2Value (value $ VUInt 1), t1TyOp = Nothing, t1Comment = Comment mempty} :| []
}
)
}
]
, gcComment = Comment mempty
}
:| []
}
)
it "Values don't need a space" $
parse pType2 "" "[ 2soon ]"
`shouldParse` T2Array
( Group
{ unGroup =
GrpChoice
{ gcGroupEntries =
[ GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1 {t1Main = T2Value (value $ VUInt 2), t1TyOp = Nothing, t1Comment = Comment mempty} :| []
}
)
}
, GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "soon", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
]
, gcComment = Comment mempty
}
:| []
}
)
grpEntrySpec :: SpecWith ()
grpEntrySpec = describe "GroupEntry" $ do
it "Prefers GEType over GERef for names" $
parse pGrpEntry "" "int"
`shouldParse` GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
it "Should parse part of a group alternative" $
parse pGrpEntry "" "int // notConsideredHere"
`shouldParse` GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main = T2Name (Name {name = "int", nameComment = Comment mempty}) Nothing
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
it "Should parse a generic" $
parse pGrpEntry "" "a<0 ... #6(0)>"
`shouldParse` GroupEntry
{ geOccurrenceIndicator = Nothing
, geComment = Comment mempty
, geVariant =
GEType
Nothing
( Type0
{ t0Type1 =
Type1
{ t1Main =
T2Name
(Name {name = "a", nameComment = Comment mempty})
( Just
( GenericArg
( Type1
{ t1Main = T2Value (value $ VUInt 0)
, t1TyOp =
Just
( RangeOp ClOpen
, T2Tag
Nothing
( Type0
{ t0Type1 =
Type1 {t1Main = T2Value (value $ VUInt 0), t1TyOp = Nothing, t1Comment = Comment mempty} :| []
}
)
)
, t1Comment = Comment mempty
}
:| []
)
)
)
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| []
}
)
}
it "Parses a GEType with an Occurrence Indicator" $
parse pGrpEntry "" "0* a"
`shouldParse` GroupEntry
(Just (OIBounded (Just 0) Nothing))
def
( GEType
Nothing
(Type0 (Type1 (T2Name (Name "a" mempty) Nothing) Nothing mempty :| []))
)
grpChoiceSpec :: SpecWith ()
grpChoiceSpec = describe "GroupChoice" $ do
it "Should parse part of a group alternative" $
parse pGrpChoice "" "int // string"
`shouldParse` GrpChoice
[ GroupEntry Nothing mempty $
GEType
Nothing
( Type0
( Type1
(T2Name (Name "int" mempty) Nothing)
Nothing
mempty
:| []
)
)
]
mempty
type1Spec :: Spec
type1Spec = describe "Type1" $ do
describe "CtlOp" $ do
it "Should parse a basic control operator" $
parse pType1 "" "uint .size 3"
`shouldParse` Type1
(T2Name (Name "uint" mempty) Nothing)
(Just (CtrlOp CtlOp.Size, T2Value (value $ VUInt 3)))
mempty
describe "RangeOp" $ do
it "Should parse a closed range operator" $
parse pType1 "" "0 .. 3"
`shouldParse` Type1
(T2Value (value $ VUInt 0))
(Just (RangeOp Closed, T2Value (value $ VUInt 3)))
mempty
it "Should parse a clopen range operator" $
parse pType1 "" "0 ... 3"
`shouldParse` Type1
(T2Value (value $ VUInt 0))
(Just (RangeOp ClOpen, T2Value (value $ VUInt 3)))
mempty
parseExample :: (Show a, Eq a) => T.Text -> Parser a -> a -> Spec
parseExample str parser val =
it (T.unpack str) $
parse (parser <* eof) "" str `shouldParse` val
-- | A bunch of cases found by hedgehog/QC
qcFoundSpec :: Spec
qcFoundSpec =
describe "Generated test cases" $ do
parseExample "{} .ge & i<{}, 3>" pType1 $
Type1
{ t1Main =
T2Map
(Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []})
, t1TyOp =
Just
( CtrlOp CtlOp.Ge
, T2EnumRef
(Name {name = "i", nameComment = Comment mempty})
( Just
( GenericArg
( Type1
{ t1Main =
T2Map
(Group {unGroup = GrpChoice {gcGroupEntries = [], gcComment = Comment mempty} :| []})
, t1TyOp = Nothing
, t1Comment = Comment mempty
}
:| [Type1 {t1Main = T2Value (value $ VUInt 3), t1TyOp = Nothing, t1Comment = Comment mempty}]
)
)
)
)
, t1Comment = Comment mempty
}
parseExample "S = 0* ()" pRule $
Rule
(Name "S" mempty)
Nothing
AssignEq
( TOGGroup
( GroupEntry (Just (OIBounded (Just 0) Nothing)) mempty $
GEGroup (Group (GrpChoice mempty mempty :| []))
)
)
mempty
parseExample
"W = \"6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95\" : \"u\""
pRule
( Rule
(Name "W" mempty)
Nothing
AssignEq
( TOGGroup
( GroupEntry
Nothing
mempty
$ GEType
(Just (MKValue (value $ VText "6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95")))
(Type0 (Type1 (T2Value (value $ VText "u")) Nothing mempty :| []))
)
)
mempty
)