mu-protobuf 0.2.0.0 → 0.3.0.0

raw patch · 7 files changed

+350/−234 lines, 7 filesdep ~compendium-clientdep ~mu-protobufdep ~mu-rpcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: compendium-client, mu-protobuf, mu-rpc, mu-schema

API changes (from Hackage documentation)

Files

• mu-protobuf.cabal +6/−6
• src/Mu/Adapter/ProtoBuf.hs +248/−153
• src/Mu/Adapter/ProtoBuf/Via.hs +15/−15
• src/Mu/Quasi/GRpc.hs +12/−11
• src/Mu/Quasi/ProtoBuf.hs +38/−21
• test/ProtoBuf.hs +30/−28
• test/protobuf/example.proto +1/−0

@@ -1,5 +1,5 @@ name:          mu-protobuf-version:       0.2.0.0+version:       0.3.0.0 synopsis:   Protocol Buffers serialization and gRPC schema import for Mu microservices @@ -33,12 +33,12 @@   build-depends:       base                    >=4.12  && <5     , bytestring-    , compendium-client       >=0.2.0+    , compendium-client       >=0.3.0     , http-client     , http2-grpc-proto3-wire     , language-protobuf-    , mu-rpc                  >=0.2.0-    , mu-schema               >=0.2.0+    , mu-rpc                  >=0.3.0+    , mu-schema               >=0.3.0     , proto3-wire     , servant-client-core     , sop-core@@ -54,8 +54,8 @@   build-depends:       base         >=4.12  && <5     , bytestring-    , mu-protobuf  >=0.2.0-    , mu-schema    >=0.2.0+    , mu-protobuf  >=0.3.0+    , mu-schema    >=0.3.0     , proto3-wire     , text 

