Add support for Generics to Huddle.

example/Conway.hs

@@ -572,19 +572,18 @@ big_VUInt = "big_VUInt" =:= tag 2 bounded_bytes
 big_nint :: Rule
 big_nint = "big_nint" =:= tag 3 bounded_bytes
 
-constr :: (IsType0 x, Show x) => x -> Rule
-constr x =
-  "constr_"
-    <> T.pack (show x)
-      =:= tag 1 (arr [0 <+ a x])
-      // tag 2 (arr [0 <+ a x])
-      // tag 3 (arr [0 <+ a x])
-      // tag 4 (arr [0 <+ a x])
-      // tag 5 (arr [0 <+ a x])
-      // tag 6 (arr [0 <+ a x])
-      // tag 7 (arr [0 <+ a x])
-      -- similarly for tag range: 6.1280 .. 6.1400 inclusive
-      // tag 2 (arr [a VUInt, a $ arr [0 <+ a x]])
+constr :: (IsType0 x) => x -> GRuleCall
+constr = binding $ \x ->
+  "constr"
+    =:= tag 1 (arr [0 <+ a x])
+    // tag 2 (arr [0 <+ a x])
+    // tag 3 (arr [0 <+ a x])
+    // tag 4 (arr [0 <+ a x])
+    // tag 5 (arr [0 <+ a x])
+    // tag 6 (arr [0 <+ a x])
+    // tag 7 (arr [0 <+ a x])
+    -- similarly for tag range: 6.1280 .. 6.1400 inclusive
+    // tag 2 (arr [a VUInt, a $ arr [0 <+ a x]])
 
 redeemers :: Rule
 redeemers =
@@ -863,14 +862,14 @@ signature = "signature" =:= VBytes `sized` (64 :: Int)
 -- second era after Conway. We recommend all the tooling to account for this future breaking
 -- change sooner rather than later, in order to provide a smooth transition for their users.
 
-set :: (IsType0 t, Show t) => t -> Rule
-set x = "set_" <> T.pack (show x) =:= arr [0 <+ a x]
+set :: (IsType0 t0) => t0 -> GRuleCall
+set = binding $ \x -> "set" =:= arr [0 <+ a x]
 
-nonempty_set :: (IsType0 t, Show t) => t -> Rule
-nonempty_set x = "set_" <> T.pack (show x) =:= arr [1 <+ a x]
+nonempty_set :: (IsType0 t0) => t0 -> GRuleCall
+nonempty_set = binding $ \x -> "nonempty_set" =:= set x
 
 -- TODO Should we give this a name?
-nonempty_oset :: (IsType0 t, Show t) => t -> Rule
+nonempty_oset :: (IsType0 t0) => t0 -> GRuleCall
 nonempty_oset = nonempty_set
 
 positive_int :: Rule

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -72,6 +72,11 @@ module Codec.CBOR.Cuddle.Huddle
     -- * Tagging
     tag,
 
+    -- * Generics
+    GRuleCall,
+    binding,
+    binding2,
+
     -- * Conversion to CDDL
     collectFrom,
     toCDDL,
@@ -81,7 +86,6 @@ where
 import Codec.CBOR.Cuddle.CDDL (CDDL)
 import Codec.CBOR.Cuddle.CDDL qualified as C
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
-import Control.Arrow (Arrow (first), second)
 import Control.Monad (when)
 import Control.Monad.State (MonadState (get), execState, modify)
 import Data.ByteString (ByteString)
@@ -92,13 +96,14 @@ import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as HaskMap
 import Data.String (IsString (fromString))
 import Data.Text qualified as T
+import Data.Tuple.Optics (Field1 (..), Field2 (..), Field3 (..))
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import GHC.IsList (IsList (Item, fromList, toList))
-import Optics.Core ((%~), (&))
+import Optics.Core (over, (%~), (&))
 import Prelude hiding ((/))
 
-data Named a = Named T.Text a
+data Named a = Named {name :: T.Text, value :: a}
   deriving (Functor)
 
 instance Show (Named a) where
@@ -109,15 +114,16 @@ type Rule = Named Type0
 -- | Top-level Huddle type is a list of rules.
 data Huddle = Huddle
   { rules :: NE.NonEmpty Rule,
-    groups :: [Named Group]
+    groups :: [Named Group],
+    gRules :: [GRuleDef]
   }
   deriving (Show)
 
 -- | This instance is mostly used for testing
 instance IsList Huddle where
   type Item Huddle = Rule
   fromList [] = error "Huddle: Cannot have empty ruleset"
-  fromList (x : xs) = Huddle (x NE.:| xs) mempty
+  fromList (x : xs) = Huddle (x NE.:| xs) mempty mempty
 
   toList = NE.toList . (.rules)
 
@@ -219,6 +225,10 @@ data Type2
   | T2Tagged (Tagged Type0)
   | T2Ref (Named Type0)
   | T2Group (Named Group)
