Merge pull request #41 from input-output-hk/nc/comments

Allow comments on group entries

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