Generics, take 2

cuddle.cabal

@@ -51,6 +51,7 @@ library
     Codec.CBOR.Cuddle.CDDL.Prelude
     Codec.CBOR.Cuddle.CDDL.Resolve
     Codec.CBOR.Cuddle.Huddle
+    Codec.CBOR.Cuddle.Huddle.Generic
     Codec.CBOR.Cuddle.Huddle.HuddleM
     Codec.CBOR.Cuddle.Huddle.Optics
     Codec.CBOR.Cuddle.Parser

example/Monad.hs

@@ -20,7 +20,7 @@ spec = huddleDef $ mdo
     "transaction"
       =:= mp
         [ idx 0 ==> set txIn
-        , idx 1 ==> set txOut
+        , idx 1 ==> set' <-- txOut
         ]
   txIn <- "txIn" =:= arr ["transaction_id" ==> hash32, "index" ==> txId]
   txOut <- "txOut" =:= arr [idx 0 ==> address, idx 1 ==> value]
@@ -29,6 +29,7 @@ spec = huddleDef $ mdo
   hash32 <- "hash32" =:= VBytes `sized` (32 :: Word64)
   value <- "value" =:= VUInt
   set <- include hdl_set
+  set' <- binding' $ \x -> "set'" Huddle.=:= arr [0 <+ a x]
 
   setRootRules [transaction]
 
