From 779885b684edc3e1e1b0d07ad6d0d5670beeb397 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 22 Nov 2024 12:02:46 +0100 Subject: [PATCH] Allow comments on group entries This addresses part of #36 - comments are still not supported _everywhere_, but they are allowed on group entries, which represent the area (other than top-level rules) where comments are the most useful. The same "comment" syntax is used as with top-level rules. Note that this does not (yet) work within groups - that will be addressed as part of #32. As yet, the parser still does not deal with comments, or attribute them to any entity. The tests are likewise oblivious to comments. But this does allow Huddle to define comments and have them reflected in the generated CDDL, which was the principal outcome. --- example/Monad.hs | 6 +- src/Codec/CBOR/Cuddle/CDDL.hs | 2 +- src/Codec/CBOR/Cuddle/CDDL/Resolve.hs | 19 +++-- src/Codec/CBOR/Cuddle/Huddle.hs | 63 ++++++++------ src/Codec/CBOR/Cuddle/Parser.hs | 6 +- test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs | 7 +- test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs | 99 ++++++++++++---------- 7 files changed, 116 insertions(+), 86 deletions(-) diff --git a/example/Monad.hs b/example/Monad.hs index 39f712a..77e6813 100644 --- a/example/Monad.hs +++ b/example/Monad.hs @@ -42,9 +42,9 @@ spec2 = _transaction <- "transaction" =:= mp - [ idx 0 ==> set txIn, - idx 1 ==> set txOut, - idx 2 ==> metadata + [ comment "Transaction inputs" $ idx 0 ==> set txIn, + comment "Transaction outputs" $ idx 1 ==> set txOut, + comment "Metadata" $ idx 2 ==> metadata ] metadata <- "metadata" =:= VBytes _value <- "value" =:= mp ["token" ==> VText, "quantity" ==> VUInt] diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs index e8b5826..60ea4f9 100644 --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -274,7 +274,7 @@ instance Hashable OccurrenceIndicator newtype Group = Group (NE.NonEmpty GrpChoice) deriving (Eq, Generic, Show, Semigroup) -type GrpChoice = [GroupEntry] +type GrpChoice = [WithComments GroupEntry] -- | -- A group entry can be given by a value type, which needs to be matched diff --git a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs index d88921e..0a5c217 100644 --- a/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs +++ b/src/Codec/CBOR/Cuddle/CDDL/Resolve.hs @@ -193,6 +193,9 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules It $ CTree.Postlude PTAny toCTreeT2 T2Any = It $ CTree.Postlude PTAny + toCTreeGroupEntryNC :: WithComments GroupEntry -> CTree.Node OrRef + toCTreeGroupEntryNC = toCTreeGroupEntry . stripComment + toCTreeGroupEntry :: GroupEntry -> CTree.Node OrRef toCTreeGroupEntry (GEType (Just occi) mmkey t0) = It $ @@ -223,18 +226,18 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules -- choice options toCTreeEnum :: Group -> CTree.Node OrRef toCTreeEnum (Group (a NE.:| [])) = - It . CTree.Enum . It . CTree.Group $ fmap toCTreeGroupEntry a + It . CTree.Enum . It . CTree.Group $ fmap toCTreeGroupEntryNC a toCTreeEnum (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Enum . It . CTree.Group . fmap toCTreeGroupEntryNC) xs -- Embed a group in another group, again floating out the choice options groupToGroup :: Group -> CTree.Node OrRef groupToGroup (Group (a NE.:| [])) = - It . CTree.Group $ fmap toCTreeGroupEntry a + It . CTree.Group $ fmap toCTreeGroupEntryNC a groupToGroup (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Group . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Group . fmap toCTreeGroupEntryNC) xs toKVPair :: Maybe MemberKey -> Type0 -> CTree.Node OrRef toKVPair Nothing t0 = toCTreeT0 t0 @@ -249,20 +252,20 @@ buildRefCTree rules = CTreeRoot $ fmap toCTreeRule rules -- Interpret a group as a map. Note that we float out the choice options toCTreeMap :: Group -> CTree.Node OrRef - toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntry a + toCTreeMap (Group (a NE.:| [])) = It . CTree.Map $ fmap toCTreeGroupEntryNC a toCTreeMap (Group xs) = It . CTree.Choice - $ fmap (It . CTree.Map . fmap toCTreeGroupEntry) xs + $ fmap (It . CTree.Map . fmap toCTreeGroupEntryNC) xs -- Interpret a group as an array. Note that we float out the choice -- options toCTreeArray :: Group -> CTree.Node OrRef toCTreeArray (Group (a NE.:| [])) = - It . CTree.Array $ fmap toCTreeGroupEntry a + It . CTree.Array $ fmap toCTreeGroupEntryNC a toCTreeArray (Group xs) = It . CTree.Choice $ - fmap (It . CTree.Array . fmap toCTreeGroupEntry) xs + fmap (It . CTree.Array . fmap toCTreeGroupEntryNC) xs toCTreeMemberKey :: MemberKey -> CTree.Node OrRef toCTreeMemberKey (MKValue v) = It $ CTree.Literal v diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 7322c87..e91ba1f 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -92,7 +92,7 @@ import Control.Monad (when) import Control.Monad.State (MonadState (get), execState, modify) import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) -import Data.Generics.Product (field, getField) +import Data.Generics.Product (HasField' (field'), field, getField) import Data.List.NonEmpty qualified as NE import Data.Map.Ordered.Strict (OMap) import Data.Map.Ordered.Strict qualified as OMap @@ -113,9 +113,9 @@ data Named a = Named } deriving (Functor, Generic) --- | Add a description to a rule, to be included as a comment. -comment :: T.Text -> Named a -> Named a -comment desc n = n & field @"description" .~ Just desc +-- | Add a description to a rule or group entry, to be included as a comment. +comment :: (HasField' "description" a (Maybe T.Text)) => T.Text -> a -> a +comment desc n = n & field' @"description" .~ Just desc instance Show (Named a) where show (Named n _ _) = T.unpack n @@ -201,7 +201,8 @@ asKey r = case toType0 r of data MapEntry = MapEntry { key :: Key, value :: Type0, - quantifier :: Occurs + quantifier :: Occurs, + description :: Maybe T.Text } deriving (Generic, Show) @@ -221,7 +222,8 @@ data ArrayEntry = ArrayEntry -- here because they can be illustrative in the generated CDDL. key :: Maybe Key, value :: Type0, - quantifier :: Occurs + quantifier :: Occurs, + description :: Maybe T.Text } deriving (Generic, Show) @@ -231,6 +233,7 @@ instance Num ArrayEntry where Nothing (NoChoice . T2Literal . Unranged $ LInt (fromIntegral i)) def + Nothing (+) = error "Cannot treat ArrayEntry as a number" (*) = error "Cannot treat ArrayEntry as a number" abs = error "Cannot treat ArrayEntry as a number" @@ -584,7 +587,8 @@ instance IsEntryLike ArrayEntry where { key = Just $ getField @"key" me, value = getField @"value" me, - quantifier = getField @"quantifier" me + quantifier = getField @"quantifier" me, + description = Nothing } instance IsEntryLike Type0 where @@ -596,7 +600,8 @@ k ==> gc = MapEntry { key = k, value = toType0 gc, - quantifier = def + quantifier = def, + description = Nothing } infixl 8 ==> @@ -620,7 +625,8 @@ instance IsGroupOrArrayEntry ArrayEntry where ArrayEntry { key = Nothing, value = toType0 x, - quantifier = def + quantifier = def, + description = Nothing } instance IsGroupOrArrayEntry Type0 where @@ -899,9 +905,9 @@ collectFrom topRs = mapM_ goT2 $ args g goT2 (T2Basic (Constrained _ _ refs)) = mapM_ goRule refs goT2 _ = pure () - goArrayEntry (ArrayEntry (Just k) t0 _) = goKey k >> goT0 t0 - goArrayEntry (ArrayEntry Nothing t0 _) = goT0 t0 - goMapEntry (MapEntry k t0 _) = goKey k >> goT0 t0 + goArrayEntry (ArrayEntry (Just k) t0 _ _) = goKey k >> goT0 t0 + goArrayEntry (ArrayEntry Nothing t0 _ _) = goT0 t0 + goMapEntry (MapEntry k t0 _ _) = goKey k >> goT0 t0 goKey (TypeKey k) = goT2 k goKey _ = pure () goGroup (Group g) = mapM_ goT0 g @@ -960,12 +966,15 @@ toCDDL' mkPseudoRoot hdl = mapChoiceToCDDL :: MapChoice -> C.GrpChoice mapChoiceToCDDL (MapChoice entries) = fmap mapEntryToCDDL entries - mapEntryToCDDL :: MapEntry -> C.GroupEntry - mapEntryToCDDL (MapEntry k v occ) = - C.GEType - (toOccurrenceIndicator occ) - (Just $ toMemberKey k) - (toCDDLType0 v) + mapEntryToCDDL :: MapEntry -> C.WithComments C.GroupEntry + mapEntryToCDDL (MapEntry k v occ cmnt) = + C.WithComments + ( C.GEType + (toOccurrenceIndicator occ) + (Just $ toMemberKey k) + (toCDDLType0 v) + ) + (fmap C.Comment cmnt) toOccurrenceIndicator :: Occurs -> Maybe C.OccurrenceIndicator toOccurrenceIndicator (Occurs Nothing Nothing) = Nothing @@ -1006,13 +1015,15 @@ toCDDL' mkPseudoRoot hdl = arrayChoiceToCDDL :: ArrayChoice -> C.GrpChoice arrayChoiceToCDDL (ArrayChoice entries) = fmap arrayEntryToCDDL entries - arrayEntryToCDDL :: ArrayEntry -> C.GroupEntry - arrayEntryToCDDL (ArrayEntry k v occ) = - C.GEType - (toOccurrenceIndicator occ) - (fmap toMemberKey k) - (toCDDLType0 v) - + arrayEntryToCDDL :: ArrayEntry -> C.WithComments C.GroupEntry + arrayEntryToCDDL (ArrayEntry k v occ cmnt) = + C.WithComments + ( C.GEType + (toOccurrenceIndicator occ) + (fmap toMemberKey k) + (toCDDLType0 v) + ) + (fmap C.Comment cmnt) toCDDLPostlude :: Value a -> C.Name toCDDLPostlude VBool = C.Name "bool" toCDDLPostlude VUInt = C.Name "uint" @@ -1042,7 +1053,7 @@ toCDDL' mkPseudoRoot hdl = . C.GEGroup Nothing . C.Group . (NE.:| []) - $ fmap (C.GEType Nothing Nothing . toCDDLType0) t0s + $ fmap (C.noComment . C.GEType Nothing Nothing . toCDDLType0) t0s ) (fmap C.Comment c) diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs index da9f4ec..2249f71 100644 --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -122,7 +122,11 @@ pGroup :: Parser Group pGroup = Group <$> NE.sepBy1 (space *> pGrpChoice <* space) (string "//") pGrpChoice :: Parser GrpChoice -pGrpChoice = many ((space *> pGrpEntry <* space) <* optional (char ',')) +pGrpChoice = + many + ( (space *> (noComment <$> pGrpEntry) <* space) + <* optional (char ',') + ) pGrpEntry :: Parser GroupEntry pGrpEntry = diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs index d0e3494..6dbb785 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -167,7 +167,7 @@ instance Arbitrary Group where shrink (Group gr) = Group <$> shrinkNE gr genGrpChoice :: Gen GrpChoice -genGrpChoice = listOf' genGroupEntry +genGrpChoice = listOf' (noComment <$> genGroupEntry) genGroupEntry :: Gen GroupEntry genGroupEntry = @@ -241,6 +241,11 @@ instance Arbitrary CtlOp where arbitrary = genCtlOp shrink = genericShrink +instance Arbitrary a => Arbitrary (WithComments a) where + arbitrary = noComment <$> arbitrary + shrink (WithComments x _) = noComment <$> shrink x + + -------------------------------------------------------------------------------- -- Utility -------------------------------------------------------------------------------- diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs index dc0faee..4c1fbd5 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -161,10 +161,11 @@ type2Spec = describe "type2" $ do `shouldParse` T2Map ( Group ( (NE.:| []) - [ GEType - Nothing - (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) - (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) + [ noComment $ + GEType + Nothing + (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) + (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) ] ) ) @@ -173,10 +174,11 @@ type2Spec = describe "type2" $ do `shouldParse` T2Map ( Group ( (NE.:| []) - [ GEType - (Just OIZeroOrMore) - (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) - (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) + [ noComment $ + GEType + (Just OIZeroOrMore) + (Just (MKType (Type1 (T2Name (Name "int") Nothing) Nothing))) + (Type0 ((NE.:| []) (Type1 (T2Name (Name "string") Nothing) Nothing))) ] ) ) @@ -185,27 +187,29 @@ type2Spec = describe "type2" $ do parse pType2 "" "[int // string]" `shouldParse` T2Array ( Group - ( [ GEType - Nothing - Nothing - ( Type0 - ( Type1 - (T2Name (Name "int") Nothing) - Nothing - NE.:| [] - ) - ) - ] - NE.:| [ [ GEType - Nothing + ( [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "int") Nothing) Nothing - ( Type0 - ( Type1 - (T2Name (Name "string") Nothing) - Nothing - NE.:| [] - ) - ) + NE.:| [] + ) + ) + ] + NE.:| [ [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "string") Nothing) + Nothing + NE.:| [] + ) + ) ] ] ) @@ -215,15 +219,17 @@ type2Spec = describe "type2" $ do parse pType2 "" "[0 // 1]" `shouldParse` T2Array ( Group - ( [ GEType - Nothing - Nothing - (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 0)) Nothing))) + ( [ noComment $ + GEType + Nothing + Nothing + (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 0)) Nothing))) ] - NE.:| [ [ GEType - Nothing - Nothing - (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 1)) Nothing))) + NE.:| [ [ noComment $ + GEType + Nothing + Nothing + (Type0 ((NE.:| []) (Type1 (T2Value (VUInt 1)) Nothing))) ] ] ) @@ -293,16 +299,17 @@ grpChoiceSpec :: SpecWith () grpChoiceSpec = describe "GroupChoice" $ do it "Should parse part of a group alternative" $ parse pGrpChoice "" "int // string" - `shouldParse` [ GEType - Nothing - Nothing - ( Type0 - ( Type1 - (T2Name (Name "int") Nothing) - Nothing - NE.:| [] - ) - ) + `shouldParse` [ noComment $ + GEType + Nothing + Nothing + ( Type0 + ( Type1 + (T2Name (Name "int") Nothing) + Nothing + NE.:| [] + ) + ) ] type1Spec :: Spec