Provide general instances for optional and unpacked repeated fields.

awakesecurity · Jan 31, 2025 · da72c79 · da72c79
1 parent a3aa098
commit da72c79
Show file tree

Hide file tree

Showing 2 changed files with 52 additions and 170 deletions.
diff --git a/src/Proto3/Suite/Form/Encode.hs b/src/Proto3/Suite/Form/Encode.hs
@@ -158,54 +158,33 @@ instance ( ProtoEnum e
          ) =>
          FieldForm ('Singular omission) ('Enumeration e) e
   where
-    fieldForm rep _ !fn x =
-      fieldForm @('Singular omission) @'Int32 rep (proxy# :: Proxy# 'Int32) fn (fromProtoEnum x)
-    {-# INLINE fieldForm #-}
-
-instance ProtoEnum e =>
-         FieldForm 'Optional ('Enumeration e) (Maybe e)
-  where
-    fieldForm rep _ !fn x =
-      fieldForm @'Optional @'Int32 rep (proxy# :: Proxy# 'Int32) fn (fmap fromProtoEnum x)
+    fieldForm rep _ !fn x = fieldForm rep (proxy# :: Proxy# 'Int32) fn (fromProtoEnum x)
     {-# INLINE fieldForm #-}
 
 instance ( ProtoEnum e
          , Functor t
-         , FieldForm ('Repeated packing) 'Int32 (t Int32)
+         , FieldForm ('Repeated 'Packed) 'Int32 (t Int32)
          ) =>
-         FieldForm ('Repeated packing) ('Enumeration e) (t e)
+         FieldForm ('Repeated 'Packed) ('Enumeration e) (t e)
   where
-    fieldForm rep _ !fn xs =
-      fieldForm @('Repeated packing) @'Int32
-                rep (proxy# :: Proxy# 'Int32) fn (fmap fromProtoEnum xs)
+    fieldForm rep _ !fn xs = fieldForm rep (proxy# :: Proxy# 'Int32) fn (fmap fromProtoEnum xs)
     {-# INLINE fieldForm #-}
 
 instance ( ProtoEnum e
          , FieldForm ('Singular omission) 'Int32 Int32
          ) =>
          FieldForm ('Singular omission) ('Enumeration e) (Enumerated e)
   where
-    fieldForm rep _ !fn x =
-      fieldForm @('Singular omission) @'Int32
-                rep (proxy# :: Proxy# 'Int32) fn (codeFromEnumerated x)
-    {-# INLINE fieldForm #-}
-
-instance ProtoEnum e =>
-         FieldForm 'Optional ('Enumeration e) (Maybe (Enumerated e))
-  where
-    fieldForm rep _ !fn x =
-      fieldForm @'Optional @'Int32 rep (proxy# :: Proxy# 'Int32) fn (fmap codeFromEnumerated x)
+    fieldForm rep _ !fn x = fieldForm rep (proxy# :: Proxy# 'Int32) fn (codeFromEnumerated x)
     {-# INLINE fieldForm #-}
 
 instance ( ProtoEnum e
          , Functor t
-         , FieldForm ('Repeated packing) 'Int32 (t Int32)
+         , FieldForm ('Repeated 'Packed) 'Int32 (t Int32)
          ) =>
-         FieldForm ('Repeated packing) ('Enumeration e) (t (Enumerated e))
+         FieldForm ('Repeated 'Packed) ('Enumeration e) (t (Enumerated e))
   where
-    fieldForm rep _ !fn xs =
-      fieldForm @('Repeated packing) @'Int32
-                rep (proxy# :: Proxy# 'Int32) fn (fmap codeFromEnumerated xs)
+    fieldForm rep _ !fn xs = fieldForm rep (proxy# :: Proxy# 'Int32) fn (fmap codeFromEnumerated xs)
     {-# INLINE fieldForm #-}
 
 instance FieldForm ('Singular 'Alternative) 'Bytes RB.BuildR
@@ -218,17 +197,6 @@ instance FieldForm ('Singular 'Implicit) 'Bytes RB.BuildR
     fieldForm _ _ !fn x = Encode.bytesIfNonempty fn x
     {-# INLINE fieldForm #-}
 
-instance FieldForm 'Optional 'Bytes (Maybe RB.BuildR)
-  where
-    fieldForm _ _ !fn = maybe mempty (Encode.bytes fn)
-    {-# INLINE fieldForm #-}
-
-instance forall t . FoldBuilders t =>
-         FieldForm ('Repeated 'Unpacked) 'Bytes (t RB.BuildR)
-  where
-    fieldForm _ _ !fn xs = foldBuilders (Encode.bytes fn <$> xs)
-    {-# INLINE fieldForm #-}
-
 -- | Specializes the argument type of 'field' to the encoding of a submessage type,
 -- which can help to avoid ambiguity when the argument expression is polymorphic.
 message ::

diff --git a/src/Proto3/Suite/Form/Encode/Core.hs b/src/Proto3/Suite/Form/Encode/Core.hs
@@ -443,6 +443,10 @@ instance forall (name :: Symbol)
 -- sure to consider how they might overlap with existing instances,
 -- and try to avoid overly broad instances that might cause ambiguity.
 --
+-- However, this library does provide general instances for 'Optional'
+-- and @'Repeated' 'Unpacked'@ that delegate to instances for
+-- @'Singular' 'Alternative'@ for the same protobuf type.
+--
 -- Design Note:
 --
 -- Importantly, the type parameters of this type class do not mention
@@ -483,31 +487,26 @@ class FieldForm repetition protoType a
     -- `Proto3.Suite.Form.Encode.associations`.
     fieldForm :: Proxy# repetition -> Proxy# protoType -> FieldNumber -> a -> Encode.MessageBuilder
 
-instance (omission ~ 'Alternative) =>
-         FieldForm ('Singular omission) ('Message inner) (MessageEncoder inner)
-  where
-    fieldForm _ _ !fn e = Encode.embedded fn (untypedMessageEncoder e)
-    {-# INLINE fieldForm #-}
-
-instance FieldForm 'Optional ('Message inner) (Maybe (MessageEncoder inner))
+instance FieldForm ('Singular 'Alternative) protoType a =>
+         FieldForm 'Optional protoType (Maybe a)
   where
-    fieldForm _ _ !fn = foldMap (Encode.embedded fn . untypedMessageEncoder)
+    fieldForm _ ty !fn me =
+      foldMap @Maybe (fieldForm (proxy# :: Proxy# ('Singular 'Alternative)) ty fn) me
     {-# INLINE fieldForm #-}
 
-instance ( packing ~ 'Unpacked
-         , FoldBuilders t
+instance ( FoldBuilders t
+         , FieldForm ('Singular 'Alternative) protoType a
          ) =>
-         FieldForm ('Repeated packing) ('Message inner) (t (MessageEncoder inner))
+         FieldForm ('Repeated 'Unpacked) protoType (t a)
   where
-    fieldForm _ _ !fn es = foldBuilders (Encode.embedded fn . untypedMessageEncoder <$> es)
+    fieldForm _ ty !fn es =
+      foldBuilders (fieldForm (proxy# :: Proxy# ('Singular 'Alternative)) ty fn <$> es)
     {-# INLINE fieldForm #-}
 
-instance ( repetition ~ 'Repeated 'Unpacked
-         , FoldBuilders t
-         ) =>
-         FieldForm repetition ('Map key value) (t (MessageEncoder (Association key value)))
+instance (omission ~ 'Alternative) =>
+         FieldForm ('Singular omission) ('Message inner) (MessageEncoder inner)
   where
-    fieldForm _ _ !fn es = foldBuilders (Encode.embedded fn . untypedMessageEncoder <$> es)
+    fieldForm _ _ !fn e = Encode.embedded fn (untypedMessageEncoder e)
     {-# INLINE fieldForm #-}
 
 instance (omission ~ 'Alternative) =>
@@ -516,25 +515,28 @@ instance (omission ~ 'Alternative) =>
     fieldForm rep ty !fn e = fieldForm rep ty fn (cachedMessageEncoding e)
     {-# INLINE fieldForm #-}
 
-instance FieldForm 'Optional ('Message inner) (Maybe (MessageEncoding inner))
-  where
-    fieldForm rep ty !fn e = fieldForm rep ty fn (fmap @Maybe cachedMessageEncoding e)
-    {-# INLINE fieldForm #-}
-
-instance ( packing ~ 'Unpacked
-         , FoldBuilders t
-         ) =>
-         FieldForm ('Repeated packing) ('Message inner) (t (MessageEncoding inner))
+-- | This instance is rather artificial because maps are automatically
+-- repeated and unpacked, with no option to specify a single key-value
+-- pair as a field of a @oneof@.  Hence the code generator should never
+-- directly make use of this instance, but it will do so indirectly via
+-- the general instance for repeated unpacked fields, which will then
+-- delegate to this instance.
+instance (omission ~ 'Alternative) =>
+         FieldForm ('Singular omission) ('Map key value) (MessageEncoder (Association key value))
   where
-    fieldForm rep ty !fn e = fieldForm rep ty fn (fmap @t cachedMessageEncoding e)
+    fieldForm _ _ !fn a = Encode.embedded fn (untypedMessageEncoder a)
     {-# INLINE fieldForm #-}
 
-instance ( repetition ~ 'Repeated 'Unpacked
-         , FoldBuilders t
-         ) =>
-         FieldForm repetition ('Map key value) (t (MessageEncoding (Association key value)))
+-- | This instance is rather artificial because maps are automatically
+-- repeated and unpacked, with no option to specify a single key-value
+-- pair as a field of a @oneof@.  Hence the code generator should never
+-- directly make use of this instance, but it will do so indirectly via
+-- the general instance for repeated unpacked fields, which will then
+-- delegate to this instance.
+instance (omission ~ 'Alternative) =>
+         FieldForm ('Singular omission) ('Map key value) (MessageEncoding (Association key value))
   where
-    fieldForm rep ty !fn e = fieldForm rep ty fn (fmap @t cachedMessageEncoding e)
+    fieldForm rep ty !fn e = fieldForm rep ty fn (cachedMessageEncoding e)
     {-# INLINE fieldForm #-}
 
 -- | Helps some type classes distinguish wrapped values from encodings of wrapper submessages.
@@ -553,20 +555,6 @@ instance ( omission ~ 'Alternative
       fieldForm rep ty fn (fieldsToMessage @(Wrapper protoType) (field @"value" @a x))
     {-# INLINE fieldForm #-}
 
-instance FieldForm ('Singular 'Implicit) protoType a =>
-         FieldForm 'Optional ('Message (Wrapper protoType)) (Maybe (Wrap a))
-  where
-    fieldForm rep ty !fn m = fieldForm rep ty fn
-      (fmap @Maybe (\(Wrap x) -> fieldsToMessage @(Wrapper protoType) (field @"value" @a x)) m)
-    {-# INLINE fieldForm #-}
-
-instance (packing ~ 'Unpacked, FoldBuilders t, FieldForm ('Singular 'Implicit) protoType a) =>
-         FieldForm ('Repeated packing) ('Message (Wrapper protoType)) (t (Wrap a))
-  where
-    fieldForm rep ty !fn es = fieldForm rep ty fn
-      (fmap @t (\(Wrap x) -> fieldsToMessage @(Wrapper protoType) (field @"value" @a x)) es)
-    {-# INLINE fieldForm #-}
-
 -- | Any encoding of the first type can be decoded as the second without
 -- changing semantics.  This relation is more strict than the compatibilities
 -- listed in <https://protobuf.dev/programming-guides/proto3/#updating>.
@@ -632,23 +620,6 @@ instance ( CompatibleScalar (RecoverProtoType a) protoType
       | otherwise = encodePrimitive fn x
     {-# INLINE encodeScalarField #-}
 
-instance ( CompatibleScalar (RecoverProtoType a) protoType
-         , Primitive a
-         ) =>
-         EncodeScalarField 'Optional protoType (Maybe a)
-  where
-    encodeScalarField _ _ !fn = maybe mempty (encodePrimitive fn)
-    {-# INLINE encodeScalarField #-}
-
-instance ( CompatibleScalar (RecoverProtoType a) protoType
-         , FoldBuilders t
-         , Primitive a
-         ) =>
-         EncodeScalarField ('Repeated 'Unpacked) protoType (t a)
-  where
-    encodeScalarField _ _ !fn xs = foldBuilders (encodePrimitive fn <$> xs)
-    {-# INLINE encodeScalarField #-}
-
 -- | Ignores the preference for packed format because there is exactly one element,
 -- and therefore packed format would be more verbose.  Conforming parsers must
 -- accept both packed and unpacked primitives regardless of packing preference.
@@ -962,51 +933,32 @@ instantiatePackableField protoType elementType conversion =
 
     instance FieldForm ('Singular 'Alternative) $protoType $elementType
       where
-        fieldForm rep ty !fn x =
-          encodeScalarField @('Singular 'Alternative) @($protoType) rep ty fn ($conversion x)
+        fieldForm rep ty !fn x = encodeScalarField rep ty fn ($conversion x)
         {-# INLINE fieldForm #-}
 
     instance FieldForm ('Singular 'Implicit) $protoType $elementType
       where
-        fieldForm rep ty !fn x =
-          encodeScalarField @('Singular 'Implicit) @($protoType) rep ty fn ($conversion x)
-        {-# INLINE fieldForm #-}
-
-    instance FieldForm 'Optional $protoType (Maybe $elementType)
-      where
-        fieldForm rep ty !fn x =
-          encodeScalarField @'Optional @($protoType) rep ty fn (fmap $conversion x)
-        {-# INLINE fieldForm #-}
-
-    instance FoldBuilders t =>
-             FieldForm ('Repeated 'Unpacked) $protoType (t $elementType)
-      where
-        fieldForm rep ty !fn xs =
-          encodeScalarField @('Repeated 'Unpacked) @($protoType) rep ty fn (fmap $conversion xs)
+        fieldForm rep ty !fn x = encodeScalarField rep ty fn ($conversion x)
         {-# INLINE fieldForm #-}
 
     instance FieldForm ('Repeated 'Packed) $protoType (Identity $elementType)
       where
-        fieldForm rep ty !fn xs =
-          encodeScalarField @('Repeated 'Packed) @($protoType) rep ty fn (fmap $conversion xs)
+        fieldForm rep ty !fn xs = encodeScalarField rep ty fn (fmap $conversion xs)
         {-# INLINE fieldForm #-}
 
     instance FieldForm ('Repeated 'Packed) $protoType (Forward $elementType)
       where
-        fieldForm rep ty !fn xs =
-          encodeScalarField @('Repeated 'Packed) @($protoType) rep ty fn (fmap $conversion xs)
+        fieldForm rep ty !fn xs = encodeScalarField rep ty fn (fmap $conversion xs)
         {-# INLINE fieldForm #-}
 
     instance FieldForm ('Repeated 'Packed) $protoType (Reverse $elementType)
       where
-        fieldForm rep ty !fn xs =
-          encodeScalarField @('Repeated 'Packed) @($protoType) rep ty fn (fmap $conversion xs)
+        fieldForm rep ty !fn xs = encodeScalarField rep ty fn (fmap $conversion xs)
         {-# INLINE fieldForm #-}
 
     instance FieldForm ('Repeated 'Packed) $protoType (Vector $elementType)
       where
-        fieldForm rep ty !fn xs =
-          encodeScalarField @('Repeated 'Packed) @($protoType) rep ty fn (fmap $conversion xs)
+        fieldForm rep ty !fn xs = encodeScalarField rep ty fn (fmap $conversion xs)
         {-# INLINE fieldForm #-}
 
     |]
@@ -1020,8 +972,7 @@ instantiateStringOrBytesField protoType elementTC specializations = do
                Primitive ($elementTC a) =>
                FieldForm ('Singular 'Alternative) $protoType ($elementTC a)
         where
-          fieldForm rep ty !fn x =
-            encodeScalarField @('Singular 'Alternative) @($protoType) rep ty fn x
+          fieldForm rep ty !fn x = encodeScalarField rep ty fn x
           {-# INLINE fieldForm #-}
 
       instance forall a .
@@ -1030,26 +981,7 @@ instantiateStringOrBytesField protoType elementTC specializations = do
                ) =>
                FieldForm ('Singular 'Implicit) $protoType ($elementTC a)
         where
-          fieldForm rep ty !fn x =
-            encodeScalarField @('Singular 'Implicit) @($protoType) rep ty fn x
-          {-# INLINE fieldForm #-}
-
-      instance forall a .
-               Primitive ($elementTC a) =>
-               FieldForm 'Optional $protoType (Maybe ($elementTC a))
-        where
-          fieldForm rep ty !fn x =
-            encodeScalarField @'Optional @($protoType) rep ty fn x
-          {-# INLINE fieldForm #-}
-
-      instance forall t a .
-               ( FoldBuilders t
-               , Primitive ($elementTC a)
-               ) =>
-               FieldForm ('Repeated 'Unpacked) $protoType (t ($elementTC a))
-        where
-          fieldForm rep ty !fn xs =
-            encodeScalarField @('Repeated 'Unpacked) @($protoType) rep ty fn xs
+          fieldForm rep ty !fn x = encodeScalarField rep ty fn x
           {-# INLINE fieldForm #-}
 
       |]
@@ -1060,31 +992,13 @@ instantiateStringOrBytesField protoType elementTC specializations = do
       instance FieldForm ('Singular 'Alternative) $protoType $spec
         where
           fieldForm rep ty !fn x =
-            encodeScalarField @('Singular 'Alternative) @($protoType)
-                              rep ty fn (coerce @($spec) @($elementTC $spec) x)
+            encodeScalarField rep ty fn (coerce @($spec) @($elementTC $spec) x)
           {-# INLINE fieldForm #-}
 
       instance FieldForm ('Singular 'Implicit) $protoType $spec
         where
           fieldForm rep ty !fn x =
-            encodeScalarField @('Singular 'Implicit) @($protoType)
-                              rep ty fn (coerce @($spec) @($elementTC $spec) x)
-          {-# INLINE fieldForm #-}
-
-      instance FieldForm 'Optional $protoType (Maybe $spec)
-        where
-          fieldForm rep ty !fn x =
-            encodeScalarField @'Optional @($protoType)
-                              rep ty fn (coerce @(Maybe $spec) @(Maybe ($elementTC $spec)) x)
-          {-# INLINE fieldForm #-}
-
-      instance forall t .
-               FoldBuilders t =>
-               FieldForm ('Repeated 'Unpacked) $protoType (t $spec)
-        where
-          fieldForm rep ty !fn xs =
-            encodeScalarField @('Repeated 'Unpacked) @($protoType)
-                              rep ty fn (coerce @($spec) @($elementTC $spec) <$> xs)
+            encodeScalarField rep ty fn (coerce @($spec) @($elementTC $spec) x)
           {-# INLINE fieldForm #-}
 
       |]