@@ -37,14 +38,14 @@ spec2 =
   spec
     <> huddleDef
       ( mdo
-          set <- include hdl_set
+          set <- unsafeIncludeFromHuddle spec "set'"
           txIn <- unsafeIncludeFromHuddle spec "txIn"
           txOut <- unsafeIncludeFromHuddle spec "txOut"
           _transaction <-
             "transaction"
               =:= mp
-                [ comment "Transaction inputs" $ idx 0 ==> set txIn
-                , comment "Transaction outputs" $ idx 1 ==> set txOut
+                [ comment "Transaction inputs" $ idx 0 ==> set <-- txIn
+                , comment "Transaction outputs" $ idx 1 ==> set <-- txOut
                 , comment "Metadata" $ idx 2 ==> metadata
                 ]
           metadata <- "metadata" =:= VBytes

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
 -- | Module for building CDDL in Haskell
@@ -76,10 +77,14 @@ module Codec.CBOR.Cuddle.Huddle (
   -- * Generics
   GRef,
   GRuleDef,
+  GRuleDef',
   GRuleCall,
+  GRuleCall',
   binding,
   binding2,
+  binding',
   callToDef,
+  (<--),
 
   -- * Conversion to CDDL
   collectFrom,
@@ -91,6 +96,7 @@ where
 import Codec.CBOR.Cuddle.CDDL (CDDL, TopLevel (..), WithComments (..))
 import Codec.CBOR.Cuddle.CDDL qualified as C
 import Codec.CBOR.Cuddle.CDDL.CtlOp qualified as CtlOp
+import Codec.CBOR.Cuddle.Huddle.Generic (FnWithArg (..), result)
 import Control.Monad (when)
 import Control.Monad.State (MonadState (get), execState, modify)
 import Data.ByteString (ByteString)
@@ -128,6 +134,7 @@ type Rule = Named Type0
 data HuddleItem
   = HIRule Rule
   | HIGRule GRuleDef
+  | HIGRule' GRuleDef'
   | HIGroup (Named Group)
   deriving (Generic, Show)
 
@@ -273,6 +280,7 @@ data Type2
   | T2Group (Named Group)
   | -- | Call to a generic rule, binding arguments
     T2Generic GRuleCall
+  | T2Generic' GRuleCall'
   | -- | Reference to a generic parameter within the body of the definition
     T2GenericRef GRef
   deriving (Show)
@@ -475,9 +483,12 @@ sized v sz =
     []
 
 class IsCborable a
+
 instance IsCborable ByteString
-instance IsCborable (AnyRef a)
-instance IsCborable GRef
+
+instance IsCborable CRefType
+
+instance IsCborable CGRefType
 
 cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained
 cbor v r@(Named n _ _) =
@@ -493,9 +504,12 @@ cbor v r@(Named n _ _) =
     [r]
 
 class IsComparable a
+
 instance IsComparable Int
-instance IsComparable (AnyRef a)
-instance IsComparable GRef
+
+instance IsComparable CRefType
+
+instance IsComparable CGRefType
 
 le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained
 le v bound =
@@ -605,6 +619,9 @@ instance IsType0 (Named Group) where
 instance IsType0 GRuleCall where
   toType0 = NoChoice . T2Generic
 
+instance IsType0 GRuleCall' where
+  toType0 = NoChoice . T2Generic'
+
 instance IsType0 GRef where
   toType0 = NoChoice . T2GenericRef
 
@@ -616,7 +633,14 @@ instance IsType0 HuddleItem where
   toType0 (HIGroup g) = toType0 g
   toType0 (HIGRule g) =
     error $
-      "Attempt to reference generic rule from HuddleItem not supported: " <> show g
+      "Attempt to reference a raw generic rule: "
+        <> show g
+        <> ". Most likely this indicates you haven't provided generic parameters."
+  toType0 (HIGRule' g) =
+    error $
+      "Attempt to reference a raw generic rule: "
+        <> show g
+        <> ". Most likely this indicates you haven't provided generic parameters."
 
 class CanQuantify a where
   -- | Apply a lower bound
@@ -684,12 +708,12 @@ infixl 8 ==>
 (=:=) :: IsType0 a => T.Text -> a -> Rule
 n =:= b = Named n (toType0 b) Nothing
 
-infixl 1 =:=
+infixl 4 =:=
 
 (=:~) :: T.Text -> Group -> Named Group
 n =:~ b = Named n b Nothing
 
-infixl 1 =:~
+infixl 4 =:~
 
 class IsGroupOrArrayEntry a where
   toGroupOrArrayEntry :: IsType0 x => x -> a
@@ -933,6 +957,54 @@ binding2 fRule t0 t1 =
       NoChoice x -> x
       _ -> error "Cannot use a choice of types as a generic argument"
 
+--------------------------------------------------------------------------------
+-- Generics (Take 2)
+--------------------------------------------------------------------------------
+
+type GRuleDef' = Named (FnWithArg GRef Type0)
+
+data GRuleCallAux = GRuleCallAux
+  { defFn :: FnWithArg GRef Type0
+  , callArg :: Type2
+  }
+
+type GRuleCall' = Named GRuleCallAux
+
+-- | Create a generic rule definition binding a single generic parameter.
+binding' :: (GRef -> Rule) -> GRuleDef'
+binding' fRule =
+  Named
+    (getField @"name" $ result defFn)
+    (getField @"value" <$> defFn)
+    Nothing
+  where
+    defFn = FnWithArg fRule (freshName 0)
+
+class IsGRuleDef f where
+  toGRuleDef :: f -> GRuleDef'
+
+instance IsGRuleDef GRuleDef' where
+  toGRuleDef = id
+
+instance IsGRuleDef HuddleItem where
+  toGRuleDef (HIGRule' gd) = gd
+  toGRuleDef hi =
+    error $
+      "Attempt to apply generic parameters to a non-generic rule: " <> show hi
+
+-- | Call a generic definition, applying the given type parameter.
+(<--) :: (IsType0 t0, IsGRuleDef gd) => gd -> t0 -> GRuleCall'
+(toGRuleDef -> f) <-- t0 = fmap toCall f
+  where
+    toCall rd =
+      GRuleCallAux
+        { defFn = rd
+        , callArg = t2
+        }
+    t2 = case toType0 t0 of
+      NoChoice x -> x
+      _ -> error "Cannot use a choice of types as a generic argument"
+
 --------------------------------------------------------------------------------
 -- Collecting all top-level rules
 --------------------------------------------------------------------------------
@@ -1022,6 +1094,7 @@ toCDDL' mkPseudoRoot hdl =
     toCDDLItem (HIRule r) = toCDDLRule r
     toCDDLItem (HIGroup g) = toCDDLGroup g
     toCDDLItem (HIGRule g) = toGenRuleDef g
+    toCDDLItem (HIGRule' g) = toGenRuleDef' g
     toTopLevelPseudoRoot :: [Rule] -> C.WithComments C.Rule
     toTopLevelPseudoRoot topRs =
       toCDDLRule $
@@ -1084,6 +1157,7 @@ toCDDL' mkPseudoRoot hdl =
       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
+      T2Generic' g -> C.Type1 (toGenericCall' g) Nothing
       T2GenericRef (GRef n) -> C.Type1 (C.T2Name (C.Name n) Nothing) Nothing
 
     toMemberKey :: Key -> C.MemberKey
@@ -1158,6 +1232,12 @@ toCDDL' mkPseudoRoot hdl =
         (C.Name n)
         (Just . C.GenericArg $ fmap toCDDLType1 (args gr))
 
+    toGenericCall' :: GRuleCall' -> C.Type2
+    toGenericCall' (Named n gr _) =
+      C.T2Name
+        (C.Name n)
+        (Just . C.GenericArg $ toCDDLType1 (callArg gr) NE.:| [])
+
     toGenRuleDef :: GRuleDef -> C.WithComments C.Rule
     toGenRuleDef (Named n gr c) =
       C.WithComments
@@ -1170,3 +1250,16 @@ toCDDL' mkPseudoRoot hdl =
       where
         gps =
           C.GenericParam $ fmap (\(GRef t) -> C.Name t) (args gr)
+
+    toGenRuleDef' :: GRuleDef' -> C.WithComments C.Rule
+    toGenRuleDef' (Named n g c) =
+      C.WithComments
+        ( C.Rule (C.Name n) (Just gps) C.AssignEq
+            . C.TOGType
+            $ C.Type0
+            $ toCDDLType1 <$> choiceToNE (fn g (arg g))
+        )
+        (C.comment <$> c)
+      where
+        gps =
+          C.GenericParam $ fmap (\(GRef t) -> C.Name t) (arg g NE.:| [])

src/Codec/CBOR/Cuddle/Huddle/Generic.hs

@@ -0,0 +1,12 @@
+module Codec.CBOR.Cuddle.Huddle.Generic where
+
+-- | Function carrying its argument
+data FnWithArg a result = FnWithArg
+  { fn :: a -> result
+  , arg :: a
+  }
+  deriving (Functor)
+
+-- | Evaluate a function carrying its argument to its result
+result :: FnWithArg a result -> result
+result a = fn a (arg a)

src/Codec/CBOR/Cuddle/Huddle/HuddleM.hs

@@ -5,6 +5,7 @@ module Codec.CBOR.Cuddle.Huddle.HuddleM (
   (=:~),
   (=::=),
   binding,
+  binding',
   setRootRules,
   huddleDef,
   huddleDef',
@@ -13,7 +14,7 @@ module Codec.CBOR.Cuddle.Huddle.HuddleM (
 )
 where
 
-import Codec.CBOR.Cuddle.Huddle hiding (binding, (=:=), (=:~))
+import Codec.CBOR.Cuddle.Huddle hiding (binding, binding', (=:=), (=:~))
 import Codec.CBOR.Cuddle.Huddle qualified as Huddle
 import Control.Monad.State.Strict (State, modify, runState)
 import Data.Default.Class (def)
@@ -28,13 +29,13 @@ type HuddleM = State Huddle
 (=:=) :: IsType0 a => T.Text -> a -> HuddleM Rule
 n =:= b = let r = n Huddle.=:= b in include r
 
-infixl 1 =:=
+infixl 4 =:=
 
 -- | Overridden version of group assignment which adds the rule to the state
 (=:~) :: T.Text -> Group -> HuddleM (Named Group)
 n =:~ b = let r = n Huddle.=:~ b in include r
 
-infixl 1 =:~
+infixl 4 =:~
 
 binding ::
   forall t0.
@@ -43,6 +44,11 @@ binding ::
   HuddleM (t0 -> GRuleCall)
 binding fRule = include (Huddle.binding fRule)
 
+binding' ::
+  (GRef -> Rule) ->
+  HuddleM GRuleDef'
+binding' fRule = include (Huddle.binding' fRule)
+
 -- | Renamed version of Huddle's underlying '=:=' for use in generic bindings
 (=::=) :: IsType0 a => T.Text -> a -> Rule
 n =::= b = n Huddle.=:= b
@@ -84,9 +90,15 @@ instance IsType0 t0 => Includable (t0 -> GRuleCall) where
           modify (field @"items" %~ (OMap.|> (n, HIGRule grDef)))
           pure gr
 
+instance Includable GRuleDef' where
+  include r =
+    modify (field @"items" %~ (OMap.|> (r ^. field @"name", HIGRule' r)))
+      >> pure r
+
 instance Includable HuddleItem where
   include x@(HIRule r) = include r >> pure x
   include x@(HIGroup g) = include g >> pure x
+  include x@(HIGRule' g) = include g >> pure x
   include x@(HIGRule g) =
     let n = g ^. field @"name"
      in do