Skip to content

Commit d146220

Browse files
SoupstrawSoupstraw
committed
Removed Eq instance for Rule
1 parent 2a82948 commit d146220

File tree

5 files changed

+154
-80
lines changed

5 files changed

+154
-80
lines changed

‎src/Codec/CBOR/Cuddle/CDDL.hs‎

Lines changed: 31 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DerivingStrategies #-}
33
{-# LANGUAGE PatternSynonyms #-}
4+
{-# LANGUAGE RecordWildCards #-}
45

56
-- | This module defined the data structure of CDDL as specified in
67
-- https://datatracker.ietf.org/doc/rfc8610/
@@ -55,7 +56,8 @@ import Data.List.NonEmpty (NonEmpty (..))
5556
import Data.List.NonEmpty qualified as NE
5657
import Data.String (IsString (..))
5758
import Data.Text qualified as T
58-
import Data.TreeDiff (ToExpr)
59+
import Data.TreeDiff (ToExpr (..))
60+
import Data.TreeDiff.Expr qualified as Expr
5961
import Data.Word (Word64, Word8)
6062
import GHC.Generics (Generic)
6163
import Optics.Core ((%), (.~))
@@ -114,7 +116,8 @@ newtype CBORGenerator
114116
-- 3. All the other top level comments and definitions
115117
-- This ensures that `CDDL` is correct by construction.
116118
data CDDL = CDDL [Comment] Rule [TopLevel]
117-
deriving (Generic)
119+
deriving (Generic, Show)
120+
deriving anyclass (ToExpr)
118121

119122
-- | Sort the CDDL Rules on the basis of their names
120123
-- Top level comments will be removed!
@@ -148,7 +151,8 @@ instance Semigroup CDDL where
148151
data TopLevel
149152
= TopLevelRule Rule
150153
| TopLevelComment Comment
151-
deriving (Generic)
154+
deriving (Generic, Show)
155+
deriving anyclass (ToExpr)
152156

153157
-- |
154158
-- A name can consist of any of the characters from the set {"A" to
@@ -272,6 +276,30 @@ data Rule = Rule
272276
instance HasComment Rule where
273277
commentL = lens ruleComment (\x y -> x {ruleComment = y})
274278

279+
instance ToExpr Rule where
280+
toExpr r@(Rule _ _ _ _ _ _) =
281+
let Rule {..} = r
282+
in Expr.App
283+
"Rule"
284+
[ toExpr ruleName
285+
, toExpr ruleGenParam
286+
, toExpr ruleAssign
287+
, toExpr ruleTerm
288+
, toExpr ruleComment
289+
, toExpr $ const "<Custom generator>" <$> ruleGenerator
290+
]
291+
292+
instance Show Rule where
293+
show r@(Rule _ _ _ _ _ _) =
294+
let Rule {..} = r
295+
in unwords
296+
[ show ruleName
297+
, show ruleGenParam
298+
, show ruleAssign
299+
, show ruleTerm
300+
, show ruleComment
301+
]
302+
275303
compareRuleName :: Rule -> Rule -> Ordering
276304
compareRuleName = compare `on` ruleName
277305

‎test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -90,7 +90,10 @@ instance Arbitrary Rule where
9090
<*> arbitrary
9191
<*> arbitrary
9292
<*> pure Nothing
93-
shrink = genericShrink
93+
shrink (Rule a b c d e _) =
94+
[ Rule a' b' c' d' e' Nothing
95+
| (a', b', c', d', e') <- shrink (a, b, c, d, e)
96+
]
9497

9598
instance Arbitrary RangeBound where
9699
arbitrary = Gen.elements [ClOpen, Closed]

‎test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs‎

Lines changed: 77 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -11,11 +11,12 @@ import Codec.CBOR.Cuddle.Pretty ()
1111
import Data.Default.Class (Default (..))
1212
import Data.List.NonEmpty (NonEmpty (..))
1313
import Data.Text qualified as T
14-
import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff)
14+
import Data.TreeDiff (ToExpr (..), ansiWlBgEditExprCompact, exprDiff, prettyExpr)
1515
import Prettyprinter (Pretty, defaultLayoutOptions, layoutPretty, pretty)
1616
import Prettyprinter.Render.String (renderString)
1717
import Prettyprinter.Render.Text (renderStrict)
1818
import Test.Codec.CBOR.Cuddle.CDDL.Gen qualified as Gen ()
19+
import Test.Codec.CBOR.Cuddle.Huddle (ruleMatches, shouldMatchParseRule, shouldMatchParseWith)
1920
import Test.Hspec
2021
import Test.Hspec.Megaparsec
2122
import Test.QuickCheck
@@ -40,15 +41,14 @@ roundtripSpec = describe "Roundtripping should be id" $ do
4041
xit "Trip Value" $ trip pValue
4142
xit "Trip Type0" $ trip pType0
4243
xit "Trip GroupEntry" $ trip pGrpEntry
43-
xit "Trip Rule" $ trip pRule
4444
where
4545
-- We show that, for a printed CDDL document p, print (parse p) == p. Note
4646
-- that we do not show that parse (print p) is p for a given generated
4747
-- 'CDDL' doc, since CDDL contains some statements that allow multiple
4848
-- parsings.
49-
trip :: forall a. (Eq a, ToExpr a, Show a, Pretty a, Arbitrary a) => Parser a -> Property
50-
trip pa = property $ \(x :: a) -> within 1000000 $ do
51-
let printed = printText x
49+
trip :: forall a. (ToExpr a, Arbitrary a, Pretty a) => Parser a -> Property
50+
trip pa = forAllShow arbitrary (show . prettyExpr . toExpr) $ \(x :: a) -> within 1000000 $ do
51+
let printed = T.pack . show . prettyExpr $ toExpr x
5252
case parse (pa <* eof) "" printed of
5353
Left e ->
5454
counterexample (show printed) $
@@ -106,63 +106,65 @@ nameSpec = describe "pName" $ do
106106
genericSpec :: Spec
107107
genericSpec = describe "generics" $ do
108108
it "Parses a simple value generic" $
109-
parse pRule "" "a = b<0>"
110-
`shouldParse` Rule
111-
(Name "a" mempty)
112-
Nothing
113-
AssignEq
114-
( TOGType
115-
( Type0
116-
( Type1
117-
( T2Name
118-
(Name "b" mempty)
119-
( Just
120-
( GenericArg
121-
( Type1
122-
(T2Value (value $ VUInt 0))
123-
Nothing
124-
mempty
125-
:| []
126-
)
127-
)
128-
)
129-
)
130-
Nothing
131-
mempty
132-
:| []
133-
)
134-
)
135-
)
136-
mempty
109+
Rule
110+
(Name "a" mempty)
111+
Nothing
112+
AssignEq
113+
( TOGType
114+
( Type0
115+
( Type1
116+
( T2Name
117+
(Name "b" mempty)
118+
( Just
119+
( GenericArg
120+
( Type1
121+
(T2Value (value $ VUInt 0))
122+
Nothing
123+
mempty
124+
:| []
125+
)
126+
)
127+
)
128+
)
129+
Nothing
130+
mempty
131+
:| []
132+
)
133+
)
134+
)
135+
mempty
136+
Nothing
137+
`shouldMatchParseRule` "a = b<0>"
137138
it "Parses a range as a generic" $
138-
parse pRule "" "a = b<0 ... 1>"
139-
`shouldParse` Rule
140-
(Name "a" mempty)
141-
Nothing
142-
AssignEq
143-
( TOGType
144-
( Type0
145-
( Type1
146-
( T2Name
147-
(Name "b" mempty)
148-
( Just
149-
( GenericArg
150-
( Type1
151-
(T2Value (value $ VUInt 0))
152-
(Just (RangeOp ClOpen, T2Value (value $ VUInt 1)))
153-
mempty
154-
:| []
155-
)
156-
)
157-
)
158-
)
159-
Nothing
160-
mempty
161-
:| []
162-
)
163-
)
164-
)
165-
mempty
139+
Rule
140+
(Name "a" mempty)
141+
Nothing
142+
AssignEq
143+
( TOGType
144+
( Type0
145+
( Type1
146+
( T2Name
147+
(Name "b" mempty)
148+
( Just
149+
( GenericArg
150+
( Type1
151+
(T2Value (value $ VUInt 0))
152+
(Just (RangeOp ClOpen, T2Value (value $ VUInt 1)))
153+
mempty
154+
:| []
155+
)
156+
)
157+
)
158+
)
159+
Nothing
160+
mempty
161+
:| []
162+
)
163+
)
164+
)
165+
mempty
166+
Nothing
167+
`shouldMatchParseRule` "a = b<0 ... 1>"
166168

167169
type2Spec :: SpecWith ()
168170
type2Spec = describe "type2" $ do
@@ -616,10 +618,16 @@ type1Spec = describe "Type1" $ do
616618
(Just (RangeOp ClOpen, T2Value (value $ VUInt 3)))
617619
mempty
618620

619-
parseExample :: (Show a, Eq a) => T.Text -> Parser a -> a -> Spec
620-
parseExample str parser val =
621+
parseExampleWith :: ToExpr a => (a -> a -> Bool) -> T.Text -> Parser a -> a -> Spec
622+
parseExampleWith matches str parser val =
621623
it (T.unpack str) $
622-
parse (parser <* eof) "" str `shouldParse` val
624+
shouldMatchParseWith matches val parser $
625+
T.unpack str
626+
627+
-- parse (parser <* eof) "" str `shouldParse` val
628+
629+
parseExample :: (Show a, ToExpr a, Eq a) => T.Text -> Parser a -> a -> Spec
630+
parseExample = parseExampleWith (==)
623631

624632
-- | A bunch of cases found by hedgehog/QC
625633
qcFoundSpec :: Spec
@@ -651,7 +659,7 @@ qcFoundSpec =
651659
)
652660
, t1Comment = Comment mempty
653661
}
654-
parseExample "S = 0* ()" pRule $
662+
parseExampleWith ruleMatches "S = 0* ()" pRule $
655663
Rule
656664
(Name "S" mempty)
657665
Nothing
@@ -662,7 +670,9 @@ qcFoundSpec =
662670
)
663671
)
664672
mempty
665-
parseExample
673+
Nothing
674+
parseExampleWith
675+
ruleMatches
666676
"W = \"6 ybe2ddl8frq0vqa8zgrk07khrljq7p plrufpd1sff3p95\" : \"u\""
667677
pRule
668678
( Rule
@@ -679,4 +689,5 @@ qcFoundSpec =
679689
)
680690
)
681691
mempty
692+
Nothing
682693
)

