hprotoc-2.4.5: Text/ProtocolBuffers/ProtoCompile/Gen.hs
{-# LANGUAGE NamedFieldPuns, RecordWildCards, ViewPatterns #-}
-- This module uses the Reflection data structures (ProtoInfo,EnumInfo,DescriptorInfo) to
-- build an AST using Language.Haskell.Syntax. This get quite verbose, so a large number
-- of helper functions (and operators) are defined to aid in specifying the output code.
--
-- Note that this may eventually also generate hs-boot files to allow
-- for breaking mutual recursion.
--
-- Mangling: For the current moment, assume the mangling is done in a prior pass:
-- (*) Uppercase all module names and type names and enum constants
-- (*) lowercase all field names
-- (*) add a prime after all field names than conflict with reserved words
--
-- The names are also assumed to have become fully-qualified, and all
-- the optional type codes have been set.
--
module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModules,enumModule,oneofModule,prettyPrint) where
import Text.ProtocolBuffers.Basic
import Text.ProtocolBuffers.Identifiers
import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),SomeRealFloat(..),DescriptorInfo(..),ProtoInfo(..),OneofInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),FieldInfo(..))
import Text.ProtocolBuffers.ProtoCompile.BreakRecursion(Result(..),VertexKind(..),pKey,pfKey,getKind,Part(..))
--import Paths_hprotoc(version)
--import Data.Version(showVersion)
import qualified Data.ByteString.Lazy.Char8 as LC(unpack)
import qualified Data.Foldable as F(foldr,toList)
import Data.List(sortBy,foldl',foldl1',group,sort,union)
import Data.Function(on)
import Language.Haskell.Exts.Pretty(prettyPrint)
import Language.Haskell.Exts.Syntax hiding (Int,String)
import Language.Haskell.Exts.Syntax as Hse
import Data.Char(isLower,isUpper)
import qualified Data.Map as M
import Data.Maybe(mapMaybe)
import Data.Sequence (ViewL(..),(><))
import qualified Data.Sequence as Seq(null,length,empty,viewl)
import qualified Data.Set as S
import System.FilePath(joinPath)
ecart :: String -> a -> a
ecart _ x = x
default (Int)
-- -- -- -- Helper functions
imp :: String -> a
imp s = error ("Impossible? Text.ProtocolBuffers.ProtoCompile.Gen."++s)
nubSort :: Ord a => [a] -> [a]
nubSort = map head . group . sort
noWhere :: Maybe (Binds ())
noWhere = Nothing
whereBinds :: Binds () -> Maybe (Binds ())
whereBinds = Just
($$) :: Exp () -> Exp () -> Exp ()
($$) = App ()
infixl 1 $$
litStr :: String -> Exp ()
litStr s = Lit () $ Hse.String () s s
litIntP :: Integral x => x -> Pat ()
litIntP (toInteger -> x)
| x<0 = PParen () $ PLit () (Signless ()) (Hse.Int () x (show x))
| otherwise = PLit () (Signless ()) (Hse.Int () x (show x))
-- Pin down the type inference
litIntP' :: Int -> Pat ()
litIntP' = litIntP
litInt :: Integral x => x -> Exp ()
litInt (toInteger -> x)
| x<0 = Paren () $ Lit () (Hse.Int () x (show x))
| otherwise = Lit () (Hse.Int () x (show x))
litInt' :: Int -> Exp ()
litInt' = litInt
typeApp :: String -> Type () -> Type ()
typeApp s = TyApp () (TyCon () (private s))
-- private is for Text.ProtocolBuffers.Header, prelude is for Prelude, local is unqualified
private :: String -> QName ()
private t = Qual () (ModuleName () "P'") (Ident () t)
prelude :: String -> QName ()
prelude t = Qual () (ModuleName () "Prelude'") (Ident () t)
local :: String -> QName ()
local t = UnQual () (Ident () t)
localField :: DescriptorInfo -> String -> QName ()
localField di t = UnQual () (fieldIdent di t)
-- pvar and preludevar and lvar are for lower-case identifiers
isVar :: String -> Bool
isVar (x:_) = isLower x || x == '_'
isVar _ = False
isCon :: String -> Bool
isCon (x:_) = isUpper x
isCon _ = False
pvar :: String -> Exp ()
pvar t | isVar t = Var () (private t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: pvar expected lower-case first letter in " ++ show t
preludevar :: String -> Exp ()
preludevar t | isVar t = Var () (prelude t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: preludevar expected lower-case first letter in " ++ show t
lvar :: String -> Exp ()
lvar t | isVar t = Var () (local t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: lvar expected lower-case first letter in " ++ show t
-- pcon and preludecon and lcon are for upper-case identifiers
pcon :: String -> Exp ()
pcon t | isCon t = Con () (private t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: pcon expected upper-case first letter in " ++ show t
preludecon :: String -> Exp ()
preludecon t | isCon t = Con () (prelude t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: preludecon expected upper-case first letter in " ++ show t
lcon :: String -> Exp ()
lcon t | isCon t = Con () (local t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: lcon expected upper-case first letter in " ++ show t
-- patvar is a pattern that binds a new lower-case variable name
patvar :: String -> Pat ()
patvar t | isVar t = PVar () (Ident () t)
| otherwise = error $ "hprotoc Gen.hs assertion failed: patvar expected lower-case first letter in " ++ show t
match :: String -> [Pat ()] -> Exp () -> Match ()
match s p r = Match () (Ident () s) p (UnGuardedRhs () r) noWhere
inst :: String -> [Pat ()] -> Exp () -> InstDecl ()
inst s p r = InsDecl () $ FunBind () [match s p r]
defun :: String -> [Pat ()] -> Exp () -> Decl ()
defun s p r = FunBind () [match s p r]
mkOp :: String -> Exp () -> Exp () -> Exp ()
mkOp s a b = InfixApp () a (QVarOp () (UnQual () (Symbol () s))) b
compose :: Exp () -> Exp () -> Exp ()
compose = mkOp "."
fqMod :: ProtoName -> String
fqMod (ProtoName _ a b c) = joinMod $ a++b++[c]
-- importPN takes the Result to look up the target info, it takes the
-- current MKey (pKey of protoName, no 'Key appended), and Part to
-- identify the module being created. The ProtoName is the target
-- TYPE that is needed.
importPN :: Result -> ModuleName () -> Part -> ProtoName -> Maybe (ImportDecl ())
importPN r selfMod@(ModuleName () self) part pn =
let o = pKey pn
m1 = ModuleName () (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))
m2 = ModuleName () (joinMod (parentModule pn))
fromSource = S.member (FMName self,part,o) (rIBoot r)
iabs = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn)))
ans = if m1 == selfMod && part /= KeyFile then Nothing
else Just $ ImportDecl () m1 True fromSource False Nothing (Just m2)
(Just (ImportSpecList () False [iabs]))
in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $
[("selfMod",show selfMod)
,("part",show part)
,("pn",show pn)
,("o",show o)
,("m1",show m1)
,("m2",show m2)
,("fromSource",show fromSource)
,("ans",show ans)]) $
ans
importPFN :: Result -> ModuleName () -> ProtoFName -> Maybe (ImportDecl ())
importPFN r m@(ModuleName () self) pfn =
let o@(FMName _other) = pfKey pfn
m1@(ModuleName () m1') = ModuleName () (joinMod (haskellPrefix' pfn ++ parentModule' pfn))
m2 = ModuleName () (joinMod (parentModule' pfn))
spec = Just (ImportSpecList () False [IVar () (Ident () (fName (baseName' pfn)))])
kind = getKind r o
fromAlt = S.member (FMName self,FMName m1') (rIKey r)
m1key = if kind == SplitKeyTypeBoot && fromAlt
then keyFile m1
else m1
qualifiedFlag = (m1 /= m)
qualifiedName | qualifiedFlag = if m2/=m1key then Just m2 else Nothing
| otherwise = Nothing
sourceFlag = (kind == KeyTypeBoot) && fromAlt
ans = if not qualifiedFlag && kind /= SplitKeyTypeBoot then Nothing else Just $
ImportDecl () m1key qualifiedFlag sourceFlag False Nothing qualifiedName spec
in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $
[("m",show m)
,("pfn",show pfn)
,("o",show o)
,("m1",show m1)
,("m2",show m2)
,("kind",show kind)
,("ans",show ans)]) $
ans
importO :: Result -> ModuleName () -> Part -> OneofInfo -> Maybe [ImportDecl ()]
importO r selfMod@(ModuleName () self) part oi =
let pn = oneofName oi
o = pKey pn
m1 = ModuleName () (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))
m2 = ModuleName () (joinMod (parentModule pn))
m3 = ModuleName () (joinMod (parentModule pn ++ [baseName pn]))
fromSource = S.member (FMName self,part,o) (rIBoot r)
iabs1 = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn)))
iabsget = map (IAbs () (NoNamespace ()) . Ident () . fst . oneofGet) . F.toList . oneofFields $ oi
ithall = IThingAll () (Ident () (mName (baseName pn)))
ans1 = ImportDecl () m1 True fromSource False Nothing (Just m2)
(Just (ImportSpecList () False [iabs1]))
ans2 = ImportDecl () m1 True fromSource False Nothing (Just m3)
(Just (ImportSpecList () False (ithall:iabsget)))
in if m1 == selfMod && part /= KeyFile
then Nothing
else Just [ans1,ans2]
-- Several items might be taken from the same module, combine these statements
mergeImports :: [ImportDecl ()] -> [ImportDecl ()]
mergeImports importsIn =
let idKey ImportDecl{..} = (importModule,importQualified,importSrc,importAs,fmap (\(ImportSpecList _ _ xs) -> xs) importSpecs)
mergeImports' ImportDecl{importSpecs=Just (ImportSpecList () hiding xs), ..} ImportDecl{importSpecs=Just (ImportSpecList () _ ys)} =
ImportDecl{importSpecs=Just (ImportSpecList () hiding (xs `union` ys)), ..}
mergeImports' i _ = i -- identical, so drop one
combined = M.fromListWith mergeImports' . map (\ i -> (idKey i,i)) $ importsIn
in M.elems combined
keyFile :: ModuleName () -> ModuleName ()
keyFile (ModuleName () s) = ModuleName () (s++"'Key")
joinMod :: [MName String] -> String
joinMod [] = ""
joinMod ms = fmName $ foldr1 dotFM . map promoteFM $ ms
baseIdent :: ProtoName -> Name ()
baseIdent = Ident () . mName . baseName
baseIdent' :: ProtoFName -> Name ()
baseIdent' pfn = Ident () $ baseNamePrefix' pfn ++ fName (baseName' pfn)
fieldIdent :: DescriptorInfo -> String -> Name ()
fieldIdent di str | makeLenses di = Ident () ('_':str)
| otherwise = Ident () str
qualName :: ProtoName -> QName ()
qualName p@(ProtoName _ _prefix [] _base) = UnQual () (baseIdent p)
qualName p@(ProtoName _ _prefix (parents) _base) = Qual () (ModuleName () (joinMod parents)) (baseIdent p)
qualFName :: ProtoFName -> QName ()
qualFName p@(ProtoFName _ _prefix [] _base _basePrefix) = UnQual () (baseIdent' p)
qualFName p@(ProtoFName _ _prefix parents _base _basePrefix) = Qual () (ModuleName () (joinMod parents)) (baseIdent' p)
unqualName :: ProtoName -> QName ()
unqualName p = UnQual () (baseIdent p)
unqualFName :: ProtoFName -> QName ()
unqualFName p = UnQual () (baseIdent' p)
mayQualName :: ProtoName -> ProtoFName -> QName ()
mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base _basePrefix) =
if joinMod (c'prefix++c'parents++[c'base]) == joinMod (prefix++parents)
then UnQual () (baseIdent' name) -- name is local, make UnQual
else qualFName name -- name is imported, make Qual
--------------------------------------------
-- utility for OneofInfo
--------------------------------------------
oneofCon :: (ProtoName,FieldInfo) -> Exp ()
oneofCon (name,_) = Con () (qualName name)
oneofPat :: (ProtoName,FieldInfo) -> (Pat (),Pat ())
oneofPat (name,fi) =
let fName@(Ident () fname) = baseIdent' (fieldName fi)
in (PApp () (qualName name) [PVar () fName],PApp () (unqualName name) [PVar () fName])
oneofRec :: (ProtoName,FieldInfo) -> (Exp (),Exp ())
oneofRec (_,fi) =
let fName@(Ident () fname) = baseIdent' (fieldName fi)
in (litStr fname,lvar fname)
oneofGet :: (ProtoName,FieldInfo) -> (String,ProtoName)
oneofGet (p,fi) =
let Ident () fname = baseIdent' (fieldName fi)
unqual = "get'" ++ fname
p' = p { baseName = MName unqual }
in (unqual,p')
--------------------------------------------
-- Define LANGUAGE options as [ModulePramga]
--------------------------------------------
modulePragmas :: Bool -> [ModulePragma ()]
modulePragmas templateHaskell =
[ LanguagePragma () (map (Ident ()) $
thPragma ++ ["BangPatterns","DeriveDataTypeable","DeriveGeneric","FlexibleInstances","MultiParamTypeClasses"]
)
, OptionsPragma () (Just GHC) " -fno-warn-unused-imports "
]
where thPragma | templateHaskell = ["TemplateHaskell"]
| otherwise = []
--------------------------------------------
-- OneofDescriptorProto module creation
--------------------------------------------
oneofModule :: Result -> OneofInfo -> Module ()
oneofModule result oi
= Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing Nothing)) (modulePragmas $ oneofMakeLenses oi)
imports (oneofDecls oi)
where protoName = oneofName oi
typs = mapMaybe typeName . F.toList . fmap snd . oneofFields $ oi
imports = (standardImports False False (oneofMakeLenses oi))
++ (mergeImports (mapMaybe (importPN result (ModuleName () (fqMod protoName)) Normal) typs))
oneofDecls :: OneofInfo -> [Decl ()]
oneofDecls oi = (oneofX oi : oneofFuncs oi) ++ lenses ++ instances
where
mkPrisms = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makePrisms"))
lenses | oneofMakeLenses oi = [SpliceDecl () (mkFun $$ TypQuote () (unqualName (oneofName oi))) |
mkFun <- [mkLenses, mkPrisms]]
| otherwise = []
instances = [ instanceDefaultOneof oi
, instanceMergeableOneof oi
]
oneofX :: OneofInfo -> Decl ()
oneofX oi = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (oneofName oi)))
(map oneofValueX (F.toList (oneofFields oi) ))
(Just derives)
where oneofValueX (pname,fi) = QualConDecl () Nothing Nothing con
where con = RecDecl () (baseIdent pname) [fieldX]
fieldX = FieldDecl () [baseIdent' . fieldName $ fi] (TyParen () (TyCon () typed ))
typed = case useType (getFieldType (typeCode fi)) of
Just s -> private s
Nothing -> case typeName fi of
Just s -> qualName s
Nothing -> imp $ "No Name for Field!\n" ++ show fi
oneofFuncs :: OneofInfo -> [Decl ()]
oneofFuncs oi = map mkfuns (F.toList (oneofFields oi))
where mkfuns f = defun (fst (oneofGet f)) [patvar "x"] $
Case () (lvar "x")
[ Alt () (snd (oneofPat f))
(UnGuardedRhs () (preludecon "Just" $$ snd (oneofRec f))) noWhere
, Alt () (PWildCard ())
(UnGuardedRhs () (preludecon "Nothing")) noWhere
]
{- oneof field does not have to have a default value, but for convenience
(to make all messages an instance of Default and Mergeable), we make
the first case as default like enum. -}
instanceDefaultOneof :: OneofInfo -> Decl ()
instanceDefaultOneof oi
= InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (oneofName oi))]) . Just $
[ inst "defaultValue" [] firstValue ]
where firstValue :: Exp ()
firstValue = case Seq.viewl (oneofFields oi) of
EmptyL -> imp ("instanceDefaultOneof: empty in " ++ show oi)
(n,_) :< _ -> case (baseIdent n) of
Ident () str -> App () (lcon str) (pvar "defaultValue")
Symbol () _ -> imp ("instanceDefaultOneof: " ++ show n)
instanceMergeableOneof :: OneofInfo -> Decl ()
instanceMergeableOneof oi
= InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (oneofName oi))]) Nothing
--------------------------------------------
-- EnumDescriptorProto module creation
--------------------------------------------
enumModule :: EnumInfo -> Module ()
enumModule ei
= let protoName = enumName ei
exportList =
(Just (ExportSpecList () [EThingWith () (EWildcard () 0) (unqualName protoName) []]))
in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing exportList)) (modulePragmas False)
(standardImports True False False) (enumDecls ei)
enumDecls :: EnumInfo -> [Decl ()]
enumDecls ei = map ($ ei) [ enumX
, instanceMergeableEnum
, instanceBounded
, instanceDefaultEnum ]
++ declToEnum ei ++
map ($ ei) [ instanceEnum
, instanceWireEnum
, instanceGPB . enumName
, instanceMessageAPI . enumName
, instanceReflectEnum
, instanceTextTypeEnum
]
enumX :: EnumInfo -> Decl ()
enumX ei = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (enumName ei))) (map enumValueX (enumValues ei)) (Just derivesEnum)
where enumValueX (_,name) = QualConDecl () Nothing Nothing (ConDecl () (Ident () name) [])
instanceTextTypeEnum :: EnumInfo -> Decl ()
instanceTextTypeEnum ei
= InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (enumName ei))]) . Just $
[ inst "tellT" [] (pvar "tellShow")
, inst "getT" [] (pvar "getRead")
]
instanceMergeableEnum :: EnumInfo -> Decl ()
instanceMergeableEnum ei
= InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (enumName ei))]) Nothing
instanceBounded :: EnumInfo -> Decl ()
instanceBounded ei
= InstDecl () Nothing (mkSimpleIRule (prelude "Bounded") [TyCon () (unqualName (enumName ei))]) .Just $
[set "minBound" (head values),set "maxBound" (last values)] -- values cannot be null in a well formed enum
where values = enumValues ei
set f (_,n) = inst f [] (lcon n)
{- from google's descriptor.h, about line 346:
// Get the field default value if cpp_type() == CPPTYPE_ENUM. If no
// explicit default was defined, the default is the first value defined
// in the enum type (all enum types are required to have at least one value).
// This never returns NULL.
-}
instanceDefaultEnum :: EnumInfo -> Decl ()
instanceDefaultEnum ei
= InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (enumName ei))]) . Just $
[ inst "defaultValue" [] firstValue ]
where firstValue :: Exp ()
firstValue = case enumValues ei of
(:) (_,n) _ -> lcon n
[] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei
declToEnum :: EnumInfo -> [Decl ()]
declToEnum ei = [ TypeSig () [Ident () "toMaybe'Enum"]
(TyFun () (TyCon () (prelude "Int"))
(typeApp "Maybe" (TyCon () (unqualName (enumName ei)))))
, FunBind () (map toEnum'one values ++ [final]) ]
where values = enumValues ei
toEnum'one (v,n) = match "toMaybe'Enum" [litIntP (getEnumCode v)] (preludecon "Just" $$ lcon n)
final = match "toMaybe'Enum" [PWildCard ()] (preludecon "Nothing")
instanceEnum :: EnumInfo -> Decl ()
instanceEnum ei
= InstDecl () Nothing (mkSimpleIRule (prelude "Enum") [TyCon () (unqualName (enumName ei))]) . Just $
(map (InsDecl () . FunBind ()) [fromEnum',toEnum',succ',pred'])
where values = enumValues ei
fromEnum' = map fromEnum'one values
fromEnum'one (v,n) = match "fromEnum" [PApp () (local n) []] (litInt (getEnumCode v))
toEnum' = [ match "toEnum" [] (compose mayErr (lvar "toMaybe'Enum")) ]
mayErr = pvar "fromMaybe" $$ (Paren () (preludevar "error" $$ (litStr $
"hprotoc generated code: toEnum failure for type "++ fqMod (enumName ei))))
succ' = zipWith (equate "succ") values (tail values) ++
[ match "succ" [PWildCard ()] (preludevar "error" $$ (litStr $
"hprotoc generated code: succ failure for type "++ fqMod (enumName ei))) ]
pred' = zipWith (equate "pred") (tail values) values ++
[ match "pred" [PWildCard ()] (preludevar "error" $$ (litStr $
"hprotoc generated code: pred failure for type "++ fqMod (enumName ei))) ]
equate f (_,n1) (_,n2) = match f [PApp () (local n1) []] (lcon n2)
-- fromEnum TYPE_ENUM == 14 :: Int
instanceWireEnum :: EnumInfo -> Decl ()
instanceWireEnum ei
= InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () (unqualName (enumName ei))]) . Just $
[ withName "wireSize", withName "wirePut", withGet, withGetErr,withGetPacked,withGetPackedErr ]
where withName foo = inst foo [patvar "ft'",patvar "enum"] rhs
where rhs = pvar foo $$ lvar "ft'" $$
(Paren () $ preludevar "fromEnum" $$ lvar "enum")
withGet = inst "wireGet" [litIntP' 14] rhs
where rhs = pvar "wireGetEnum" $$ lvar "toMaybe'Enum"
withGetErr = inst "wireGet" [patvar "ft'"] rhs
where rhs = pvar "wireGetErr" $$ lvar "ft'"
withGetPacked = inst "wireGetPacked" [litIntP' 14] rhs
where rhs = pvar "wireGetPackedEnum" $$ lvar "toMaybe'Enum"
withGetPackedErr = inst "wireGetPacked" [patvar "ft'"] rhs
where rhs = pvar "wireGetErr" $$ lvar "ft'"
instanceGPB :: ProtoName -> Decl ()
instanceGPB protoName
= InstDecl () Nothing (mkSimpleIRule (private "GPB") [TyCon () (unqualName protoName)]) Nothing
instanceReflectEnum :: EnumInfo -> Decl ()
instanceReflectEnum ei
= InstDecl () Nothing (mkSimpleIRule (private "ReflectEnum") [TyCon () (unqualName (enumName ei))]) . Just $
[ inst "reflectEnum" [] ascList
, inst "reflectEnumInfo" [ PWildCard () ] ei' ]
where (ProtoName xxx a b c) = enumName ei
xxx'Exp = Paren () $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx)))
values = enumValues ei
ascList,ei',protoNameExp :: Exp ()
ascList = List () (map one values)
where one (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns,lcon ns]
ei' = foldl' (App ()) (pcon "EnumInfo") [protoNameExp
,List () $ map litStr (enumFilePath ei)
,List () (map two values)]
where two (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns]
protoNameExp = Paren () $ foldl' (App ()) (pvar "makePNF")
[ xxx'Exp, mList a, mList b, litStr (mName c) ]
where mList = List () . map (litStr . mName)
hasExt :: DescriptorInfo -> Bool
hasExt di = not (null (extRanges di))
--------------------------------------------
-- FileDescriptorProto module creation
--------------------------------------------
protoModule :: Result -> ProtoInfo -> ByteString -> Module ()
protoModule result pri fdpBS
= let protoName = protoMod pri
(extendees,myKeys) = unzip $ F.toList (extensionKeys pri)
m = ModuleName () (fqMod protoName)
exportKeys = map (EVar () . unqualFName . fieldName) myKeys
exportNames = map (EVar () . UnQual () . Ident ()) ["protoInfo","fileDescriptorProto"]
imports = (protoImports ++) . mergeImports $
mapMaybe (importPN result m Normal) $
extendees ++ mapMaybe typeName myKeys
in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exportKeys++exportNames))))) (modulePragmas False) imports
(keysXTypeVal protoName (extensionKeys pri) ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)
where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) False ++
[ ImportDecl () (ModuleName () "Text.DescriptorProtos.FileDescriptorProto") False False False Nothing Nothing
(Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "FileDescriptorProto")]))
, ImportDecl () (ModuleName () "Text.ProtocolBuffers.Reflections") False False False Nothing Nothing
(Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "ProtoInfo")]))
, ImportDecl () (ModuleName () "Text.ProtocolBuffers.WireMessage") True False False Nothing (Just (ModuleName () "P'"))
(Just (ImportSpecList () False [IVar () (Ident () "wireGet,getFromBS")]))
]
embed'ProtoInfo :: ProtoInfo -> [Decl ()]
embed'ProtoInfo pri = [ myType, myValue ]
where myType = TypeSig () [ Ident () "protoInfo" ] (TyCon () (local "ProtoInfo"))
myValue = PatBind () (PApp () (local "protoInfo") []) (UnGuardedRhs () $
preludevar "read" $$ litStr (show pri)) noWhere
embed'fdpBS :: ByteString -> [Decl ()]
embed'fdpBS bs = [ myType, myValue ]
where myType = TypeSig () [ Ident () "fileDescriptorProto" ] (TyCon () (local "FileDescriptorProto"))
myValue = PatBind () (PApp () (local "fileDescriptorProto") []) (UnGuardedRhs () $
pvar "getFromBS" $$
Paren () (pvar "wireGet" $$ litInt' 11) $$
Paren () (pvar "pack" $$ litStr (LC.unpack bs))) noWhere
--------------------------------------------
-- DescriptorProto module creation
--------------------------------------------
descriptorModules :: Result -> DescriptorInfo -> [(FilePath,Module ())]
descriptorModules result di
= let mainPath = joinPath (descFilePath di)
bootPath = joinPath (descFilePath di) ++ "-boot"
keyfilePath = take (length mainPath - 3) mainPath ++ "'Key.hs"
in (mainPath,descriptorNormalModule result di) :
case getKind result (pKey (descName di)) of
TopProtoInfo -> imp $ "descriptorModules was given a TopProtoInfo kinded DescriptorInfo!"
Simple -> []
TypeBoot -> [(bootPath,descriptorBootModule di)]
KeyTypeBoot -> [(bootPath,descriptorKeyBootModule result di)]
SplitKeyTypeBoot -> [(bootPath,descriptorBootModule di)
,(keyfilePath,descriptorKeyfileModule result di)]
-- This build a hs-boot that declares the type of the data type only
descriptorBootModule :: DescriptorInfo -> Module ()
descriptorBootModule di
= let protoName = descName di
un = unqualName protoName
classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Typeable",prelude "Data", prelude "Generic"
,private "Mergeable",private "Default"
,private "Wire",private "GPB",private "ReflectDescriptor"
, private "TextType", private "TextMsg"
]
++ if hasExt di then [private "ExtendMessage"] else []
++ if storeUnknown di then [private "UnknownMessage"] else []
instMesAPI = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI")
[TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) Nothing
dataDecl = DataDecl () (DataType ()) Nothing (DHead () (baseIdent protoName)) [] Nothing
mkInst s = InstDecl () Nothing (mkSimpleIRule s [TyCon () un]) Nothing
eabs = EAbs () (NoNamespace ()) un
in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing (Just (ExportSpecList () [eabs])))) (modulePragmas $ makeLenses di) minimalImports
(dataDecl : instMesAPI : map mkInst classes)
-- This builds on the output of descriptorBootModule and declares a hs-boot that
-- declares the data type and the keys
descriptorKeyBootModule :: Result -> DescriptorInfo -> Module ()
descriptorKeyBootModule result di
= let Module () (Just (ModuleHead () m _ (Just (ExportSpecList () exports)))) pragmas imports decls = descriptorBootModule di
(extendees,myKeys) = unzip $ F.toList (keys di)
exportKeys = map (EVar () . unqualFName . fieldName) myKeys
importTypes = mergeImports . mapMaybe (importPN result m Source) . nubSort $
extendees ++ mapMaybe typeName myKeys
declKeys = keysXType (descName di) (keys di)
in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exports++exportKeys))))) pragmas (imports++importTypes) (decls++declKeys)
-- This build the 'Key module that defines the keys only
descriptorKeyfileModule :: Result -> DescriptorInfo -> Module ()
descriptorKeyfileModule result di
= let protoName'Key = (descName di) { baseName = MName . (++"'Key") . mName $ (baseName (descName di)) }
(extendees,myKeys) = unzip $ F.toList (keys di)
mBase = ModuleName () (fqMod (descName di))
m = ModuleName () (fqMod protoName'Key)
exportKeys = map (EVar () . unqualFName . fieldName) myKeys
importTypes = mergeImports . mapMaybe (importPN result mBase KeyFile) . nubSort $
extendees ++ mapMaybe typeName myKeys
declKeys = keysXTypeVal protoName'Key (keys di)
in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () exportKeys)) )) (modulePragmas $ makeLenses di) (minimalImports++importTypes) declKeys
-- This builds the normal module
descriptorNormalModule :: Result -> DescriptorInfo -> Module ()
descriptorNormalModule result di
= let protoName = descName di
un = unqualName protoName
myKind = getKind result (pKey protoName)
sepKey = myKind == SplitKeyTypeBoot
(extendees,myKeys) = unzip $ F.toList (keys di)
extendees' = if sepKey then [] else extendees
myKeys' = if sepKey then [] else myKeys
m = ModuleName () (fqMod protoName)
exportKeys :: [ExportSpec ()]
exportKeys = map (EVar () . unqualFName . fieldName) myKeys
imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $
[ mapMaybe (importPN result m Normal) $
extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di)))
, concat . mapMaybe (importO result m Normal) $ F.toList (descOneofs di)
, mapMaybe (importPFN result m) (map fieldName (myKeys ++ F.toList (knownKeys di))) ]
lenses | makeLenses di = [SpliceDecl () (mkLenses $$ TypQuote () (unqualName protoName))]
| otherwise = []
declKeys | sepKey = []
| otherwise = keysXTypeVal (descName di) (keys di)
in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () ((EThingWith () (EWildcard () 0) un [] : exportLenses di ++ exportKeys)))))) (modulePragmas $ makeLenses di) imports
(descriptorX di : lenses ++ declKeys ++ instancesDescriptor di)
mkLenses :: Exp ()
mkLenses = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makeLenses"))
exportLenses :: DescriptorInfo -> [ExportSpec ()]
exportLenses di =
if makeLenses di
then
map (EVar () . unqualFName . stripPrefix) (lensFieldNames di)
else []
where stripPrefix pfn = pfn { baseNamePrefix' = "" }
lensFieldNames di = map fieldName (F.toList (fields di))
++ map oneofFName (F.toList (descOneofs di))
minimalImports :: [ImportDecl ()]
minimalImports =
[ ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing ]
standardImports :: Bool -> Bool -> Bool -> [ImportDecl ()]
standardImports isEnumMod ext lenses =
[ ImportDecl () (ModuleName () "Prelude") False False False Nothing Nothing (Just (ImportSpecList () False ops))
, ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing
, ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing ] ++ lensTH
where
ops | ext = map (IVar () . Symbol ()) $ base ++ ["==","<=","&&"]
| otherwise = map (IVar () . Symbol ()) base
base | isEnumMod = ["+","/","."]
| otherwise = ["+","/"]
lensTH | lenses = [ImportDecl () (ModuleName () "Control.Lens.TH") True False False Nothing Nothing Nothing]
| otherwise = []
keysXType :: ProtoName -> Seq KeyInfo -> [Decl ()]
keysXType self ks = map (makeKeyType self) . F.toList $ ks
keysXTypeVal :: ProtoName -> Seq KeyInfo -> [Decl ()]
keysXTypeVal self ks = concatMap (\ ki -> [makeKeyType self ki,makeKeyVal self ki]) . F.toList $ ks
makeKeyType :: ProtoName -> KeyInfo -> Decl ()
makeKeyType self (extendee,f) = keyType
where keyType = TypeSig () [ baseIdent' . fieldName $ f ] (foldl1 (TyApp ()) . map (TyCon ()) $
[ private "Key", private labeled
, if extendee /= self then qualName extendee else unqualName extendee
, typeQName ])
labeled | isPacked f = "PackedSeq"
| canRepeat f = "Seq"
| otherwise = "Maybe"
typeNumber = getFieldType . typeCode $ f
typeQName :: QName ()
typeQName = case useType typeNumber of
Just s -> private s
Nothing -> case typeName f of
Just s | self /= s -> qualName s
| otherwise -> unqualName s
Nothing -> error $ "No Name for Field!\n" ++ show f
makeKeyVal :: ProtoName -> KeyInfo -> Decl ()
makeKeyVal _self (_extendee,f) = keyVal
where typeNumber = getFieldType . typeCode $ f
keyVal = PatBind () (PApp () (unqualFName . fieldName $ f) []) (UnGuardedRhs ()
(pcon "Key" $$ litInt (getFieldId (fieldNumber f))
$$ litInt typeNumber
$$ maybe (preludecon "Nothing")
(Paren () . (preludecon "Just" $$) . (defToSyntax (typeCode f)))
(hsDefault f)
)) noWhere
defToSyntax :: FieldType -> HsDefault -> Exp ()
defToSyntax tc x =
case x of
HsDef'Bool b -> preludecon (show b)
HsDef'ByteString bs -> (if tc == 9 then (\ xx -> Paren () (pcon "Utf8" $$ xx)) else id) $
(Paren () $ pvar "pack" $$ litStr (LC.unpack bs))
HsDef'RealFloat (SRF'Rational r) | r < 0 -> Paren () $ Lit () (Frac () r (show r))
| otherwise -> Lit () (Frac () r (show r))
HsDef'RealFloat SRF'nan -> litInt' 0 /! litInt' 0
HsDef'RealFloat SRF'ninf -> litInt' 1 /! litInt' 0
HsDef'RealFloat SRF'inf -> litInt' (-1) /! litInt' 0
HsDef'Integer i -> litInt i
HsDef'Enum s -> Paren () $ preludevar "read" $$ litStr s
where (/!) a b = Paren () (mkOp "/" a b)
descriptorX :: DescriptorInfo -> Decl ()
descriptorX di = DataDecl () (DataType ()) Nothing (DHead () name) [QualConDecl () Nothing Nothing con] (Just derives)
where self = descName di
name = baseIdent self
con = RecDecl () name eFields
where eFields = map (\(ns, t) -> FieldDecl () ns t) $ F.foldr ((:) . fieldX) end (fields di)
end = (if hasExt di then (extfield:) else id)
. (if storeUnknown di then (unknownField:) else id)
$ eOneof
eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di)
bangType = if lazyFields di then TyParen () {- UnBangedTy -} else TyBang () (BangedTy ()) (NoUnpackPragma ()) . TyParen ()
-- extfield :: ([Name],BangType)
extfield = ([fieldIdent di "ext'field"], bangType (TyCon () (private "ExtField")))
-- unknownField :: ([Name],BangType)
unknownField = ([fieldIdent di "unknown'field"], bangType (TyCon () (private "UnknownField")))
-- fieldX :: FieldInfo -> ([Name],BangType)
fieldX fi = ([baseIdent' . fieldName $ fi], bangType (labeled (TyCon () typed)))
where labeled | canRepeat fi = typeApp "Seq"
| isRequired fi = id
| otherwise = typeApp "Maybe"
typed :: QName ()
typed = case useType (getFieldType (typeCode fi)) of
Just s -> private s
Nothing -> case typeName fi of
Just s | self /= s -> qualName s
| otherwise -> unqualName s
Nothing -> error $ "No Name for Field!\n" ++ show fi
fieldOneofX :: OneofInfo -> ([Name ()],Type ())
fieldOneofX oi = ([baseIdent' . oneofFName $ oi], typeApp "Maybe" (TyParen () (TyCon () typed)))
where typed = qualName (oneofName oi)
instancesDescriptor :: DescriptorInfo -> [Decl ()]
instancesDescriptor di = map ($ di) $
(if hasExt di then (instanceExtendMessage:) else id) $
(if storeUnknown di then (instanceUnknownMessage:) else id) $
[ instanceMergeable
, instanceDefault
, instanceWireDescriptor
, instanceMessageAPI . descName
, instanceGPB . descName
, instanceReflectDescriptor
, instanceTextType
, instanceTextMsg
]
instanceExtendMessage :: DescriptorInfo -> Decl ()
instanceExtendMessage di
= InstDecl () Nothing (mkSimpleIRule (private "ExtendMessage") [TyCon () (unqualName (descName di))]) . Just $
[ inst "getExtField" [] (Var () (localField di "ext'field"))
, inst "putExtField" [patvar "e'f", patvar "msg"] putextfield
, inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren () $ pvar "reflectDescriptorInfo" $$ lvar "msg"))
]
where putextfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "ext'field") (lvar "e'f") ]
instanceUnknownMessage :: DescriptorInfo -> Decl ()
instanceUnknownMessage di
= InstDecl () Nothing (mkSimpleIRule (private "UnknownMessage") [TyCon () (unqualName (descName di))]) . Just $
[ inst "getUnknownField" [] (Var () (localField di "unknown'field"))
, inst "putUnknownField" [patvar "u'f",patvar "msg"] putunknownfield
]
where putunknownfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "unknown'field") (lvar "u'f") ]
instanceTextType :: DescriptorInfo -> Decl ()
instanceTextType di
= InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (descName di))]) . Just $
[ inst "tellT" [] (pvar "tellSubMessage")
, inst "getT" [] (pvar "getSubMessage")
]
instanceTextMsg :: DescriptorInfo -> Decl ()
instanceTextMsg di
= InstDecl () Nothing (mkSimpleIRule (private "TextMsg") [TyCon () (unqualName (descName di))]) . Just $
[ inst "textPut" [patvar msgVar] genPrint
, InsDecl () $ FunBind () [Match () (Ident () "textGet") [] (UnGuardedRhs () parser) bdecls]
]
where
bdecls = Just (BDecls () (subparsers ++ subparsersO))
flds = F.toList (fields di)
os = F.toList (descOneofs di)
msgVar = distinctVar "msg"
distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var
reservedVars = map toPrintName flds
genPrintFields = map (Qualifier () . printField msgVar) flds
genPrintOneofs = map (Qualifier () . printOneof msgVar) os
genPrint = if null flds && null os
then preludevar "return" $$ Hse.Tuple () Boxed []
else Do () $ genPrintFields ++ genPrintOneofs
parser
| null flds && null os = preludevar "return" $$ pvar "defaultValue"
| otherwise = Do () [
Generator () (patvar "mods")
$ pvar "sepEndBy"
$$ Paren () (pvar "choice" $$ List () (map (lvar . parserName) flds ++ map (lvar . parserNameO) os))
$$ pvar "spaces",
Qualifier () $ (preludevar "return")
$$ Paren () (preludevar "foldl"
$$ Lambda () [patvar "v", patvar "f"] (lvar "f" $$ lvar "v")
$$ pvar "defaultValue"
$$ lvar "mods")
]
parserName f = let Ident () fname = baseIdent' (fieldName f) in "parse'" ++ fname
parserNameO o = let Ident () oname = baseIdent' (oneofFName o) in "parse'" ++ oname
subparsers = map (\f -> defun (parserName f) [] (getField f)) flds
getField fi = let printname = toPrintName fi
Ident () funcname = baseIdent' (fieldName fi)
update = if canRepeat fi then pvar "append" $$ Paren () (lvar funcname $$ lvar "o") $$ lvar "v" else lvar "v"
in pvar "try" $$ Do () [
Generator () (patvar "v") $ pvar "getT" $$ litStr printname,
Qualifier () $ (preludevar "return")
$$ Paren () (Lambda () [patvar "o"]
(RecUpdate () (lvar "o") [ FieldUpdate () (local funcname) update]))
]
subparsersO = map funbind os
funbind o = FunBind () [Match () (Ident () (parserNameO o)) [] (UnGuardedRhs () (getOneof)) whereParse]
where getOneof = pvar "try" $$
(pvar "choice" $$ List () (map (Var () . UnQual () . Ident ()) parsefs))
oflds = F.toList (oneofFields o)
flds = map snd oflds
parsefs = map parserName flds
whereParse = whereBinds $ BDecls () (map decl oflds)
where decl (n,f) = defun (parserName f) [] (getOneofField (n,f))
getOneofField p@(n,f) =
let Ident () oname = baseIdent' (oneofFName o)
printname = toPrintName f
update = preludecon "Just" $$ Paren () (oneofCon p $$ lvar "v")
in pvar "try" $$ Do () [
Generator () (patvar "v") $ pvar "getT" $$ litStr printname,
Qualifier () $ (preludevar "return")
$$ Paren () (Lambda () [patvar "s"]
(RecUpdate () (lvar "s") [ FieldUpdate () (local oname) update]))
]
printField :: String -> FieldInfo -> Exp ()
printField msgVar fi
= let Ident () funcname = baseIdent' (fieldName fi)
printname = toPrintName fi
in pvar "tellT" $$ litStr printname $$ Paren () (lvar funcname $$ lvar msgVar)
toPrintName :: FieldInfo -> String
toPrintName fi = let IName uname = last $ splitFI $ protobufName' (fieldName fi) in uToString uname
printOneof :: String -> OneofInfo -> Exp ()
printOneof msgVar oi
= Case () (Paren () (lvar funcname $$ lvar msgVar)) (map caseAlt flds ++ [caseAltNothing])
where Ident () funcname = baseIdent' (oneofFName oi)
IName uname = last $ splitFI $ protobufName' (oneofFName oi)
printname = uToString uname
flds = F.toList (oneofFields oi)
caseAlt :: (ProtoName,FieldInfo) -> Alt ()
caseAlt f = Alt () patt (UnGuardedRhs () rhs) noWhere
where patt = PApp () (prelude "Just") [fst (oneofPat f)]
(rstr,rvar) = oneofRec f
rhs = pvar "tellT" $$ rstr $$ rvar -- litStr fname $$ (lvar fname)
caseAltNothing :: Alt ()
caseAltNothing = Alt () (PApp () (prelude "Nothing") []) (UnGuardedRhs () rhs) noWhere
where rhs = preludevar "return" $$ unit_con ()
instanceMergeable :: DescriptorInfo -> Decl ()
instanceMergeable di
= InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () un]) . Just $
[ -- inst "mergeEmpty" [] (foldl' App (Con un) (replicate len (pvar "mergeEmpty"))),
inst "mergeAppend" [PApp () un patternVars1, PApp () un patternVars2]
(foldl' (App ()) (Con () un) (zipWith append vars1 vars2))
]
where un = unqualName (descName di)
len = (if hasExt di then succ else id)
$ (if storeUnknown di then succ else id)
$ Seq.length (fields di) + Seq.length (descOneofs di)
patternVars1,patternVars2 :: [Pat ()]
patternVars1 = take len inf
where inf = map (\ n -> patvar ("x'" ++ show n)) [(1::Int)..]
patternVars2 = take len inf
where inf = map (\ n -> patvar ("y'" ++ show n)) [(1::Int)..]
vars1,vars2 :: [Exp ()]
vars1 = take len inf
where inf = map (\ n -> lvar ("x'" ++ show n)) [(1::Int)..]
vars2 = take len inf
where inf = map (\ n -> lvar ("y'" ++ show n)) [(1::Int)..]
append x y = Paren () $ pvar "mergeAppend" $$ x $$ y
instanceDefault :: DescriptorInfo -> Decl ()
instanceDefault di
= InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () un]) . Just $
[ inst "defaultValue" [] (foldl' (App ()) (Con () un) deflistExt) ]
where un = unqualName (descName di)
deflistExt = F.foldr ((:) . defX) end (fields di)
end = (if hasExt di then (pvar "defaultValue":) else id)
. (if storeUnknown di then (pvar "defaultValue":) else id)
$ F.foldr ((:) . defOneof) [] (descOneofs di)
defX :: FieldInfo -> Exp ()
defX fi | isRequired fi = dv1
| otherwise = dv2
where dv1 = case hsDefault fi of
Nothing -> pvar "defaultValue"
Just hsdef -> defToSyntax (typeCode fi) hsdef
dv2 = case hsDefault fi of
Nothing -> pvar "defaultValue"
Just hsdef -> Paren () $ preludecon "Just" $$ defToSyntax (typeCode fi) hsdef
defOneof :: OneofInfo -> Exp ()
defOneof oi= pvar "defaultValue"
instanceMessageAPI :: ProtoName -> Decl ()
instanceMessageAPI protoName
= InstDecl () Nothing (mkSimpleIRule (private "MessageAPI")
[TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) . Just $
[ inst "getVal" [patvar "m'",patvar "f'"] (App () (lvar "f'" ) (lvar "m'")) ]
where un = unqualName protoName
instanceWireDescriptor :: DescriptorInfo -> Decl ()
instanceWireDescriptor di@(DescriptorInfo { descName = protoName
, fields = fieldInfos
, descOneofs = oneofInfos
, extRanges = allowedExts
, knownKeys = fieldExts })
= let me = unqualName protoName
extensible = not (null allowedExts)
len = (if extensible then succ else id)
$ (if storeUnknown di then succ else id)
$ Seq.length fieldInfos + Seq.length oneofInfos
mine = PApp () me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [(1::Int)..]
vars = take len . map (\ n -> lvar ("x'" ++ show n)) $ [(1::Int)..]
mExt | extensible = Just (vars !! Seq.length fieldInfos)
| otherwise = Nothing
mUnknown | storeUnknown di = Just (last vars)
| otherwise = Nothing
-- reusable 'cases' generator
-- first case is for Group behavior, second case is for Message behavior, last is error handler
cases g m e = Case () (lvar "ft'") [ Alt () (litIntP' 10) (UnGuardedRhs () g) noWhere
, Alt () (litIntP' 11) (UnGuardedRhs () m) noWhere
, Alt () (PWildCard ()) (UnGuardedRhs () e) noWhere
]
-- wireSize generation
sizeCases = UnGuardedRhs () $ cases (lvar "calc'Size")
(pvar "prependMessageSize" $$ lvar "calc'Size")
(pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")
whereCalcSize = Just (BDecls () [defun "calc'Size" [] sizes])
sizes | null sizesList = Lit () (Hse.Int () 0 "0")
| otherwise = Paren () (foldl1' (+!) sizesList)
where (+!) = mkOp "+"
sizesList | Just v <- mUnknown = sizesListExt ++ [ pvar "wireSizeUnknownField" $$ v ]
| otherwise = sizesListExt
sizesListExt | Just v <- mExt = sizesListFields ++ [ pvar "wireSizeExtField" $$ v ]
| otherwise = sizesListFields
sizesListFields = concat . zipWith toSize vars . F.toList $
fmap Left fieldInfos >< fmap Right oneofInfos
toSize var (Left fi)
= let f = if isPacked fi then "wireSizePacked"
else if isRequired fi then "wireSizeReq"
else if canRepeat fi then "wireSizeRep"
else "wireSizeOpt"
in [foldl' (App ()) (pvar f) [ litInt (wireTagLength fi)
, litInt (getFieldType (typeCode fi))
, var]]
toSize var (Right oi) = map (toSize' var) . F.toList . oneofFields $ oi
where toSize' var r@(n,fi)
= let f = "wireSizeOpt"
var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var
in foldl' (App ()) (pvar f) [ litInt (wireTagLength fi)
, litInt (getFieldType (typeCode fi))
, var']
-- wirePut generation
putCases = UnGuardedRhs () $ cases
(lvar "put'Fields")
(Do () [ Qualifier () $ pvar "putSize" $$
(Paren () $ foldl' (App ()) (pvar "wireSize") [ litInt' 10 , lvar "self'" ])
, Qualifier () $ lvar "put'Fields" ])
(pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")
wherePutFields = Just (BDecls () [defun "put'Fields" [] (Do () putStmts)])
putStmts = putStmtsContent
where putStmtsContent | null putStmtsAll = [Qualifier () $ preludevar "return" $$ Con () (Special () (UnitCon ()))]
| otherwise = putStmtsAll
putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ Qualifier () $ pvar "wirePutUnknownField" $$ v ]
| otherwise = putStmtsListExt
putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ Qualifier () $ pvar "wirePutExtField" $$ v ]
| otherwise = sortedPutStmtsList
sortedPutStmtsList = map snd -- remove number
. sortBy (compare `on` fst) -- sort by number
$ putStmtsList
putStmtsList = concat . zipWith toPut vars . F.toList $
fmap Left fieldInfos >< fmap Right oneofInfos
toPut var (Left fi)
= let f = if isPacked fi then "wirePutPacked"
else if isRequired fi then "wirePutReq"
else if canRepeat fi then "wirePutRep"
else "wirePutOpt"
in [(fieldNumber fi,
Qualifier () $
foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi))
, litInt (getFieldType (typeCode fi))
, var]
)]
toPut var (Right oi) = map (toPut' var) . F.toList . oneofFields $ oi
where toPut' var r@(n,fi)
= let f = "wirePutOpt"
var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var
in (fieldNumber fi
,Qualifier () $
foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi))
, litInt (getFieldType (typeCode fi))
, var']
)
-- wireGet generation
-- new for 1.5.7, rewriting this a great deal!
getCases = let param = if storeUnknown di
then Paren () (pvar "catch'Unknown" $$ lvar "update'Self")
else lvar "update'Self"
in UnGuardedRhs () $ cases (pvar "getBareMessageWith" $$ param)
(pvar "getMessageWith" $$ param)
(pvar "wireGetErr" $$ lvar "ft'")
whereDecls = Just (BDecls () [whereUpdateSelf])
whereUpdateSelf = defun "update'Self" [patvar "wire'Tag", patvar "old'Self"]
(Case () (lvar "wire'Tag") updateAlts)
-- update cases are all normal fields then all known extensions then wildcard
updateAlts = concatMap toUpdate (F.toList fieldInfos)
++ (do -- in list monad
o <- F.toList oneofInfos
f <- F.toList (oneofFields o)
toUpdateO o f)
++ (if extensible then concatMap toUpdateExt (F.toList fieldExts) else [])
++ [Alt () (PWildCard ()) (UnGuardedRhs () wildcardAlt) noWhere]
-- the wildcard alternative handles new extensions and
wildcardAlt = letPair extBranch
where letPair = Let () (BDecls () [PatBind () (PTuple () Boxed [patvar "field'Number",patvar "wire'Type"])
(UnGuardedRhs () (pvar "splitWireTag" $$ lvar "wire'Tag")) bdecls])
extBranch | extensible = If () (isAllowedExt (lvar "field'Number"))
(argPair (pvar "loadExtension"))
unknownBranch
| otherwise = unknownBranch
unknownBranch = argPair (pvar "unknown")
argPair x = x $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self"
bdecls = Nothing
isAllowedExt x = preludevar "or" $$ List () ranges where
(<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp "=="; (FieldId maxHi) = maxBound
ranges = map (\ (FieldId lo,FieldId hi) ->
if hi < maxHi
then if lo == hi
then (x ==! litInt lo)
else (litInt lo <=! x) &&! (x <=! litInt hi)
else litInt lo <=! x )
allowedExts
-- wireGetErr for known extensions
-- need to check isPacked and call appropriate wireGetKey[Un]Packed substitute function
toUpdateExt fi | Just (wt1,wt2) <- packedTag fi = [toUpdateExtUnpacked wt1, toUpdateExtPacked wt2]
| otherwise = [toUpdateExtUnpacked (wireTag fi)]
where (getUnP,getP) | isPacked fi = (pvar "wireGetKeyToPacked",pvar "wireGetKey")
| otherwise = (pvar "wireGetKey",pvar "wireGetKeyToUnPacked")
toUpdateExtUnpacked wt1 =
Alt () (litIntP . getWireTag $ wt1)
(UnGuardedRhs () $ getUnP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")
noWhere
toUpdateExtPacked wt2 =
Alt () (litIntP . getWireTag $ wt2)
(UnGuardedRhs () $ getP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")
noWhere
-- wireGet without extensions
toUpdate fi | Just (wt1,wt2) <- packedTag fi = [toUpdateUnpacked wt1 fi, toUpdatePacked wt2 fi]
| otherwise = [toUpdateUnpacked (wireTag fi) fi]
toUpdateUnpacked wt1 fi =
Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $
preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
RecUpdate () (lvar "old'Self")
[FieldUpdate () (unqualFName . fieldName $ fi)
(labelUpdateUnpacked fi)])
$$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
labelUpdateUnpacked fi | canRepeat fi = pvar "append" $$ Paren () ((Var () . unqualFName . fieldName $ fi)
$$ lvar "old'Self")
$$ lvar "new'Field"
| isRequired fi = qMerge (lvar "new'Field")
| otherwise = qMerge (preludecon "Just" $$ lvar "new'Field")
where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =
pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . fieldName $ fi)
$$ lvar "old'Self" )
$$ Paren () x
| otherwise = x
toUpdatePacked wt2 fi =
Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $
preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
RecUpdate () (lvar "old'Self")
[FieldUpdate () (unqualFName . fieldName $ fi)
(labelUpdatePacked fi)])
$$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
labelUpdatePacked fi = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . fieldName $ fi)
$$ lvar "old'Self")
$$ lvar "new'Field"
-- in the above, the [10,11] check optimizes using the
-- knowledge that only TYPE_MESSAGE and TYPE_GROUP have merges
-- that are not right-biased replacements. The "mergeAppend" uses
-- knowledge of how all repeated fields get merged.
-- for fields in OneofInfo
toUpdateO oi f@(_n,fi)
| Just (wt1,wt2) <- packedTag fi = [toUpdateUnpackedO oi wt1 f, toUpdatePackedO oi wt2 f]
| otherwise = [toUpdateUnpackedO oi (wireTag fi) f]
toUpdateUnpackedO oi wt1 f@(_,fi) =
Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $
preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
RecUpdate () (lvar "old'Self")
[FieldUpdate () (unqualFName . oneofFName $ oi)
(labelUpdateUnpackedO oi f)])
$$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
labelUpdateUnpackedO oi f@(_,fi) = qMerge (preludecon "Just" $$
(oneofCon f $$ lvar "new'Field")
)
where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =
pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . oneofFName $ oi)
$$ lvar "old'Self" )
$$ Paren () x
| otherwise = x
toUpdatePackedO oi wt2 f@(_,fi) =
Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $
preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $
RecUpdate () (lvar "old'Self")
[FieldUpdate () (unqualFName . oneofFName $ oi)
(labelUpdatePackedO oi f)])
$$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
labelUpdatePackedO oi f@(_,fi) = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . oneofFName $ oi)
$$ lvar "old'Self")
$$ Paren () (preludecon "Just" $$
(oneofCon f $$ lvar "new'Field"))
in InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () me]) . Just . map (InsDecl ()) $
[ FunBind () [Match () (Ident () "wireSize") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] sizeCases whereCalcSize]
, FunBind () [Match () (Ident () "wirePut") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] putCases wherePutFields]
, FunBind () [Match () (Ident () "wireGet") [patvar "ft'"] getCases whereDecls]
]
instanceReflectDescriptor :: DescriptorInfo -> Decl ()
instanceReflectDescriptor di
= InstDecl () Nothing (mkSimpleIRule (private "ReflectDescriptor") [TyCon () (unqualName (descName di))]) . Just $
[ inst "getMessageInfo" [PWildCard ()] gmi
, inst "reflectDescriptorInfo" [PWildCard ()] rdi ]
where -- massive shortcut through show and read
rdi :: Exp ()
rdi = preludevar "read" $$ litStr (show di)
gmi,reqId,allId :: Exp ()
gmi = pcon "GetMessageInfo" $$ Paren () reqId $$ Paren () allId
reqId = pvar "fromDistinctAscList" $$
List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di), isRequired fi])
allId = pvar "fromDistinctAscList" $$
List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di)] ++
[ allowedList fi | fi <- F.toList (knownKeys di)])
allowedList fi | Just (wt1,wt2) <- packedTag fi = [getWireTag wt1,getWireTag wt2]
| otherwise = [getWireTag (wireTag fi)]
------------------------------------------------------------------
mkSimpleIRule :: QName () -> [Type ()] -> InstRule ()
mkSimpleIRule con args =
let instHead = foldl' (IHApp ()) (IHCon () con) args
in IRule () Nothing Nothing instHead
mkDeriving :: [QName ()] -> Deriving ()
mkDeriving xs = Deriving () (map (\x -> mkSimpleIRule x []) xs)
derives,derivesEnum :: Deriving ()
derives = mkDeriving $ map prelude ["Show","Eq","Ord","Typeable","Data","Generic"]
derivesEnum = mkDeriving $ map prelude ["Read","Show","Eq","Ord","Typeable","Data","Generic"]
-- All of these type names are also exported by Text.ProtocolBuffers.Header via Text.ProtocolBuffers.Basic
useType :: Int -> Maybe String
useType 1 = Just "Double"
useType 2 = Just "Float"
useType 3 = Just "Int64"
useType 4 = Just "Word64"
useType 5 = Just "Int32"
useType 6 = Just "Word64"
useType 7 = Just "Word32"
useType 8 = Just "Bool"
useType 9 = Just "Utf8"
useType 10 = Nothing
useType 11 = Nothing
useType 12 = Just "ByteString"
useType 13 = Just "Word32"
useType 14 = Nothing
useType 15 = Just "Int32"
useType 16 = Just "Int64"
useType 17 = Just "Int32"
useType 18 = Just "Int64"
useType x = imp $ "useType: Unknown type code (expected 1 to 18) of "++show x