{-# language CPP             #-}
{-# language DataKinds       #-}
{-# language LambdaCase      #-}
{-# language NamedFieldPuns  #-}
{-# 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.IO.Class
import qualified Data.ByteString                 as B
import           Data.Int
import qualified Data.Text                       as T
import           Language.Haskell.TH
import           Language.ProtocolBuffers.Parser
import qualified Language.ProtocolBuffers.Types  as P

import           Mu.Adapter.ProtoBuf
import           Mu.Schema.Definition
import           Mu.Schema.Annotations

-- | 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 schemaName :: String
schemaName fp :: 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 e :: ParseErrorBundle Text Char
e
           -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 p :: 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 schemaName :: String
schemaName p :: ProtoBuf
p
  = do let schemaName' :: Name
schemaName' = String -> Name
mkName String
schemaName
       (schTy :: Type
schTy, annTy :: Type
annTy) <- ProtoBuf -> Q (Type, Type)
schemaFromProtoBuf ProtoBuf
p
       Dec
schemaDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
schemaName' [] (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return Type
annTy))
#else
       annDec <- tySynInstD ''AnnotatedSchema
                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))
#endif
       [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [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 = [TypeDeclaration] -> [TypeDeclaration]
flattenDecls [TypeDeclaration]
tys
  (schTys :: [Type]
schTys, anns :: [[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 (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Type
typesToList [Type]
schTys, [Type] -> Type
typesToList ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
anns))

flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]
flattenDecls :: [TypeDeclaration] -> [TypeDeclaration]
flattenDecls = (TypeDeclaration -> [TypeDeclaration])
-> [TypeDeclaration] -> [TypeDeclaration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypeDeclaration -> [TypeDeclaration]
flattenDecl
  where
    flattenDecl :: TypeDeclaration -> [TypeDeclaration]
flattenDecl d :: TypeDeclaration
d@P.DEnum {} = [TypeDeclaration
d]
    flattenDecl (P.DMessage name :: Text
name o :: [Option]
o r :: [Reserved]
r fs :: [MessageField]
fs decls :: [TypeDeclaration]
decls) =
      Text
-> [Option]
-> [Reserved]
-> [MessageField]
-> [TypeDeclaration]
-> TypeDeclaration
P.DMessage Text
name [Option]
o [Reserved]
r [MessageField]
fs [] TypeDeclaration -> [TypeDeclaration] -> [TypeDeclaration]
forall a. a -> [a] -> [a]
: [TypeDeclaration] -> [TypeDeclaration]
flattenDecls [TypeDeclaration]
decls

pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
pbTypeDeclToType :: TypeDeclaration -> Q (Type, [Type])
pbTypeDeclToType (P.DEnum name :: Text
name _ fields :: [EnumField]
fields) = do
  (tys :: [Type]
tys, anns :: [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) $(return $ 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 nm :: Text
nm number :: FieldNumber
number _)
      = (,) (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 name :: Text
name _ _ fields :: [MessageField]
fields _) = do
  (tys :: [Type]
tys, anns :: [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)
    pbMsgFieldToType :: MessageField -> Q (Type, Type)
pbMsgFieldToType (P.NormalField P.Single ty :: FieldType
ty nm :: Text
nm n :: FieldNumber
n _)
      = (,) (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)) |]
    pbMsgFieldToType (P.NormalField P.Repeated ty :: FieldType
ty nm :: Text
nm n :: FieldNumber
n _)
      = (,) (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)) |]
    pbMsgFieldToType (P.MapField k :: FieldType
k v :: FieldType
v nm :: Text
nm n :: FieldNumber
n _)
      = (,) (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)) |]
    pbMsgFieldToType (P.OneOfField nm :: Text
nm vs :: [MessageField]
vs)
      | (MessageField -> Bool) -> [MessageField] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (MessageField -> Bool) -> MessageField -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageField -> Bool
hasFieldNumber) [MessageField]
vs
      = String -> Q (Type, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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) $(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 P.TInt32     = [t|'TPrimitive Int32|]
    pbFieldTypeToType P.TUInt32    = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unsigned integers are not currently supported"
    pbFieldTypeToType P.TSInt32    = [t|'TPrimitive Int32|]
    pbFieldTypeToType P.TInt64     = [t|'TPrimitive Int64|]
    pbFieldTypeToType P.TUInt64    = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unsigned integers are not currently supported"
    pbFieldTypeToType P.TSInt64    = [t|'TPrimitive Int64|]
    pbFieldTypeToType P.TFixed32   = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fixed integers are not currently supported"
    pbFieldTypeToType P.TFixed64   = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fixed integers are not currently supported"
    pbFieldTypeToType P.TSFixed32  = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fixed integers are not currently supported"
    pbFieldTypeToType P.TSFixed64  = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fixed integers are not currently supported"
    pbFieldTypeToType P.TDouble    = [t|'TPrimitive Double|]
    pbFieldTypeToType P.TBool      = [t|'TPrimitive Bool|]
    pbFieldTypeToType P.TString    = [t|'TPrimitive T.Text|]
    pbFieldTypeToType P.TBytes     = [t|'TPrimitive B.ByteString|]
    pbFieldTypeToType (P.TOther t :: TypeName
t) = [t|'TSchematic $(textToStrLit (last t))|]

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

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

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

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 (\y :: Type
y ys :: Type
ys -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
PromotedConsT Type
y) Type
ys) Type
PromotedNilT

textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit s :: Text
s = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (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 n :: FieldNumber
n = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (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