‎test/Test/Codec/CBOR/Cuddle/CDDL/Pretty.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -121,6 +121,7 @@ drep =
121121
)
122122
)
123123
mempty
124+
Nothing
124125

125126
unitSpec :: Spec
126127
unitSpec = describe "HUnit" $ do
@@ -181,6 +182,7 @@ unitSpec = describe "HUnit" $ do
181182
AssignEq
182183
(TOGType (Type0 (Type1 (T2Name (Name "b" mempty) mempty) Nothing mempty :| [])))
183184
mempty
185+
Nothing
184186
`prettyPrintsTo` "a = b"
185187
xit "drep" $
186188
drep

‎test/Test/Codec/CBOR/Cuddle/Huddle.hs‎

Lines changed: 40 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -5,13 +5,13 @@
55

66
module Test.Codec.CBOR.Cuddle.Huddle where
77

8-
import Codec.CBOR.Cuddle.CDDL (CDDL, sortCDDL)
9-
import Codec.CBOR.Cuddle.Huddle
10-
import Codec.CBOR.Cuddle.Parser
8+
import Codec.CBOR.Cuddle.CDDL (CDDL (..), Rule (..), TopLevel (..), sortCDDL)
9+
import Codec.CBOR.Cuddle.Huddle hiding (Rule)
10+
import Codec.CBOR.Cuddle.Parser (pCDDL, pRule)
1111
import Data.Text qualified as T
12+
import Data.TreeDiff (ToExpr, ediff, prettyEditExpr)
1213
import Test.Codec.CBOR.Cuddle.CDDL.Pretty qualified as Pretty
1314
import Test.Hspec
14-
import Test.Hspec.Megaparsec
1515
import Text.Megaparsec
1616
import Prelude hiding ((/))
1717

