Merge pull request #44 from input-output-hk/nc/group-keys

Support keys in group entries

Author: nc6

CHANGELOG.md

@@ -38,3 +38,13 @@
   additional hints are required to type literal numerics correctly. Typically 
   this is most easily fixed by adding a call `int` for any numeric literals in 
   ranges. An example is shown in `example/Conway.hs` 
+
+## 0.3.6.0 -- 2024-12-02
+* Support having keys in group entries. This is needed when using a group to
+  define a map, or when wishing to include keys in for-use-in-array groups for
+  documentation purposes. This may introduce problems with existing specifications
+  where some type hints (using 'a') are needed to properly type entries in groups,
+  where previously they were unambiguous.
+
+  Note that it is not yet supported to use a group inside a map, where the 
+  issue of merging keys arises.

cuddle.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.4
 name:            cuddle
-version:         0.3.5.0
+version:         0.3.6.0
 synopsis:        CDDL Generator and test utilities
 
 -- description:

example/Conway.hs

@@ -159,30 +159,30 @@ parameter_change_action =
   "parameter_change_action"
     =:~ grp
       [ 0,
-        gov_action_id / VNil,
+        a (gov_action_id / VNil),
         a protocol_param_update,
-        policy_hash / VNil
+        a (policy_hash / VNil)
       ]
 
 hard_fork_initiation_action :: Named Group
 hard_fork_initiation_action =
   "hard_fork_initiation_action"
-    =:~ grp [1, gov_action_id / VNil, a (arr [a protocol_version])]
+    =:~ grp [1, a (gov_action_id / VNil), a (arr [a protocol_version])]
 
 treasury_withdrawals_action :: Named Group
 treasury_withdrawals_action =
   "treasury_withdrawals_action"
-    =:~ grp [2, a (arr [asKey reward_account ==> coin / VInt]), policy_hash / VNil]
+    =:~ grp [2, a (arr [asKey reward_account ==> coin / VInt]), a (policy_hash / VNil)]
 
 no_confidence :: Named Group
-no_confidence = "no_confidence" =:~ grp [3, gov_action_id / VNil]
+no_confidence = "no_confidence" =:~ grp [3, a (gov_action_id / VNil)]
 
 update_committee :: Named Group
 update_committee =
   "update_committee"
     =:~ grp
       [ 4,
-        gov_action_id / VNil,
+        a (gov_action_id / VNil),
         a (set committee_cold_credential),
         a (arr [asKey committee_cold_credential ==> epoch]),
         a unit_interval
@@ -191,7 +191,7 @@ update_committee =
 new_constitution :: Named Group
 new_constitution =
   "new_constitution"
-    =:~ grp [5, gov_action_id / VNil, a constitution]
+    =:~ grp [5, a (gov_action_id / VNil), a constitution]
 
 constitution :: Rule
 constitution =
@@ -356,16 +356,16 @@ auth_committee_hot_cert =
 resign_committee_cold_cert :: Named Group
 resign_committee_cold_cert =
   "resign_committee_cold_cert"
-    =:~ grp [15, a committee_cold_credential, anchor / VNil]
+    =:~ grp [15, a committee_cold_credential, a (anchor / VNil)]
 
 reg_drep_cert :: Named Group
-reg_drep_cert = "reg_drep_cert" =:~ grp [16, a drep_credential, a coin, anchor / VNil]
+reg_drep_cert = "reg_drep_cert" =:~ grp [16, a drep_credential, a coin, a (anchor / VNil)]
 
 unreg_drep_cert :: Named Group
 unreg_drep_cert = "unreg_drep_cert" =:~ grp [17, a drep_credential, a coin]
 
 update_drep_cert :: Named Group
-update_drep_cert = "update_drep_cert" =:~ grp [18, a drep_credential, anchor / VNil]
+update_drep_cert = "update_drep_cert" =:~ grp [18, a drep_credential, a (anchor / VNil)]
 
 delta_coin :: Rule
 delta_coin = "delta_coin" =:= VUInt
@@ -429,17 +429,17 @@ single_host_addr =
   "single_host_addr"
     =:~ grp
       [ 0,
-        port / VNil,
-        ipv4 / VNil,
-        ipv6 / VNil
+        a (port / VNil),
+        a (ipv4 / VNil),
+        a (ipv6 / VNil)
       ]
 
 single_host_name :: Named Group
 single_host_name =
   "single_host_name"
     =:~ grp
       [ 1,
-        port / VNil,
+        a (port / VNil),
         a dns_name -- An A or AAAA DNS record
       ]
 

noindex.cache

@@ -254,11 +254,11 @@ instance IsList ArrayChoice where
 
 type Array = Choice ArrayChoice
 
-newtype Group = Group {unGroup :: [Type0]}
+newtype Group = Group {unGroup :: [ArrayEntry]}
   deriving (Show, Monoid, Semigroup)
 
 instance IsList Group where
-  type Item Group = Type0
+  type Item Group = ArrayEntry
 
   fromList = Group
   toList (Group l) = l
@@ -991,7 +991,7 @@ collectFrom topRs =
     goMapEntry (MapEntry k t0 _ _) = goKey k >> goT0 t0
     goKey (TypeKey k) = goT2 k
     goKey _ = pure ()
-    goGroup (Group g) = mapM_ goT0 g
+    goGroup (Group g) = mapM_ goArrayEntry g
     goRanged (Unranged _) = pure ()
     goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub 
     goRangeBound (RangeBoundLiteral _) = pure ()
@@ -1148,7 +1148,7 @@ toCDDL' mkPseudoRoot hdl =
             . C.GEGroup Nothing
             . C.Group
             . (NE.:| [])
-            $ fmap (C.noComment . C.GEType Nothing Nothing . toCDDLType0) t0s
+            $ fmap arrayEntryToCDDL t0s
         )
         (fmap C.Comment c)
 

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -20,6 +20,7 @@ huddleSpec = describe "huddle" $ do
   basicAssign
   arraySpec
   mapSpec
+  grpSpec
   nestedSpec
   genericSpec
   constraintSpec
@@ -85,6 +86,21 @@ mapSpec = describe "Maps" $ do
     toSortedCDDL ["mir" =:= arr [a (int 0 / int 1), a $ mp [0 <+ "test" ==> VUInt]]]
       `shouldMatchParseCDDL` "mir = [ 0 / 1, { * test : uint }]"
 
+grpSpec :: Spec 
+grpSpec = describe "Groups" $ do 
+  it "Can handle a choice in a group entry" $ 
+    let g1 = "g1" =:~ grp [a (VUInt / VBytes), a VUInt]
+    in toSortedCDDL (collectFrom ["a1" =:= arr [a g1]])
+      `shouldMatchParseCDDL` "a1 = [g1]\n g1 = ( uint / bytes, uint )"
+  it "Can handle keys in a group entry" $ 
+    let g1 = "g1" =:~ grp ["bytes"==> VBytes]
+    in toSortedCDDL (collectFrom ["a1" =:= arr [a g1]])
+      `shouldMatchParseCDDL` "a1 = [g1]\n g1 = (bytes : bytes)"
+  -- it "Can handle a group in a map" $ 
+  --   let g1 = "g1" =:~ grp ["bytes"==> VBytes]
+  --   in toSortedCDDL (collectFrom ["a1" =:= mp [g1]])
+  --     `shouldMatchParseCDDL` "a1 = [g1]\n g1 = (bytes : bytes)"
+ 
 nestedSpec :: Spec
 nestedSpec =
   describe "Nesting" $