hprotoc-0.3.1: Text/ProtocolBuffers/ProtoCompile/Gen.hs
-- try "test", "testDesc", and "testLabel" to see sample output
--
-- Obsolete : Turn *Proto into Language.Haskell.Exts.Syntax from haskell-src-exts package
-- Now cut back to use just Language.Haskell.Syntax, see coments marked YYY for the Exts verision
--
-- Note that this may eventually also generate hs-boot files to allow
-- for breaking mutual recursion. This is ignored for getting
-- descriptor.proto running.
--
-- 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.
--
-- default values are an awful mess. They are documented in descriptor.proto as
{-
// For numeric types, contains the original text representation of the value.
// For booleans, "true" or "false".
// For strings, contains the default text contents (not escaped in any way).
// For bytes, contains the C escaped value. All bytes >= 128 are escaped.
// TODO(kenton): Base-64 encode?
optional string default_value = 7;
-}
module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModule,enumModule,prettyPrint) where
import Text.ProtocolBuffers.Basic
import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),DescriptorInfo(..),ProtoInfo(..),EnumInfo(..),ProtoName(..),FieldInfo(..))
import qualified Data.ByteString.Lazy.Char8 as LC(unpack)
import Data.Char(isUpper)
import qualified Data.Foldable as F(foldr,toList)
import Data.List(sort,sortBy,group,foldl',foldl1')
import Data.Function(on)
import Language.Haskell.Pretty(prettyPrint)
import Language.Haskell.Syntax
import qualified Data.Map as M
import qualified Data.Sequence as Seq(null,length)
import qualified Data.Set as S
--import Debug.Trace(trace)
default (Int)
-- -- -- -- Helper functions
noWhere :: [HsDecl]
noWhere = [] -- YYY noWhere = (HsBDecls [])
($$) :: HsExp -> HsExp -> HsExp
($$) = HsApp
infixl 1 $$
dotPre :: String -> String -> String
dotPre "" x = x -- after this the value of s cannot be []
dotPre s "" = s
dotPre s x@('.':xs) | '.' == last s = s ++ xs -- s cannnot be [], so last is safe
| otherwise = s ++ x
dotPre s x | '.' == last s = s++x -- s cannnot be [], so last is safe
| otherwise = s++('.':x)
src :: SrcLoc
src = SrcLoc "No SrcLoc" 0 0
litIntP :: Integral x => x -> HsPat
litIntP x | x<0 = HsPParen $ HsPLit (HsInt (toInteger x))
| otherwise = HsPLit (HsInt (toInteger x))
litInt :: Integral x => x -> HsExp
litInt x | x<0 = HsParen $ HsLit (HsInt (toInteger x))
| otherwise = HsLit (HsInt (toInteger x))
typeApp :: String -> HsType -> HsType
typeApp s = HsTyApp (HsTyCon (private s))
pvar :: String -> HsExp
pvar t = HsVar (private t)
lvar :: String -> HsExp
lvar t = HsVar (UnQual (HsIdent t))
private :: String -> HsQName
private t = Qual (Module "P'") (HsIdent t)
inst :: String -> [HsPat] -> HsExp -> HsDecl
inst s p r = HsFunBind [HsMatch src (HsIdent s) p (HsUnGuardedRhs r) noWhere]
fqName :: ProtoName -> String
fqName (ProtoName a b c) = dotPre a (dotPre b c)
qualName :: ProtoName -> HsQName
qualName (ProtoName _prefix "" base) = UnQual (HsIdent base)
qualName (ProtoName _prefix parent base) = Qual (Module parent) (HsIdent base)
unqualName :: ProtoName -> HsQName
unqualName (ProtoName _prefix _parent base) = UnQual (HsIdent base)
mayQualName :: ProtoName -> ProtoName -> HsQName
mayQualName context name@(ProtoName prefix modname base) =
if fqName context == dotPre prefix modname then UnQual (HsIdent base)
else qualName name
--------------------------------------------
-- EnumDescriptorProto module creation
--------------------------------------------
{-
enumModule :: String -> D.EnumDescriptorProto -> HsModule
enumModule prefix e
= let ei = makeEnumInfo prefix e
-}
enumModule :: EnumInfo -> HsModule
enumModule ei
= let protoName = enumName ei
in HsModule src (Module (fqName protoName))
(Just [HsEThingAll (UnQual (HsIdent (baseName protoName)))])
(standardImports False) (enumDecls ei)
enumDecls :: EnumInfo -> [HsDecl]
enumDecls ei = map ($ ei) [ enumX
, instanceMergeableEnum
, instanceBounded
, instanceDefaultEnum
, instanceEnum
, instanceWireEnum
, instanceGPB . enumName
, instanceMessageAPI . enumName
, instanceReflectEnum
]
enumX :: EnumInfo -> HsDecl
enumX ei = HsDataDecl src [] (HsIdent (baseName (enumName ei))) [] (map enumValueX (enumValues ei)) derivesEnum
where enumValueX (_,name) = HsConDecl src (HsIdent name) []
instanceMergeableEnum :: EnumInfo -> HsDecl
instanceMergeableEnum ei
= HsInstDecl src [] (private "Mergeable") [HsTyCon (unqualName (enumName ei))] []
instanceBounded :: EnumInfo -> HsDecl
instanceBounded ei
= HsInstDecl src [] (private "Bounded") [HsTyCon (unqualName (enumName ei))]
[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 [] (HsCon (UnQual (HsIdent 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 -> HsDecl
instanceDefaultEnum ei
= HsInstDecl src [] (private "Default") [HsTyCon (unqualName (enumName ei))]
[ inst "defaultValue" [] firstValue ]
where firstValue :: HsExp
firstValue = case enumValues ei of
(:) (_,n) _ -> HsCon (UnQual (HsIdent n))
[] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei
instanceEnum :: EnumInfo -> HsDecl
instanceEnum ei
= HsInstDecl src [] (private "Enum") [HsTyCon (unqualName (enumName ei))]
(map HsFunBind [fromEnum',toEnum',succ',pred'])
where values = enumValues ei
fromEnum' = map fromEnum'one values
fromEnum'one (v,n) = HsMatch src (HsIdent "fromEnum") [HsPApp (UnQual (HsIdent n)) []]
(HsUnGuardedRhs (litInt (getEnumCode v))) noWhere
toEnum' = map toEnum'one values
toEnum'one (v,n) = HsMatch src (HsIdent "toEnum") [litIntP (getEnumCode v)] -- enums cannot be negative so no parenthesis are required to protect a negative sign
(HsUnGuardedRhs (HsCon (UnQual (HsIdent n)))) noWhere
succ' = zipWith (equate "succ") values (tail values)
pred' = zipWith (equate "pred") (tail values) values
equate f (_,n1) (_,n2) = HsMatch src (HsIdent f) [HsPApp (UnQual (HsIdent n1)) []]
(HsUnGuardedRhs (HsCon (UnQual (HsIdent n2)))) noWhere
-- fromEnum TYPE_ENUM == 14 :: Int
instanceWireEnum :: EnumInfo -> HsDecl
instanceWireEnum ei
= HsInstDecl src [] (private "Wire") [HsTyCon (unqualName (enumName ei))]
[ withName "wireSize", withName "wirePut", withGet, withGetErr ]
where withName foo = inst foo [HsPVar (HsIdent "ft'"),HsPVar (HsIdent "enum")] rhs
where rhs = pvar foo $$ lvar "ft'" $$
(HsParen $ pvar "fromEnum" $$ lvar "enum")
withGet = inst "wireGet" [litIntP 14] rhs
where rhs = pvar "fmap" $$ pvar "toEnum" $$
(HsParen $ pvar "wireGet" $$ HsLit (HsInt 14))
withGetErr = inst "wireGet" [HsPVar (HsIdent "ft'")] rhs
where rhs = pvar "wireGetErr" $$ lvar "ft'"
instanceGPB :: ProtoName -> HsDecl
instanceGPB protoName
= HsInstDecl src [] (private "GPB") [HsTyCon (unqualName protoName)] []
instanceReflectEnum :: EnumInfo -> HsDecl
instanceReflectEnum ei
= HsInstDecl src [] (private "ReflectEnum") [HsTyCon (unqualName (enumName ei))]
[ inst "reflectEnum" [] ascList
, inst "reflectEnumInfo" [ HsPWildCard ] ei' ]
where (ProtoName a b c) = enumName ei
values = enumValues ei
ascList,ei',protoNameExp :: HsExp
ascList = HsList (map one values)
where one (v,ns) = HsTuple [litInt (getEnumCode v),HsLit (HsString ns),HsCon (UnQual (HsIdent ns))]
ei' = foldl' HsApp (HsCon (private "EnumInfo")) [protoNameExp
,HsList $ map (HsLit . HsString) (enumFilePath ei)
,HsList (map two values)]
where two (v,ns) = HsTuple [litInt (getEnumCode v),HsLit (HsString ns)]
protoNameExp = HsParen $ foldl' HsApp (HsCon (private "ProtoName")) . map (HsLit . HsString) $ [a,b,c]
--------------------------------------------
-- DescriptorProto module creation is unfinished
-- There are difficult namespace issues
--------------------------------------------
hasExt :: DescriptorInfo -> Bool
hasExt di = not (null (extRanges di))
protoModule :: ProtoInfo -> ByteString -> HsModule
protoModule pri@(ProtoInfo protoName _ _ keyInfos _ _ _) fdpBS
= let exportKeys = map (HsEVar . UnQual . HsIdent . baseName . fieldName . snd) (F.toList keyInfos)
exportNames = map (HsEVar . UnQual . HsIdent) ["protoInfo","fileDescriptorProto"]
imports = protoImports ++ map formatImport (protoImport pri)
in HsModule src (Module (fqName protoName)) (Just (exportKeys++exportNames)) imports (keysX protoName keyInfos ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)
where protoImports = standardImports (not . Seq.null . extensionKeys $ pri) ++
[ HsImportDecl src (Module "Text.DescriptorProtos.FileDescriptorProto") False Nothing
(Just (False,[HsIAbs (HsIdent "FileDescriptorProto")]))
, HsImportDecl src (Module "Text.ProtocolBuffers.Reflections") False Nothing
(Just (False,[HsIAbs (HsIdent "ProtoInfo")]))
, HsImportDecl src (Module "Text.ProtocolBuffers.WireMessage") True (Just (Module "P'"))
(Just (False,[HsIVar (HsIdent "wireGet,getFromBS")]))
]
formatImport (m,t) = HsImportDecl src (Module (dotPre (haskellPrefix protoName) (dotPre m t))) True
(Just (Module m)) (Just (False,[HsIAbs (HsIdent t)]))
protoImport :: ProtoInfo -> [(String,String)]
protoImport (ProtoInfo protoName _ _ keyInfos _ _ _)
= map head . group . sort
. filter (selfName /=)
. concatMap withMod
$ allNames
where selfName = (parentModule protoName, baseName protoName)
withMod (ProtoName _prefix "" _base) = []
withMod (ProtoName _prefix modname base) = [(modname,base)]
allNames = F.foldr (\(e,fi) rest -> e : addName fi rest) [] keyInfos
addName fi rest = maybe rest (:rest) (typeName fi)
embed'ProtoInfo :: ProtoInfo -> [HsDecl]
embed'ProtoInfo pri = [ myType, myValue ]
where myType = HsTypeSig src [ HsIdent "protoInfo" ] (HsQualType [] (HsTyCon (UnQual (HsIdent "ProtoInfo"))))
myValue = HsPatBind src (HsPApp (UnQual (HsIdent "protoInfo")) []) (HsUnGuardedRhs $
pvar "read" $$ HsLit (HsString (show pri))) noWhere
embed'fdpBS :: ByteString -> [HsDecl]
embed'fdpBS bs = [ myType, myValue ]
where myType = HsTypeSig src [ HsIdent "fileDescriptorProto" ] (HsQualType [] (HsTyCon (UnQual (HsIdent "FileDescriptorProto"))))
myValue = HsPatBind src (HsPApp (UnQual (HsIdent "fileDescriptorProto")) []) (HsUnGuardedRhs $
pvar "getFromBS" $$
HsParen (pvar "wireGet" $$ litInt 11) $$
HsParen (pvar "pack" $$ HsLit (HsString (LC.unpack bs)))) noWhere
descriptorModule :: DescriptorInfo -> HsModule
descriptorModule di
= let protoName = descName di
un = UnQual . HsIdent . baseName $ protoName
imports = standardImports (hasExt di) ++ map formatImport (toImport di)
exportKeys = map (HsEVar . UnQual . HsIdent . baseName . fieldName . snd) (F.toList (keys di))
formatImport ((a,b),s) = HsImportDecl src (Module a) True (Just (Module b)) (Just (False,
map (HsIAbs . HsIdent) (S.toList s)))
in HsModule src (Module (fqName protoName))
(Just (HsEThingAll un : exportKeys))
imports (descriptorX di : (keysX protoName (keys di) ++ instancesDescriptor di))
standardImports :: Bool -> [HsImportDecl]
standardImports ext =
[ HsImportDecl src (Module "Prelude") False Nothing (Just (False,ops))
, HsImportDecl src (Module "Prelude") True (Just (Module "P'")) Nothing
, HsImportDecl src (Module "Text.ProtocolBuffers.Header") True (Just (Module "P'")) Nothing ]
where ops | ext = map (HsIVar . HsSymbol) ["+","<=","&&"," || "]
| otherwise = map (HsIVar . HsSymbol) ["+"]
toImport :: DescriptorInfo -> [((String,String),S.Set String)]
toImport di
= M.assocs . M.fromListWith S.union . filter isForeign . map withMod $ allNames
where isForeign = let here = fqName protoName
in (\((a,_),_) -> a/=here)
protoName = descName di
withMod p@(ProtoName prefix modname base) | isUpper (head base) = ((fqName p,modname),S.singleton base)
| otherwise = ((dotPre prefix modname,modname),S.singleton base)
allNames = F.foldr addName keyNames (fields di)
keyNames = F.foldr (\(e,fi) rest -> e : addName fi rest) keysKnown (keys di)
keysKnown = F.foldr (\fi rest -> fieldName fi : rest) [] (knownKeys di)
-- keysKnown = F.foldr (\fi rest -> addName fi (fieldName fi : rest)) [] (knownKeys di)
addName fi rest = maybe rest (:rest) (typeName fi)
keysX :: ProtoName -> Seq KeyInfo -> [HsDecl]
keysX self i = concatMap (makeKey self) . F.toList $ i
makeKey :: ProtoName -> KeyInfo -> [HsDecl]
makeKey self (extendee,f) = [ keyType, keyVal ]
where keyType = HsTypeSig src [ HsIdent (baseName . fieldName $ f) ] (HsQualType [] (foldl1 HsTyApp . map HsTyCon $
[ private "Key", private labeled
, if extendee /= self then qualName extendee else unqualName extendee
, typeQName ]))
labeled | canRepeat f = "Seq"
| otherwise = "Maybe"
typeNumber = getFieldType . typeCode $ f
typeQName :: HsQName
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
keyVal = HsPatBind src (HsPApp (UnQual (HsIdent (baseName (fieldName f)))) []) (HsUnGuardedRhs
(pvar "Key" $$ litInt (getFieldId (fieldNumber f))
$$ litInt typeNumber
$$ maybe (pvar "Nothing") (HsParen . (pvar "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f)
)) noWhere
defToSyntax :: FieldType -> HsDefault -> HsExp
defToSyntax tc x =
case x of
HsDef'Bool b -> HsCon (private (show b))
HsDef'ByteString bs -> (if tc == 9 then (\xx -> HsParen (pvar "Utf8" $$ xx)) else id) $
(HsParen $ pvar "pack" $$ HsLit (HsString (LC.unpack bs)))
HsDef'Rational r | r < 0 -> HsParen $ HsLit (HsFrac r)
| otherwise -> HsLit (HsFrac r)
HsDef'Integer i | i < 0 -> HsParen $ HsLit (HsInt i)
| otherwise -> HsLit (HsInt i)
HsDef'Enum s -> HsParen $ pvar "read" $$ HsLit (HsString s)
descriptorX :: DescriptorInfo -> HsDecl
descriptorX di = HsDataDecl src [] name [] [con] derives
where self = descName di
name = HsIdent (baseName self)
con = HsRecDecl src name eFields
where eFields = F.foldr ((:) . fieldX) end (fields di)
end = (if hasExt di then (extfield:) else id)
$ (if storeUnknown di then [unknownField] else [])
extfield :: ([HsName],HsBangType)
extfield = ([HsIdent "ext'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "ExtField"))))
unknownField :: ([HsName],HsBangType)
unknownField = ([HsIdent "unknown'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "UnknownField"))))
fieldX :: FieldInfo -> ([HsName],HsBangType)
fieldX fi = ([HsIdent (baseName $ fieldName fi)],HsUnBangedTy (labeled (HsTyCon typed)))
where labeled | canRepeat fi = typeApp "Seq"
| isRequired fi = id
| otherwise = typeApp "Maybe"
typed :: HsQName
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
instancesDescriptor :: DescriptorInfo -> [HsDecl]
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
]
instanceExtendMessage :: DescriptorInfo -> HsDecl
instanceExtendMessage di
= HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]
[ inst "getExtField" [] (lvar "ext'field")
, inst "putExtField" [HsPVar (HsIdent "e'f"),HsPVar (HsIdent "msg")] putextfield
, inst "validExtRanges" [ HsPVar (HsIdent "msg") ] (pvar "extRanges" $$ (HsParen $ pvar "reflectDescriptorInfo" $$ lvar "msg"))
]
where putextfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "ext'field")) (lvar "e'f") ]
instanceUnknownMessage :: DescriptorInfo -> HsDecl
instanceUnknownMessage di
= HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]
[ inst "getUnknownField" [] (lvar "unknown'field")
, inst "putUnknownField" [HsPVar (HsIdent "u'f"),HsPVar (HsIdent "msg")] putunknownfield
]
where putunknownfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "unknown'field")) (lvar "u'f") ]
instanceMergeable :: DescriptorInfo -> HsDecl
instanceMergeable di
= HsInstDecl src [] (private "Mergeable") [HsTyCon un]
[ inst "mergeEmpty" [] (foldl' HsApp (HsCon un) (replicate len (HsCon (private "mergeEmpty"))))
, inst "mergeAppend" [HsPApp un patternVars1, HsPApp un patternVars2]
(foldl' HsApp (HsCon un) (zipWith append vars1 vars2))
]
where un = UnQual (HsIdent (baseName (descName di)))
len = (if hasExt di then succ else id)
$ (if storeUnknown di then succ else id)
$ Seq.length (fields di)
patternVars1,patternVars2 :: [HsPat]
patternVars1 = take len inf
where inf = map (\n -> HsPVar (HsIdent ("x'" ++ show n))) [1..]
patternVars2 = take len inf
where inf = map (\n -> HsPVar (HsIdent ("y'" ++ show n))) [1..]
vars1,vars2 :: [HsExp]
vars1 = take len inf
where inf = map (\n -> lvar ("x'" ++ show n)) [1..]
vars2 = take len inf
where inf = map (\n -> lvar ("y'" ++ show n)) [1..]
append x y = HsParen $ pvar "mergeAppend" $$ x $$ y
instanceDefault :: DescriptorInfo -> HsDecl
instanceDefault di
= HsInstDecl src [] (private "Default") [HsTyCon un]
[ inst "defaultValue" [] (foldl' HsApp (HsCon un) deflistExt) ]
where un = UnQual (HsIdent (baseName (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 [])
defX :: FieldInfo -> HsExp
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 -> HsParen $ HsCon (private "Just") $$ defToSyntax (typeCode fi) hsdef
instanceMessageAPI :: ProtoName -> HsDecl
instanceMessageAPI protoName
= HsInstDecl src [] (private "MessageAPI") [HsTyVar (HsIdent "msg'"), HsTyFun (HsTyVar (HsIdent "msg'")) (HsTyCon un), (HsTyCon un)]
[ inst "getVal" [HsPVar (HsIdent "m'"),HsPVar (HsIdent "f'")] (HsApp (lvar "f'" ) (lvar "m'")) ]
where un = UnQual (HsIdent (baseName protoName))
mkOp :: String -> HsExp -> HsExp -> HsExp
mkOp s a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol s))) b
instanceWireDescriptor :: DescriptorInfo -> HsDecl
instanceWireDescriptor di@(DescriptorInfo { descName = protoName
, fields = fieldInfos
, 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
mine = HsPApp me . take len . map (\n -> HsPVar (HsIdent ("x'" ++ show n))) $ [1..]
vars = take len . map (\n -> lvar ("x'" ++ show n)) $ [1..]
mExt | extensible = Just (vars !! Seq.length fieldInfos)
| otherwise = Nothing
mUnknown | storeUnknown di = Just (last vars)
| otherwise = Nothing
-- first case is for Group behavior, second case is for Message behavior, last is error handler
cases g m e = HsCase (lvar "ft'") [ HsAlt src (litIntP 10) (HsUnGuardedAlt g) noWhere
, HsAlt src (litIntP 11) (HsUnGuardedAlt m) noWhere
, HsAlt src HsPWildCard (HsUnGuardedAlt e) noWhere
]
sizeCases = HsUnGuardedRhs $ cases (lvar "calc'Size")
(pvar "prependMessageSize" $$ lvar "calc'Size")
(pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")
whereCalcSize = [HsFunBind [HsMatch src (HsIdent "calc'Size") [] (HsUnGuardedRhs sizes) noWhere]]
sizes | null sizesList = HsLit (HsInt 0)
| otherwise = HsParen (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 = zipWith toSize vars . F.toList $ fieldInfos
toSize var fi = let f = if isRequired fi then "wireSizeReq"
else if canRepeat fi then "wireSizeRep"
else "wireSizeOpt"
in foldl' HsApp (pvar f) [ litInt (wireTagLength fi)
, litInt (getFieldType (typeCode fi))
, var]
putCases = HsUnGuardedRhs $ cases
(lvar "put'Fields")
(HsDo [ HsQualifier $ pvar "putSize" $$
(HsParen $ foldl' HsApp (pvar "wireSize") [ litInt 10 , lvar "self'" ])
, HsQualifier $ lvar "put'Fields" ])
(pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")
wherePutFields = [HsFunBind [HsMatch src (HsIdent "put'Fields") [] (HsUnGuardedRhs (HsDo putStmts)) noWhere]]
putStmts = putStmtsContent
where putStmtsContent | null putStmtsAll = [HsQualifier $ pvar "return" $$ HsCon (Special HsUnitCon)]
| otherwise = putStmtsAll
putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ HsQualifier $ pvar "wirePutUnknownField" $$ v ]
| otherwise = putStmtsListExt
putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ HsQualifier $ pvar "wirePutExtField" $$ v ]
| otherwise = sortedPutStmtsList
sortedPutStmtsList = map snd -- remove number
. sortBy (compare `on` fst) -- sort by number
. zip (map fieldNumber . F.toList $ fieldInfos) -- add number as fst
$ putStmtsList
putStmtsList = zipWith toPut vars . F.toList $ fieldInfos
toPut var fi = let f = if isRequired fi then "wirePutReq"
else if canRepeat fi then "wirePutRep"
else "wirePutOpt"
in HsQualifier $
foldl' HsApp (pvar f) [ litInt (getWireTag (wireTag fi))
, litInt (getFieldType (typeCode fi))
, var]
getCases = HsUnGuardedRhs $ cases
(pvar "getBareMessageWith" $$ otherField $$ lvar "update'Self")
(pvar "getMessageWith" $$ otherField $$ lvar "update'Self")
(pvar "wireGetErr" $$ lvar "ft'")
whereDecls | extensible = [whereUpdateSelf,processExt]
| otherwise = [whereUpdateSelf]
whereUpdateSelf = HsFunBind [HsMatch src (HsIdent "update'Self")
[HsPVar (HsIdent "field'Number") ,HsPVar (HsIdent "old'Self")]
(HsUnGuardedRhs (HsCase (lvar "field'Number") updateAlts)) noWhere]
otherField | extensible = lvar "other'Field"
| otherwise = processUnknown
processUnknown | storeUnknown di = pvar "loadUnknown"
| otherwise = pvar "unknown"
processExt =
HsFunBind [HsMatch src (HsIdent "other'Field")
[HsPVar (HsIdent "field'Number"), HsPVar (HsIdent "wire'Type"), HsPVar (HsIdent "old'Self")]
(HsUnGuardedRhs (HsParen (HsIf (isAllowed (lvar "field'Number"))
(pvar "loadExtension")
(processUnknown))
$$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self")) noWhere]
isAllowed x = pvar "or" $$ HsList ranges where
(<=!) = mkOp "<="; (&&!) = mkOp "&&";
ranges = map (\(FieldId lo,FieldId hi) -> if hi < maxHi then (litInt lo <=! x) &&! (x <=! litInt hi)
else litInt lo <=! x) allowedExts
where FieldId maxHi = maxBound
updateAlts = map toUpdate (F.toList fieldInfos)
++ (if extensible && (not (Seq.null fieldExts)) then map toUpdateExt (F.toList fieldExts) else [])
++ [HsAlt src HsPWildCard (HsUnGuardedAlt $
pvar "unknownField" $$ (lvar "field'Number")) noWhere]
toUpdateExt fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $
pvar "wireGetKey" $$ HsVar (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere
-- fieldIds cannot be negative so no parenthesis are required to protect a negative sign
toUpdate fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $
pvar "fmap" $$ (HsParen $ HsLambda src [HsPVar (HsIdent "new'Field")] $
HsRecUpdate (lvar "old'Self") [HsFieldUpdate (UnQual . HsIdent . baseName . fieldName $ fi)
(labelUpdate fi)])
$$ (HsParen (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere
labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . baseName . fieldName $ fi) $$ lvar "old'Self")
$$ lvar "new'Field"
| isRequired fi = qMerge (lvar "new'Field")
| otherwise = qMerge (HsCon (private "Just") $$ lvar "new'Field")
where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,11] =
pvar "mergeAppend" $$ HsParen ((lvar . baseName . fieldName $ fi) $$ lvar "old'Self") $$ (HsParen x)
| otherwise = x
in HsInstDecl src [] (private "Wire") [HsTyCon me]
[ HsFunBind [HsMatch src (HsIdent "wireSize") [HsPVar (HsIdent "ft'"),HsPAsPat (HsIdent "self'") (HsPParen mine)] sizeCases whereCalcSize]
, HsFunBind [HsMatch src (HsIdent "wirePut") [HsPVar (HsIdent "ft'"),HsPAsPat (HsIdent "self'") (HsPParen mine)] putCases wherePutFields]
, HsFunBind [HsMatch src (HsIdent "wireGet") [HsPVar (HsIdent "ft'")] getCases whereDecls]
]
-- TODO : Encode allow as a proper set of numbers!
instanceReflectDescriptor :: DescriptorInfo -> HsDecl
instanceReflectDescriptor di
= HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]
[ inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ]
where -- massive shortcut through show and read
rdi :: HsExp
rdi = pvar "read" $$ HsLit (HsString (show di))
------------------------------------------------------------------
derives,derivesEnum :: [HsQName]
derives = map private ["Show","Eq","Ord","Typeable"]
derivesEnum = map private ["Read","Show","Eq","Ord","Typeable"]
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 = error $ "Text.ProtocolBuffers.Gen: Impossible? useType Unknown type code "++show x
-----------------------
{-
test = putStrLn . prettyPrint . descriptorModule False "Text" $ d'
testDesc = putStrLn . prettyPrint . descriptorModule False "Text" $ genFieldOptions
testLabel = putStrLn . prettyPrint $ enumModule "Text" labelTest
testType = putStrLn . prettyPrint $ enumModule "Text" t
-- testing
utf8FromString = Utf8 . U.fromString
-- try and generate a small replacement for my manual file
genFieldOptions :: D.DescriptorProto.DescriptorProto
genFieldOptions =
defaultValue
{ D.DescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldOptions")
, D.DescriptorProto.field = Seq.fromList
[ defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "ctype")
, D.FieldDescriptorProto.number = Just 1
, D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
, D.FieldDescriptorProto.type' = Just TYPE_ENUM
, D.FieldDescriptorProto.type_name = Just (utf8FromString "DescriptorProtos.FieldOptions.CType")
, D.FieldDescriptorProto.default_value = Nothing
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "experimental_map_key")
, D.FieldDescriptorProto.number = Just 9
, D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
, D.FieldDescriptorProto.type' = Just TYPE_STRING
, D.FieldDescriptorProto.default_value = Nothing
}
]
}
-- test several features
d' :: D.DescriptorProto.DescriptorProto
d' = defaultValue
{ D.DescriptorProto.name = Just (utf8FromString "SomeMod.ServiceOptions")
, D.DescriptorProto.field = Seq.fromList
[ defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "fieldString")
, D.FieldDescriptorProto.number = Just 1
, D.FieldDescriptorProto.label = Just LABEL_REQUIRED
, D.FieldDescriptorProto.type' = Just TYPE_STRING
, D.FieldDescriptorProto.default_value = Just (utf8FromString "Hello World")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "fieldDouble")
, D.FieldDescriptorProto.number = Just 4
, D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
, D.FieldDescriptorProto.type' = Just TYPE_DOUBLE
, D.FieldDescriptorProto.default_value = Just (utf8FromString "+5.5e-10")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "fieldBytes")
, D.FieldDescriptorProto.number = Just 2
, D.FieldDescriptorProto.label = Just LABEL_REQUIRED
, D.FieldDescriptorProto.type' = Just TYPE_STRING
, D.FieldDescriptorProto.default_value = Just (utf8FromString . map toEnum $ [0,5..255])
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "fieldInt64")
, D.FieldDescriptorProto.number = Just 3
, D.FieldDescriptorProto.label = Just LABEL_REQUIRED
, D.FieldDescriptorProto.type' = Just TYPE_INT64
, D.FieldDescriptorProto.default_value = Just (utf8FromString "-0x40")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "fieldBool")
, D.FieldDescriptorProto.number = Just 5
, D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
, D.FieldDescriptorProto.type' = Just TYPE_STRING
, D.FieldDescriptorProto.default_value = Just (utf8FromString "False")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "field2TestSelf")
, D.FieldDescriptorProto.number = Just 6
, D.FieldDescriptorProto.label = Just LABEL_OPTIONAL
, D.FieldDescriptorProto.type' = Just TYPE_MESSAGE
, D.FieldDescriptorProto.type_name = Just (utf8FromString "ServiceOptions")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "field3TestQualified")
, D.FieldDescriptorProto.number = Just 7
, D.FieldDescriptorProto.label = Just LABEL_REPEATED
, D.FieldDescriptorProto.type' = Just TYPE_MESSAGE
, D.FieldDescriptorProto.type_name = Just (utf8FromString "A.B.C.Label")
}
, defaultValue
{ D.FieldDescriptorProto.name = Just (utf8FromString "field4TestUnqualified")
, D.FieldDescriptorProto.number = Just 8
, D.FieldDescriptorProto.label = Just LABEL_REPEATED
, D.FieldDescriptorProto.type' = Just TYPE_MESSAGE
, D.FieldDescriptorProto.type_name = Just (utf8FromString "Maybe")
}
]
}
labelTest :: D.EnumDescriptorProto.EnumDescriptorProto
labelTest = defaultValue
{ D.EnumDescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldDescriptorProto.Label")
, D.EnumDescriptorProto.value = Seq.fromList
[ defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_OPTIONAL")
, D.EnumValueDescriptorProto.number = Just 1 }
, defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_REQUIRED")
, D.EnumValueDescriptorProto.number = Just 2 }
, defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_REPEATED")
, D.EnumValueDescriptorProto.number = Just 3 }
]
}
t :: D.EnumDescriptorProto.EnumDescriptorProto
t = defaultValue { D.EnumDescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldDescriptorProto.Type")
, D.EnumDescriptorProto.value = Seq.fromList . zipWith make [1..] $ names }
where make :: Int32 -> String -> D.EnumValueDescriptorProto
make i s = defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString s)
, D.EnumValueDescriptorProto.number = Just i }
names = ["TYPE_DOUBLE","TYPE_FLOAT","TYPE_INT64","TYPE_UINT64","TYPE_INT32"
,"TYPE_FIXED64","TYPE_FIXED32","TYPE_BOOL","TYPE_STRING","TYPE_GROUP"
,"TYPE_MESSAGE","TYPE_BYTES","TYPE_UINT32","TYPE_ENUM","TYPE_SFIXED32"
,"TYPE_SFIXED64","TYPE_SINT32","TYPE_SINT64"]
-}