@@ -13,7 +13,6 @@ {-# language TypeFamilies          #-} {-# language TypeOperators         #-} {-# language UndecidableInstances  #-}-{-# language ViewPatterns          #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Description : Adapter for Protocol Buffers serialization@@ -40,7 +39,6 @@  import           Control.Applicative import qualified Data.ByteString          as BS-import           Data.Functor.MaybeLike import           Data.Int import           Data.SOP                 (All) import qualified Data.Text                as T@@ -63,7 +61,8 @@ -- | Annotations for Protocol Buffers fields. data ProtoBufAnnotation   = -- | Numeric field identifier for normal fields-    ProtoBufId Nat+    --   and whether it should be packed (only used for lists of number-like values)+    ProtoBufId Nat Bool     -- | List of identifiers for fields which contain a union   | ProtoBufOneOfIds [Nat] @@ -72,11 +71,21 @@     = FindProtoBufId' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)  type family FindProtoBufId' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Nat where-  FindProtoBufId' t f ('ProtoBufId n) = n+  FindProtoBufId' t f ('ProtoBufId n b) = n   FindProtoBufId' t f other     = TypeError ('Text "protocol buffers id not available for field "                  ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) +type family FindProtoBufPacked (sch :: Schema tn fn) (t :: tn) (f :: fn) where+  FindProtoBufPacked sch t f+    = FindProtoBufPacked' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)++type family FindProtoBufPacked' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Bool where+  FindProtoBufPacked' t f ('ProtoBufId n b) = b+  FindProtoBufPacked' t f other+    = TypeError ('Text "protocol buffers id not available for field "+                 ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)+ type family FindProtoBufOneOfIds (sch :: Schema tn fn) (t :: tn) (f :: fn) where   FindProtoBufOneOfIds sch t f     = FindProtoBufOneOfIds' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)@@ -92,16 +101,16 @@ -- | Represents those 'Schema's which are supported by Protocol Buffers. --   Some values which can be represented as 'Term's cannot be so in --   Protocol Buffers. For example, you cannot have a list within an option.-class ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty-instance ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty+class ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty+instance ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty  -- type HasProtoSchema w sch sty a = (HasSchema w sch sty a, IsProtoSchema w sch sty)  -- | Conversion to Protocol Buffers mediated by a schema. toProtoViaSchema :: forall t f (sch :: Schema t f) a sty.-                    (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty a)+                    (IsProtoSchema sch sty, ToSchema sch sty a)                  => a -> PBEnc.MessageBuilder-toProtoViaSchema = termToProto . toSchema' @_ @_ @sch @Maybe+toProtoViaSchema = termToProto . toSchema' @_ @_ @sch  -- | Conversion from Protocol Buffers mediated by a schema. --   This function requires a 'PBDec.RawMessage', which means@@ -109,15 +118,15 @@ --   is well-formed. Use 'parseProtoViaSchema' to parse directly --   from a 'BS.ByteString'. fromProtoViaSchema :: forall t f (sch :: Schema t f) a sty.-                      (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a)+                      (IsProtoSchema sch sty, FromSchema sch sty a)                    => PBDec.Parser PBDec.RawMessage a-fromProtoViaSchema = fromSchema' @_ @_ @sch @Maybe <$> protoToTerm+fromProtoViaSchema = fromSchema' @_ @_ @sch <$> protoToTerm  -- | Conversion from Protocol Buffers mediated by a schema. --   This function receives the 'BS.ByteString' directly, --   and parses it as part of its duty. parseProtoViaSchema :: forall sch a sty.-                       (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a)+                       (IsProtoSchema sch sty, FromSchema sch sty a)                     => BS.ByteString -> Either PBDec.ParseError a parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch) @@ -152,7 +161,7 @@  instance FromProtoBufRegistry '[] t where   fromProtoBufRegistry' _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "no schema found in registry"))-instance (IsProtoSchema Maybe s sty, FromSchema Maybe s sty t, FromProtoBufRegistry ms t)+instance (IsProtoSchema s sty, FromSchema s sty t, FromProtoBufRegistry ms t)          => FromProtoBufRegistry ( (n ':-> s) ': ms) t where   fromProtoBufRegistry' _ = fromProtoViaSchema @_ @_ @s <|> fromProtoBufRegistry' (Proxy @ms) @@ -169,30 +178,37 @@                              r@(Right _) -> r  -- Top-level terms-class ProtoBridgeTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where-  termToProto :: Term w sch t -> PBEnc.MessageBuilder-  protoToTerm :: PBDec.Parser PBDec.RawMessage (Term w sch t)+class ProtoBridgeTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where+  termToProto :: Term sch t -> PBEnc.MessageBuilder+  protoToTerm :: PBDec.Parser PBDec.RawMessage (Term sch t)  -- Embedded terms-class ProtoBridgeEmbedTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where-  termToEmbedProto :: FieldNumber -> Term w sch t -> PBEnc.MessageBuilder-  embedProtoToFieldValue :: PBDec.Parser PBDec.RawField (Term w sch t)-  embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term w sch t)--class ProtoBridgeField (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where-  fieldToProto :: Field w sch f -> PBEnc.MessageBuilder-  protoToField :: PBDec.Parser PBDec.RawMessage (Field w sch f)+class ProtoBridgeEmbedTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where+  termToEmbedProto :: FieldNumber -> Term sch t -> PBEnc.MessageBuilder+  embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term sch t)+  -- support for packed encodings+  -- https://developers.google.com/protocol-buffers/docs/encoding#packed+  supportsPackingTerm :: Proxy (Term sch t) -> Bool+  termToPackedEmbedProto :: FieldNumber -> [Term sch t] -> PBEnc.MessageBuilder+  embedProtoToPackedFieldValue :: PBDec.Parser PBDec.RawPrimitive [Term sch t] -class ProtoBridgeFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where-  fieldValueToProto :: FieldNumber -> FieldValue w sch t -> PBEnc.MessageBuilder-  protoToFieldValue :: PBDec.Parser PBDec.RawField (FieldValue w sch t)+class ProtoBridgeField (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where+  fieldToProto :: Field sch f -> PBEnc.MessageBuilder+  protoToField :: PBDec.Parser PBDec.RawMessage (Field sch f) -class ProtoBridgeOneFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where-  protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue w sch t)+class ProtoBridgeOneFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where+  defaultOneFieldValue :: Maybe (FieldValue sch t)+  oneFieldValueToProto :: FieldNumber -> FieldValue sch t -> PBEnc.MessageBuilder+  protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue sch t)+  -- support for packed encodings+  -- https://developers.google.com/protocol-buffers/docs/encoding#packed+  supportsPacking         :: Proxy (FieldValue sch t) -> Bool+  packedFieldValueToProto :: FieldNumber -> [FieldValue sch t] -> PBEnc.MessageBuilder+  protoToPackedFieldValue :: PBDec.Parser PBDec.RawPrimitive [FieldValue sch t] -class ProtoBridgeUnionFieldValue (w :: * -> *) (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where-  unionFieldValueToProto :: NS (FieldValue w sch) ts -> PBEnc.MessageBuilder-  protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue w sch) ts)+class ProtoBridgeUnionFieldValue (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where+  unionFieldValueToProto :: NS (FieldValue sch) ts -> PBEnc.MessageBuilder+  protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue sch) ts)  -- -------- -- TERMS --@@ -201,62 +217,61 @@ -- RECORDS -- ------- -instance (All (ProtoBridgeField w sch name) args, ProtoBridgeFields w sch name args)-         => ProtoBridgeTerm w sch ('DRecord name args) where+instance (All (ProtoBridgeField sch name) args, ProtoBridgeFields sch name args)+         => ProtoBridgeTerm sch ('DRecord name args) where   termToProto (TRecord fields) = go fields-    where go :: forall fs. All (ProtoBridgeField w sch name) fs-             => NP (Field w sch) fs -> PBEnc.MessageBuilder+    where go :: forall fs. All (ProtoBridgeField sch name) fs+             => NP (Field sch) fs -> PBEnc.MessageBuilder           go Nil       = mempty-          go (f :* fs) = fieldToProto @_ @_ @w @sch @name f <> go fs-  protoToTerm = TRecord <$> protoToFields @_ @_ @w @sch @name+          go (f :* fs) = fieldToProto @_ @_ @sch @name f <> go fs+  protoToTerm = TRecord <$> protoToFields @_ @_ @sch @name -class ProtoBridgeFields (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where-  protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field w sch) fields)-instance ProtoBridgeFields w sch ty '[] where+class ProtoBridgeFields (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where+  protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field sch) fields)+instance ProtoBridgeFields sch ty '[] where   protoToFields = pure Nil-instance (ProtoBridgeField w sch ty f, ProtoBridgeFields w sch ty fs)-         => ProtoBridgeFields w sch ty (f ': fs) where-  protoToFields = (:*) <$> protoToField @_ @_ @w @sch @ty <*> protoToFields @_ @_ @w @sch @ty+instance (ProtoBridgeField sch ty f, ProtoBridgeFields sch ty fs)+         => ProtoBridgeFields sch ty (f ': fs) where+  protoToFields = (:*) <$> protoToField @_ @_ @sch @ty <*> protoToFields @_ @_ @sch @ty -instance ProtoBridgeTerm w sch ('DRecord name args)-         => ProtoBridgeEmbedTerm w sch ('DRecord name args) where+instance ProtoBridgeTerm sch ('DRecord name args)+         => ProtoBridgeEmbedTerm sch ('DRecord name args) where   termToEmbedProto fid v = PBEnc.embedded fid (termToProto v)-  embedProtoToFieldValue = do-    t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))-    case t of-      Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))-      Just v  -> return v-  embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))+  embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @sch @('DRecord name args))+  supportsPackingTerm _ = False+  termToPackedEmbedProto = error "this is a bug, since we declare we do not support packed encoding"+  embedProtoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding"  -- ENUMERATIONS -- ------------  instance TypeError ('Text "protobuf requires wrapping enums in a message")-         => ProtoBridgeTerm w sch ('DEnum name choices) where+         => ProtoBridgeTerm sch ('DEnum name choices) where   termToProto = error "protobuf requires wrapping enums in a message"   protoToTerm = error "protobuf requires wrapping enums in a message"  instance ProtoBridgeEnum sch name choices-         => ProtoBridgeEmbedTerm w sch ('DEnum name choices) where-  termToEmbedProto fid (TEnum v) = enumToProto @_ @_ @sch @name fid v-  embedProtoToFieldValue    = do n <- PBDec.one PBDec.int32 0-                                 TEnum <$> protoToEnum @_ @_ @sch @name n-  embedProtoToOneFieldValue = do n <- PBDec.int32-                                 TEnum <$> protoToEnum @_ @_ @sch @name n+         => ProtoBridgeEmbedTerm sch ('DEnum name choices) where+  termToEmbedProto fid (TEnum v) = PBEnc.int32 fid (enumToProto @_ @_ @sch @name v)+  embedProtoToOneFieldValue = PBDec.int32 >>= fmap TEnum . protoToEnum @_ @_ @sch @name+  supportsPackingTerm _ = True+  termToPackedEmbedProto fid ts+    = PBEnc.packedVarints fid $ map (\(TEnum v) -> enumToProto @_ @_ @sch @name v) ts+  embedProtoToPackedFieldValue =+    PBDec.packedVarints >>= traverse (fmap TEnum . protoToEnum @_ @_ @sch @name)  class ProtoBridgeEnum (sch :: Schema tn fn) (ty :: tn) (choices :: [ChoiceDef fn]) where-  enumToProto :: FieldNumber -> NS Proxy choices -> PBEnc.MessageBuilder+  enumToProto :: Integral a => NS Proxy choices -> a   protoToEnum :: Int32 -> PBDec.Parser a (NS Proxy choices) instance ProtoBridgeEnum sch ty '[] where   enumToProto = error "empty enum"   protoToEnum _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown enum type")) instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs)          => ProtoBridgeEnum sch ty ('ChoiceDef c ': cs) where-  enumToProto fid (Z _) = PBEnc.int32 fid enumValue-    where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))-  enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v+  enumToProto (Z _) = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))+  enumToProto (S v) = enumToProto @_ @_ @sch @ty v   protoToEnum n-    | n == enumValue = return (Z Proxy)+    | n == enumValue = pure (Z Proxy)     | otherwise      = S <$> protoToEnum @_ @_ @sch @ty n     where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c))) @@ -264,7 +279,7 @@ -- ------  instance TypeError ('Text "protobuf requires wrapping primitives in a message")-         => ProtoBridgeTerm w sch ('DSimple t) where+         => ProtoBridgeTerm sch ('DSimple t) where   termToProto = error "protobuf requires wrapping primitives in a message"   protoToTerm = error "protobuf requires wrapping primitives in a message" @@ -273,23 +288,63 @@ -- ---------  instance {-# OVERLAPPABLE #-}-         (MaybeLike w, Alternative w, ProtoBridgeFieldValue w sch t, KnownNat (FindProtoBufId sch ty name))-         => ProtoBridgeField w sch ty ('FieldDef name t) where-  fieldToProto (Field (likeMaybe -> Just v)) = fieldValueToProto fieldId v+         (ProtoBridgeOneFieldValue sch t, KnownNat (FindProtoBufId sch ty name))+         => ProtoBridgeField sch ty ('FieldDef name t) where+  fieldToProto (Field v) = oneFieldValueToProto fieldId v     where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))-  fieldToProto (Field _) = mempty-  protoToField = Field <$> ((pure <$> protoToFieldValue `at` fieldId) <|> pure empty)+  protoToField+    = Field <$> case defaultOneFieldValue of+        Nothing -> do r <- one (Just <$> protoToOneFieldValue) Nothing `at` fieldId+                      maybe empty pure r+        Just d  -> one protoToOneFieldValue d `at` fieldId <|> pure d     where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))  instance {-# OVERLAPS #-}-         (MaybeLike w, Alternative w, ProtoBridgeUnionFieldValue w (FindProtoBufOneOfIds sch ty name) sch ts)-         => ProtoBridgeField w sch ty ('FieldDef name ('TUnion ts)) where-  fieldToProto (Field (likeMaybe -> Just (FUnion v)))-    = unionFieldValueToProto @_ @_ @w @(FindProtoBufOneOfIds sch ty name) v-  fieldToProto (Field _) = mempty+         (ProtoBridgeOneFieldValue sch t, KnownNat (FindProtoBufId sch ty name))+         => ProtoBridgeField sch ty ('FieldDef name ('TOption t)) where+  fieldToProto (Field (FOption Nothing))  = mempty+  fieldToProto (Field (FOption (Just v))) = oneFieldValueToProto fieldId v+    where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))+  protoToField = Field . FOption <$>+                   (PBDec.one (Just <$> protoToOneFieldValue) Nothing `at` fieldId <|> pure Nothing)+    where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))++class KnownBool (b :: Bool) where+  boolVal :: proxy b -> Bool+instance KnownBool 'True where+  boolVal _ = True+instance KnownBool 'False where+  boolVal _ = False++instance {-# OVERLAPS #-}+         (ProtoBridgeOneFieldValue sch t, KnownNat (FindProtoBufId sch ty name), KnownBool (FindProtoBufPacked sch ty name))+         => ProtoBridgeField sch ty ('FieldDef name ('TList t)) where+  fieldToProto (Field (FList xs))+    | boolVal (Proxy @(FindProtoBufPacked sch ty name)), supportsPacking (Proxy @(FieldValue sch t))+    = packedFieldValueToProto fieldId xs+    | otherwise+    = foldMap (oneFieldValueToProto fieldId) xs+    where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))+  protoToField = Field . FList <$> go+    where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))+          base = PBDec.repeated protoToOneFieldValue `at` fieldId <|> pure []+          go | supportsPacking (Proxy @(FieldValue sch t))+             = PBDec.one protoToPackedFieldValue [] `at` fieldId <|> base+             | otherwise+             = base++instance TypeError ('Text "maps are not currently supported")+         => ProtoBridgeField sch ty ('FieldDef name ('TMap k v)) where+  fieldToProto = error "maps are not currently supported"+  protoToField = error "maps are not currently supported"++instance {-# OVERLAPS #-}+         (ProtoBridgeUnionFieldValue (FindProtoBufOneOfIds sch ty name) sch ts)+         => ProtoBridgeField sch ty ('FieldDef name ('TUnion ts)) where+  fieldToProto (Field (FUnion v))+    = unionFieldValueToProto @_ @_ @(FindProtoBufOneOfIds sch ty name) v   protoToField-    = Field . pure . FUnion <$> protoToUnionFieldValue @_ @_ @w @(FindProtoBufOneOfIds sch ty name)-    <|> pure (Field empty)+    = Field . FUnion <$> protoToUnionFieldValue @_ @_ @(FindProtoBufOneOfIds sch ty name)  -- ------------------ -- TYPES OF FIELDS --@@ -298,130 +353,170 @@ -- SCHEMATIC -- --------- -instance ProtoBridgeEmbedTerm w sch (sch :/: t)-         => ProtoBridgeFieldValue w sch ('TSchematic t) where-  fieldValueToProto fid (FSchematic v) = termToEmbedProto fid v-  protoToFieldValue = FSchematic <$> embedProtoToFieldValue-instance ProtoBridgeEmbedTerm w sch (sch :/: t)-         => ProtoBridgeOneFieldValue w sch ('TSchematic t) where+instance ProtoBridgeEmbedTerm sch (sch :/: t)+         => ProtoBridgeOneFieldValue sch ('TSchematic t) where+  defaultOneFieldValue = Nothing+  oneFieldValueToProto fid (FSchematic v) = termToEmbedProto fid v   protoToOneFieldValue = FSchematic <$> embedProtoToOneFieldValue+  supportsPacking _ = supportsPackingTerm (Proxy @(Term sch (sch :/: t)))+  packedFieldValueToProto fid vs = termToPackedEmbedProto fid $ map (\(FSchematic t) -> t) vs+  protoToPackedFieldValue = map FSchematic <$> embedProtoToPackedFieldValue  -- PRIMITIVE TYPES -- ---------------  instance TypeError ('Text "null cannot be converted to protobuf")-         => ProtoBridgeFieldValue w sch 'TNull where-  fieldValueToProto = error "null cannot be converted to protobuf"-  protoToFieldValue = error "null cannot be converted to protobuf"-instance TypeError ('Text "null cannot be converted to protobuf")-         => ProtoBridgeOneFieldValue w sch 'TNull where+         => ProtoBridgeOneFieldValue sch 'TNull where+  defaultOneFieldValue = error "null cannot be converted to protobuf"+  oneFieldValueToProto = error "null cannot be converted to protobuf"   protoToOneFieldValue = error "null cannot be converted to protobuf"+  supportsPacking _ = False+  packedFieldValueToProto = error "null cannot be converted to protobuf"+  protoToPackedFieldValue = error "null cannot be converted to protobuf" -instance ProtoBridgeFieldValue w sch ('TPrimitive Int) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid (fromIntegral n)-  protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int32 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Int) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid (fromIntegral n)   protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int32+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints -instance ProtoBridgeFieldValue w sch ('TPrimitive Int32) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int32 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int32) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Int32) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid n   protoToOneFieldValue = FPrimitive <$> PBDec.int32+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints -instance ProtoBridgeFieldValue w sch ('TPrimitive Int64) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int64 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int64) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Int64) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid n   protoToOneFieldValue = FPrimitive <$> PBDec.int64+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints  -- WARNING! These instances may go out of bounds-instance ProtoBridgeFieldValue w sch ('TPrimitive Integer) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid (fromInteger n)-  protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int64 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Integer) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Integer) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid (fromInteger n)   protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int64+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints -instance ProtoBridgeFieldValue w sch ('TPrimitive Float) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.float fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.float 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Float) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Float) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.float fid n   protoToOneFieldValue = FPrimitive <$> PBDec.float+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedFloats fid $ map (\(FPrimitive i) -> i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedFloats -instance ProtoBridgeFieldValue w sch ('TPrimitive Double) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.double fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.double 0-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Double) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Double) where+  defaultOneFieldValue = Just $ FPrimitive 0+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.double fid n   protoToOneFieldValue = FPrimitive <$> PBDec.double+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedDoubles fid $ map (\(FPrimitive i) -> i) vs+  protoToPackedFieldValue = map FPrimitive <$> PBDec.packedDoubles -instance ProtoBridgeFieldValue w sch ('TPrimitive Bool) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.enum fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.bool False-instance ProtoBridgeOneFieldValue w sch ('TPrimitive Bool) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive Bool) where+  defaultOneFieldValue = Just $ FPrimitive False+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.enum fid n   protoToOneFieldValue = FPrimitive <$> PBDec.bool+  supportsPacking _ = True+  packedFieldValueToProto fid vs+    = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> if i then 1 else 0) vs+  protoToPackedFieldValue = map (\(i :: Integer) -> FPrimitive (i /= 0)) <$> PBDec.packedVarints -instance ProtoBridgeFieldValue w sch ('TPrimitive T.Text) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.text fid (LT.fromStrict n)-  protoToFieldValue = FPrimitive . LT.toStrict <$> PBDec.one PBDec.text ""-instance ProtoBridgeOneFieldValue w sch ('TPrimitive T.Text) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive T.Text) where+  defaultOneFieldValue = Just $ FPrimitive ""+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.text fid (LT.fromStrict n)   protoToOneFieldValue = FPrimitive . LT.toStrict <$> PBDec.text+  supportsPacking _ = False+  packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding"+  protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" -instance ProtoBridgeFieldValue w sch ('TPrimitive LT.Text) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.text fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.text ""-instance ProtoBridgeOneFieldValue w sch ('TPrimitive LT.Text) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive LT.Text) where+  defaultOneFieldValue = Just $ FPrimitive ""+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.text fid n   protoToOneFieldValue = FPrimitive <$> PBDec.text+  supportsPacking _ = False+  packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding"+  protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" -instance ProtoBridgeFieldValue w sch ('TPrimitive BS.ByteString) where-  fieldValueToProto fid (FPrimitive n) = PBEnc.byteString fid n-  protoToFieldValue = FPrimitive <$> PBDec.one PBDec.byteString ""-instance ProtoBridgeOneFieldValue w sch ('TPrimitive BS.ByteString) where+instance ProtoBridgeOneFieldValue sch ('TPrimitive BS.ByteString) where+  defaultOneFieldValue = Just $ FPrimitive ""+  oneFieldValueToProto fid (FPrimitive n) = PBEnc.byteString fid n   protoToOneFieldValue = FPrimitive <$> PBDec.byteString+  supportsPacking _ = False+  packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding"+  protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding"  -- Note that Maybes and Lists require that we recur on the OneFieldValue class -instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t)-         => ProtoBridgeFieldValue w sch ('TOption t) where-  fieldValueToProto _   (FOption Nothing)  = mempty-  fieldValueToProto fid (FOption (Just v)) = fieldValueToProto fid v-  protoToFieldValue = FOption <$> PBDec.one (Just <$> protoToOneFieldValue) Nothing- instance TypeError ('Text "optionals cannot be nested in protobuf")-         => ProtoBridgeOneFieldValue w sch ('TOption t) where+         => ProtoBridgeOneFieldValue sch ('TOption t) where+  defaultOneFieldValue = error "optionals cannot be nested in protobuf"+  oneFieldValueToProto = error "optionals cannot be nested in protobuf"   protoToOneFieldValue = error "optionals cannot be nested in protobuf"--instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t)-         => ProtoBridgeFieldValue w sch ('TList t) where-  fieldValueToProto fid (FList xs) = foldMap (fieldValueToProto fid) xs-  protoToFieldValue = FList <$> PBDec.repeated protoToOneFieldValue+  supportsPacking      = error "optionals cannot be nested in protobuf"+  packedFieldValueToProto = error "optionals cannot be nested in protobuf"+  protoToPackedFieldValue = error "optionals cannot be nested in protobuf"  instance TypeError ('Text "lists cannot be nested in protobuf")-         => ProtoBridgeOneFieldValue w sch ('TList t) where+         => ProtoBridgeOneFieldValue sch ('TList t) where+  defaultOneFieldValue = error "lists cannot be nested in protobuf"+  oneFieldValueToProto = error "lists cannot be nested in protobuf"   protoToOneFieldValue = error "lists cannot be nested in protobuf"+  supportsPacking      = error "lists cannot be nested in protobuf"+  packedFieldValueToProto = error "lists cannot be nested in protobuf"+  protoToPackedFieldValue = error "lists cannot be nested in protobuf"  instance TypeError ('Text "maps are not currently supported")-         => ProtoBridgeFieldValue w sch ('TMap k v) where-  fieldValueToProto = error "maps are not currently supported"-  protoToFieldValue = error "maps are not currently supported"+         => ProtoBridgeOneFieldValue sch ('TMap k v) where+  defaultOneFieldValue = error "maps are not currently supported"+  oneFieldValueToProto = error "maps are not currently supported"+  protoToOneFieldValue = error "maps are not currently supported"+  supportsPacking      = error "maps are not currently supported"+  packedFieldValueToProto = error "maps are not currently supported"+  protoToPackedFieldValue = error "maps are not currently supported"  instance TypeError ('Text "nested unions are not currently supported")-         => ProtoBridgeFieldValue w sch ('TUnion choices) where-  fieldValueToProto = error "nested unions are not currently supported"-  protoToFieldValue = error "nested unions are not currently supported"+         => ProtoBridgeOneFieldValue sch ('TUnion choices) where+  defaultOneFieldValue = error "nested unions are not currently supported"+  oneFieldValueToProto = error "nested unions are not currently supported"+  protoToOneFieldValue = error "nested unions are not currently supported"+  supportsPacking      = error "nested unions are not currently supported"+  packedFieldValueToProto = error "nested unions are not currently supported"+  protoToPackedFieldValue = error "nested unions are not currently supported"  -- UNIONS -- ------ -instance ProtoBridgeUnionFieldValue w ids sch '[] where+instance ProtoBridgeUnionFieldValue ids sch '[] where   unionFieldValueToProto = error "empty list of unions"   protoToUnionFieldValue = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown type in an union")) -instance ( ProtoBridgeFieldValue w sch t, KnownNat thisId-         , ProtoBridgeUnionFieldValue w restIds sch ts )-         => ProtoBridgeUnionFieldValue w (thisId ': restIds) sch (t ': ts) where-  unionFieldValueToProto (Z v) = fieldValueToProto fieldId v+instance ( ProtoBridgeOneFieldValue sch t, KnownNat thisId+         , ProtoBridgeUnionFieldValue restIds sch ts )+         => ProtoBridgeUnionFieldValue (thisId ': restIds) sch (t ': ts) where+  unionFieldValueToProto (Z v) = oneFieldValueToProto fieldId v     where fieldId = fromInteger $ natVal (Proxy @thisId)-  unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @w @restIds v+  unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v   protoToUnionFieldValue-    = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @w @restIds+    = Z <$> p <|> S <$> protoToUnionFieldValue @_ @_ @restIds     where fieldId = fromInteger $ natVal (Proxy @thisId)+          p = case defaultOneFieldValue of+            Nothing -> do r <- one (Just <$> protoToOneFieldValue) Nothing `at` fieldId+                          maybe empty pure r+            Just d  -> one protoToOneFieldValue d `at` fieldId <|> pure d

@@ -28,11 +28,11 @@  -- | Specifies that a type is turned into a Protocol Buffers --   message by using the schema as intermediate representation.-newtype ViaToProtoBufTypeRef (ref :: TypeRef) t+newtype ViaToProtoBufTypeRef (ref :: TypeRef snm) t   = ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t } -- | Specifies that a type can be parsed from a Protocol Buffers --   message by using the schema as intermediate representation.-newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t+newtype ViaFromProtoBufTypeRef (ref :: TypeRef snm) t   = ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }  instance ToProtoBufTypeRef ref t@@ -46,29 +46,29 @@  instance Proto3WireEncoder () where   proto3WireEncode _ = mempty-  proto3WireDecode = return ()+  proto3WireDecode = pure ()  -- | Types which can be parsed from a Protocol Buffers message.-class FromProtoBufTypeRef (ref :: TypeRef) t where+class FromProtoBufTypeRef (ref :: TypeRef snm) t where   fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t -- | Types which can be turned into a Protocol Buffers message.-class ToProtoBufTypeRef (ref :: TypeRef) t where+class ToProtoBufTypeRef (ref :: TypeRef snm) t where   toProtoBufTypeRef   :: Proxy ref -> t -> PBEnc.MessageBuilder -instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)-         => FromProtoBufTypeRef ('ViaSchema sch sty) t where+instance (IsProtoSchema sch sty, FromSchema sch sty t)+         => FromProtoBufTypeRef ('SchemaRef sch sty) t where   fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch-instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)-         => ToProtoBufTypeRef ('ViaSchema sch sty) t where+instance (IsProtoSchema sch sty, ToSchema sch sty t)+         => ToProtoBufTypeRef ('SchemaRef sch sty) t where   toProtoBufTypeRef   _ = toProtoViaSchema @_ @_ @sch  instance ( FromProtoBufRegistry r t-         , IsProtoSchema Maybe (MappingRight r last) sty-         , FromSchema Maybe (MappingRight r last) sty t )-         => FromProtoBufTypeRef ('ViaRegistry r t last) t where+         , IsProtoSchema (MappingRight r last) sty+         , FromSchema (MappingRight r last) sty t )+         => FromProtoBufTypeRef ('RegistryRef r t last) t where   fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r instance ( FromProtoBufRegistry r t-         , IsProtoSchema Maybe (MappingRight r last) sty-         , ToSchema Maybe (MappingRight r last) sty t )-         => ToProtoBufTypeRef ('ViaRegistry r t last) t where+         , IsProtoSchema (MappingRight r last) sty+         , ToSchema (MappingRight r last) sty t )+         => ToProtoBufTypeRef ('RegistryRef r t last) t where   toProtoBufTypeRef   _ = toProtoViaSchema @_ @_ @(MappingRight r last)

