{-# language CPP               #-}
{-# language DataKinds         #-}
{-# language LambdaCase        #-}
{-# language NamedFieldPuns    #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell   #-}
{-|
Description : Quasi-quoters for Protocol Buffers schemas

Read @.proto@ files as a 'Mu.Schema.Definition.Schema'.
If you want to get the service definitions too,
you should use 'Mu.Quasi.GRpc' instead.
-}
module Mu.Quasi.ProtoBuf (
  -- * Quasi-quoters for @.proto@ files
    protobuf
  -- * Only for internal use
  , protobufToDecls
  ) where

import           Control.Monad                   (when)
import           Control.Monad.IO.Class
import qualified Data.ByteString                 as B
import           Data.Int
import qualified Data.List                       as L
import           Data.List.NonEmpty              (NonEmpty (..))
import qualified Data.Text                       as T
import           Data.Word
import           Language.Haskell.TH
import           Language.ProtocolBuffers.Parser
import qualified Language.ProtocolBuffers.Types  as P

import           Mu.Adapter.ProtoBuf
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
--   as first argument.
protobuf :: String -> FilePath -> Q [Dec]
protobuf :: String -> String -> Q [Dec]
protobuf String
schemaName String
fp
  = do Either (ParseErrorBundle Text Char) ProtoBuf
r <- IO (Either (ParseErrorBundle Text Char) ProtoBuf)
-> Q (Either (ParseErrorBundle Text Char) ProtoBuf)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ParseErrorBundle Text Char) ProtoBuf)
 -> Q (Either (ParseErrorBundle Text Char) ProtoBuf))
-> IO (Either (ParseErrorBundle Text Char) ProtoBuf)
-> Q (Either (ParseErrorBundle Text Char) ProtoBuf)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either (ParseErrorBundle Text Char) ProtoBuf)
parseProtoBufFile String
fp
       case Either (ParseErrorBundle Text Char) ProtoBuf
r of
         Left ParseErrorBundle Text Char
e
           -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not parse protocol buffers spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseErrorBundle Text Char -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Char
e)
         Right ProtoBuf
p
           -> String -> ProtoBuf -> Q [Dec]
protobufToDecls String
schemaName ProtoBuf
p

-- | Shared portion of Protocol Buffers and gRPC quasi-quoters.
protobufToDecls :: String -> P.ProtoBuf -> Q [Dec]
protobufToDecls :: String -> ProtoBuf -> Q [Dec]
protobufToDecls String
schemaName ProtoBuf
p
  = do let schemaName' :: Name
schemaName' = String -> Name
mkName String
schemaName
       (Type
schTy, Type
annTy) <- ProtoBuf -> Q (Type, Type)
schemaFromProtoBuf ProtoBuf
p
       Dec
schemaDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
schemaName' [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
schTy)
#if MIN_VERSION_template_haskell(2,15,0)
       Dec
annDec <- TySynEqnQ -> DecQ
tySynInstD (Maybe [TyVarBndr] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing
                               [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]
                               (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
annTy))
#else
       annDec <- tySynInstD ''AnnotatedSchema
                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy))
#endif
       [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
schemaDec, Dec
annDec]

schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type)
schemaFromProtoBuf :: ProtoBuf -> Q (Type, Type)
schemaFromProtoBuf P.ProtoBuf {types :: ProtoBuf -> [TypeDeclaration]
P.types = [TypeDeclaration]
tys} = do
  let decls :: [TypeDeclaration]
