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