+  | -- | Call to a generic rule, binding arguments
+    T2Generic GRuleCall
+  | -- | Reference to a generic parameter within the body of the definition
+    T2GenericRef GRef
   deriving (Show)
 
 type Type0 = Choice Type2
@@ -455,6 +465,12 @@ instance IsType0 (Value a) where
 instance IsType0 (Named Group) where
   toType0 = NoChoice . T2Group
 
+instance IsType0 GRuleCall where
+  toType0 = NoChoice . T2Generic
+
+instance IsType0 GRef where
+  toType0 = NoChoice . T2GenericRef
+
 instance (IsType0 a) => IsType0 (Tagged a) where
   toType0 = NoChoice . T2Tagged . fmap toType0
 
@@ -568,6 +584,12 @@ instance IsChoosable Type2 Type2 where
 instance IsChoosable Rule Type2 where
   toChoice = toChoice . T2Ref
 
+instance IsChoosable GRuleCall Type2 where
+  toChoice = toChoice . T2Generic
+
+instance IsChoosable GRef Type2 where
+  toChoice = toChoice . T2GenericRef
+
 instance IsChoosable ByteString Type2 where
   toChoice = toChoice . T2Literal . Unranged . LBytes
 
@@ -666,24 +688,96 @@ data Tagged a = Tagged (Maybe Int) a
 tag :: Int -> a -> Tagged a
 tag mi = Tagged (Just mi)
 
+--------------------------------------------------------------------------------
+-- Generics
+--------------------------------------------------------------------------------
+
+newtype GRef = GRef T.Text
+  deriving (Show)
+
+freshName :: Int -> GRef
+freshName ix =
+  GRef $
+    T.singleton (['a' .. 'z'] !! (ix `rem` 26))
+      <> T.pack (show $ ix `quot` 26)
+
+data GRule a = GRule
+  { args :: NE.NonEmpty a,
+    body :: Type0
+  }
+  deriving (Show)
+
+type GRuleCall = Named (GRule Type2)
+
+type GRuleDef = Named (GRule GRef)
+
+callToDef :: GRule Type2 -> GRule GRef
+callToDef gr = gr {args = refs}
+  where
+    refs =
+      NE.unfoldr
+        ( \ix ->
+            ( freshName ix,
+              if ix < NE.length gr.args - 1 then Just (ix + 1) else Nothing
+            )
+        )
+        0
+
+-- | Bind a single variable into a generic call
+binding :: (IsType0 t0) => (GRef -> Rule) -> t0 -> GRuleCall
+binding fRule t0 =
+  Named
+    rule.name
+    GRule
+      { args = NE.singleton t2,
+        body = rule.value
+      }
+  where
+    rule = fRule (freshName 0)
+    t2 = case toType0 t0 of
+      NoChoice x -> x
+      _ -> error "Cannot use a choice of types as a generic argument"
+
+-- | Bind two variables as a generic call
+binding2 :: (IsType0 t0, IsType0 t1) => (GRef -> GRef -> Rule) -> t0 -> t1 -> GRuleCall
+binding2 fRule t0 t1 =
+  Named
+    rule.name
+    GRule
+      { args = t02 NE.:| [t12],
+        body = rule.value
+      }
+  where
+    rule = fRule (freshName 0) (freshName 1)
+    t02 = case toType0 t0 of
+      NoChoice x -> x
+      _ -> error "Cannot use a choice of types as a generic argument"
+    t12 = case toType0 t1 of
+      NoChoice x -> x
+      _ -> error "Cannot use a choice of types as a generic argument"
+
 --------------------------------------------------------------------------------
 -- Collecting all top-level rules
 --------------------------------------------------------------------------------
 
 -- | Collect all rules starting from a given point.
--- TODO Make sure we have no infinite loops here!
 collectFrom :: Rule -> Huddle
-collectFrom topR = toHuddle $ execState (goRule topR) (HaskMap.empty, HaskMap.empty)
+collectFrom topR =
+  toHuddle $
+    execState
+      (goRule topR)
+      (HaskMap.empty, HaskMap.empty, HaskMap.empty)
   where
-    toHuddle (rules, groups) =
+    toHuddle (rules, groups, gRules) =
       Huddle
         { rules = NE.fromList $ uncurry Named <$> HaskMap.toList rules,
-          groups = uncurry Named <$> HaskMap.toList groups
+          groups = uncurry Named <$> HaskMap.toList groups,
+          gRules = uncurry Named <$> HaskMap.toList gRules
         }
     goRule (Named n t0) = do
-      (rules, _) <- get
+      (rules, _, _) <- get
       when (HaskMap.notMember n rules) $ do
-        modify (first $ HaskMap.insert n t0)
+        modify (over _1 $ HaskMap.insert n t0)
         goT0 t0
     goChoice f (NoChoice x) = f x
     goChoice f (ChoiceOf x xs) = f x >> goChoice f xs