@@ -146,19 +146,49 @@ constraintSpec =
146146
-- Helper functions
147147
--------------------------------------------------------------------------------
148148

149-
shouldMatchParse ::
150-
(Text.Megaparsec.ShowErrorComponent e, Show a, Eq a) =>
149+
shouldMatchParseWith ::
150+
(Text.Megaparsec.ShowErrorComponent e, Show e, ToExpr a) =>
151+
(a -> a -> Bool) ->
151152
a ->
152153
Text.Megaparsec.Parsec e T.Text a ->
153154
String ->
154155
Expectation
155-
shouldMatchParse x parseFun input = parse parseFun "" (T.pack input) `shouldParse` x
156+
shouldMatchParseWith matches expected parseFun input = do
157+
case parse parseFun "" $ T.pack input of
158+
Right parsed
159+
| parsed `matches` expected -> pure ()
160+
| otherwise ->
161+
expectationFailure $
162+
unlines
163+
[ "Mismatch between parsed and expected"
164+
, show . prettyEditExpr $ expected `ediff` parsed
165+
]
166+
Left e -> expectationFailure $ show e
156167

157-
shouldMatchParseCDDL ::
158-
CDDL ->
168+
shouldMatchParse ::
169+
(ShowErrorComponent e, Show e, ToExpr a, Eq a) =>
170+
a ->
171+
Text.Megaparsec.Parsec e T.Text a ->
159172
String ->
160173
Expectation
161-
shouldMatchParseCDDL x = shouldMatchParse x pCDDL
174+
shouldMatchParse = shouldMatchParseWith (==)
175+
176+
shouldMatchParseCDDL :: CDDL -> String -> Expectation
177+
shouldMatchParseCDDL x = shouldMatchParseWith cddlMatches x pCDDL
178+
179+
shouldMatchParseRule :: Rule -> String -> Expectation
180+
shouldMatchParseRule x = shouldMatchParseWith ruleMatches x pRule
181+
182+
cddlMatches :: CDDL -> CDDL -> Bool
183+
cddlMatches (CDDL c r t) (CDDL c' r' t') = c == c' && ruleMatches r r' && and (zipWith topLevelMatches t t')
184+
185+
ruleMatches :: Codec.CBOR.Cuddle.CDDL.Rule -> Codec.CBOR.Cuddle.CDDL.Rule -> Bool
186+
ruleMatches (Rule n b c d e _) (Rule n' b' c' d' e' _) = n == n' && b == b' && c == c' && d == d' && e == e'
187+
188+
topLevelMatches :: TopLevel -> TopLevel -> Bool
189+
topLevelMatches (TopLevelComment c) (TopLevelComment c') = c == c'
190+
topLevelMatches (TopLevelRule r) (TopLevelRule r') = ruleMatches r r'
191+
topLevelMatches _ _ = False
162192

163193
toSortedCDDL :: Huddle -> CDDL
164194
toSortedCDDL = sortCDDL . toCDDLNoRoot

0 commit comments

Comments
 (0)