mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Keep all annotations from .proto files (#222)
Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>
This commit is contained in:
Alejandro Serrano
GitHub
parent
2a413c7c48
commit
fc423dc387
@ -26,6 +26,7 @@ need to annotate your schema using 'ProtoBufAnnotation'.
|
||||
module Mu.Adapter.ProtoBuf (
|
||||
-- * Custom annotations
|
||||
ProtoBufAnnotation(..)
|
||||
, ProtoBufOptionConstant(..)
|
||||
-- * Conversion using schemas
|
||||
, IsProtoSchema
|
||||
, toProtoViaSchema
|
||||
@ -62,16 +63,23 @@ instance ProtoEnum Bool
|
||||
data ProtoBufAnnotation
|
||||
= -- | Numeric field identifier for normal fields
|
||||
-- and whether it should be packed (only used for lists of number-like values)
|
||||
ProtoBufId Nat Bool
|
||||
ProtoBufId Nat [(Symbol, ProtoBufOptionConstant)]
|
||||
-- | List of identifiers for fields which contain a union
|
||||
| ProtoBufOneOfIds [Nat]
|
||||
|
||||
-- Values for constants
|
||||
data ProtoBufOptionConstant
|
||||
= ProtoBufOptionConstantInt Nat
|
||||
| ProtoBufOptionConstantBool Bool
|
||||
| ProtoBufOptionConstantObject [(Symbol, ProtoBufOptionConstant)]
|
||||
| ProtoBufOptionConstantOther Symbol
|
||||
|
||||
type family FindProtoBufId (sch :: Schema tn fn) (t :: tn) (f :: fn) where
|
||||
FindProtoBufId sch t f
|
||||
= 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 b) = n
|
||||
FindProtoBufId' t f ('ProtoBufId n opts) = n
|
||||
FindProtoBufId' t f other
|
||||
= TypeError ('Text "protocol buffers id not available for field "
|
||||
':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)
|
||||
@ -81,11 +89,22 @@ type family FindProtoBufPacked (sch :: Schema tn fn) (t :: tn) (f :: fn) where
|
||||
= 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 ('ProtoBufId n opts)
|
||||
= FindProtoBufPacked'' t f opts
|
||||
FindProtoBufPacked' t f other
|
||||
= TypeError ('Text "protocol buffers id not available for field "
|
||||
':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)
|
||||
|
||||
type family FindProtoBufPacked'' (t :: tn) (f :: fn) (opts :: [(Symbol, ProtoBufOptionConstant)]) :: Bool where
|
||||
FindProtoBufPacked'' t f '[] = 'True -- by default we are packed
|
||||
FindProtoBufPacked'' t f ( '("packed", 'ProtoBufOptionConstantBool b) ': rest )
|
||||
= b -- found!
|
||||
FindProtoBufPacked'' t f ( '("packed", other) ': rest )
|
||||
= TypeError ('Text "non-boolean value for 'packed' for field "
|
||||
':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)
|
||||
FindProtoBufPacked'' t f ( other ': rest)
|
||||
= FindProtoBufPacked'' t f rest
|
||||
|
||||
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)
|
||||
|
||||
@ -80,7 +80,7 @@ pbTypeDeclToType (P.DEnum name _ fields) = do
|
||||
pbChoiceToType :: P.EnumField -> Q (Type, Type)
|
||||
pbChoiceToType (P.EnumField nm number _)
|
||||
= (,) <$> [t|'ChoiceDef $(textToStrLit nm) |]
|
||||
<*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) 'True) |]
|
||||
<*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) '[]) |]
|
||||
pbTypeDeclToType (P.DMessage name _ _ fields _) = do
|
||||
(tys, anns) <- unzip <$> mapM pbMsgFieldToType fields
|
||||
(,) <$> [t|'DRecord $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns
|
||||
@ -90,22 +90,18 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = do
|
||||
-- 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) = do
|
||||
reportDefaultWarning opts
|
||||
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) = do
|
||||
reportDefaultWarning opts
|
||||
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption 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) $(pbOptionsToPacked opts)) |]
|
||||
pbMsgFieldToType (P.NormalField P.Repeated ty nm n opts) = do
|
||||
reportDefaultWarning opts
|
||||
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption 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) $(pbOptionsToPacked opts)) |]
|
||||
pbMsgFieldToType (P.MapField k v nm n opts) = do
|
||||
reportDefaultWarning opts
|
||||
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption 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) $(pbOptionsToPacked opts)) |]
|
||||
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]
|
||||
pbMsgFieldToType (P.OneOfField nm vs)
|
||||
| not (all hasFieldNumber vs)
|
||||
= fail "nested oneof fields are not supported"
|
||||
@ -114,11 +110,6 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = do
|
||||
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm)
|
||||
('ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs )) |]
|
||||
|
||||
reportDefaultWarning :: [P.Option] -> Q ()
|
||||
reportDefaultWarning opts =
|
||||
when (any (\(P.Option ident _) -> ident == ["default"]) opts)
|
||||
(reportError "mu-protobuf does not (yet) support default values")
|
||||
|
||||
pbFieldTypeToType :: P.FieldType -> Q Type
|
||||
pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|]
|
||||
pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported"
|
||||
@ -152,14 +143,27 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = do
|
||||
= [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
|
||||
pbOption (P.Option oname val)
|
||||
= do when (oname == ["default"])
|
||||
(reportError "mu-protobuf does not (yet) support default values")
|
||||
[t| '( $(textToStrLit (T.intercalate "." oname))
|
||||
, $(pbConstantToOption val) ) |]
|
||||
|
||||
pbConstantToOption (P.KIdentifier names)
|
||||
= [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.intercalate "." names)) |]
|
||||
pbConstantToOption (P.KInt n)
|
||||
= [t| 'ProtoBufOptionConstantInt $(intToLit (fromInteger n)) |]
|
||||
pbConstantToOption (P.KBool True)
|
||||
= [t| 'ProtoBufOptionConstantBool 'True |]
|
||||
pbConstantToOption (P.KBool False)
|
||||
= [t| 'ProtoBufOptionConstantBool 'False |]
|
||||
pbConstantToOption (P.KString s)
|
||||
= [t| 'ProtoBufOptionConstantOther $(textToStrLit s) |]
|
||||
pbConstantToOption (P.KFloat s)
|
||||
= [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.pack (show s))) |]
|
||||
pbConstantToOption (P.KObject s)
|
||||
= [t| 'ProtoBufOptionConstantObject
|
||||
$(typesToList <$> mapM (\(n, o) -> [t| '( $(textToStrLit n), $(pbConstantToOption o) ) |] ) s ) |]
|
||||
|
||||
typesToList :: [Type] -> Type
|
||||
typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT
|
||||
|
||||
@ -39,17 +39,17 @@ data MAddress
|
||||
deriving (FromSchema ExampleSchema "address")
|
||||
|
||||
type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema
|
||||
= '[ '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) ]
|
||||
= '[ '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 "person" "lucky_numbers" ('ProtoBufId 6 '[ '("packed", 'ProtoBufOptionConstantBool 'True) ]) ]
|
||||
|
||||
exampleAddress :: MAddress
|
||||
exampleAddress = MAddress "1111BB" "Spain"
|
||||
|
||||
@ -20,9 +20,9 @@ import Mu.Rpc.Examples
|
||||
import Mu.Schema
|
||||
|
||||
type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema
|
||||
= '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 'True)
|
||||
, 'AnnField "HelloResponse" "message" ('ProtoBufId 1 'True)
|
||||
, 'AnnField "HiRequest" "number" ('ProtoBufId 1 'True) ]
|
||||
= '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 '[])
|
||||
, 'AnnField "HelloResponse" "message" ('ProtoBufId 1 '[])
|
||||
, 'AnnField "HiRequest" "number" ('ProtoBufId 1 '[]) ]
|
||||
|
||||
sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text)
|
||||
sayHello' host port req
|
||||
|
||||
@ -9,9 +9,9 @@ import Mu.Rpc.Examples
|
||||
import Mu.Schema
|
||||
|
||||
type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema
|
||||
= '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 'True)
|
||||
, 'AnnField "HelloResponse" "message" ('ProtoBufId 1 'True)
|
||||
, 'AnnField "HiRequest" "number" ('ProtoBufId 1 'True) ]
|
||||
= '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1 '[])
|
||||
, 'AnnField "HelloResponse" "message" ('ProtoBufId 1 '[])
|
||||
, 'AnnField "HiRequest" "number" ('ProtoBufId 1 '[]) ]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user