diff --git a/mu-protobuf.cabal b/mu-protobuf.cabal --- a/mu-protobuf.cabal +++ b/mu-protobuf.cabal @@ -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 diff --git a/src/Mu/Adapter/ProtoBuf.hs b/src/Mu/Adapter/ProtoBuf.hs --- a/src/Mu/Adapter/ProtoBuf.hs +++ b/src/Mu/Adapter/ProtoBuf.hs @@ -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 diff --git a/src/Mu/Adapter/ProtoBuf/Via.hs b/src/Mu/Adapter/ProtoBuf/Via.hs --- a/src/Mu/Adapter/ProtoBuf/Via.hs +++ b/src/Mu/Adapter/ProtoBuf/Via.hs @@ -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) diff --git a/src/Mu/Quasi/GRpc.hs b/src/Mu/Quasi/GRpc.hs --- a/src/Mu/Quasi/GRpc.hs +++ b/src/Mu/Quasi/GRpc.hs @@ -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 diff --git a/src/Mu/Quasi/ProtoBuf.hs b/src/Mu/Quasi/ProtoBuf.hs --- a/src/Mu/Quasi/ProtoBuf.hs +++ b/src/Mu/Quasi/ProtoBuf.hs @@ -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 diff --git a/test/ProtoBuf.hs b/test/ProtoBuf.hs --- a/test/ProtoBuf.hs +++ b/test/ProtoBuf.hs @@ -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 diff --git a/test/protobuf/example.proto b/test/protobuf/example.proto --- a/test/protobuf/example.proto +++ b/test/protobuf/example.proto @@ -6,6 +6,7 @@ int32 age = 3; gender gender = 4; address address = 5; + repeated int32 lucky_numbers = 6 [packed=true]; } message address {