@@ -60,7 +60,7 @@   = do let schemaName' = mkName schemaName        schemaDec <- protobufToDecls schemaName p        serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs-       return (schemaDec ++ serviceTy)+       pure (schemaDec ++ serviceTy)  pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)@@ -69,11 +69,12 @@  pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type pbServiceDeclToType pkg schema (P.Service nm _ methods)-  = [t| 'Service $(textToStrLit nm) $(pkgType pkg)-                 $(typesToList <$> mapM (pbMethodToType schema) methods) |]+  = [t| 'Package $(pkgType pkg)+          '[ 'Service $(textToStrLit nm) '[]+                      $(typesToList <$> mapM (pbMethodToType schema) methods) ] |]   where-    pkgType Nothing  = [t| '[] |]-    pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]+    pkgType Nothing  = [t| 'Nothing |]+    pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]  pbMethodToType :: Name -> P.Method -> Q Type pbMethodToType s (P.Method nm vr v rr r _)@@ -83,27 +84,27 @@     argToType P.Single (P.TOther ["google","protobuf","Empty"])       = [t| '[ ] |]     argToType P.Single (P.TOther a)-      = [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]+      = [t| '[ 'ArgSingle 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]     argToType P.Stream (P.TOther a)-      = [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]+      = [t| '[ 'ArgStream 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]     argToType _ _       = fail "only message types may be used as arguments"      retToType P.Single (P.TOther ["google","protobuf","Empty"])       = [t| 'RetNothing |]     retToType P.Single (P.TOther a)-      = [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]+      = [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]     retToType P.Stream (P.TOther a)-      = [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]+      = [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]     retToType _ _       = fail "only message types may be used as results"  schemaTy :: Name -> Q Type-schemaTy schema = return $ ConT schema+schemaTy schema = pure $ ConT schema  typesToList :: [Type] -> Type typesToList   = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT textToStrLit :: T.Text -> Q Type textToStrLit s-  = return $ LitT $ StrTyLit $ T.unpack s+  = pure $ LitT $ StrTyLit $ T.unpack s

@@ -1,8 +1,9 @@-{-# language CPP             #-}-{-# language DataKinds       #-}-{-# language LambdaCase      #-}-{-# language NamedFieldPuns  #-}-{-# language TemplateHaskell #-}+{-# language CPP               #-}+{-# language DataKinds         #-}+{-# language LambdaCase        #-}+{-# language NamedFieldPuns    #-}+{-# language OverloadedStrings #-}+{-# language TemplateHaskell   #-} {-| Description : Quasi-quoters for Protocol Buffers schemas @@ -26,8 +27,8 @@ import qualified Language.ProtocolBuffers.Types  as P  import           Mu.Adapter.ProtoBuf-import           Mu.Schema.Definition import           Mu.Schema.Annotations+import           Mu.Schema.Definition  -- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema' --   with all the message types, using the name given@@ -46,22 +47,22 @@ protobufToDecls schemaName p   = do let schemaName' = mkName schemaName        (schTy, annTy) <- schemaFromProtoBuf p-       schemaDec <- tySynD schemaName' [] (return schTy)+       schemaDec <- tySynD schemaName' [] (pure schTy) #if MIN_VERSION_template_haskell(2,15,0)        annDec <- tySynInstD (tySynEqn Nothing                                [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]-                               (return annTy))+                               (pure annTy)) #else        annDec <- tySynInstD ''AnnotatedSchema-                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))+                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy)) #endif-       return [schemaDec, annDec]+       pure [schemaDec, annDec]  schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type) schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do   let decls = flattenDecls tys   (schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls-  return (typesToList schTys, typesToList (concat anns))+  pure (typesToList schTys, typesToList (concat anns))  flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration] flattenDecls = concatMap flattenDecl@@ -73,26 +74,33 @@ pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type]) pbTypeDeclToType (P.DEnum name _ fields) = do   (tys, anns) <- unzip <$> mapM pbChoiceToType fields-  (,) <$> [t|'DEnum $(textToStrLit name) $(return $ typesToList tys)|] <*> pure anns+  (,) <$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns   where     pbChoiceToType :: P.EnumField -> Q (Type, Type)     pbChoiceToType (P.EnumField nm number _)       = (,) <$> [t|'ChoiceDef $(textToStrLit nm) |]-            <*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number)) |]+            <*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) 'True) |] pbTypeDeclToType (P.DMessage name _ _ fields _) = do   (tys, anns) <- unzip <$> mapM pbMsgFieldToType fields   (,) <$> [t|'DRecord $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns   where     pbMsgFieldToType :: P.MessageField -> Q (Type, Type)-    pbMsgFieldToType (P.NormalField P.Single ty nm n _)+    -- If we have a field type which is not primitive,+    -- it's possible to distinguish whether it's missing on wire+    -- or should be set to the default, so use Option+    -- +info -> https://github.com/higherkindness/mu-haskell/pull/130#issuecomment-596433307+    pbMsgFieldToType (P.NormalField P.Single ty@(P.TOther _) nm n opts)+      = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TOption $(pbFieldTypeToType ty)) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]+    pbMsgFieldToType (P.NormalField P.Single ty nm n opts)       = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]-    pbMsgFieldToType (P.NormalField P.Repeated ty nm n _)+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]+    pbMsgFieldToType (P.NormalField P.Repeated ty nm n opts)       = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]-    pbMsgFieldToType (P.MapField k v nm n _)+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]+    pbMsgFieldToType (P.MapField k v nm n opts)       = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]     pbMsgFieldToType (P.OneOfField nm vs)       | any (not . hasFieldNumber) vs       = fail "nested oneof fields are not supported"@@ -134,11 +142,20 @@       = [t| 'TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v) |]     pbOneOfFieldToType _ = error "this should never happen" +    pbOptionsToPacked []+      = [t| 'True |]+    pbOptionsToPacked (P.Option ["packed"] val : _)+      | P.KBool True  <- val = [t| 'True  |]+      | P.KBool False <- val = [t| 'False |]+      | otherwise = fail "'packed' with a non-boolean value"+    pbOptionsToPacked (_ : rest)+      = pbOptionsToPacked rest+ typesToList :: [Type] -> Type typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT  textToStrLit :: T.Text -> Q Type-textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s+textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s  intToLit :: Int -> Q Type-intToLit n = return $ LitT $ NumTyLit $ toInteger n+intToLit n = pure $ LitT $ NumTyLit $ toInteger n

@@ -21,44 +21,46 @@ import           Mu.Schema.Examples  data MPerson-  = MPerson { firstName :: Maybe T.Text-            , lastName  :: Maybe T.Text-            , age       :: Maybe (Maybe Int)-            , gender    :: Maybe (Maybe Gender)-            , address   :: Maybe MAddress }+  = MPerson { firstName     :: T.Text+            , lastName      :: T.Text+            , age           :: Maybe Int+            , gender        :: Maybe Gender+            , address       :: MAddress+            , lucky_numbers :: [Int] }   deriving (Eq, Show, Generic)-  deriving (ToSchema Maybe ExampleSchema "person")-  deriving (FromSchema Maybe ExampleSchema "person")+  deriving (ToSchema ExampleSchema "person")+  deriving (FromSchema ExampleSchema "person")  data MAddress-  = MAddress { postcode :: Maybe T.Text-             , country  :: Maybe T.Text }+  = MAddress { postcode :: T.Text+             , country  :: T.Text }   deriving (Eq, Show, Generic)-  deriving (ToSchema Maybe ExampleSchema "address")-  deriving (FromSchema Maybe ExampleSchema "address")+  deriving (ToSchema ExampleSchema "address")+  deriving (FromSchema ExampleSchema "address")  type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema-  = '[ 'AnnField "gender" "male"   ('ProtoBufId 1)-     , 'AnnField "gender" "female" ('ProtoBufId 2)-     , 'AnnField "gender" "nb"     ('ProtoBufId 3)-     , 'AnnField "address" "postcode" ('ProtoBufId 1)-     , 'AnnField "address" "country"  ('ProtoBufId 2)-     , 'AnnField "person" "firstName" ('ProtoBufId 1)-     , 'AnnField "person" "lastName"  ('ProtoBufId 2)-     , 'AnnField "person" "age"       ('ProtoBufId 3)-     , 'AnnField "person" "gender"    ('ProtoBufId 4)-     , 'AnnField "person" "address"   ('ProtoBufId 5) ]+  = '[ 'AnnField "gender" "male"   ('ProtoBufId 1 'True)+     , 'AnnField "gender" "female" ('ProtoBufId 2 'True)+     , 'AnnField "gender" "nb"     ('ProtoBufId 3 'True)+     , 'AnnField "address" "postcode" ('ProtoBufId 1 'True)+     , 'AnnField "address" "country"  ('ProtoBufId 2 'True)+     , 'AnnField "person" "firstName" ('ProtoBufId 1 'True)+     , 'AnnField "person" "lastName"  ('ProtoBufId 2 'True)+     , 'AnnField "person" "age"       ('ProtoBufId 3 'True)+     , 'AnnField "person" "gender"    ('ProtoBufId 4 'True)+     , 'AnnField "person" "address"   ('ProtoBufId 5 'True)+     , 'AnnField "person" "lucky_numbers" ('ProtoBufId 6 'True) ]  exampleAddress :: MAddress-exampleAddress = MAddress (Just "1111BB") (Just "Spain")+exampleAddress = MAddress "1111BB" "Spain"  examplePerson1, examplePerson2 :: MPerson-examplePerson1 = MPerson (Just "Haskellio") (Just "Gómez")-                         (Just $ Just 30) (Just $ Just Male)-                         (Just exampleAddress)-examplePerson2 = MPerson (Just "Cuarenta") (Just "Siete")-                         (Just Nothing) (Just Nothing)-                         (Just exampleAddress)+examplePerson1 = MPerson "Haskellio" "Gómez"+                         (Just 30) (Just Male)+                         exampleAddress [1,2,3]+examplePerson2 = MPerson "Cuarenta" "Siete"+                         Nothing Nothing+                         exampleAddress []  main :: IO () main = do -- Obtain the filenames

@@ -6,6 +6,7 @@   int32 age = 3;   gender gender = 4;   address address = 5;+  repeated int32 lucky_numbers = 6 [packed=true]; }  message address {