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

@@ -50,6 +50,7 @@ library
     Codec.CBOR.Cuddle.CDDL.Postlude
     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,7 +19,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]
@@ -28,6 +28,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]
 
@@ -36,14 +37,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)
 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)
@@ -433,7 +441,7 @@ class IsSize a where
 
 instance IsSize Word where
   sizeAsCDDL = C.T2Value . C.VUInt . fromIntegral
-  sizeAsString = show 
+  sizeAsString = show
 
 instance IsSize Word64 where
   sizeAsCDDL = C.T2Value . C.VUInt
@@ -474,10 +482,13 @@ sized v sz =
       }
     []
 
-class IsCborable a 
-instance IsCborable ByteString 
-instance IsCborable CRef 
-instance IsCborable CGRef 
+class IsCborable a
+
+instance IsCborable ByteString
+
+instance IsCborable CRef
+
+instance IsCborable CGRef
 
 cbor :: (IsCborable b, IsConstrainable c b) => c -> Rule -> Constrained
 cbor v r@(Named n _ _) =
@@ -492,9 +503,12 @@ cbor v r@(Named n _ _) =
       }
     [r]
 
-class IsComparable a 
-instance IsComparable Int 
-instance IsComparable CRef 
+class IsComparable a
+
+instance IsComparable Int
+
+instance IsComparable CRef
+
 instance IsComparable CGRef
 
 le :: (IsComparable a, IsConstrainable c a) => c -> Word64 -> Constrained
@@ -512,16 +526,16 @@ le v bound =
 
 -- Ranges
 
-data RangeBound =
-    RangeBoundLiteral Literal 
-  | RangeBoundRef (Named Type0) 
-  deriving Show
+data RangeBound
+  = RangeBoundLiteral Literal
+  | RangeBoundRef (Named Type0)
+  deriving (Show)
 
 class IsRangeBound a where
-  toRangeBound :: a -> RangeBound 
+  toRangeBound :: a -> RangeBound
 
 instance IsRangeBound Literal where
-  toRangeBound = RangeBoundLiteral 
+  toRangeBound = RangeBoundLiteral
 
 instance IsRangeBound Integer where
   toRangeBound = RangeBoundLiteral . inferInteger
@@ -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
 --------------------------------------------------------------------------------
@@ -960,7 +1024,7 @@ collectFrom topRs =
     goChoice f (NoChoice x) = f x
     goChoice f (ChoiceOf x xs) = f x >> goChoice f xs
     goT0 = goChoice goT2
-    goT2 (T2Range r) = goRanged r 
+    goT2 (T2Range r) = goRanged r
     goT2 (T2Map m) = goChoice (mapM_ goMapEntry . unMapChoice) m
     goT2 (T2Array m) = goChoice (mapM_ goArrayEntry . unArrayChoice) m
     goT2 (T2Tagged (Tagged _ t0)) = goT0 t0
@@ -993,10 +1057,10 @@ collectFrom topRs =
     goKey _ = pure ()
     goGroup (Group g) = mapM_ goArrayEntry g
     goRanged (Unranged _) = pure ()
-    goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub 
+    goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub
     goRangeBound (RangeBoundLiteral _) = pure ()
     goRangeBound (RangeBoundRef r) = goRule r
-    
+
 --------------------------------------------------------------------------------
 -- Conversion to CDDL
 --------------------------------------------------------------------------------
@@ -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
@@ -1136,7 +1202,7 @@ toCDDL' mkPseudoRoot hdl =
         (toCDDLRangeBound lb)
         (Just (C.RangeOp rop, toCDDLRangeBound ub))
 
-    toCDDLRangeBound :: RangeBound -> C.Type2 
+    toCDDLRangeBound :: RangeBound -> C.Type2
     toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l
     toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n) Nothing
 
@@ -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))
+        )
+        (fmap 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

@@ -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)
@@ -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
@@ -95,10 +107,10 @@ instance Includable HuddleItem where
 
 unsafeIncludeFromHuddle ::
   Huddle ->
-  T.Text -> 
+  T.Text ->
   HuddleM HuddleItem
 unsafeIncludeFromHuddle h name =
   let items = h ^. field @"items"
-   in case OMap.lookup name items  of
+   in case OMap.lookup name items of
         Just v -> include v
         Nothing -> error $ show name <> " was not found in Huddle spec"