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.

Author: nc6

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]

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

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

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)
 

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 =

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
 --------------------------------------------------------------------------------

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