decls = NonEmpty (Text, [TypeDeclaration])
-> [TypeDeclaration] -> [TypeDeclaration]
flattenDecls ((Text
"", [TypeDeclaration]
tys) (Text, [TypeDeclaration])
-> [(Text, [TypeDeclaration])]
-> NonEmpty (Text, [TypeDeclaration])
forall a. a -> [a] -> NonEmpty a
:| []) [TypeDeclaration]
tys
  ([Type]
schTys, [[Type]]
anns) <- [(Type, [Type])] -> ([Type], [[Type]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, [Type])] -> ([Type], [[Type]]))
-> Q [(Type, [Type])] -> Q ([Type], [[Type]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDeclaration -> Q (Type, [Type]))
-> [TypeDeclaration] -> Q [(Type, [Type])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeDeclaration -> Q (Type, [Type])
pbTypeDeclToType [TypeDeclaration]
decls
  (Type, Type) -> Q (Type, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> Type
typesToList [Type]
schTys, [Type] -> Type
typesToList ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
anns))

flattenDecls :: NonEmpty (P.Identifier, [P.TypeDeclaration]) -> [P.TypeDeclaration] -> [P.TypeDeclaration]
flattenDecls :: NonEmpty (Text, [TypeDeclaration])
-> [TypeDeclaration] -> [TypeDeclaration]
flattenDecls ((Text, [TypeDeclaration])
currentScope :| [(Text, [TypeDeclaration])]
higherScopes) = (TypeDeclaration -> [TypeDeclaration])
-> [TypeDeclaration] -> [TypeDeclaration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypeDeclaration -> [TypeDeclaration]
flattenDecl
  where
    flattenDecl :: TypeDeclaration -> [TypeDeclaration]
flattenDecl (P.DEnum Text
name [Option]
o [EnumField]
f) = [Text -> [Option] -> [EnumField] -> TypeDeclaration
P.DEnum (Text -> Text
prependCurrentScope Text
name) [Option]
o [EnumField]
f]
    flattenDecl (P.DMessage Text
name [Option]
o [Reserved]
r [MessageField]
fs [TypeDeclaration]
decls) =
      let newScopeName :: Text
newScopeName = Text -> Text
prependCurrentScope Text
name
          newScopes :: NonEmpty (Text, [TypeDeclaration])
newScopes = (Text
newScopeName, [TypeDeclaration]
decls) (Text, [TypeDeclaration])
-> [(Text, [TypeDeclaration])]
-> NonEmpty (Text, [TypeDeclaration])
forall a. a -> [a] -> NonEmpty a
:| ((Text, [TypeDeclaration])
currentScope (Text, [TypeDeclaration])
-> [(Text, [TypeDeclaration])] -> [(Text, [TypeDeclaration])]
forall a. a -> [a] -> [a]
: [(Text, [TypeDeclaration])]
higherScopes)
      in Text
-> [Option]
-> [Reserved]
-> [MessageField]
-> [TypeDeclaration]
-> TypeDeclaration
P.DMessage Text
newScopeName [Option]
o [Reserved]
r (NonEmpty (Text, [TypeDeclaration]) -> MessageField -> MessageField
forall (t :: * -> *).
Foldable t =>
NonEmpty (Text, t TypeDeclaration) -> MessageField -> MessageField
scopeFieldType NonEmpty (Text, [TypeDeclaration])
newScopes (MessageField -> MessageField) -> [MessageField] -> [MessageField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MessageField]
fs) [] TypeDeclaration -> [TypeDeclaration] -> [TypeDeclaration]
forall a. a -> [a] -> [a]
: NonEmpty (Text, [TypeDeclaration])
-> [TypeDeclaration] -> [TypeDeclaration]
flattenDecls NonEmpty (Text, [TypeDeclaration])
newScopes [TypeDeclaration]
decls

    scopeFieldType :: NonEmpty (Text, t TypeDeclaration) -> MessageField -> MessageField
scopeFieldType NonEmpty (Text, t TypeDeclaration)
scopes (P.NormalField Repetition
frep FieldType
ftype Text
fname FieldNumber
fnum [Option]
fopts) =
      Repetition
-> FieldType -> Text -> FieldNumber -> [Option] -> MessageField
P.NormalField Repetition
frep (NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
forall (t :: * -> *).
Foldable t =>
NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
qualifyType NonEmpty (Text, t TypeDeclaration)
scopes FieldType
ftype) Text
fname FieldNumber
fnum [Option]
fopts
    scopeFieldType NonEmpty (Text, t TypeDeclaration)
scopes (P.OneOfField Text
fname [MessageField]
fields) = Text -> [MessageField] -> MessageField
P.OneOfField Text
fname (NonEmpty (Text, t TypeDeclaration) -> MessageField -> MessageField
scopeFieldType NonEmpty (Text, t TypeDeclaration)
scopes (MessageField -> MessageField) -> [MessageField] -> [MessageField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MessageField]
fields)
    scopeFieldType NonEmpty (Text, t TypeDeclaration)
scopes (P.MapField FieldType
fkey FieldType
fval Text
fname FieldNumber
fnumber [Option]
fopts) =
      FieldType
-> FieldType -> Text -> FieldNumber -> [Option] -> MessageField
P.MapField (NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
forall (t :: * -> *).
Foldable t =>
NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
qualifyType NonEmpty (Text, t TypeDeclaration)
scopes FieldType
fkey) (NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
forall (t :: * -> *).
Foldable t =>
NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
qualifyType NonEmpty (Text, t TypeDeclaration)
scopes FieldType
fval) Text
fname FieldNumber
fnumber [Option]
fopts

    qualifyType :: NonEmpty (Text, t TypeDeclaration) -> FieldType -> FieldType
qualifyType NonEmpty (Text, t TypeDeclaration)
scopes (P.TOther TypeName
ts) = TypeName -> FieldType
P.TOther (NonEmpty (Text, t TypeDeclaration) -> TypeName -> TypeName
forall (t :: * -> *).
Foldable t =>
NonEmpty (Text, t TypeDeclaration) -> TypeName -> TypeName
qualifyTOther NonEmpty (Text, t TypeDeclaration)
scopes TypeName
ts)
    qualifyType NonEmpty (Text, t TypeDeclaration)
_scopes FieldType
t            = FieldType
t

    qualifyTOther :: NonEmpty (Text, t TypeDeclaration) -> TypeName -> TypeName
qualifyTOther NonEmpty (Text, t TypeDeclaration)
_scopes [] = String -> TypeName
forall a. HasCallStack => String -> a
error String
"This shouldn't be possible"
    qualifyTOther ((Text
_, t TypeDeclaration
_) :| []) TypeName
ts =
      [Text -> TypeName -> Text
T.intercalate Text
"." TypeName
ts] -- Top level scope, no need to search anything, use
                             -- the name as is. Maybe we should search and fail
                             -- if a type is not found even from top level, but
                             -- that could be a lot of work as this function is
                             -- pure right now.
    qualifyTOther ((Text
scopeName, t TypeDeclaration
decls) :| ((Text, t TypeDeclaration)
restFirst : [(Text, t TypeDeclaration)]
restTail)) TypeName
ts =
      if (TypeDeclaration -> Bool) -> t TypeDeclaration -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any (TypeName -> TypeDeclaration -> Bool
hasDeclFor TypeName
ts) t TypeDeclaration
decls
      then [Text -> TypeName -> Text
T.intercalate Text
"." (Text
scopeNameText -> TypeName -> TypeName
forall a. a -> [a] -> [a]
:TypeName
ts)]
      else NonEmpty (Text, t TypeDeclaration) -> TypeName -> TypeName
qualifyTOther ((Text, t TypeDeclaration)
restFirst (Text, t TypeDeclaration)
-> [(Text, t TypeDeclaration)]
-> NonEmpty (Text, t TypeDeclaration)
forall a. a -> [a] -> NonEmpty a
:| [(Text, t TypeDeclaration)]
restTail) TypeName
ts

    hasDeclFor :: TypeName -> TypeDeclaration -> Bool
hasDeclFor [] TypeDeclaration
_ = Bool
True
    hasDeclFor [Text
t] (P.DEnum Text
enumName [Option]
_ [EnumField]
_) = Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
enumName
    hasDeclFor (Text
_:Text
_:TypeName
_) P.DEnum{} = Bool
False
    hasDeclFor (Text
t:TypeName
ts) (P.DMessage Text
msgName [Option]
_ [Reserved]
_ [MessageField]
_ [TypeDeclaration]
rest) =
      let nameMatch :: Bool
nameMatch = Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
msgName
          -- 'L.any' returns 'False' if 'rest' is empty, hence the 'null ts'
          -- check is required.
          restMatch :: Bool
restMatch = TypeName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TypeName
ts Bool -> Bool -> Bool
|| (TypeDeclaration -> Bool) -> [TypeDeclaration] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
L.any (TypeName -> TypeDeclaration -> Bool
hasDeclFor TypeName
ts) [TypeDeclaration]
rest
      in Bool
nameMatch Bool -> Bool -> Bool
&& Bool
restMatch

    prependCurrentScope :: Text -> Text
prependCurrentScope Text
x =
      case (Text, [TypeDeclaration]) -> Text
forall a b. (a, b) -> a
fst (Text, [TypeDeclaration])
currentScope of
        Text
"" -> Text
x
        Text
_  -> (Text, [TypeDeclaration]) -> Text
forall a b. (a, b) -> a
fst (Text, [TypeDeclaration])
currentScope Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x

pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
pbTypeDeclToType :: TypeDeclaration -> Q (Type, [Type])
pbTypeDeclToType (P.DEnum Text
name [Option]
_ [EnumField]
fields) = do
  ([Type]
tys, [Type]
anns) <- [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Type)] -> ([Type], [Type]))
-> Q [(Type, Type)] -> Q ([Type], [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EnumField -> Q (Type, Type)) -> [EnumField] -> Q [(Type, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EnumField -> Q (Type, Type)
pbChoiceToType [EnumField]
fields
  (,) (Type -> [Type] -> (Type, [Type]))
-> TypeQ -> Q ([Type] -> (Type, [Type]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] Q ([Type] -> (Type, [Type])) -> Q [Type] -> Q (Type, [Type])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
anns
  where
    pbChoiceToType :: P.EnumField -> Q (Type, Type)
    pbChoiceToType :: EnumField -> Q (Type, Type)
pbChoiceToType (P.EnumField Text
nm FieldNumber
number [Option]
_)
      = (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'ChoiceDef $(textToStrLit nm) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) '[]) |]
pbTypeDeclToType (P.DMessage Text
name [Option]
_ [Reserved]
_ [MessageField]
fields [TypeDeclaration]
_) = do
  ([Type]
tys, [Type]
anns) <- [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Type, Type)] -> ([Type], [Type]))
-> Q [(Type, Type)] -> Q ([Type], [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MessageField -> Q (Type, Type))
-> [MessageField] -> Q [(Type, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MessageField -> Q (Type, Type)
pbMsgFieldToType [MessageField]
fields
  (,) (Type -> [Type] -> (Type, [Type]))
-> TypeQ -> Q ([Type] -> (Type, [Type]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DRecord $(textToStrLit name) $(pure $ typesToList tys)|] Q ([Type] -> (Type, [Type])) -> Q [Type] -> Q (Type, [Type])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> Q [Type]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
anns
  where
    pbMsgFieldToType :: P.MessageField -> Q (Type, Type)
    -- 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 :: MessageField -> Q (Type, Type)
pbMsgFieldToType (P.NormalField Repetition
P.Single ty :: FieldType
ty@(P.TOther TypeName
_) Text
nm FieldNumber
n [Option]
opts) =
        (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'FieldDef $(textToStrLit nm) ('TOption $(pbFieldTypeToType ty)) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]
    pbMsgFieldToType (P.NormalField Repetition
P.Single FieldType
ty Text
nm FieldNumber
n [Option]
opts) =
        (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]
    pbMsgFieldToType (P.NormalField Repetition
P.Repeated FieldType
ty Text
nm FieldNumber
n [Option]
opts) =
        (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]
    pbMsgFieldToType (P.MapField FieldType
k FieldType
v Text
nm FieldNumber
n [Option]
opts) =
        (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]
    pbMsgFieldToType (P.OneOfField Text
nm [MessageField]
vs)
      | Bool -> Bool
not ((MessageField -> Bool) -> [MessageField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all MessageField -> Bool
hasFieldNumber [MessageField]
vs)
      = String -> Q (Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"nested oneof fields are not supported"
      | Bool
otherwise
      = (,) (Type -> Type -> (Type, Type)) -> TypeQ -> Q (Type -> (Type, Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'FieldDef $(textToStrLit nm) ('TUnion $(typesToList <$> mapM pbOneOfFieldToType vs )) |]
            Q (Type -> (Type, Type)) -> TypeQ -> Q (Type, Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm)
                       ('ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs )) |]

    pbFieldTypeToType :: P.FieldType -> Q Type
    pbFieldTypeToType :: FieldType -> TypeQ
pbFieldTypeToType FieldType
P.TInt32     = [t|'TPrimitive Int32|]
    pbFieldTypeToType FieldType
P.TUInt32    = [t|'TPrimitive Word32|]
    pbFieldTypeToType FieldType
P.TSInt32    = [t|'TPrimitive Int32|]
    pbFieldTypeToType FieldType
P.TInt64     = [t|'TPrimitive Int64|]
    pbFieldTypeToType FieldType
P.TUInt64    = [t|'TPrimitive Word64|]
    pbFieldTypeToType FieldType
P.TSInt64    = [t|'TPrimitive Int64|]
    pbFieldTypeToType FieldType
P.TFixed32   = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fixed integers are not currently supported"
    pbFieldTypeToType FieldType
P.TFixed64   = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fixed integers are not currently supported"
    pbFieldTypeToType FieldType
P.TSFixed32  = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fixed integers are not currently supported"
    pbFieldTypeToType FieldType
P.TSFixed64  = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"fixed integers are not currently supported"
    pbFieldTypeToType FieldType
P.TDouble    = [t|'TPrimitive Double|]
    pbFieldTypeToType FieldType
P.TBool      = [t|'TPrimitive Bool|]
    pbFieldTypeToType FieldType
P.TString    = [t|'TPrimitive T.Text|]
    pbFieldTypeToType FieldType
P.TBytes     = [t|'TPrimitive B.ByteString|]
    pbFieldTypeToType (P.TOther TypeName
t) = [t|'TSchematic $(textToStrLit (last t))|]

    hasFieldNumber :: MessageField -> Bool
hasFieldNumber P.NormalField {} = Bool
True
    hasFieldNumber P.MapField {}    = Bool
True
    hasFieldNumber MessageField
_                = Bool
False

    getFieldNumber :: MessageField -> FieldNumber
getFieldNumber (P.NormalField Repetition
_ FieldType
_ Text
_ FieldNumber
n [Option]
_) = FieldNumber
n
    getFieldNumber (P.MapField    FieldType
_ FieldType
_ Text
_ FieldNumber
n [Option]
_) = FieldNumber
n
    getFieldNumber MessageField
_                         = String -> FieldNumber
forall a. HasCallStack => String -> a
error String
"this should never happen"

    pbOneOfFieldToType :: MessageField -> TypeQ
pbOneOfFieldToType (P.NormalField Repetition
P.Single FieldType
ty Text
_ FieldNumber
_ [Option]
_)
      = FieldType -> TypeQ
pbFieldTypeToType FieldType
ty
    pbOneOfFieldToType (P.NormalField Repetition
P.Repeated FieldType
ty Text
_ FieldNumber
_ [Option]
_)
      = [t| 'TList $(pbFieldTypeToType ty) |]
    pbOneOfFieldToType (P.MapField FieldType
k FieldType
v Text
_ FieldNumber
_ [Option]
_)
      = [t| 'TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v) |]
    pbOneOfFieldToType MessageField
_ = String -> TypeQ
forall a. HasCallStack => String -> a
error String
"this should never happen"

    pbOption :: Option -> TypeQ
pbOption (P.Option TypeName
oname Constant
val)
      = do Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TypeName
oname TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
"default"])
                (String -> Q ()
reportError String
"mu-protobuf does not (yet) support default values")
           [t| '( $(textToStrLit (T.intercalate "." oname))
                , $(pbConstantToOption val) ) |]

    pbConstantToOption :: Constant -> TypeQ
pbConstantToOption (P.KIdentifier TypeName
names)
      = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.intercalate "." names)) |]
    pbConstantToOption (P.KInt Integer
n)
      = [t| 'ProtoBufOptionConstantInt $(intToLit (fromInteger n)) |]
    pbConstantToOption (P.KBool Bool
True)
      = [t| 'ProtoBufOptionConstantBool 'True |]
    pbConstantToOption (P.KBool Bool
False)
      = [t| 'ProtoBufOptionConstantBool 'False |]
    pbConstantToOption (P.KString Text
s)
      = [t| 'ProtoBufOptionConstantOther $(textToStrLit s) |]
    pbConstantToOption (P.KFloat Float
s)
      = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.pack (show s))) |]
    pbConstantToOption (P.KObject [(Text, Constant)]
s)
      = [t| 'ProtoBufOptionConstantObject
            $(typesToList <$> mapM (\(n, o) -> [t| '( $(textToStrLit n), $(pbConstantToOption o) ) |] ) s ) |]

typesToList :: [Type] -> Type
typesToList :: [Type] -> Type
typesToList = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT

textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit Text
s = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s

intToLit :: Int -> Q Type
intToLit :: FieldNumber -> TypeQ
intToLit FieldNumber
n = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
NumTyLit (Integer -> TyLit) -> Integer -> TyLit
forall a b. (a -> b) -> a -> b
$ FieldNumber -> Integer
forall a. Integral a => a -> Integer
toInteger FieldNumber
n