Generics, take 2

This commit adds an alternative attempt at generics. It has both
advantages and disadvantages.

The principal advantage is that it really allows generics to work with
HuddleM - see the example in example/Monad.hs for a demonstration. The
previous way of writing this was quite horrible.

There are two main disadvantages:

- Now, rather than treating a generic function as a regular Haskell
function, we have to treat it specially and call it with the special
syntax (<--).
- Only one generic parameter is supported. We can potentially fix this,
but it's always going to play unkindly with the (<--) syntax. That
having been said, we had only implemented up to two parameters before.

For these reasons, these new-style generics are currently implemented
alongside the existing ones for consideration.

Author: nc6

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

@@ -19,8 +19,8 @@ spec = huddleDef $ mdo
   transaction <-
     "transaction"
       =:= mp
-        [ idx 0 ==> set txIn
-        , idx 1 ==> set txOut
+        [ idx 0 ==> set txIn,
+          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,15 +38,15 @@ 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 "Metadata" $ 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/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 CRef
+
+instance IsCborable CGRef
 
 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 CRef
+
+instance IsComparable CGRef
 
 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
 
@@ -617,6 +634,9 @@ instance IsType0 HuddleItem where
   toType0 (HIGRule g) =
     error $
       "Attempt to reference generic rule from HuddleItem not supported: " <> show g
+  toType0 (HIGRule' g) =
+    error $
+      "Attempt to reference generic rule from HuddleItem not supported: " <> show g
 
 class CanQuantify a where
   -- | Apply a lower bound
@@ -933,6 +953,50 @@ 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
+
+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 _ = error "Attempt to use a non-generic rule as a GRuleDef"
+
+(<--) :: (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 +1086,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 +1149,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 +1224,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 $ NE.singleton (toCDDLType1 (callArg gr)))
+
     toGenRuleDef :: GRuleDef -> C.WithComments C.Rule
     toGenRuleDef (Named n gr c) =
       C.WithComments
@@ -1170,3 +1242,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) (NE.singleton $ arg g)

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

@@ -1,19 +1,20 @@
 -- | Monad for declaring Huddle constructs
-module Codec.CBOR.Cuddle.Huddle.HuddleM (
-  module Huddle,
-  (=:=),
-  (=:~),
-  (=::=),
-  binding,
-  setRootRules,
-  huddleDef,
-  huddleDef',
-  include,
-  unsafeIncludeFromHuddle,
-)
+module Codec.CBOR.Cuddle.Huddle.HuddleM
+  ( module Huddle,
+    (=:=),
+    (=:~),
+    (=::=),
+    binding,
+    binding',
+    setRootRules,
+    huddleDef,
+    huddleDef',
+    include,
+    unsafeIncludeFromHuddle,
+  )
 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)
@@ -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