@@ -693,10 +787,15 @@ collectFrom topR = toHuddle $ execState (goRule topR) (HaskMap.empty, HaskMap.em
     goT2 (T2Tagged (Tagged _ t0)) = goT0 t0
     goT2 (T2Ref n) = goRule n
     goT2 (T2Group (Named n g)) = do
-      (_, groups) <- get
+      (_, groups, _) <- get
       when (HaskMap.notMember n groups) $ do
-        modify (second $ HaskMap.insert n g)
+        modify (over _2 $ HaskMap.insert n g)
         goGroup g
+    goT2 (T2Generic (Named n g)) = do
+      (_, _, gRules) <- get
+      when (HaskMap.notMember n gRules) $ do
+        modify (over _3 $ HaskMap.insert n (callToDef g))
+        goT0 g.body
     goT2 _ = pure ()
     goArrayEntry (ArrayEntry (Just k) t0 _) = goKey k >> goT0 t0
     goArrayEntry (ArrayEntry Nothing t0 _) = goT0 t0
@@ -711,7 +810,11 @@ collectFrom topR = toHuddle $ execState (goRule topR) (HaskMap.empty, HaskMap.em
 
 -- | Convert from Huddle to CDDL for the purpose of pretty-printing.
 toCDDL :: Huddle -> CDDL
-toCDDL hdl = C.CDDL $ fmap toCDDLRule hdl.rules `NE.appendList` fmap toCDDLGroup hdl.groups
+toCDDL hdl =
+  C.CDDL $
+    fmap toCDDLRule hdl.rules
+      `NE.appendList` fmap toCDDLGroup hdl.groups
+      `NE.appendList` fmap toGenRuleDef hdl.gRules
   where
     toCDDLRule :: Rule -> C.Rule
     toCDDLRule (Named n t0) =
@@ -760,6 +863,8 @@ toCDDL hdl = C.CDDL $ fmap toCDDLRule hdl.rules `NE.appendList` fmap toCDDLGroup
         C.Type1 (C.T2Tag mmin $ toCDDLType0 x) Nothing
       T2Ref (Named n _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
       T2Group (Named n _) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
+      T2Generic g -> C.Type1 (toGenericCall g) Nothing
+      T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
 
     toMemberKey :: Key -> C.MemberKey
     toMemberKey (LiteralKey (LText t)) = C.MKBareword (C.Name t)
@@ -811,3 +916,19 @@ toCDDL hdl = C.CDDL $ fmap toCDDLRule hdl.rules `NE.appendList` fmap toCDDLGroup
         . C.Group
         . NE.singleton
         $ fmap (C.GEType Nothing Nothing . toCDDLType0) t0s
+
+    toGenericCall :: GRuleCall -> C.Type2
+    toGenericCall (Named n gr) =
+      C.T2Name
+        (C.Name n)
+        (Just . C.GenericArg $ fmap toCDDLType1 gr.args)
+
+    toGenRuleDef :: GRuleDef -> C.Rule
+    toGenRuleDef (Named n gr) =
+      C.Rule (C.Name n) (Just gps) C.AssignEq
+        . C.TOGType
+        . C.Type0
+        $ toCDDLType1 <$> choiceToNE gr.body
+      where
+        gps =
+          C.GenericParam $ fmap (\(GRef t) -> C.Name t) gr.args

test/Test/Codec/CBOR/Cuddle/Huddle.hs

@@ -21,6 +21,7 @@ huddleSpec = describe "huddle" $ do
   arraySpec
   mapSpec
   nestedSpec
+  genericSpec
 
 basicAssign :: Spec
 basicAssign = describe "basic assignment" $ do
@@ -94,6 +95,22 @@ nestedSpec =
             ]
             `shouldMatchParseCDDL` "header_body = [block_number : uint, slot : uint]\n header = [header_body, body_signature : bytes]"
 
+genericSpec :: Spec
+genericSpec =
+  describe "Generics" $
+    let set :: (IsType0 t0) => t0 -> GRuleCall
+        set = binding $ \x -> "set" =:= arr [0 <+ a x]
+
+        dict :: (IsType0 t0, IsType0 t1) => t0 -> t1 -> GRuleCall
+        dict = binding2 $ \k v -> "dict" =:= mp [0 <+ asKey k ==> v]
+     in do
+          it "Should bind a single parameter" $
+            toCDDL (collectFrom ("intset" =:= set VUInt))
+              `shouldMatchParseCDDL` "intset = set<uint>\n set<a0> = [* a0]"
+          it "Should bind two parameters" $
+            toCDDL (collectFrom ("mymap" =:= dict VUInt VText))
+              `shouldMatchParseCDDL` "mymap = dict<uint, text>\n dict<a0, b0> = {* a0 => b0}"
+
 --------------------------------------------------------------------------------
 -- Helper functions
 --------------------------------------------------------------------------------