hprotoc 0.3.1 → 1.0.0
raw patch · 9 files changed
+1526/−918 lines, 9 filesdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
Files
- Text/ProtocolBuffers/ProtoCompile.hs +111/−41
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +71/−194
- Text/ProtocolBuffers/ProtoCompile/Instances.hs +2/−2
- Text/ProtocolBuffers/ProtoCompile/Lexer.x +7/−7
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +94/−127
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +248/−179
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +977/−354
- dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs +7/−7
- hprotoc.cabal +9/−7
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -1,56 +1,102 @@--- | This is the Main module for the command line program+-- | This is the Main module for the command line program 'hprotoc' module Main where -import qualified Data.Map as M-import Data.Version+import Control.Monad(when)+import qualified Data.ByteString.Lazy.Char8 as LC (writeFile)+import Data.List(break)+import qualified Data.Sequence as Seq (fromList,singleton)+import Data.Version(Version(..),showVersion) import Language.Haskell.Pretty(prettyPrintStyleMode,Style(..),Mode(..),PPHsMode(..),PPLayout(..))-import System.Console.GetOpt-import System.Environment-import System.Directory-import System.FilePath+import System.Console.GetOpt(OptDescr(Option),ArgDescr(NoArg,ReqArg)+ ,usageInfo,getOpt,ArgOrder(ReturnInOrder))+import System.Directory(getCurrentDirectory,createDirectoryIfMissing)+import System.Environment(getArgs)+import System.FilePath(takeDirectory,combine,joinPath)+import qualified System.FilePath.Posix as Canon(takeBaseName) +import Text.ProtocolBuffers.Basic(defaultValue)+import Text.ProtocolBuffers.Identifiers(MName,checkDIString,mangle) import Text.ProtocolBuffers.Reflections(ProtoInfo(..),DescriptorInfo(..),EnumInfo(..))+import Text.ProtocolBuffers.WireMessage (messagePut) +import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto)+import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.FileDescriptorSet as D(FileDescriptorSet)+import qualified Text.DescriptorProtos.FileDescriptorSet as D.FileDescriptorSet(FileDescriptorSet(..))+ import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModule,enumModule)-import Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto)+import Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,makeNameMaps,getTLS+ ,LocalFP(..),CanonFP(..),TopLevel(..)) import Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) -- | Version of protocol-buffers. -- The version tags that I have used are ["unreleased"] version :: Version-version = Version { versionBranch = [0,3,1]+version = Version { versionBranch = [1,0,0] , versionTags = [] } -data Options = Options { optPrefix :: String- , optTarget :: FilePath- , optInclude :: [FilePath]- , optProto :: FilePath- , optVerbose :: Bool- , optUnknownFields :: Bool }+data Options = Options { optPrefix :: [MName String]+ , optAs :: [(CanonFP,[MName String])]+ , optTarget :: LocalFP+ , optInclude :: [LocalFP]+ , optProto :: LocalFP+ , optDesc :: Maybe (LocalFP)+ , optImports,optVerbose,optUnknownFields,optDryRun :: Bool } deriving Show -setPrefix,setTarget,setInclude,setProto :: String -> Options -> Options-setVerbose,setUnknown :: Options -> Options-setPrefix s o = o { optPrefix = s }-setTarget s o = o { optTarget = s }-setInclude s o = o { optInclude = s : optInclude o }-setProto s o = o { optProto = s }+setPrefix,setTarget,setInclude,setProto,setDesc :: String -> Options -> Options+setImports,setVerbose,setUnknown,setDryRun :: Options -> Options+setPrefix s o = o { optPrefix = toPrefix s }+setTarget s o = o { optTarget = (LocalFP s) }+setInclude s o = o { optInclude = LocalFP s : optInclude o }+setProto s o = o { optProto = LocalFP s }+setDesc s o = o { optDesc = Just (LocalFP s) }+setImports o = o { optImports = True } setVerbose o = o { optVerbose = True } setUnknown o = o { optUnknownFields = True }+setDryRun o = o { optDryRun = True } +toPrefix :: String -> [MName String]+toPrefix s = case checkDIString s of+ Left msg -> error $ "Bad module name in options:"++show s++"\n"++msg+ Right (True,_) -> error $ "Bad module name in options (cannot start with '.'): "++show s+ Right (False,ms) -> map mangle ms++-- | 'setAs' puts both the full path and the basename as keys into the association list+setAs :: String -> Options -> Options+setAs s o =+ case break ('='==) s of+ (filepath,'=':rawPrefix) -> let value = toPrefix rawPrefix+ in o { optAs = (CanonFP filepath,value):+ (CanonFP (Canon.takeBaseName filepath),value):+ optAs o}+ _ -> error . unlines $ [ "Malformed -a or --as option "++show s+ , " Expected \"FILEPATH=MODULE\""+ , " where FILEPATH is the basename or relative path (using '/') of an imported file"+ , " where MODULE is a dotted Haskell name to use as a prefix"+ , " also MODULE can be empty to have no prefix" ]+ data OptionAction = Mutate (Options->Options) | Run (Options->Options) | Switch Flag data Flag = VersionInfo optionList :: [OptDescr OptionAction] optionList =- [ Option ['I'] ["proto_path"] (ReqArg (Mutate . setInclude) "DIR")+ [ Option ['a'] ["as"] (ReqArg (Mutate . setAs) "FILEPATH=MODULE")+ "assign prefix module to imported prot file: --as decriptor.proto=Text"+ , Option ['I'] ["proto_path"] (ReqArg (Mutate . setInclude) "DIR") "directory from which to search for imported proto files (default is pwd); all DIR searched"- , Option ['o'] ["haskell_out"] (ReqArg (Mutate . setTarget) "DIR")+ , Option ['d'] ["haskell_out"] (ReqArg (Mutate . setTarget) "DIR") "directory to use are root of generated files (default is pwd); last flag"+ , Option ['n'] ["dry_run"] (NoArg (Mutate setDryRun))+ "produce no output but still parse and check the proto file(s)"+ , Option ['o'] ["descriptor_set_out"] (ReqArg (Mutate . setDesc) "FILE")+ "filename to write binary FileDescriptorSet to"+ , Option [] ["include_imports"] (NoArg (Mutate setImports))+ "when writing descriptor_set_out include all imported files to be self-contained" , Option ['p'] ["prefix"] (ReqArg (Mutate . setPrefix) "MODULE")- "dotted haskell MODULE name to use as prefix (default is none); last flag used"- , Option ['u'] ["unknown-fields"] (NoArg (Mutate setUnknown))+ "dotted Haskell MODULE name to use as a prefix (default is none); last flag used"+ , Option ['u'] ["unknown_fields"] (NoArg (Mutate setUnknown)) "generated messages and groups all support unknown fields" , Option ['v'] ["verbose"] (NoArg (Mutate setVerbose)) "increase amount of printed information"@@ -68,6 +114,8 @@ , "Some proto files, such as descriptor.proto and unittest*.proto" , "are from google's code and are under an Apache 2.0 license." , ""+ , "Most command line arguments are similar to those of 'protoc'."+ , "" , "This program reads a .proto file and generates haskell code files." , "See http://code.google.com/apis/protocolbuffers/docs/overview.html for more." ]@@ -80,8 +128,17 @@ defaultOptions :: IO Options defaultOptions = do- pwd <- getCurrentDirectory- return $ Options { optPrefix = "", optTarget = pwd, optInclude = [pwd], optProto = "", optVerbose = False, optUnknownFields = False }+ pwd <- fmap LocalFP getCurrentDirectory+ return $ Options { optPrefix = []+ , optAs = []+ , optTarget = pwd+ , optInclude = [pwd]+ , optProto = LocalFP ""+ , optDesc = Nothing+ , optImports = False+ , optVerbose = False+ , optUnknownFields = False+ , optDryRun = False } main :: IO () main = do@@ -92,7 +149,7 @@ Right todo -> process defs todo process :: Options -> [OptionAction] -> IO ()-process options [] = if null (optProto options)+process options [] = if null (unLocalFP (optProto options)) then do putStrLn "No proto file specified (or empty proto file)" putStrLn "" putStrLn usageMsg@@ -106,31 +163,44 @@ mkdirFor p = createDirectoryIfMissing True (takeDirectory p) style :: Style-style = Style PageMode 132 0.5+style = Style PageMode 132 0.6 myMode :: PPHsMode-myMode = PPHsMode 2 2 2 2 4 2 True PPOffsideRule False True+myMode = PPHsMode 2 2 2 2 4 1 True PPOffsideRule False True +dump :: Bool -> Maybe LocalFP -> D.FileDescriptorProto -> [D.FileDescriptorProto] -> IO ()+dump _ Nothing _ _ = return ()+dump imports (Just (LocalFP dumpFile)) fdp fdps = do+ putStrLn $ "dumping to filename: "++show dumpFile+ let s = if imports then Seq.fromList fdps else Seq.singleton fdp+ LC.writeFile dumpFile (messagePut $ defaultValue { D.FileDescriptorSet.file = s })+ putStrLn $ "finished dumping FileDescriptorSet binary of: "++show (D.FileDescriptorProto.name fdp)+ run :: Options -> IO () run options = do print options- protos <- loadProto (optInclude options) (optProto options)- let (Just (fdp,_,names)) = M.lookup (optProto options) protos- protoInfo = makeProtoInfo (optUnknownFields options) (optPrefix options) names fdp+ (env,fdps) <- loadProto (optInclude options) (optProto options)+ print "Proto files loaded"+ let fdp = either error id . top'FDP . fst . getTLS $ env+ when (not (optDryRun options)) $ dump (optImports options) (optDesc options) fdp fdps+ nameMap <- either error return $ makeNameMaps (optPrefix options) (optAs options) env+ print "Haskell name mangling done"+ let protoInfo = makeProtoInfo (optUnknownFields options) nameMap fdp let produceMSG di = do- let file = combine (optTarget options) . joinPath . descFilePath $ di+ let file = combine (unLocalFP . optTarget $ options) . joinPath . descFilePath $ di print file- mkdirFor file- writeFile file (prettyPrintStyleMode style myMode (descriptorModule di))+ when (not (optDryRun options)) $ do+ mkdirFor file+ writeFile file (prettyPrintStyleMode style myMode (descriptorModule di)) produceENM ei = do- let file = combine (optTarget options) . joinPath . enumFilePath $ ei+ let file = combine (unLocalFP . optTarget $ options) . joinPath . enumFilePath $ ei print file- mkdirFor file- writeFile file (prettyPrintStyleMode style myMode (enumModule ei))+ when (not (optDryRun options)) $ do+ mkdirFor file+ writeFile file (prettyPrintStyleMode style myMode (enumModule ei)) mapM_ produceMSG (messages protoInfo) mapM_ produceENM (enums protoInfo) - let file = combine (optTarget options) . joinPath . protoFilePath $ protoInfo+ let file = combine (unLocalFP . optTarget $ options) . joinPath . protoFilePath $ protoInfo print file writeFile file (prettyPrintStyleMode style myMode (protoModule protoInfo (serializeFDP fdp)))-
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -27,12 +27,12 @@ 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 Text.ProtocolBuffers.Identifiers+import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),DescriptorInfo(..),ProtoInfo(..),EnumInfo(..),ProtoName(..),ProtoFName(..),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.List(sortBy,foldl',foldl1') import Data.Function(on) import Language.Haskell.Pretty(prettyPrint) import Language.Haskell.Syntax@@ -54,14 +54,6 @@ 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 @@ -88,20 +80,34 @@ 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)+fqMod :: ProtoName -> String+fqMod (ProtoName _ a b c) = fmName $ foldr dotFM (promoteFM c) . map promoteFM $ a++b +joinMod :: [MName String] -> String+joinMod [] = ""+joinMod ms = fmName $ foldr1 dotFM . map promoteFM $ ms++baseIdent :: ProtoName -> HsName+baseIdent = HsIdent . mName . baseName+baseIdent' :: ProtoFName -> HsName+baseIdent' = HsIdent . fName . baseName'+ qualName :: ProtoName -> HsQName-qualName (ProtoName _prefix "" base) = UnQual (HsIdent base)-qualName (ProtoName _prefix parent base) = Qual (Module parent) (HsIdent base)+qualName p@(ProtoName _ _prefix [] _base) = UnQual (baseIdent p)+qualName p@(ProtoName _ _prefix (parents) _base) = Qual (Module (joinMod parents)) (baseIdent p) +qualFName :: ProtoFName -> HsQName+qualFName p@(ProtoFName _ _prefix [] _base) = UnQual (baseIdent' p)+qualFName p@(ProtoFName _ _prefix parents _base) = Qual (Module (joinMod parents)) (baseIdent' p)+ unqualName :: ProtoName -> HsQName-unqualName (ProtoName _prefix _parent base) = UnQual (HsIdent base)+unqualName p@(ProtoName _ _prefix _parent _base) = UnQual (baseIdent p) -mayQualName :: ProtoName -> ProtoName -> HsQName-mayQualName context name@(ProtoName prefix modname base) =- if fqName context == dotPre prefix modname then UnQual (HsIdent base)- else qualName name+mayQualName :: ProtoName -> ProtoFName -> HsQName+mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base) =+ 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 -------------------------------------------- -- EnumDescriptorProto module creation@@ -114,8 +120,8 @@ enumModule :: EnumInfo -> HsModule enumModule ei = let protoName = enumName ei- in HsModule src (Module (fqName protoName))- (Just [HsEThingAll (UnQual (HsIdent (baseName protoName)))])+ in HsModule src (Module (fqMod protoName))+ (Just [HsEThingAll (UnQual (baseIdent protoName))]) (standardImports False) (enumDecls ei) enumDecls :: EnumInfo -> [HsDecl]@@ -131,7 +137,7 @@ ] enumX :: EnumInfo -> HsDecl-enumX ei = HsDataDecl src [] (HsIdent (baseName (enumName ei))) [] (map enumValueX (enumValues ei)) derivesEnum+enumX ei = HsDataDecl src [] (baseIdent (enumName ei)) [] (map enumValueX (enumValues ei)) derivesEnum where enumValueX (_,name) = HsConDecl src (HsIdent name) [] instanceMergeableEnum :: EnumInfo -> HsDecl@@ -201,7 +207,8 @@ = HsInstDecl src [] (private "ReflectEnum") [HsTyCon (unqualName (enumName ei))] [ inst "reflectEnum" [] ascList , inst "reflectEnumInfo" [ HsPWildCard ] ei' ]- where (ProtoName a b c) = enumName ei+ where (ProtoName xxx a b c) = enumName ei+ xxx'Exp = HsParen $ pvar "pack" $$ HsLit (HsString (LC.unpack (utf8 (fiName xxx)))) values = enumValues ei ascList,ei',protoNameExp :: HsExp ascList = HsList (map one values)@@ -210,22 +217,18 @@ ,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---------------------------------------------+ protoNameExp = HsParen $ foldl' HsApp (HsVar (private "makePNF")) [ xxx'Exp, mList a, mList b, HsLit (HsString (mName c)) ]+ where mList = HsList . map (HsLit . HsString . mName) 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)+ = let exportKeys = map (HsEVar . UnQual . baseIdent' . 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)+ in HsModule src (Module (fqMod 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")]))@@ -234,19 +237,18 @@ , 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)]))+ formatImport ((a,b),s) = HsImportDecl src (Module a) True asM (Just (False,map (HsIAbs . HsIdent) (S.toList s)))+ where asM | a==b = Nothing+ | otherwise = Just (Module b) -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+protoImport :: ProtoInfo -> [((String,String),S.Set String)]+protoImport protoInfo+ = M.assocs . M.fromListWith S.union . filter isForeign . map withMod $ keyNames+ where isForeign = let here = fqMod protoName+ in (\((a,_),_) -> a/=here)+ protoName = protoMod protoInfo+ withMod p@(ProtoName _ _prefix modname base) = ((fqMod p,joinMod modname),S.singleton (mName base))+ keyNames = F.foldr (\(e,fi) rest -> e : addName fi rest) [] (extensionKeys protoInfo) addName fi rest = maybe rest (:rest) (typeName fi) embed'ProtoInfo :: ProtoInfo -> [HsDecl]@@ -266,12 +268,13 @@ descriptorModule :: DescriptorInfo -> HsModule descriptorModule di = let protoName = descName di- un = UnQual . HsIdent . baseName $ protoName+ un = UnQual . baseIdent $ 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))+ exportKeys = map (HsEVar . UnQual . baseIdent' . fieldName . snd) (F.toList (keys di))+ formatImport ((a,b),s) = HsImportDecl src (Module a) True asM (Just (False, map (HsIAbs . HsIdent) (S.toList s)))+ where asM | a==b = Nothing+ | otherwise = Just (Module b)+ in HsModule src (Module (fqMod protoName)) (Just (HsEThingAll un : exportKeys)) imports (descriptorX di : (keysX protoName (keys di) ++ instancesDescriptor di)) @@ -286,23 +289,22 @@ 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+ where isForeign = let here = fqMod 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)+ withMod (Left p@(ProtoName _ _prefix modname base)) = ((fqMod p,joinMod modname),S.singleton (mName base))+ withMod (Right (ProtoFName _ prefix modname base)) = ((joinMod (prefix++modname),joinMod modname),S.singleton (fName 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)+ keyNames = F.foldr (\(e,fi) rest -> Left e : addName fi rest) keysKnown (keys di)+ addName fi rest = maybe rest (:rest) (fmap Left (typeName fi))+ keysKnown = F.foldr (\fi rest -> Right (fieldName fi) : rest) [] (knownKeys di) 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 $+ where keyType = HsTypeSig src [ baseIdent' . fieldName $ f ] (HsQualType [] (foldl1 HsTyApp . map HsTyCon $ [ private "Key", private labeled , if extendee /= self then qualName extendee else unqualName extendee , typeQName ]))@@ -316,7 +318,7 @@ 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+ keyVal = HsPatBind src (HsPApp (UnQual (baseIdent' . fieldName $ f)) []) (HsUnGuardedRhs (pvar "Key" $$ litInt (getFieldId (fieldNumber f)) $$ litInt typeNumber $$ maybe (pvar "Nothing") (HsParen . (pvar "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f)@@ -337,7 +339,7 @@ descriptorX :: DescriptorInfo -> HsDecl descriptorX di = HsDataDecl src [] name [] [con] derives where self = descName di- name = HsIdent (baseName self)+ name = baseIdent $ self con = HsRecDecl src name eFields where eFields = F.foldr ((:) . fieldX) end (fields di) end = (if hasExt di then (extfield:) else id) @@ -347,7 +349,7 @@ 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)))+ fieldX fi = ([baseIdent' . fieldName $ fi],HsUnBangedTy (labeled (HsTyCon typed))) where labeled | canRepeat fi = typeApp "Seq" | isRequired fi = id | otherwise = typeApp "Maybe"@@ -373,7 +375,7 @@ instanceExtendMessage :: DescriptorInfo -> HsDecl instanceExtendMessage di- = HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ = HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (baseIdent (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"))@@ -382,7 +384,7 @@ instanceUnknownMessage :: DescriptorInfo -> HsDecl instanceUnknownMessage di- = HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ = HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (baseIdent (descName di)))] [ inst "getUnknownField" [] (lvar "unknown'field") , inst "putUnknownField" [HsPVar (HsIdent "u'f"),HsPVar (HsIdent "msg")] putunknownfield ]@@ -395,7 +397,7 @@ , inst "mergeAppend" [HsPApp un patternVars1, HsPApp un patternVars2] (foldl' HsApp (HsCon un) (zipWith append vars1 vars2)) ]- where un = UnQual (HsIdent (baseName (descName di)))+ where un = UnQual (baseIdent (descName di)) len = (if hasExt di then succ else id) $ (if storeUnknown di then succ else id) $ Seq.length (fields di)@@ -415,7 +417,7 @@ instanceDefault di = HsInstDecl src [] (private "Default") [HsTyCon un] [ inst "defaultValue" [] (foldl' HsApp (HsCon un) deflistExt) ]- where un = UnQual (HsIdent (baseName (descName di)))+ where un = UnQual (baseIdent (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 [])@@ -434,7 +436,7 @@ 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))+ where un = UnQual (baseIdent protoName) mkOp :: String -> HsExp -> HsExp -> HsExp mkOp s a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol s))) b@@ -542,15 +544,15 @@ -- 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)+ HsRecUpdate (lvar "old'Self") [HsFieldUpdate (UnQual . baseIdent' . 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")+ labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . fName . 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)+ pvar "mergeAppend" $$ HsParen ((lvar . fName . baseName' . fieldName $ fi) $$ lvar "old'Self") $$ (HsParen x) | otherwise = x in HsInstDecl src [] (private "Wire") [HsTyCon me]@@ -562,7 +564,7 @@ -- TODO : Encode allow as a proper set of numbers! instanceReflectDescriptor :: DescriptorInfo -> HsDecl instanceReflectDescriptor di- = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (baseIdent (descName di)))] [ inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ] where -- massive shortcut through show and read rdi :: HsExp@@ -594,128 +596,3 @@ 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"]--}
Text/ProtocolBuffers/ProtoCompile/Instances.hs view
@@ -64,15 +64,15 @@ , return TYPE_BOOL << string "bool" , return TYPE_STRING << string "string" , return TYPE_GROUP << string "group"- , return TYPE_MESSAGE << string "message" , return TYPE_BYTES << string "bytes" , return TYPE_UINT32 << string "uint32"- , return TYPE_ENUM << string "enum" , return TYPE_SFIXED32 << string "sfixed32" , return TYPE_SFIXED64 << string "sfixed64" , return TYPE_SINT32 << string "sint32" , return TYPE_SINT64 << string "sint64" ]+-- , return TYPE_MESSAGE << string "..."+-- , return TYPE_ENUM << string "..." (<<) :: Monad m => m a -> m b -> m a (<<) = flip (>>)
Text/ProtocolBuffers/ProtoCompile/Lexer.x view
@@ -32,7 +32,7 @@ @inStr = @hexEscape | @octEscape | @charEscape | [^'\"\0\n] @strLit = ['] (@inStr | [\"])* ['] | [\"] (@inStr | ['])* [\"] -$special = [=\(\)\,\;\[\]\{\}]+$special = [=\(\)\,\;\[\]\{\}\.] :- @@ -59,7 +59,7 @@ data Lexed = L_Integer !Int !Integer | L_Double !Int !Double | L_Name !Int !L.ByteString- | L_String !Int !L.ByteString+ | L_String !Int !L.ByteString !L.ByteString | L !Int !Char | L_Error !Int !String deriving (Show,Eq)@@ -69,7 +69,7 @@ L_Integer i _ -> i L_Double i _ -> i L_Name i _ -> i- L_String i _ -> i+ L_String i _ _ -> i L i _ -> i L_Error i _ -> i @@ -94,10 +94,10 @@ parseDouble pos s = maybe (errAt pos "Impossible? parseDouble failed") (L_Double (line pos)) $ mayRead (readSigned readFloat) (ByteString.unpack s) -- The sDecode of the string contents may fail-parseStr pos s = either (errAt pos) (L_String (line pos) . L.pack) - . sDecode . ByteString.unpack- . ByteString.init . ByteString.tail- $ s+parseStr pos s = let middle = ByteString.init . ByteString.tail $ s+ in either (errAt pos) (L_String (line pos) middle . L.pack)+ . sDecode . ByteString.unpack $ middle+ parseName pos s = L_Name (line pos) s parseChar pos s = L (line pos) (ByteString.head s)
Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -11,10 +11,11 @@ -- a Descriptor are listed in that Descriptor. -- -- In building the reflection info new things are computed. It changes--- dotted names to ProtoName with the outer prefix. It parses the--- default value from the ByteString to a Haskell type. The value of--- the tag on the wire is computed and so is its size on the wire.-module Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,makeEnumInfo,makeDescriptorInfo,serializeFDP) where+-- dotted names to ProtoName useing the translator from+-- 'makeNameMaps'. It parses the default value from the ByteString to+-- a Haskell type. For fields, the value of the tag on the wire is+-- computed and so is its size on the wire.+module Text.ProtocolBuffers.ProtoCompile.MakeReflections(makeProtoInfo,serializeFDP) where import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto) import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))@@ -34,188 +35,154 @@ import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..)) import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections import Text.ProtocolBuffers.WireMessage(size'Varint,toWireTag,runPut)+import Text.ProtocolBuffers.ProtoCompile.Resolve(ReMap,NameMap(..)) import qualified Data.Foldable as F(foldr,toList)-import qualified Data.ByteString as S(concat)-import qualified Data.ByteString.Char8 as SC(spanEnd)-import qualified Data.ByteString.Lazy.Char8 as LC(toChunks,fromChunks,length,init,empty) import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString)-import Data.List(partition,unfoldr) import qualified Data.Sequence as Seq(fromList,empty,singleton,null) import Numeric(readHex,readOct,readDec) import Data.Monoid(mconcat,mappend)-import qualified Data.Map as M(fromListWith,lookup)-import Data.Maybe(fromMaybe,catMaybes)+import qualified Data.Map as M(fromListWith,lookup,keys)+import Data.Maybe(fromMaybe,catMaybes,fromJust) import System.FilePath --import Debug.Trace (trace) imp :: String -> a-imp msg = error $ "Text.ProtocolBuffers.ProtoCompile.MakeReflections: Impossible? "++msg--spanEndL :: (Char -> Bool) -> ByteString -> (ByteString, ByteString)-spanEndL f bs = let (a,b) = SC.spanEnd f (S.concat . LC.toChunks $ bs)- in (LC.fromChunks [a],LC.fromChunks [b])---- Take a bytestring of "A" into "Right A" and "A.B.C" into "Left (A.B,C)"-splitMod :: Utf8 -> Either (Utf8,Utf8) Utf8-splitMod (Utf8 bs) = case spanEndL ('.'/=) bs of- (pre,post) | LC.length pre <= 1 -> Right (Utf8 bs)- | otherwise -> Left (Utf8 (LC.init pre),Utf8 post)--toString :: Utf8 -> String-toString = U.toString . utf8--toProtoName :: String -> Utf8 -> ProtoName-toProtoName prefix rawName =- case splitMod rawName of- Left (m,b) -> ProtoName prefix (toString m) (toString b)- Right b -> ProtoName prefix "" (toString b)--toPath :: String -> Utf8 -> [FilePath]-toPath prefix name = splitDirectories (combine a b)- where a = joinPath . splitDot $ prefix- b = flip addExtension "hs" . joinPath . splitDot . U.toString . utf8 $ name--splitDot :: String -> [FilePath]-splitDot = unfoldr s where- s ('.':xs) = s xs- s [] = Nothing- s xs = Just (span ('.'/=) xs)+imp msg = error $ "Text.ProtocolBuffers.ProtoCompile.MakeReflections: Impossible?\n "++msg pnPath :: ProtoName -> [FilePath]-pnPath (ProtoName a b c) = splitDirectories .flip addExtension "hs" . joinPath . splitDot $ dotPre a (dotPre b c)--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)+pnPath (ProtoName _ a b c) = splitDirectories .flip addExtension "hs" . joinPath . map mName $ a++b++[c] serializeFDP :: D.FileDescriptorProto -> ByteString-serializeFDP fdp = LC.empty -- XXX runPut (wirePut 11 fdp)+serializeFDP fdp = runPut (wirePut 11 fdp) -makeProtoInfo :: Bool -> String -> [String] -> D.FileDescriptorProto -> ProtoInfo-makeProtoInfo unknownField prefix names- fdp@(D.FileDescriptorProto- { D.FileDescriptorProto.name = Just rawName })+toHaskell :: ReMap -> FIName Utf8 -> ProtoName+toHaskell reMap k = case M.lookup k reMap of+ Nothing -> imp $ "toHaskell failed to find "++show k++" among "++show (M.keys reMap)+ Just pn -> pn++makeProtoInfo :: Bool -> NameMap -> D.FileDescriptorProto -> ProtoInfo+makeProtoInfo unknownField (NameMap (packageName,hPrefix,hParent) reMap)+ fdp@(D.FileDescriptorProto { D.FileDescriptorProto.name = Just rawName }) = ProtoInfo protoName (pnPath protoName) (toString rawName) keyInfos allMessages allEnums allKeys where- protoName = case names of- [] -> ProtoName prefix "" "" -- after this the value of names cannot be []- [name] -> ProtoName prefix "" name- _ -> ProtoName prefix (foldr1 (\a bs -> a ++ ('.' : bs)) (init names)) (last names) -- names cannot be []- keyInfos = Seq.fromList . map (\f -> (keyExtendee prefix f,toFieldInfo protoName f))+ protoName = case hParent of+ [] -> case hPrefix of+ [] -> imp $ "makeProtoInfo: no hPrefix or hParent in NameMap for: "++show fdp+ _ -> ProtoName packageName (init hPrefix) [] (last hPrefix)+ _ -> ProtoName packageName hPrefix (init hParent) (last hParent)+ keyInfos = Seq.fromList . map (\f -> (keyExtendee' reMap f,toFieldInfo' reMap packageName f)) . F.toList . D.FileDescriptorProto.extension $ fdp- allMessages = concatMap (processMSG False) (F.toList $ D.FileDescriptorProto.message_type fdp)- allEnums = map (makeEnumInfo prefix) (F.toList $ D.FileDescriptorProto.enum_type fdp) - ++ concatMap processENM (F.toList $ D.FileDescriptorProto.message_type fdp)+ allMessages = concatMap (processMSG packageName False) (F.toList $ D.FileDescriptorProto.message_type fdp)+ allEnums = map (makeEnumInfo' reMap packageName) (F.toList $ D.FileDescriptorProto.enum_type fdp) + ++ concatMap (processENM packageName) (F.toList $ D.FileDescriptorProto.message_type fdp) allKeys = M.fromListWith mappend . map (\(k,a) -> (k,Seq.singleton a)) . F.toList . mconcat $ keyInfos : map keys allMessages-- processMSG msgIsGroup msg = + processMSG parent msgIsGroup msg = let getKnownKeys protoName' = fromMaybe Seq.empty (M.lookup protoName' allKeys) groups = collectedGroups msg checkGroup x = elem (fromMaybe (imp $ "no message name in makeProtoInfo.processMSG.checkGroup:\n"++show msg) (D.DescriptorProto.name x)) groups- in makeDescriptorInfo getKnownKeys prefix msgIsGroup unknownField msg- : concatMap (\x -> processMSG (checkGroup x) x)+ parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))]+ in makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup unknownField msg+ : concatMap (\x -> processMSG parent' (checkGroup x) x) (F.toList (D.DescriptorProto.nested_type msg))- processENM msg = foldr ((:) . makeEnumInfo prefix) nested- (F.toList (D.DescriptorProto.enum_type msg))- where nested = concatMap processENM (F.toList (D.DescriptorProto.nested_type msg))-makeProtoInfo unknownField prefix names fdp = imp $ "no name in fdp passed to makeProtoInfo: " ++ show (unknownField,prefix,names,fdp)--collectedGroups :: D.DescriptorProto -> [Utf8] -collectedGroups = catMaybes- . map D.FieldDescriptorProto.type_name- . filter (\f -> D.FieldDescriptorProto.type' f == Just TYPE_GROUP) - . F.toList- . D.DescriptorProto.field+ processENM parent msg = foldr ((:) . makeEnumInfo' reMap parent') nested+ (F.toList (D.DescriptorProto.enum_type msg))+ where parent' = fqAppend parent [IName (fromJust (D.DescriptorProto.name msg))]+ nested = concatMap (processENM parent') (F.toList (D.DescriptorProto.nested_type msg))+makeProtoInfo _ _ _ = imp $ "makeProtoInfo: missing name or package" -makeEnumInfo :: String -> D.EnumDescriptorProto -> EnumInfo-makeEnumInfo prefix e@(D.EnumDescriptorProto.EnumDescriptorProto- { D.EnumDescriptorProto.name = Just rawName- , D.EnumDescriptorProto.value = value })- = let protoName = toProtoName prefix rawName- in if Seq.null value then imp $ "enum has no values: "++show (prefix,e)- else EnumInfo protoName (toPath prefix rawName) enumVals- where enumVals ::[(EnumCode,String)]+makeEnumInfo' :: ReMap -> FIName Utf8 -> D.EnumDescriptorProto -> EnumInfo+makeEnumInfo' reMap parent+ e@(D.EnumDescriptorProto.EnumDescriptorProto+ { D.EnumDescriptorProto.name = Just rawName+ , D.EnumDescriptorProto.value = value })+ = if Seq.null value then imp $ "enum has no values: "++show e+ else EnumInfo protoName (pnPath protoName) enumVals+ where protoName = toHaskell reMap $ fqAppend parent [IName rawName]+ enumVals ::[(EnumCode,String)] enumVals = F.foldr ((:) . oneValue) [] value- where oneValue :: D.EnumValueDescriptorProto -> (EnumCode,String)+ where oneValue :: D.EnumValueDescriptorProto -> (EnumCode,String) oneValue (D.EnumValueDescriptorProto.EnumValueDescriptorProto { D.EnumValueDescriptorProto.name = Just name , D.EnumValueDescriptorProto.number = Just number })- = (EnumCode number,toString name)+ = (EnumCode number,mName . baseName . toHaskell reMap $ fqAppend (protobufName protoName) [IName name]) oneValue evdp = imp $ "no name or number for evdp passed to makeEnumInfo.oneValue: "++show evdp-makeEnumInfo prefix e = imp $ "no name for enum passed to makeEnumInfo: " ++ show (prefix,e)+makeEnumInfo' _ _ _ = imp "makeEnumInfo: missing name" -makeDescriptorInfo :: (ProtoName -> Seq FieldInfo)- -> String -> Bool -> Bool- -> D.DescriptorProto -> DescriptorInfo-makeDescriptorInfo getKnownKeys prefix msgIsGroup unknownField- (D.DescriptorProto.DescriptorProto- { D.DescriptorProto.name = Just rawName- , D.DescriptorProto.field = rawFields- , D.DescriptorProto.extension_range = extension_range })- = let di = DescriptorInfo protoName (toPath prefix rawName) msgIsGroup+keyExtendee' :: ReMap -> D.FieldDescriptorProto.FieldDescriptorProto -> ProtoName+keyExtendee' reMap f = case D.FieldDescriptorProto.extendee f of+ Nothing -> imp $ "keyExtendee expected Just but found Nothing: "++show f+ Just extName -> toHaskell reMap (FIName extName)++makeDescriptorInfo' :: ReMap -> FIName Utf8+ -> (ProtoName -> Seq FieldInfo)+ -> Bool -> Bool+ -> D.DescriptorProto -> DescriptorInfo+makeDescriptorInfo' reMap parent getKnownKeys msgIsGroup unknownField+ (D.DescriptorProto.DescriptorProto+ { D.DescriptorProto.name = Just rawName+ , D.DescriptorProto.field = rawFields+ , D.DescriptorProto.extension = rawKeys+ , D.DescriptorProto.extension_range = extension_range })+ = let di = DescriptorInfo protoName (pnPath protoName) msgIsGroup fieldInfos keyInfos extRangeList (getKnownKeys protoName) unknownField in di -- trace (toString rawName ++ "\n" ++ show di ++ "\n\n") $ di- where protoName = toProtoName prefix rawName- (msgFields,keysHere) = partition (\ f -> Nothing == (D.FieldDescriptorProto.extendee f)) . F.toList $ rawFields- fieldInfos = Seq.fromList . map (toFieldInfo protoName) $ msgFields- keyInfos = Seq.fromList . map (\f -> (keyExtendee prefix f,toFieldInfo protoName f)) $ keysHere+ where protoName = toHaskell reMap $ fqAppend parent [IName rawName]+ fieldInfos = fmap (toFieldInfo' reMap (protobufName protoName)) rawFields+ keyInfos = fmap (\f -> (keyExtendee' reMap f,toFieldInfo' reMap (protobufName protoName) f)) rawKeys extRangeList = concatMap check unchecked where check x@(lo,hi) | hi < lo = [] | hi<19000 || 19999<lo = [x] | otherwise = concatMap check [(lo,18999),(20000,hi)] unchecked = F.foldr ((:) . extToPair) [] extension_range extToPair (D.DescriptorProto.ExtensionRange- { D.DescriptorProto.ExtensionRange.start = start- , D.DescriptorProto.ExtensionRange.end = end }) =- (maybe minBound FieldId start, maybe maxBound FieldId end)-makeDescriptorInfo _ prefix msgIsGroup unknownField d =- imp $ "No name passed in dp passed to makeDescriptorInfo: "++show (prefix,msgIsGroup,unknownField,d)--keyExtendee :: String -> D.FieldDescriptorProto.FieldDescriptorProto -> ProtoName-keyExtendee prefix f- = case D.FieldDescriptorProto.extendee f of- Nothing -> imp $ "keyExtendee expected Just but found Nothing: "++show (prefix,f)- Just extName -> toProtoName prefix extName+ { D.DescriptorProto.ExtensionRange.start = mStart+ , D.DescriptorProto.ExtensionRange.end = mEnd }) =+ (maybe minBound FieldId mStart, maybe maxBound (FieldId . pred) mEnd)+makeDescriptorInfo' _ _ _ _ _ _ = imp $ "makeDescriptorInfo: missing name" -toFieldInfo :: ProtoName -> D.FieldDescriptorProto -> FieldInfo-toFieldInfo (ProtoName prefix modName parent)- f@(D.FieldDescriptorProto.FieldDescriptorProto- { D.FieldDescriptorProto.name = Just name- , D.FieldDescriptorProto.number = Just number- , D.FieldDescriptorProto.label = Just label- , D.FieldDescriptorProto.type' = Just type'- , D.FieldDescriptorProto.type_name = mayTypeName--- , D.FieldDescriptorProto.extendee = Nothing -- sanity check- , D.FieldDescriptorProto.default_value = mayRawDef })+toFieldInfo' :: ReMap -> FIName Utf8 -> D.FieldDescriptorProto -> FieldInfo+toFieldInfo' reMap parent+ f@(D.FieldDescriptorProto.FieldDescriptorProto+ { D.FieldDescriptorProto.name = Just name+ , D.FieldDescriptorProto.number = Just number+ , D.FieldDescriptorProto.label = Just label+ , D.FieldDescriptorProto.type' = Just type'+ , D.FieldDescriptorProto.type_name = mayTypeName+ , D.FieldDescriptorProto.default_value = mayRawDef }) = fieldInfo where mayDef = parseDefaultValue f- fieldInfo = let fullName = ProtoName prefix (dotPre modName parent) (toString name)+ fieldInfo = let (ProtoName x a b c) = toHaskell reMap $ fqAppend parent [IName name]+ protoFName = ProtoFName x a b (mangle c) fieldId = (FieldId (fromIntegral number)) fieldType = (FieldType (fromEnum type')) wt = toWireTag fieldId fieldType wtLength = size'Varint (getWireTag wt)- in FieldInfo fullName+ in FieldInfo protoFName fieldId wt wtLength (label == LABEL_REQUIRED) (label == LABEL_REPEATED) fieldType- (fmap (toProtoName prefix) mayTypeName)+ (fmap (toHaskell reMap . FIName) mayTypeName) (fmap utf8 mayRawDef) mayDef-toFieldInfo pn f = imp $ "Not enough information defined in field passed to toFieldInfo: "++show(pn,f)+toFieldInfo' _ _ f = imp $ "toFieldInfo: missing info in "++show f++collectedGroups :: D.DescriptorProto -> [Utf8] +collectedGroups = catMaybes+ . map D.FieldDescriptorProto.type_name+ . filter (\f -> D.FieldDescriptorProto.type' f == Just TYPE_GROUP) + . F.toList+ . D.DescriptorProto.field -- "Nothing" means no value specified -- A failure to parse a provided value will result in an error at the moment
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -1,55 +1,79 @@-module Text.ProtocolBuffers.ProtoCompile.Parser(pbParse,parseProto,filename1,filename2) where+-- | This "Parser" module takes a filename and its contents as a+-- bytestring, and uses Lexer.hs to make a stream of tokens that it+-- parses. No IO is performed and the error function is not used.+-- Since the Lexer should also avoid such errors this should be a+-- reliably total function of the input.+--+-- The inernals have been updated to handle Google's protobuf version+-- 2.0.2 formats.+module Text.ProtocolBuffers.ProtoCompile.Parser(parseProto,isValidUTF8) where import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto) import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange) import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..)) import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto) import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..))-import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto(EnumValueDescriptorProto))+import qualified Text.DescriptorProtos.EnumOptions as D(EnumOptions)+import qualified Text.DescriptorProtos.EnumOptions as D.EnumOptions(EnumOptions(..))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto) import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))-import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto(FieldDescriptorProto))+import qualified Text.DescriptorProtos.EnumValueOptions as D(EnumValueOptions)+import qualified Text.DescriptorProtos.EnumValueOptions as D.EnumValueOptions(EnumValueOptions(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto) import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..)) import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto(Type)-import Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto.Type(Type(..))+import Text.DescriptorProtos.FieldDescriptorProto.Type (Type(..)) import qualified Text.DescriptorProtos.FieldOptions as D(FieldOptions) import qualified Text.DescriptorProtos.FieldOptions as D.FieldOptions(FieldOptions(..)) import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto) import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.FileOptions as D(FileOptions) import qualified Text.DescriptorProtos.FileOptions as D.FileOptions(FileOptions(..))+import qualified Text.DescriptorProtos.MessageOptions as D(MessageOptions) import qualified Text.DescriptorProtos.MessageOptions as D.MessageOptions(MessageOptions(..))-import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto(MethodDescriptorProto))+import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto) import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.MethodOptions as D(MethodOptions)+import qualified Text.DescriptorProtos.MethodOptions as D.MethodOptions(MethodOptions(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto as D(ServiceDescriptorProto) import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceOptions as D(ServiceOptions)+import qualified Text.DescriptorProtos.ServiceOptions as D.ServiceOptions(ServiceOptions(..))+import qualified Text.DescriptorProtos.UninterpretedOption as D(UninterpretedOption)+import qualified Text.DescriptorProtos.UninterpretedOption as D.UninterpretedOption(UninterpretedOption(..))+import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D(NamePart)+import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D.NamePart(NamePart(..)) import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Header(ByteString,Int32,Int64,Word32,Word64- ,mergeEmpty,ReflectEnum(reflectEnumInfo),enumName)-+ ,ReflectEnum(reflectEnumInfo),enumName) import Text.ProtocolBuffers.ProtoCompile.Lexer(Lexed(..),alexScanTokens,getLinePos) import Text.ProtocolBuffers.ProtoCompile.Instances(parseLabel,parseType) -import Control.Monad(when,liftM3)+import Control.Monad(when,liftM2,liftM3,replicateM) import qualified Data.ByteString.Lazy as L(unpack)-import qualified Data.ByteString.Lazy.Char8 as LC(notElem,head,readFile)-import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString,uncons)-import Data.Char(isUpper)+import qualified Data.ByteString.Lazy.Char8 as LC(notElem,head)+import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString)+import Data.Char(isUpper,toLower) import Data.Ix(inRange) import Data.Maybe(fromMaybe) import Data.Sequence((|>))-import Text.ParserCombinators.Parsec(GenParser,ParseError,runParser,sourceName+import qualified Data.Sequence as Seq(fromList)+--import System.FilePath(takeFileName)+import Text.ParserCombinators.Parsec(GenParser,ParseError,runParser,sourceName,anyToken ,getInput,setInput,getPosition,setPosition,getState,setState- ,(<?>),(<|>),option,token,choice,between,eof,unexpected,skipMany)+ ,(<?>),(<|>),token,choice,between,eof,unexpected,skipMany) import Text.ParserCombinators.Parsec.Pos(newPos) import Data.Word(Word8) +-- import Debug.Trace(trace)+ default () type P = GenParser Lexed -pbParse :: String -> IO (Either ParseError D.FileDescriptorProto)-pbParse filename = fmap (parseProto filename) (LC.readFile filename)- parseProto :: String -> ByteString -> Either ParseError D.FileDescriptorProto parseProto filename file = do let lexed = alexScanTokens file@@ -58,17 +82,13 @@ (l:_) -> setPosition (newPos filename (getLinePos l) 0) runParser (ipos >> parser) (initState filename) filename lexed -filename1,filename2 :: String-filename1 = "/tmp/unittest.proto"-filename2 = "/tmp/descriptor.proto"- utf8FromString :: String -> Maybe Utf8 utf8FromString = Just . Utf8 . U.fromString utf8ToString :: Utf8 -> String utf8ToString = U.toString . utf8 initState :: String -> D.FileDescriptorProto-initState filename = mergeEmpty {D.FileDescriptorProto.name=utf8FromString filename}+initState filename = defaultValue {D.FileDescriptorProto.name=utf8FromString filename} {-# INLINE mayRead #-} mayRead :: ReadS a -> String -> Maybe a@@ -86,41 +106,37 @@ pChar c = tok (\l-> case l of L _ x -> if (x==c) then return () else Nothing _ -> Nothing) <?> ("character "++show c) -eol :: P s ()+eol,eols :: P s () eol = pChar ';'--eols :: P s () eols = skipMany eol pName :: ByteString -> P s Utf8 pName name = tok (\l-> case l of L_Name _ x -> if (x==name) then return (Utf8 x) else Nothing _ -> Nothing) <?> ("name "++show (U.toString name)) -bsLit :: P s ByteString-bsLit = tok (\l-> case l of L_String _ x -> return x++bsLit :: P s (ByteString,ByteString)+bsLit = tok (\l-> case l of L_String _ raw x -> return (raw,x) _ -> Nothing) <?> "quoted bytes literal" strLit :: P s Utf8-strLit = tok (\l-> case l of L_String _ x -> case isValidUTF8 x of- Nothing -> return (Utf8 x)- Just n -> fail $ "bad utf-8 byte in string literal position # "++show n+strLit = tok (\l-> case l of L_String _ _ x -> case isValidUTF8 x of+ Nothing -> return (Utf8 x)+ Just n -> fail $ "bad utf-8 byte in string literal position # "++show n _ -> fail "quoted string literal (UTF-8)") -intLit :: (Num a) => P s a+intLit,fieldInt,enumInt :: (Num a) => P s a intLit = tok (\l-> case l of L_Integer _ x -> return (fromInteger x) _ -> Nothing) <?> "integer literal" -fieldInt :: (Num a) => P s a fieldInt = tok (\l-> case l of L_Integer _ x | inRange validRange x && not (inRange reservedRange x) -> return (fromInteger x) _ -> Nothing) <?> "field number (from 0 to 2^29-1 and not in 19000 to 19999)" where validRange = (0,(2^(29::Int))-1) reservedRange = (19000,19999) -enumInt :: (Num a) => P s a enumInt = tok (\l-> case l of L_Integer _ x | inRange validRange x -> return (fromInteger x)- _ -> Nothing) <?> "enum value (from 0 to 2^31-1)"+ _ -> Nothing) <?> "enum value (from -2^31 to 2^31-1)" where validRange = (toInteger (minBound :: Int32), toInteger (maxBound :: Int32))--- where validRange = (0,(2^(31::Int))-1) -- documentation was wrong doubleLit :: P s Double doubleLit = tok (\l-> case l of L_Double _ x -> return x@@ -152,13 +168,17 @@ -- subParser changes the user state. It is a bit of a hack and is used -- to define an interesting style of parsing below.-subParser :: GenParser t sSub a -> sSub -> GenParser t s sSub+subParser :: Show t => GenParser t sSub a -> sSub -> GenParser t s sSub subParser doSub inSub = do in1 <- getInput pos1 <- getPosition let out = runParser (setPosition pos1 >> doSub >> getStatus) inSub (sourceName pos1) in1- case out of Left pe -> fail ("the error message from the nested subParser was:\n"++indent (show pe))- Right (outSub,in2,pos2) -> setInput in2 >> setPosition pos2 >> return outSub+ case out of+ Left pe -> do+ context <- replicateM 10 anyToken+ fail ( unlines [ "The error message from the nested subParser was:\n"++indent (show pe) + , " The next 10 tokens were "++show context ] )+ Right (outSub,in2,pos2) -> setInput in2 >> setPosition pos2 >> return outSub where getStatus = liftM3 (,,) getState getInput getPosition indent = unlines . map (\s -> ' ':' ':s) . lines @@ -170,8 +190,8 @@ fmap' :: (Monad m) => (a->b) -> m a -> m b fmap' f m = m >>= \a -> seq a (return $! (f a)) -type Update s = (s -> s) -> P s ()-update' :: Update s+{-# INLINE update' #-}+update' :: (s -> s) -> P s () update' f = getState >>= \s -> setState $! (f s) parser :: P D.FileDescriptorProto D.FileDescriptorProto @@ -182,35 +202,77 @@ , fileOption , message upTopMsg , enum upTopEnum- , extend upTopMsg upTopField+ , extend upTopMsg upTopExt , service] >> proto) upTopMsg msg = update' (\s -> s {D.FileDescriptorProto.message_type=D.FileDescriptorProto.message_type s |> msg}) upTopEnum e = update' (\s -> s {D.FileDescriptorProto.enum_type=D.FileDescriptorProto.enum_type s |> e})- upTopField f = update' (\s -> s {D.FileDescriptorProto.extension=D.FileDescriptorProto.extension s |> f})+ upTopExt f = update' (\s -> s {D.FileDescriptorProto.extension=D.FileDescriptorProto.extension s |> f}) importFile,package,fileOption,service :: P D.FileDescriptorProto.FileDescriptorProto () importFile = pName (U.fromString "import") >> strLit >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.dependency=(D.FileDescriptorProto.dependency s) |> p}) -package = pName (U.fromString "package") >> ident_package >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.package=Just p})+package = pName (U.fromString "package") >> do+ p <- ident_package+ eol+ update' (\s -> s {D.FileDescriptorProto.package=Just p}) -pOption :: P s String-pOption = pName (U.fromString "option") >> fmap utf8ToString ident1 >>= \optName -> pChar '=' >> return optName+-- This parses the new extensible option name format of Google's protobuf verison 2.0.2+-- "foo.(bar.baz).qux" goes to Left [("foo",False),("bar.baz",True),("qux",False)]+pOptionE :: P s (Either D.UninterpretedOption String)+pOptionE = do+ let pieces = withParens <|> withoutParens+ withParens = do+ part <- between (pChar '(') (pChar ')') ident+ fmap ((part,True) :) ( choice [ pChar '=' >> return []+ , pChar '.' >> withParens+ , withoutParens ] )+ withoutParens = do+ parts <- fmap split ident+ let prepend rest = foldr (\part xs -> (part,False):xs) rest parts+ fmap prepend ( choice [ pChar '=' >> return []+ , pChar '.' >> withParens ] )+ nameParts <- pieces+ case nameParts of+ [(optName,False)] -> return (Right (utf8ToString optName))+ _ -> do uno <- pUnValue (makeUninterpetedOption nameParts)+ return (Left uno) -fileOption = pOption >>= setOption >>= \p -> eol >> update' (\s -> s {D.FileDescriptorProto.options=Just p})- where- setOption optName = do- old <- fmap (maybe mergeEmpty id . D.FileDescriptorProto.options) getState- case optName of- "java_package" -> strLit >>= \p -> return' (old {D.FileOptions.java_package=Just p})- "java_outer_classname" -> strLit >>= \p -> return' (old {D.FileOptions.java_outer_classname=Just p})- "java_multiple_files" -> boolLit >>= \p -> return' (old {D.FileOptions.java_multiple_files=Just p})- "optimize_for" -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for=Just p})- s -> unexpected $ "option name "++s+pOptionWith :: P s t -> P s (Either D.UninterpretedOption String, t)+pOptionWith = liftM2 (,) (pName (U.fromString "option") >> pOptionE) +pUnValue :: D.UninterpretedOption -> P s D.UninterpretedOption+pUnValue uno = tok storeLexed where+ storeLexed (L_Name _ bs) = return $ uno {D.UninterpretedOption.identifier_value = Just (Utf8 bs)}+ storeLexed (L_Integer _ i) | i >= 0 =+ return $ uno { D.UninterpretedOption.positive_int_value = Just (fromInteger i) }+ | otherwise =+ return $ uno { D.UninterpretedOption.negative_int_value = Just (fromInteger i) }+ storeLexed (L_Double _ d) = return $ uno {D.UninterpretedOption.double_value = Just d }+ storeLexed (L_String _ _raw bs) = return $ uno {D.UninterpretedOption.string_value = Just bs }+ storeLexed _ = Nothing++makeUninterpetedOption :: [(Utf8,Bool)] -> D.UninterpretedOption+makeUninterpetedOption nameParts = defaultValue { D.UninterpretedOption.name = Seq.fromList . map makeNamePart $ nameParts }+ where makeNamePart (name_part,is_extension) = defaultValue { D.NamePart.name_part = name_part+ , D.NamePart.is_extension = is_extension }++fileOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.FileDescriptorProto.options) getState+ setNew p = update' (\s -> s {D.FileDescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' (old {D.FileOptions.uninterpreted_option = D.FileOptions.uninterpreted_option old |> uno})+ setOption (Right optName,old) =+ case optName of+ "java_package" -> strLit >>= \p -> return' (old {D.FileOptions.java_package =Just p})+ "java_outer_classname" -> strLit >>= \p -> return' (old {D.FileOptions.java_outer_classname=Just p})+ "java_multiple_files" -> boolLit >>= \p -> return' (old {D.FileOptions.java_multiple_files =Just p})+ "optimize_for" -> enumLit >>= \p -> return' (old {D.FileOptions.optimize_for =Just p})+ _ -> unexpected $ "FileOptions has no option named " ++ optName+ message :: (D.DescriptorProto -> P s ()) -> P s () message up = pName (U.fromString "message") >> do self <- ident1- up =<< subParser (pChar '{' >> subMessage) (mergeEmpty {D.DescriptorProto.name=Just self})+ up =<< subParser (pChar '{' >> subMessage) (defaultValue {D.DescriptorProto.name=Just self}) -- subMessage is also used to parse group declarations subMessage,messageOption,extensions :: P D.DescriptorProto.DescriptorProto ()@@ -219,36 +281,31 @@ , message upNestedMsg , enum upNestedEnum , extensions- , extend upNestedMsg upMsgField+ , extend upNestedMsg upExtField , messageOption] >> subMessage) where upNestedMsg msg = update' (\s -> s {D.DescriptorProto.nested_type=D.DescriptorProto.nested_type s |> msg}) upNestedEnum e = update' (\s -> s {D.DescriptorProto.enum_type=D.DescriptorProto.enum_type s |> e}) upMsgField f = update' (\s -> s {D.DescriptorProto.field=D.DescriptorProto.field s |> f})+ upExtField f = update' (\s -> s {D.DescriptorProto.extension=D.DescriptorProto.extension s |> f}) -messageOption = pOption >>= setOption >>= \p -> eol >> update' (\s -> s {D.DescriptorProto.options=Just p}) - where- setOption optName = do- old <- fmap (maybe mergeEmpty id . D.DescriptorProto.options) getState- case optName of- "message_set_wire_format" -> boolLit >>= \p -> return' (old {D.MessageOptions.message_set_wire_format=Just p})- s -> unexpected $ "option name "++s+messageOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.DescriptorProto.options) getState+ setNew p = update' (\s -> s {D.DescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' (old {D.MessageOptions.uninterpreted_option = D.MessageOptions.uninterpreted_option old |> uno })+ setOption (Right optName,old) =+ case optName of+ "message_set_wire_format" -> boolLit >>= \p -> return' (old {D.MessageOptions.message_set_wire_format=Just p})+ _ -> unexpected $ "MessageOptions has no option named "++optName -extend :: (D.DescriptorProto -> P s ()) -> (D.FieldDescriptorProto -> P s ())- -> P s ()+extend :: (D.DescriptorProto -> P s ()) -> (D.FieldDescriptorProto -> P s ()) -> P s () extend upGroup upField = pName (U.fromString "extend") >> do typeExtendee <- ident pChar '{' let rest = (field upGroup (Just typeExtendee) >>= upField) >> eols >> (pChar '}' <|> rest) eols >> rest -{-- let first = (eol >> first) <|> ((field upGroup (Just typeExtendee) >>= upField) >> rest)- rest = pChar '}' <|> ((eol <|> (field upGroup (Just typeExtendee) >>= upField)) >> rest)- pChar '{' >> first--}- -field :: (D.DescriptorProto -> P s ()) -> Maybe Utf8- -> P s D.FieldDescriptorProto+field :: (D.DescriptorProto -> P s ()) -> Maybe Utf8 -> P s D.FieldDescriptorProto field upGroup maybeExtendee = do let allowedLabels = case maybeExtendee of Nothing -> ["optional","repeated","required"]@@ -260,52 +317,32 @@ Just t -> (Just t,Nothing) Nothing -> (Nothing, Just sType) name <- ident1- let first = fromMaybe (error "Impossible: ident1 for field name was empty") . fmap fst $ U.uncons (utf8 name) number <- pChar '=' >> fieldInt- (maybeOptions,maybeDefault) <-- if maybeTypeCode == Just TYPE_GROUP- then do when (not (isUpper first))- (fail $ "Group names must start with an upper case letter: "++show name)- upGroup =<< subParser (pChar '{' >> subMessage) (mergeEmpty {D.DescriptorProto.name=Just name})- return (Nothing,Nothing)- else do hasBracket <- option False (pChar '[' >> return True)- pair <- if not hasBracket then return (Nothing,Nothing)- else subParser (subBracketOptions maybeTypeCode) (Nothing,Nothing)- eol- return pair- return $ D.FieldDescriptorProto- { D.FieldDescriptorProto.name = Just name- , D.FieldDescriptorProto.number = Just number- , D.FieldDescriptorProto.label = Just theLabel- , D.FieldDescriptorProto.type' = maybeTypeCode- , D.FieldDescriptorProto.type_name = maybeTypeName- , D.FieldDescriptorProto.extendee = maybeExtendee- , D.FieldDescriptorProto.default_value = fmap Utf8 maybeDefault -- XXX Hack: we lie about Utf8 for the default value- , D.FieldDescriptorProto.options = maybeOptions- , D.FieldDescriptorProto.unknown'field = mergeEmpty- }+ let v1 = defaultValue { D.FieldDescriptorProto.name = Just name+ , D.FieldDescriptorProto.number = Just number+ , D.FieldDescriptorProto.label = Just theLabel+ , D.FieldDescriptorProto.type' = maybeTypeCode+ , D.FieldDescriptorProto.type_name = maybeTypeName+ , D.FieldDescriptorProto.extendee = maybeExtendee }+ if maybeTypeCode == Just TYPE_GROUP+ then do let nameString = utf8ToString name+ when (null nameString) (fail "Impossible? ident1 for field name was empty")+ when (not (isUpper (head nameString))) (fail $ "Group names must start with an upper case letter: "++show name)+ upGroup =<< subParser (pChar '{' >> subMessage) (defaultValue {D.DescriptorProto.name=Just name})+ let fieldName = utf8FromString (map toLower nameString) -- down-case the whole name+ v = v1 { D.FieldDescriptorProto.name = fieldName+ , D.FieldDescriptorProto.type_name = Just name }+ return v+ else (eol >> return v1) <|> (subParser (pChar '[' >> subField maybeTypeCode) v1)+ +subField,defaultConstant :: Maybe Type -> P D.FieldDescriptorProto ()+subField mt = (defaultConstant mt <|> fieldOption mt) >> ( (pChar ']' >> eol) <|> (pChar ',' >> subField mt) ) -subBracketOptions :: Maybe Type- -> P (Maybe D.FieldOptions, Maybe ByteString) ()-subBracketOptions mt = (defaultConstant <|> fieldOptions) >> (pChar ']' <|> (pChar ',' >> subBracketOptions mt))- where defaultConstant = do- pName (U.fromString "default")- x <- pChar '=' >> constant mt- (a,_) <- getState- setState $! (a,Just x)- fieldOptions = do- optName <- fmap utf8ToString ident1- pChar '='- (mOld,def) <- getState- let old = maybe mergeEmpty id mOld- case optName of- "ctype" | (Just TYPE_STRING) == mt -> do- enumLit >>= \p -> let new = old {D.FieldOptions.ctype=Just p}- in seq new $ setState $! (Just new,def)- "experimental_map_key" | Nothing == mt -> do- strLit >>= \p -> let new = old {D.FieldOptions.experimental_map_key=Just p}- in seq new $ setState $! (Just new,def)- s -> unexpected $ "option name: "++s+defaultConstant mt = do+ pName (U.fromString "default")+ maybeDefault <- pChar '=' >> fmap Just (constant mt)+ -- XXX Hack: we lie about Utf8 for the default_value below+ update' (\s -> s { D.FieldDescriptorProto.default_value = fmap Utf8 maybeDefault }) -- This does a type and range safe parsing of the default value, -- except for enum constants which cannot be checked (the definition@@ -328,12 +365,12 @@ (fail $ "default floating point literal "++show d++" is out of range for type "++show t) return' (U.fromString . show $ d) TYPE_BOOL -> boolLit >>= \b -> return' $ if b then true else false- TYPE_STRING -> bsLit >>= \s -> maybe (return s) - (\n -> fail $ "default string literal is invalid UTF-8 at byte # "++show n)- (isValidUTF8 s)- TYPE_BYTES -> bsLit- TYPE_GROUP -> unexpected $ "cannot have a default literal for type "++show t- TYPE_MESSAGE -> unexpected $ "cannot have a default literal for type "++show t+ TYPE_STRING -> bsLit >>= \(_raw,s) -> case isValidUTF8 s of+ Nothing -> (return s)+ Just errPos -> fail $ "default string literal is invalid UTF-8 at byte # "++show errPos+ TYPE_BYTES -> bsLit >>= \(raw,_s) -> return raw+ TYPE_GROUP -> unexpected $ "cannot have a default for field of "++show t+ TYPE_MESSAGE -> unexpected $ "cannot have a default for field of "++show t TYPE_ENUM -> fmap utf8 ident1 -- IMPOSSIBLE : SHOULD HAVE HAD Maybe Type PARAMETER match Nothing TYPE_SFIXED32 -> f (undefined :: Int32) TYPE_SINT32 -> f (undefined :: Int32)@@ -371,74 +408,106 @@ | otherwise = Just n high [] n = Just n +fieldOption :: Maybe Type -> P D.FieldDescriptorProto ()+fieldOption mt = liftM2 (,) pOptionE getOld >>= setOption >>= setNew where+ getOld = fmap (fromMaybe mergeEmpty . D.FieldDescriptorProto.options) getState+ setNew p = update' (\s -> s { D.FieldDescriptorProto.options = Just p })+ setOption (Left uno,old) =+ return' (old {D.FieldOptions.uninterpreted_option = D.FieldOptions.uninterpreted_option old |> uno })+ setOption (Right optName,old) =+ case optName of+ "ctype" | (Just TYPE_STRING) == mt -> do+ enumLit >>= \p -> return' (old {D.FieldOptions.ctype=Just p})+ "experimental_map_key" | Nothing == mt -> do+ strLit >>= \p -> return' (old {D.FieldOptions.experimental_map_key=Just p})+ _ -> unexpected $ "FieldOptions has no option named "++optName+ enum :: (D.EnumDescriptorProto -> P s ()) -> P s () enum up = pName (U.fromString "enum") >> do self <- ident1- up =<< subParser (pChar '{' >> subEnum) (mergeEmpty {D.EnumDescriptorProto.name=Just self})+ up =<< subParser (pChar '{' >> subEnum) (defaultValue {D.EnumDescriptorProto.name=Just self}) -enumOption,subEnum :: P D.EnumDescriptorProto.EnumDescriptorProto ()-subEnum = eols >> rest - where rest = (enumVal <|> enumOption) >> eols >> (pChar '}' <|> rest)-{- setOption = fail "There are no options for enumerations (when this parser was written)" -}- enumVal :: P D.EnumDescriptorProto ()- enumVal = do- name <- ident1- number <- pChar '=' >> enumInt- -- enum value option- eol- let v = D.EnumValueDescriptorProto- { D.EnumValueDescriptorProto.name = Just name- , D.EnumValueDescriptorProto.number = Just number- , D.EnumValueDescriptorProto.options = Nothing- , D.EnumValueDescriptorProto.unknown'field = mergeEmpty- }- update' (\s -> s {D.EnumDescriptorProto.value=D.EnumDescriptorProto.value s |> v})+subEnum,enumOption :: P D.EnumDescriptorProto.EnumDescriptorProto ()+subEnum = eols >> rest -- Note: Must check enumOption before enumVal+ where rest = (enumOption <|> enumVal) >> eols >> (pChar '}' <|> rest) -enumOption = pOption >>= setOption >>= \p -> eol >> update' (\s -> s {D.EnumDescriptorProto.options=Just p})- where- setOption optName = do- -- old <- fmap (maybe mergeEmpty id . D.EnumDescriptorProto.options) getState- case optName of- s -> unexpected $ "There are no options for enumerations (when this parser was written): "++s+enumOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.EnumDescriptorProto.options) getState+ setNew p = update' (\s -> s {D.EnumDescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' $ (old {D.EnumOptions.uninterpreted_option = D.EnumOptions.uninterpreted_option old |> uno })+ setOption (Right optName,_old) =+ case optName of+ _ -> unexpected $ "EnumOptions has no option named "++optName +enumVal :: P D.EnumDescriptorProto ()+enumVal = do+ name <- ident1+ number <- pChar '=' >> enumInt+ let v1 = defaultValue { D.EnumValueDescriptorProto.name = Just name+ , D.EnumValueDescriptorProto.number = Just number }+ v <- (eol >> return v1) <|> subParser (pChar '{' >> subEnumValue) v1+ update' (\s -> s {D.EnumDescriptorProto.value=D.EnumDescriptorProto.value s |> v})++subEnumValue,enumValueOption :: P D.EnumValueDescriptorProto ()+subEnumValue = pChar '}' <|> (choice [ eol, enumValueOption ] >> subEnumValue)++enumValueOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.EnumValueDescriptorProto.options) getState+ setNew p = update' (\s -> s {D.EnumValueDescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' $ (old {D.EnumValueOptions.uninterpreted_option = D.EnumValueOptions.uninterpreted_option old |> uno })+ setOption (Right optName,_old) =+ case optName of+ _ -> unexpected $ "EnumValueOptions has no option named "++optName+ extensions = pName (U.fromString "extensions") >> do- start <- fmap Just fieldInt+ start <- fieldInt pName (U.fromString "to")- end <- (fmap Just fieldInt <|> fmap (const Nothing) (pName (U.fromString "max")))- let e = D.ExtensionRange- { D.ExtensionRange.start = start- , D.ExtensionRange.end = end- , D.ExtensionRange.unknown'field = mergeEmpty- }+ end <- fieldInt <|> (pName (U.fromString "max") >> return (getFieldId maxBound))+ let e = defaultValue { D.ExtensionRange.start = Just start+ , D.ExtensionRange.end = Just (succ end) } -- One _past_ the end! update' (\s -> s {D.DescriptorProto.extension_range=D.DescriptorProto.extension_range s |> e}) service = pName (U.fromString "service") >> do name <- ident1- f <- subParser (pChar '{' >> subRpc) (mergeEmpty {D.ServiceDescriptorProto.name=Just name})+ f <- subParser (pChar '{' >> subService) (defaultValue {D.ServiceDescriptorProto.name=Just name}) update' (\s -> s {D.FileDescriptorProto.service=D.FileDescriptorProto.service s |> f})- - where subRpc = pChar '}' <|> (choice [ eol- , rpc- , pOption >>= setOption- ] >> subRpc)- rpc = pName (U.fromString "rpc") >> do- name <- ident1- input <- between (pChar '(') (pChar ')') ident1- pName (U.fromString "returns")- output <- between (pChar '(') (pChar ')') ident1- eol- let m = D.MethodDescriptorProto- { D.MethodDescriptorProto.name=Just name- , D.MethodDescriptorProto.input_type=Just input- , D.MethodDescriptorProto.output_type=Just output- , D.MethodDescriptorProto.options=Nothing- , D.MethodDescriptorProto.unknown'field = mergeEmpty- }- update' (\s -> s {D.ServiceDescriptorProto.method=D.ServiceDescriptorProto.method s |> m})- setOption optName = do- -- old <- fmap (maybe mergeEmpty id . D.ServiceDescriptorProto.options) getState- case optName of- s -> unexpected $ "There are no options for services (when this parser was written): "++s++ where subService = pChar '}' <|> (choice [ eol, rpc, serviceOption ] >> subService)++serviceOption,rpc :: P D.ServiceDescriptorProto ()+serviceOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.ServiceDescriptorProto.options) getState+ setNew p = update' (\s -> s {D.ServiceDescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' (old {D.ServiceOptions.uninterpreted_option = D.ServiceOptions.uninterpreted_option old |> uno })+ setOption (Right optName,_old) =+ case optName of+ _ -> unexpected $ "ServiceOptions has no option named "++optName++rpc = pName (U.fromString "rpc") >> do+ name <- ident1+ input <- between (pChar '(') (pChar ')') ident1+ pName (U.fromString "returns")+ output <- between (pChar '(') (pChar ')') ident1+ let m1 = defaultValue { D.MethodDescriptorProto.name=Just name+ , D.MethodDescriptorProto.input_type=Just input+ , D.MethodDescriptorProto.output_type=Just output }+ m <- (eol >> return m1) <|> subParser (pChar '{' >> subRpc) m1+ update' (\s -> s {D.ServiceDescriptorProto.method=D.ServiceDescriptorProto.method s |> m})++subRpc,rpcOption :: P D.MethodDescriptorProto ()+subRpc = pChar '}' <|> (choice [ eol, rpcOption ] >> subRpc)++rpcOption = pOptionWith getOld >>= setOption >>= setNew >> eol where+ getOld = fmap (fromMaybe mergeEmpty . D.MethodDescriptorProto.options) getState+ setNew p = update' (\s -> s {D.MethodDescriptorProto.options=Just p})+ setOption (Left uno,old) =+ return' $ (old {D.MethodOptions.uninterpreted_option = D.MethodOptions.uninterpreted_option old |> uno })+ setOption (Right optName,_old) =+ case optName of+ _ -> unexpected $ "MethodOptions has no option named "++optName {- -- see google's stubs/strutil.cc lines 398-449/1121 and C99 specification
Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -1,354 +1,977 @@--- | Text.ProtocolBuffers.Resolve takes the output of Text.ProtocolBuffers.Parse and runs all--- the preprocessing and sanity checks that precede Text.ProtocolBuffers.Gen creating modules.------ Currently this involves mangling the names, building a NameSpace (or [NameSpace]), and making--- all the names fully qualified (and setting TYPE_MESSAGE or TYPE_ENUM) as appropriate.--- Field names are also checked against a list of reserved words, appending a single quote--- to disambiguate.--- All names from Parser should start with a letter, but _ is also handled by replacing with U' or u'.--- Anything else will trigger a "subborn ..." error.--- Name resolution failure are not handled elegantly: it will kill the system with a long error message.------ TODO: treat names with leading "." as already "fully-qualified"--- make sure the optional fields that will be needed are not Nothing (or punt to Reflections.hs)--- look for repeated use of the same name (before and after mangling)-module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,resolveFDP) where--import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto)-import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))-import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))-import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto)-import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..))-import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto)-import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))-import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..))-import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto(Type)-import Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto.Type(Type(..))-import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto(FileDescriptorProto))-import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))-import qualified Text.DescriptorProtos.FileOptions as D.FileOptions(FileOptions(..))-import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto)-import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..))-import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))--import Text.ProtocolBuffers.Header-import Text.ProtocolBuffers.ProtoCompile.Parser--import Control.Monad.State-import Data.Char-import Data.Ix(inRange)-import qualified Data.Foldable as F-import qualified Data.Set as Set-import Data.Maybe(fromMaybe,catMaybes)-import Data.Monoid(Monoid(..))-import Data.Map(Map)-import qualified Data.Map as M-import Data.List(unfoldr,span,inits,foldl')-import qualified Data.ByteString.Lazy.UTF8 as U-import qualified Data.ByteString.Lazy.Char8 as LC-import System.Directory-import System.FilePath--err :: forall b. String -> b-err s = error $ "Text.ProtocolBuffers.Resolve fatal error encountered, message:\n"++indent s- where indent = unlines . map (\str -> ' ':' ':str) . lines--encodeModuleNames :: [String] -> Utf8-encodeModuleNames [] = Utf8 mempty-encodeModuleNames xs = Utf8 . U.fromString . foldr1 (\a b -> a ++ '.':b) $ xs--mangleCap :: Maybe Utf8 -> [String]-mangleCap = mangleModuleNames . fromMaybe (Utf8 mempty)- where mangleModuleNames :: Utf8 -> [String]- mangleModuleNames bs = map mangleModuleName . splitDot . toString $ bs- splitDot :: String -> [String]- splitDot = unfoldr s where- s ('.':xs) = s xs- s [] = Nothing- s xs = Just (span ('.'/=) xs)--mangleCap1 :: Maybe Utf8 -> String-mangleCap1 Nothing = ""-mangleCap1 (Just u) = mangleModuleName . toString $ u--mangleEnums :: Seq D.EnumValueDescriptorProto -> Seq D.EnumValueDescriptorProto-mangleEnums s = fmap fixEnum s- where fixEnum v = v { D.EnumValueDescriptorProto.name = mangleEnum (D.EnumValueDescriptorProto.name v)}--mangleEnum :: Maybe Utf8 -> Maybe Utf8-mangleEnum = fmap (Utf8 . U.fromString . mangleModuleName . toString)--mangleModuleName :: String -> String-mangleModuleName [] = "Empty'Name" -- XXX-mangleModuleName ('_':xs) = "U'"++xs-mangleModuleName (x:xs) | isLower x = let x' = toUpper x- in if isLower x' then err ("subborn lower case"++show (x:xs))- else x': xs-mangleModuleName xs = xs--mangleFieldName :: Maybe Utf8 -> Maybe Utf8-mangleFieldName = fmap (Utf8 . U.fromString . fixname . toString)- where fixname [] = "empty'name" -- XXX- fixname ('_':xs) = "u'"++xs- fixname (x:xs) | isUpper x = let x' = toLower x- in if isUpper x' then err ("stubborn upper case: "++show (x:xs))- else fixname (x':xs)- fixname xs | xs `elem` reserved = xs ++ "'"- fixname xs = xs- reserved :: [String]- reserved = ["case","class","data","default","deriving","do","else","foreign"- ,"if","import","in","infix","infixl","infixr","instance"- ,"let","module","newtype","of","then","type","where"] -- also reserved is "_"--checkER :: [(Int32,Int32)] -> Int32 -> Bool-checkER ers fid = any (`inRange` fid) ers--extRangeList :: D.DescriptorProto -> [(Int32,Int32)]-extRangeList d = concatMap check unchecked- where check x@(lo,hi) | hi < lo = []- | hi<19000 || 19999<lo = [x]- | otherwise = concatMap check [(lo,18999),(20000,hi)]- unchecked = F.foldr ((:) . extToPair) [] (D.DescriptorProto.extension_range d)- extToPair (D.ExtensionRange- { D.ExtensionRange.start = start- , D.ExtensionRange.end = end }) =- (getFieldId $ maybe minBound FieldId start, getFieldId $ maybe maxBound FieldId end)--newtype NameSpace = NameSpace {unNameSpace::(Map String ([String],NameType,Maybe NameSpace))}- deriving (Show,Read)-data NameType = Message [(Int32,Int32)] | Enumeration [Utf8] | Service | Void - deriving (Show,Read)--type Context = [NameSpace]--seeContext :: Context -> [String] -seeContext cx = map ((++"[]") . concatMap (\k -> show k ++ ", ") . M.keys . unNameSpace) cx--toString :: Utf8 -> String-toString = U.toString . utf8--findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)-findFile paths target = do- let test [] = return Nothing- test (path:rest) = do- let fullname = combine path target- found <- doesFileExist fullname- if found then return (Just fullname)- else test rest- test paths---- loadProto is a slight kludge. It takes a single search directory--- and an initial .proto file path relative to this directory. It--- loads this file and then chases the imports. If an import loop is--- detected then it aborts. A state monad is used to memorize--- previous invocations of 'load'. A progress message of the filepath--- is printed before reading a new .proto file.------ The "contexts" collected and used to "resolveWithContext" can--- contain duplicates: File A imports B and C, and File B imports C--- will cause the context for C to be included twice in contexts.------ The result type of loadProto is enough for now, but may be changed--- in the future. It returns a map from the files (relative to the--- search directory) to a pair of the resolved descriptor and a set of--- directly imported files. The dependency tree is thus implicit.-loadProto :: [FilePath] -> FilePath -> IO (Map FilePath (D.FileDescriptorProto,Set.Set FilePath,[String]))-loadProto protoDirs protoFile = fmap answer $ execStateT (load Set.empty protoFile) mempty where- answer built = fmap snd built -- drop the fst Context from the pair in the memorized map- loadFailed f msg = fail . unlines $ ["Parsing proto:",f,"has failed with message",msg]- load :: Set.Set FilePath -- set of "parents" that is used by load to detect an import loop. Not memorized.- -> FilePath -- the FilePath to load and resolve (may used memorized result of load)- -> StateT (Map FilePath (Context,(D.FileDescriptorProto,Set.Set FilePath,[String]))) -- memorized results of load- IO (Context -- Only used during load. This is the view of the file as an imported namespace.- ,(D.FileDescriptorProto -- This is the resolved version of the FileDescriptorProto- ,Set.Set FilePath- ,[String])) -- This is the list of file directly imported by the FilePath argument- load parentsIn file = do- built <- get -- to check memorized results- when (Set.member file parentsIn)- (loadFailed file (unlines ["imports failed: recursive loop detected"- ,unlines . map show . M.assocs $ built,show parentsIn]))- let parents = Set.insert file parentsIn- case M.lookup file built of- Just result -> return result- Nothing -> do- mayToRead <- liftIO $ findFile protoDirs file- when (Nothing == mayToRead) $- loadFailed file (unlines (["loading failed, could not find file: "++show file- ,"Searched paths were:"] ++ map (" "++) protoDirs))- let (Just toRead) = mayToRead- proto <- liftIO $ do print ("Loading filepath: "++toRead)- LC.readFile toRead- parsed <- either (loadFailed toRead . show) return (parseProto toRead proto)- let (context,imports,names) = toContext parsed- contexts <- fmap (concatMap fst) -- keep only the fst Context's- . mapM (load parents) -- recursively chase imports- . Set.toList $ imports- let result = ( withPackage context parsed ++ contexts- , ( resolveWithContext (context++contexts) parsed- , imports- , names ) )- -- add to memorized results, the "load" above may have updated/invalidated the "built <- get" state above- modify (\built' -> M.insert file result built')- return result---- Imported names must be fully qualified in the .proto file by the--- target's package name, but the resolved name might be fully--- quilified by something else (e.g. one of the java options).-withPackage :: Context -> D.FileDescriptorProto -> Context-withPackage (cx:_) (D.FileDescriptorProto {D.FileDescriptorProto.package=Just package}) =- let prepend = mangleCap1 . Just $ package- in [NameSpace (M.singleton prepend ([prepend],Void,Just cx))]-withPackage (_:_) (D.FileDescriptorProto {D.FileDescriptorProto.name=n}) = err $- "withPackage given an imported FDP without a package declaration: "++show n-withPackage [] (D.FileDescriptorProto {D.FileDescriptorProto.name=n}) = err $- "withPackage given an empty context: "++show n--resolveFDP :: D.FileDescriptorProto.FileDescriptorProto- -> (D.FileDescriptorProto.FileDescriptorProto, [String])-resolveFDP fdpIn =- let (context,_,names) = toContext fdpIn- in (resolveWithContext context fdpIn,names)- --- process to get top level context for FDP and list of its imports-toContext :: D.FileDescriptorProto -> (Context,Set.Set FilePath,[String])-toContext protoIn =- let prefix :: [String]- prefix = mangleCap . msum $- [ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options protoIn)- , D.FileOptions.java_package =<< (D.FileDescriptorProto.options protoIn)- , D.FileDescriptorProto.package protoIn]- -- Make top-most root NameSpace- nameSpace = fromMaybe (NameSpace mempty) $ foldr addPrefix protoNames $ zip prefix (tail (inits prefix))- where addPrefix (s1,ss) ns = Just . NameSpace $ M.singleton s1 (ss,Void,ns)- protoNames | null protoMsgs = Nothing- | otherwise = Just . NameSpace . M.fromList $ protoMsgs- where protoMsgs = F.foldr ((:) . msgNames prefix) protoEnums (D.FileDescriptorProto.message_type protoIn)- protoEnums = F.foldr ((:) . enumNames prefix) protoServices (D.FileDescriptorProto.enum_type protoIn)- protoServices = F.foldr ((:) . serviceNames prefix) [] (D.FileDescriptorProto.service protoIn)- msgNames context dIn =- let s1 = mangleCap1 (D.DescriptorProto.name dIn)- ss' = context ++ [s1]- dNames | null dMsgs = Nothing- | otherwise = Just . NameSpace . M.fromList $ dMsgs- dMsgs = F.foldr ((:) . msgNames ss') dEnums (D.DescriptorProto.nested_type dIn)- dEnums = F.foldr ((:) . enumNames ss') [] (D.DescriptorProto.enum_type dIn)- in ( s1 , (ss',Message (extRangeList dIn),dNames) )- enumNames context eIn = -- XXX todo mangle enum names ? No- let s1 = mangleCap1 (D.EnumDescriptorProto.name eIn)- values :: [Utf8]- values = catMaybes $ map D.EnumValueDescriptorProto.name (F.toList (D.EnumDescriptorProto.value eIn))- in ( s1 , (context ++ [s1],Enumeration values,Nothing) )- serviceNames context sIn =- let s1 = mangleCap1 (D.ServiceDescriptorProto.name sIn)- in ( s1 , (context ++ [s1],Service,Nothing) )- -- Context stack for resolving the top level declarations- protoContext :: Context- protoContext = foldl' (\nss@(NameSpace ns:_) pre -> case M.lookup pre ns of- Just (_,Void,Just ns1) -> (ns1:nss)- _ -> nss) [nameSpace] prefix- in ( protoContext- , Set.fromList (map toString (F.toList (D.FileDescriptorProto.dependency protoIn)))- , prefix- )--resolveWithContext :: Context -> D.FileDescriptorProto -> D.FileDescriptorProto-resolveWithContext protoContext protoIn =- let rerr msg = err $ "Failure while resolving file descriptor proto whose name is "- ++ maybe "<empty name>" toString (D.FileDescriptorProto.name protoIn)++"\n"- ++ msg- descend :: Context -> Maybe Utf8 -> Context -- XXX todo take away the maybe - descend cx@(NameSpace n:_) name =- case M.lookup mangled n of- Just (_,_,Nothing) -> cx- Just (_,_,Just ns1) -> ns1:cx- x -> rerr $ "*** Name resolution failed when descending:\n"++unlines (mangled : show x : "KNOWN NAMES" : seeContext cx)- where mangled = mangleCap1 name -- XXX empty on nothing?- descend [] _ = []- resolve :: Context -> Maybe Utf8 -> Maybe Utf8- resolve _context Nothing = Nothing- resolve context (Just bs) = fmap fst (resolveWithNameType context bs)- resolveWithNameType :: Context -> Utf8 -> Maybe (Utf8,NameType)- resolveWithNameType context bsIn =- let nameIn = mangleCap (Just bsIn)- errMsg = "*** Name resolution failed:\n"- ++unlines ["Unmangled name: "++show bsIn- ,"Mangled name: "++show nameIn- ,"List of known names:"]- ++ unlines (seeContext context)- resolver [] (NameSpace _cx) = rerr $ "Impossible? case in Text.ProtocolBuffers.Resolve.resolveWithNameType.resolver []\n" ++ errMsg- resolver [name] (NameSpace cx) = case M.lookup name cx of- Nothing -> Nothing- Just (fqName,nameType,_) -> Just (encodeModuleNames fqName,nameType)- resolver (name:rest) (NameSpace cx) = case M.lookup name cx of- Nothing -> Nothing- Just (_,_,Nothing) -> Nothing- Just (_,_,Just cx') -> resolver rest cx'- in case msum . map (resolver nameIn) $ context of- Nothing -> rerr errMsg- Just x -> Just x- processFDP fdp = fdp- { D.FileDescriptorProto.message_type = fmap (processMSG protoContext) (D.FileDescriptorProto.message_type fdp)- , D.FileDescriptorProto.enum_type = fmap (processENM protoContext) (D.FileDescriptorProto.enum_type fdp)- , D.FileDescriptorProto.service = fmap (processSRV protoContext) (D.FileDescriptorProto.service fdp)- , D.FileDescriptorProto.extension = fmap (processFLD protoContext Nothing) (D.FileDescriptorProto.extension fdp) }- processMSG cx msg = msg- { D.DescriptorProto.name = self- , D.DescriptorProto.field = fmap (processFLD cx' self) (D.DescriptorProto.field msg)- , D.DescriptorProto.extension = fmap (processFLD cx' self) (D.DescriptorProto.extension msg)- , D.DescriptorProto.nested_type = fmap (processMSG cx') (D.DescriptorProto.nested_type msg)- , D.DescriptorProto.enum_type = fmap (processENM cx') (D.DescriptorProto.enum_type msg) }- where cx' = descend cx (D.DescriptorProto.name msg)- self = resolve cx (D.DescriptorProto.name msg)- processFLD cx mp f = f { D.FieldDescriptorProto.name = mangleFieldName (D.FieldDescriptorProto.name f)- , D.FieldDescriptorProto.type' = new_type'- , D.FieldDescriptorProto.type_name = if new_type' == Just TYPE_GROUP- then groupName- else fmap fst r2- , D.FieldDescriptorProto.default_value = checkEnumDefault- , D.FieldDescriptorProto.extendee = fmap newExt (D.FieldDescriptorProto.extendee f)}- where newExt :: Utf8 -> Utf8- newExt orig = let e2 = resolveWithNameType cx orig- in case (e2,D.FieldDescriptorProto.number f) of- (Just (newName,Message ers),Just fid) ->- if checkER ers fid then newName- else rerr $ "*** Name resolution found an extension field that is out of the allowed extension ranges: "++show f ++ "\n has a number "++ show fid ++" not in one of the valid ranges: " ++ show ers- (Just _,_) -> rerr $ "*** Name resolution found wrong type for "++show orig++" : "++show e2- (Nothing,Just {}) -> rerr $ "*** Name resolution failed for the extendee: "++show f- (_,Nothing) -> rerr $ "*** No field id number for the extension field: "++show f- r2 = fmap (fromMaybe (rerr $ "*** Name resolution failed for the type_name of extension field: "++show f)- . (resolveWithNameType cx))- (D.FieldDescriptorProto.type_name f)- t (Message {}) = TYPE_MESSAGE- t (Enumeration {}) = TYPE_ENUM- t _ = rerr $ unlines [ "Problem found: processFLD cannot resolve type_name to Void or Service"- , " The parent message is "++maybe "<no message>" toString mp- , " The field name is "++maybe "<no field name>" toString (D.FieldDescriptorProto.name f)]- new_type' = (D.FieldDescriptorProto.type' f) `mplus` (fmap (t.snd) r2)- checkEnumDefault = case (D.FieldDescriptorProto.default_value f,fmap snd r2) of- (Just name,Just (Enumeration values)) | name `elem` values -> mangleEnum (Just name)- | otherwise ->- rerr $ unlines ["Problem found: default enumeration value not recognized:"- ," The parent message is "++maybe "<no message>" toString mp- ," field name is "++maybe "" toString (D.FieldDescriptorProto.name f)- ," bad enum name is "++show (toString name)- ," possible enum values are "++show (map toString values)]- (Just def,_) | new_type' == Just TYPE_MESSAGE- || new_type' == Just TYPE_GROUP ->- rerr $ "Problem found: You set a default value for a MESSAGE or GROUP: "++unlines [show def,show f]- (maybeDef,_) -> maybeDef- - groupName = case mp of- Nothing -> resolve cx (D.FieldDescriptorProto.name f)- Just p -> do n <- D.FieldDescriptorProto.name f- return (Utf8 . U.fromString . (toString p++) . ('.':) . mangleModuleName . toString $ n)-- processENM cx e = e { D.EnumDescriptorProto.name = resolve cx (D.EnumDescriptorProto.name e)- , D.EnumDescriptorProto.value = mangleEnums (D.EnumDescriptorProto.value e) }- processSRV cx s = s { D.ServiceDescriptorProto.name = resolve cx (D.ServiceDescriptorProto.name s)- , D.ServiceDescriptorProto.method = fmap (processMTD cx) (D.ServiceDescriptorProto.method s) }- processMTD cx m = m { D.MethodDescriptorProto.name = mangleFieldName (D.MethodDescriptorProto.name m)- , D.MethodDescriptorProto.input_type = resolve cx (D.MethodDescriptorProto.input_type m)- , D.MethodDescriptorProto.output_type = resolve cx (D.MethodDescriptorProto.output_type m) }- in processFDP protoIn+-- | This huge module handles the loading and name resolution. The+-- loadProto command recursively gets all the imported proto files.+-- The makeNameMaps command makes the translator from proto name to+-- Haskell name. Many possible errors in the proto data are caught+-- and reported by these operations.+module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,makeNameMap,makeNameMaps,getTLS+ ,Env(..),TopLevel(..),ReMap,NameMap(..),LocalFP(..),CanonFP(..)) where++import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto)+import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))+import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto(EnumDescriptorProto))+import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto)+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto)+import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D(Type)+import Text.DescriptorProtos.FieldDescriptorProto.Type as D.Type(Type(..))+import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto)+import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto)+import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto as D(ServiceDescriptorProto)+import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))+import qualified Text.DescriptorProtos.UninterpretedOption as D(UninterpretedOption)+import qualified Text.DescriptorProtos.UninterpretedOption as D.UninterpretedOption(UninterpretedOption(..))+import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D(NamePart(NamePart))+import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D.NamePart(NamePart(..))+import qualified Text.DescriptorProtos.EnumOptions as D(EnumOptions)+import qualified Text.DescriptorProtos.EnumOptions as D.EnumOptions(EnumOptions(uninterpreted_option))+import qualified Text.DescriptorProtos.EnumValueOptions as D(EnumValueOptions)+import qualified Text.DescriptorProtos.EnumValueOptions as D.EnumValueOptions(EnumValueOptions(uninterpreted_option))+import qualified Text.DescriptorProtos.FieldOptions as D(FieldOptions)+import qualified Text.DescriptorProtos.FieldOptions as D.FieldOptions(FieldOptions(uninterpreted_option))+import qualified Text.DescriptorProtos.FileOptions as D(FileOptions)+import qualified Text.DescriptorProtos.FileOptions as D.FileOptions(FileOptions(..))+import qualified Text.DescriptorProtos.MessageOptions as D(MessageOptions)+import qualified Text.DescriptorProtos.MessageOptions as D.MessageOptions(MessageOptions(uninterpreted_option))+import qualified Text.DescriptorProtos.MethodOptions as D(MethodOptions)+import qualified Text.DescriptorProtos.MethodOptions as D.MethodOptions(MethodOptions(uninterpreted_option))+import qualified Text.DescriptorProtos.ServiceOptions as D(ServiceOptions)+import qualified Text.DescriptorProtos.ServiceOptions as D.ServiceOptions(ServiceOptions(uninterpreted_option))++import Text.ProtocolBuffers.Header+import Text.ProtocolBuffers.Identifiers+import Text.ProtocolBuffers.Extensions+import Text.ProtocolBuffers.WireMessage+import Text.ProtocolBuffers.ProtoCompile.Instances+import Text.ProtocolBuffers.ProtoCompile.Parser++import Control.Applicative+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Error+import Control.Monad.Writer+import Data.Char+import Data.Ratio+import Data.Ix(inRange)+import Data.List(foldl',stripPrefix,lookup,isPrefixOf)+import Data.Map(Map)+import Data.Maybe(mapMaybe)+import Data.Monoid(Monoid(..))+import Data.Set(Set)+import System.Directory+import qualified System.FilePath as Local(pathSeparator,splitDirectories,joinPath,combine,makeRelative)+import qualified System.FilePath.Posix as Canon(pathSeparator,splitDirectories,joinPath,takeBaseName)+import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import qualified Data.Map as M+import qualified Data.Set as Set+import qualified Data.Traversable as T++--import Debug.Trace(trace)++-- Used by err and throw+indent :: String -> String+indent = unlines . map (\str -> ' ':' ':str) . lines++ishow :: Show a => a -> String+ishow = indent . show++errMsg :: String -> String+errMsg s = "Text.ProtocolBuffers.Resolve fatal error encountered, message:\n"++indent s++err :: forall b. String -> b+err = error . errMsg ++throw :: (Error e, MonadError e m) => String -> m a+throw s = throwError (strMsg (errMsg s))++annErr :: (MonadError String m) => String -> m a -> m a+annErr s act = catchError act (\e -> throwError ("annErr: "++s++'\n':indent e))++getJust :: (Error e,MonadError e m, Typeable a) => String -> Maybe a -> m a+{-# INLINE getJust #-}+getJust s ma@Nothing = throw $ "Impossible? Expected Just of type "++show (typeOf ma)++" but got nothing:\n"++indent s+getJust _s (Just a) = return a++-- This adds a leading dot if the input is non-empty+joinDot :: [IName String] -> FIName String+joinDot [] = err $ "joinDot on an empty list of IName!"+joinDot (x:xs) = fqAppend (promoteFI x) xs++checkFI :: [(FieldId,FieldId)] -> FieldId -> Bool+checkFI ers fid = any (`inRange` fid) ers++getExtRanges :: D.DescriptorProto -> [(FieldId,FieldId)]+getExtRanges d = concatMap check unchecked+ where check x@(lo,hi) | hi < lo = []+ | hi<19000 || 19999<lo = [x]+ | otherwise = concatMap check [(lo,18999),(20000,hi)]+ unchecked = F.foldr ((:) . extToPair) [] (D.DescriptorProto.extension_range d)+ extToPair (D.ExtensionRange+ { D.ExtensionRange.start = start+ , D.ExtensionRange.end = end }) =+ (maybe minBound FieldId start, maybe maxBound (FieldId . pred) end)++-- | By construction Env is 0 or more Local Entity namespaces followed+-- by 1 or more Global TopLevel namespaces (self and imported files).+-- Entities in first Global TopLevel namespace can refer to each other+-- and to Entities in the list of directly imported TopLevel namespaces only.+data Env = Local Entity {- E'Message -} Env | Global TopLevel [TopLevel] deriving Show+-- | TopLevel corresponds to all items defined in a .proto file. This+-- includes the FileOptions since this will be consulted when+-- generating the Haskel module names, and the imported files are only+-- known through their TopLevel data.+data TopLevel = TopLevel { top'Path :: FilePath+ , top'Package :: [IName String]+ , top'FDP :: Either ErrStr D.FileDescriptorProto -- resolvedFDP'd+ , top'mVals :: EMap } deriving Show+-- | The EMap type is a local namespace attached to an entity+type EMap = Map (IName String) Entity+-- | An Entity is some concrete item in the namespace of a proto file.+-- All Entity values have a leading-dot fully-qualified with the package "eName".+-- The E'Message,Group,Service have EMap namespaces to inner Entity items.+data Entity = E'Message { eName :: [IName String], validExtensions :: [(FieldId,FieldId)]+ , mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }+ | E'Group { eName :: [IName String], mVals :: EMap {- E'Message,Group,Field,Key,Enum -} }+ | E'Field { eName :: [IName String], fNumber :: FieldId, fType :: Maybe D.Type+ , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }+ | E'Key { eName :: [IName String], eMsg :: Either ErrStr Entity {- E'Message -}+ , fNumber :: FieldId, fType :: Maybe D.Type+ , mVal :: Maybe (Either ErrStr Entity) {- E'Message,Group,Enum -} }+ | E'Enum { eName :: [IName String], eVals :: Map (IName Utf8) Int32 }+ | E'Service { eName :: [IName String], mVals :: EMap {- E'Method -} }+ | E'Method { eName :: [IName String], eMsgIn,eMsgOut :: Maybe (Either ErrStr Entity) {- E'Message -} }+ | E'Error String [Entity]+ deriving (Show)++newtype LocalFP = LocalFP { unLocalFP :: FilePath } deriving (Read,Show,Eq,Ord)+newtype CanonFP = CanonFP { unCanonFP :: FilePath } deriving (Read,Show,Eq,Ord)++fpLocalToCanon :: LocalFP -> CanonFP+fpLocalToCanon | Canon.pathSeparator == Local.pathSeparator = CanonFP . unLocalFP+ | otherwise = CanonFP . Canon.joinPath . Local.splitDirectories . unLocalFP++fpCanonToLocal :: CanonFP -> LocalFP+fpCanonToLocal | Canon.pathSeparator == Local.pathSeparator = LocalFP . unCanonFP+ | otherwise = LocalFP . Local.joinPath . Canon.splitDirectories . unCanonFP++allowed :: Env -> [([IName String],[IName String])]+allowed (Local entity env) = allowedE entity : allowed env+allowed (Global t ts) = map allowedT (t:ts)+allowedE :: Entity -> ([IName String], [IName String])+allowedE entity = ((,) (eName entity)) $+ case get'mVals entity of+ Nothing -> []+ Just m -> M.keys m+allowedT :: TopLevel -> ([IName String], [IName String])+allowedT tl = (top'Package tl,M.keys (top'mVals tl))++data NameMap = NameMap (FIName Utf8,[MName String],[MName String]) ReMap++-- Create a mapping from the "official" name to the Haskell hierarchy mangled name+type ReMap = Map (FIName Utf8) ProtoName++type RE a = ReaderT Env (Either ErrStr) a++data SEnv = SEnv { my'Parent :: [IName String]+ , my'Env :: Env }+-- , my'Template :: ProtoName }++instance Show SEnv where+ show (SEnv p e) = "(SEnv "++show p++" ; "++ whereEnv e ++ ")" --" ; "++show (haskellPrefix t,parentModule t)++ " )"++type ErrStr = String++type SE a = ReaderT SEnv (Either ErrStr) a++fqName :: Entity -> FIName Utf8+fqName = fiFromString . joinDot . eName++fiFromString :: FIName String -> FIName Utf8+fiFromString = FIName . fromString . fiName++iToString :: IName Utf8 -> IName String+iToString = IName . toString . iName++-- Three entities provide child namespaces: E'Message, E'Group, and E'Service+get'mVals :: Entity -> Maybe EMap+get'mVals (E'Message {mVals = x}) = Just x+get'mVals (E'Group {mVals = x}) = Just x+get'mVals (E'Service {mVals = x}) = Just x+get'mVals _ = Nothing++-- | This is a helper for resolveEnv+toGlobal :: Env -> Env+toGlobal (Local _entity env) = toGlobal env+toGlobal x@(Global {}) = x++getTL :: Env -> TopLevel+getTL (Local _entity env) = getTL env+getTL (Global tl _tls) = tl++getTLS :: Env -> (TopLevel,[TopLevel])+getTLS (Local _entity env) = getTLS env+getTLS (Global tl tls) = (tl, tls)++-- | This is used for resolving some UninterpretedOption names+resolveHere :: Entity -> Utf8 -> RE Entity+resolveHere parent nameU = do+ let rFail msg = throw ("Could not lookup "++show (toString nameU)++"\n"++indent msg)+ x <- getJust ("resolveHere: validI nameU failed for "++show nameU) (fmap iToString (validI nameU))+ case get'mVals parent of+ Just vals -> case M.lookup x vals of+ Just entity -> return entity+ Nothing -> rFail ("because there is no such name here: "++show (eName parent))+ Nothing -> rFail ("because environment has no local names:\n"++ishow (eName parent))++-- | 'resolveEnv' is the query operation for the Env namespace. It+-- recorgnizes names beginning with a '.' as already being+-- fully-qualified names. This is called from the different monads via+-- resolveRE, resolveSE, or getType.+resolveEnv :: Utf8 -> Env -> Either ErrStr Entity+resolveEnv nameU envIn = do+ (isGlobal,xs) <- checkDIUtf8 nameU+ let mResult = if isGlobal then lookupEnv (map iToString xs) (toGlobal envIn)+ else lookupEnv (map iToString xs) envIn+ case mResult of+ Nothing -> throw . unlines $ [ "resolveEnv: Could not lookup "++show nameU+ , "which parses as "++show (isGlobal,xs)+ , "in environment: "++(whereEnv envIn)+ , "allowed: "++show (allowed envIn)]+ Just e@(E'Error {}) -> throw (show e)+ Just e -> return e++resolveRE :: Utf8 -> RE Entity+resolveRE nameU = lift . (resolveEnv nameU) =<< ask++resolveSE :: Utf8 -> SE (Either ErrStr Entity)+resolveSE nameU = fmap (resolveEnv nameU) (asks my'Env)++-- | 'getType' is used to lookup the type strings in service method records.+getType :: Show a => String -> (a -> Maybe Utf8) -> a -> SE (Maybe (Either ErrStr Entity))+getType s f a = do+ typeU <- getJust s (f a)+ case parseType (toString typeU) of+ Just _ -> return Nothing+ Nothing -> do ee <- resolveSE typeU+ return (Just (expectMGE ee))++-- | 'expectMGE' is used by getType and 'entityField'+expectMGE :: Either ErrStr Entity -> Either ErrStr Entity+expectMGE ee@(Left {}) = ee+expectMGE ee@(Right e) = if isMGE e then ee+ else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow e+ where isMGE e' = case e' of E'Message {} -> True+ E'Group {} -> True+ E'Enum {} -> True+ _ -> False++-- | 'expectM' is used by 'entityField'+expectM :: Either ErrStr Entity -> Either ErrStr Entity+expectM ee@(Left {}) = ee+expectM ee@(Right e) = if isMGE e then ee+ else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e)+ where isMGE e' = case e' of E'Message {} -> True+ _ -> False++expectFK :: Entity -> RE Entity+expectFK e = if isFK e then return e+ else throwError $ "expectF: Name resolution failed to find a Field or Key:\n"++ishow (eName e)+ where isFK e' = case e' of E'Field {} -> True+ E'Key {} -> True+ _ -> False++-- | This is a helper for resolveEnv for error messages+whereEnv :: Env -> String+whereEnv (Local entity env) = fiName (joinDot (eName entity)) ++ " in "++show (top'Path . getTL $ env)+whereEnv (Global tl _) = fiName (joinDot (top'Package tl)) ++ " in " ++ show (top'Path tl)++-- | lookupEnv is used only by resolveEnv+lookupEnv :: [IName String] -> Env -> Maybe Entity+lookupEnv xs (Global tl tls) = lookupTopLevel xs tl <|> msum (map (lookupTopLevel xs) tls)+lookupEnv _xs (Local e@(E'Error {}) _env) = return e+lookupEnv xs (Local entity env) = case get'mVals entity of+ Just vals -> lookupVals vals xs <|> lookupEnv xs env+ Nothing -> Nothing++-- | lookupTopLeve is used only by lookupEnv+lookupTopLevel :: [IName String] -> TopLevel -> Maybe Entity+lookupTopLevel xs tl =+ lookupVals (top'mVals tl) xs <|> (stripPrefix (top'Package tl) xs >>= lookupVals (top'mVals tl))++-- | lookupVals is used by lookupEnv and lookupTopLevel+lookupVals :: EMap -> [IName String] -> Maybe Entity+lookupVals _vals [] = Nothing+lookupVals vals [x] = M.lookup x vals+lookupVals vals (x:xs) = do entity <- M.lookup x vals+ case get'mVals entity of+ Just vals' -> lookupVals vals' xs+ Nothing -> Nothing++-- | 'partEither' separates the Left errors and Right success in the obvious way.+partEither :: [Either a b] -> ([a],[b])+partEither [] = ([],[])+partEither (Left a:xs) = let ~(ls,rs) = partEither xs+ in (a:ls,rs)+partEither (Right b:xs) = let ~(ls,rs) = partEither xs+ in (ls,b:rs)++-- | The 'unique' function is used with Data.Map.fromListWithKey to detect+-- name collisions and record this as E'Error entries in the map.+unique :: IName String -> Entity -> Entity -> Entity+unique name (E'Error _ a) (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a++b)+unique name (E'Error _ a) b = E'Error ("Namespace collision for "++show name) (a++[b])+unique name a (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a:b)+unique name a b = E'Error ("Namespace collision for "++show name) [a,b]++maybeM :: Monad m => (x -> m a) -> (Maybe x) -> m (Maybe a)+maybeM f mx = maybe (return Nothing) (liftM Just . f) mx++runSE :: SEnv -> SE a -> Either ErrStr a+runSE sEnv m = runReaderT m sEnv++makeNameMaps :: [MName String] -> [(CanonFP,[MName String])] -> Env -> Either ErrStr NameMap+makeNameMaps hPrefix hAs env = do+ let getPrefix fdp =+ let ans = case D.FileDescriptorProto.name fdp of+ Nothing -> hPrefix -- really likely to be an error elsewhere+ Just n -> let path = CanonFP (toString n)+ in case lookup path hAs of+ Just p -> p+ Nothing -> case lookup (CanonFP . Canon.takeBaseName . unCanonFP $ path) hAs of+ Just p -> p+ Nothing -> hPrefix+ in ans + let (tl,tls) = getTLS env+ (fdp:fdps) <- mapM top'FDP (tl:tls)+ (NameMap tuple m) <- makeNameMap (getPrefix fdp) fdp+ let f (NameMap _ x) = x+ ms <- fmap (map f) . mapM (\y -> makeNameMap (getPrefix y) y) $ fdps+ return (NameMap tuple (M.unions (m:ms)))++-- | 'makeNameMap' conservatively checks its input.+makeNameMap :: [MName String] -> D.FileDescriptorProto -> Either ErrStr NameMap+makeNameMap hPrefix fdpIn = -- trace (show ("getPrefix",D.FileDescriptorProto.name fdpIn,hPrefix)) $+ go (makeOne fdpIn) where+ go = fmap ((\(a,w) -> NameMap a (M.fromList w))) . runWriterT+-- makeOne :: D.FileDescriptorProto -> WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) ()+ makeOne fdp = do+ -- Create 'template' :: ProtoName using "Text.ProtocolBuffers.Identifiers"+ rawPackage <- getJust "makeNameMap.makeOne: D.FileDescriptorProto.package"+ (D.FileDescriptorProto.package fdp)+ lift (checkDIUtf8 rawPackage) -- guard-like effect+ let packageName = difi (DIName rawPackage)+ rawParent <- getJust "makeNameMap.makeOne: " . msum $+ [ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options fdp)+ , D.FileOptions.java_package =<< (D.FileDescriptorProto.options fdp)+ , D.FileDescriptorProto.package fdp]+ diParent <- getJust ("makeNameMap.makeOne: invalid character in: "++show rawParent)+ (validDI rawParent)+ let hParent = map (mangle :: IName Utf8 -> MName String) . splitDI $ diParent+ template = ProtoName packageName hPrefix hParent+ (error "makeNameMap.makeOne.template.baseName undefined")+ runReaderT (mrmFile fdp) template+ return (packageName,hPrefix,hParent)+ -- Traversal of the named DescriptorProto types+ mrmFile :: D.FileDescriptorProto -> MRM ()+ mrmFile fdp = do+ F.mapM_ mrmMsg (D.FileDescriptorProto.message_type fdp)+ F.mapM_ mrmField (D.FileDescriptorProto.extension fdp)+ F.mapM_ mrmEnum (D.FileDescriptorProto.enum_type fdp)+ F.mapM_ mrmService (D.FileDescriptorProto.service fdp)+ mrmMsg dp = do+ template <- mrmName "mrmMsg.name" D.DescriptorProto.name dp+ local (const template) $ do+ F.mapM_ mrmEnum (D.DescriptorProto.enum_type dp)+ F.mapM_ mrmField (D.DescriptorProto.extension dp)+ F.mapM_ mrmField (D.DescriptorProto.field dp)+ F.mapM_ mrmMsg (D.DescriptorProto.nested_type dp)+ mrmField fdp = mrmName "mrmField.name" D.FieldDescriptorProto.name fdp+ mrmEnum edp = do+ template <- mrmName "mrmEnum.name" D.EnumDescriptorProto.name edp+ local (const template) $ F.mapM_ mrmEnumValue (D.EnumDescriptorProto.value edp)+ mrmEnumValue evdp = mrmName "mrmEnumValue.name" D.EnumValueDescriptorProto.name evdp+ mrmService sdp = do+ template <- mrmName "mrmService.name" D.ServiceDescriptorProto.name sdp+ local (const template) $ F.mapM_ mrmMethod (D.ServiceDescriptorProto.method sdp)+ mrmMethod mdp = mrmName "mrmMethod.name" D.MethodDescriptorProto.name mdp++type MRM a = ReaderT ProtoName (WriterT [(FIName Utf8,ProtoName)] (Either ErrStr)) a++mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName+mrmName s f a = do+ template <- ask+ iSelf <- getJust s (validI =<< f a)+ let mSelf = mangle iSelf+ fqSelf = fqAppend (protobufName template) [iSelf]+ self = template { protobufName = fqSelf+ , baseName = mSelf }+ template' = template { protobufName = fqSelf+ , parentModule = parentModule template ++ [mSelf] }+ tell [(fqSelf,self)]+-- trace (unlines [show fqSelf,ishow self]) $ + return template'++getNames :: String -> (a -> Maybe Utf8) -> a -> SE (IName String,[IName String])+getNames errorMessage accessor record = do+ parent <- asks my'Parent+ iSelf <- getJust errorMessage (validI =<< accessor record)+ let names = parent ++ [ iToString iSelf ]+ return (iToString iSelf,names)++descend :: [IName String] -> Entity -> SE a -> SE a+descend names entity act = local mutate act+ where mutate (SEnv _parent env) = SEnv parent' env'+ where parent' = names -- cannot call eName ename, will cause <<loop>> with "getNames" -- XXX revisit+ env' = Local entity env++-- Run each element of (Seq x) as (f x) with same initial environment and state.+-- Then merge the output states and sort out the failures and successes.+kids :: (x -> SE (IName String,Entity)) -> Seq x -> SE ([ErrStr],[(IName String,Entity)])+kids f xs = do sEnv <- ask+ let ans = map (runSE sEnv) . map f . F.toList $ xs+ return (partEither ans)++-- | XXX 'makeTopLevel' takes a .proto file's FileDescriptorProto and the+-- TopLevel values of its directly imported file and constructs the+-- TopLevel of the FileDescriptorProto in a Global Environment.+--+-- This goes to some lengths to be a total function with good error+-- messages. Erros in building the skeleton of the namespace are+-- detected and reported instead of returning the new 'Global'+-- environment. Collisions in the namespace are only detected when+-- the offending name is lookedup, it will return an E'Error entity+-- with a message and list of colliding Entity items. The+-- cross-linking of Entity fields may fail and this failure is stored+-- in the corresponding Entity.+--+-- Also caught: name collisions in Enum definitions.+--+-- mdo notes: sEnv depends on global which depends on sEnv ...+makeTopLevel :: D.FileDescriptorProto -> [IName String] -> [TopLevel] -> Either ErrStr Env {- Global -}+makeTopLevel fdp packageName imports = mdo+ filePath <- getJust "makeTopLevel.filePath" (D.FileDescriptorProto.name fdp)+ let sEnv = SEnv packageName global+ groupNames = mapMaybe validI . map toString . mapMaybe D.FieldDescriptorProto.type_name+ . filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type') + $ (F.toList . D.FileDescriptorProto.extension $ fdp)+ isGroup = (`elem` groupNames)+ global <- runSE sEnv (do+ (bads,children) <- fmap unzip . sequence $+ [ kids (entityMsg isGroup) (D.FileDescriptorProto.message_type fdp)+ , kids (entityField True) (D.FileDescriptorProto.extension fdp)+ , kids entityEnum (D.FileDescriptorProto.enum_type fdp)+ , kids entityService (D.FileDescriptorProto.service fdp) ]+ let global' = Global (TopLevel (toString filePath)+ packageName+ (resolveFDP fdp global')+ (M.fromListWithKey unique (concat children)))+ imports+ bad = unlines (concat bads)+ when (not (null bad)) $+ throw $ "makeTopLevel.bad: Some children failed for "++show filePath++"\n"++bad+ return global'+ )+ return global++{- ***++All the entity* functions are used by makeTopLevel and each other.+They are very scrupulous in being total functions, there is no use of+'error' or 'undefined' and all failures (many of which are Impossible)+are reported by hopefully sensible (Left String) messages.++ *** -}++entityMsg :: (IName String -> Bool) -> D.DescriptorProto -> SE (IName String,Entity)+entityMsg isGroup dp = annErr ("entityMsg "++show (D.DescriptorProto.name dp)) $ mdo+ (self,names) <- getNames "entityMsg.name" D.DescriptorProto.name dp+ numbers <- fmap Set.fromList . mapM (getJust "entityMsg.field.number" . D.FieldDescriptorProto.number) . F.toList . D.DescriptorProto.field $ dp+ when (Set.size numbers /= Seq.length (D.DescriptorProto.field dp)) $+ throwError $ "entityMsg.field.number: There must be duplicate field numbers for "++show names++"\n "++show numbers+ let groupNames = mapMaybe validI . map toString . mapMaybe D.FieldDescriptorProto.type_name+ . filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type') + $ (F.toList . D.DescriptorProto.field $ dp) ++ (F.toList . D.DescriptorProto.extension $ dp)+ isGroup' = (`elem` groupNames)+ entity <- descend names entity $ do+ (bads,children) <- fmap unzip . sequence $+ [ kids entityEnum (D.DescriptorProto.enum_type dp)+ , kids (entityField True) (D.DescriptorProto.extension dp)+ , kids (entityField False) (D.DescriptorProto.field dp)+ , kids (entityMsg isGroup') (D.DescriptorProto.nested_type dp) ]+ let entity' | isGroup self = E'Group names (M.fromListWithKey unique (concat children))+ | otherwise = E'Message names (getExtRanges dp) (M.fromListWithKey unique (concat children))+ bad = unlines (concat bads)+ when (not (null bad)) $+ throwError $ "entityMsg.bad: Some children failed for "++show names++"\n"++bad+ return entity'+ return (self,entity)++entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,Entity)+entityField isKey fdp = annErr ("entityField "++show fdp) $ do+ (self,names) <- getNames "entityField.name" D.FieldDescriptorProto.name fdp+ let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)+ when (isKey/=isKey') $+ throwError $ "entityField: Impossible? Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),names,fdp)+ number <- getJust "entityField.name" . D.FieldDescriptorProto.number $ fdp+ let mType = D.FieldDescriptorProto.type' fdp+ typeName <- maybeM (fmap expectMGE . resolveSE) (D.FieldDescriptorProto.type_name fdp)+ if isKey then do extendee <- fmap expectM . resolveSE =<< getJust "entityField.extendee" (D.FieldDescriptorProto.extendee fdp)+ return (self,E'Key names extendee (FieldId number) mType typeName)+ else return (self,E'Field names (FieldId number) mType typeName)++entityEnum :: D.EnumDescriptorProto -> SE (IName String,Entity)+entityEnum edp@(D.EnumDescriptorProto {D.EnumDescriptorProto.value=vs}) = do+ (self,names) <- getNames "entityEnum.name" D.EnumDescriptorProto.name edp+ values <- mapM (getJust "entityEnum.value.number" . D.EnumValueDescriptorProto.number) . F.toList $ vs+{- Cannot match protoc if I enable this as a fatal check here+ when (Set.size (Set.fromList values) /= Seq.length vs) $+ throwError $ "entityEnum.value.number: There must be duplicate enum values for "++show names++"\n "++show values+-}+ justNames <- mapM (\v -> getJust ("entityEnum.value.name failed for "++show v) (D.EnumValueDescriptorProto.name v))+ . F.toList $ vs+ valNames <- mapM (\n -> getJust ("validI of entityEnum.value.name failed for "++show n) (validI n)) justNames+ let mapping = M.fromList (zip valNames values)+ when (M.size mapping /= Seq.length vs) $+ throwError $ "entityEnum.value.name: There must be duplicate enum names for "++show names++"\n "++show valNames+ let entity = E'Enum names mapping+ descend names entity $ F.mapM_ entityEnumValue vs+ return (self,E'Enum names mapping) -- discard values++entityEnumValue :: D.EnumValueDescriptorProto -> SE ()+entityEnumValue evdp = do -- Merely use getNames to add mangled self to ReMap state+ getNames "entityEnumValue.name" D.EnumValueDescriptorProto.name evdp+ return ()++entityService :: D.ServiceDescriptorProto -> SE (IName String,Entity)+entityService sdp = mdo+ (self,names) <- getNames "entityService.name" D.ServiceDescriptorProto.name sdp+ let entity = E'Service names (M.fromListWithKey unique methods)+ (badMethods,methods) <- descend names entity $+ kids entityMethod (D.ServiceDescriptorProto.method sdp)+ when (not (null badMethods)) $+ throwError $ "entityService.badMethods: Some methods failed for "++show names++"\n"++unlines badMethods+ return (self,entity)++entityMethod :: D.MethodDescriptorProto -> SE (IName String,Entity)+entityMethod mdp = do+ (self,names) <- getNames "entityMethod.name" D.MethodDescriptorProto.name mdp+ inputType <- getType "entityMethod.input_type" D.MethodDescriptorProto.input_type mdp+ outputType <- getType "entityMethod.output_type" D.MethodDescriptorProto.output_type mdp+ return (self,E'Method names inputType outputType)++{- ***++The namespace Env is used to transform the original+FileDescriptorProto into a canonical FileDescriptorProto. The new goal+is to match the transformation done by Google's protoc program. This+will allow the "front end" vs "back end" of each program to+cross-couple, which will at least allow better testing of hprotoc and+the new UninterpretedOption support.++The UninterpretedOption fields are converted by the resolveFDP code below.++These should be total functions with no 'error' or 'undefined' values+possible.++*** -}++resolveFDP :: D.FileDescriptorProto -> Env -> Either ErrStr D.FileDescriptorProto+resolveFDP = runReaderT . fqFileDP ++fqFail :: Show a => String -> a -> Entity -> RE b+fqFail msg dp entity = do+ env <- ask+ throw $ unlines [ msg, "resolving: "++show dp, "in environment: "++whereEnv env, "found: "++show entity ]++fqFileDP :: D.FileDescriptorProto -> RE D.FileDescriptorProto+fqFileDP fdp = do+ newMessages <- T.mapM fqMessage (D.FileDescriptorProto.message_type fdp)+ newEnums <- T.mapM fqEnum (D.FileDescriptorProto.enum_type fdp)+ newServices <- T.mapM fqService (D.FileDescriptorProto.service fdp)+ newKeys <- T.mapM (fqField True) (D.FileDescriptorProto.extension fdp)+ consumeUNO $ fdp { D.FileDescriptorProto.message_type = newMessages+ , D.FileDescriptorProto.enum_type = newEnums+ , D.FileDescriptorProto.service = newServices+ , D.FileDescriptorProto.extension = newKeys }++fqMessage :: D.DescriptorProto -> RE D.DescriptorProto+fqMessage dp = do+ entity <- resolveRE =<< getJust "fqMessage.name" (D.DescriptorProto.name dp)+ case entity of+ E'Message {} -> return ()+ E'Group {} -> return ()+ _ -> fqFail "fqMessage.entity: did not resolve to an E'Message or E'Group:" dp entity+ local (\env -> (Local entity env)) $ do+ newFields <- T.mapM (fqField False) (D.DescriptorProto.field dp)+ newKeys <- T.mapM (fqField True) (D.DescriptorProto.extension dp)+ newMessages <- T.mapM fqMessage (D.DescriptorProto.nested_type dp)+ newEnums <- T.mapM fqEnum (D.DescriptorProto.enum_type dp)+ consumeUNO $ dp { D.DescriptorProto.field = newFields+ , D.DescriptorProto.extension = newKeys+ , D.DescriptorProto.nested_type = newMessages+ , D.DescriptorProto.enum_type = newEnums }++fqService :: D.ServiceDescriptorProto -> RE D.ServiceDescriptorProto+fqService sdp = do+ entity <- resolveRE =<< getJust "fqService.name" (D.ServiceDescriptorProto.name sdp)+ case entity of+ E'Service {} -> do newMethods <- local (Local entity) $ T.mapM fqMethod (D.ServiceDescriptorProto.method sdp)+ consumeUNO $ sdp { D.ServiceDescriptorProto.method = newMethods }+ _ -> fqFail "fqService.entity: did not resolve to a service:" sdp entity++fqMethod :: D.MethodDescriptorProto -> RE D.MethodDescriptorProto+fqMethod mdp = do+ entity <- resolveRE =<< getJust "fqMethod.name" (D.MethodDescriptorProto.name mdp)+ case entity of+ E'Method {} -> do mdp1 <- case eMsgIn entity of+ Nothing -> return mdp+ Just resolveIn -> do new <- fmap fqName (lift resolveIn)+ return (mdp {D.MethodDescriptorProto.input_type = Just (fiName new)})+ mdp2 <- case eMsgOut entity of+ Nothing -> return mdp1+ Just resolveIn -> do new <- fmap fqName (lift resolveIn)+ return (mdp1 {D.MethodDescriptorProto.output_type = Just (fiName new)})+ consumeUNO mdp2+ _ -> fqFail "fqMethod.entity: did not resolve to a Method:" mdp entity++-- The field is a bit more complicated to resolve. The Key variant+-- needs to resolve the extendee. The type code from Parser.hs might+-- be Nothing and this needs to be resolved to TYPE_MESSAGE or+-- TYPE_ENUM, and if it is the latter then any default value string is+-- checked for validity.+fqField :: Bool -> D.FieldDescriptorProto -> RE D.FieldDescriptorProto+fqField isKey fdp = annErr ("fqField "++show fdp) $ do+ let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)+ when (isKey/=isKey') $+ ask >>= \env -> throwError $ "fqField.isKey: Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),whereEnv env,fdp)+ entity <- expectFK =<< resolveRE =<< getJust "fqField.name" (D.FieldDescriptorProto.name fdp)+ newExtendee <- case (isKey,entity) of+ (True,E'Key {}) -> do+ ext <- lift (eMsg entity)+ case ext of+ E'Message {} -> when (not (checkFI (validExtensions ext) (fNumber entity))) $+ throwError $ "fqField.newExtendee: Field Number of extention key invalid:\n"+ ++unlines ["Number is "++show (fNumber entity),"Valid ranges: "++show (validExtensions ext),"Extendee: "++show (eName ext),"Descriptor: "++show fdp]+ _ -> fqFail "fqField.ext: Key's target is not an E'Message:" fdp ext+ fmap (Just . fiName . fqName) . lift . eMsg $ entity+ (False,E'Field {}) -> return Nothing+ _ -> fqFail "fqField.entity: did not resolve to expected E'Key or E'Field:" fdp entity+ mTypeName <- maybeM lift (mVal entity) -- "Just (Left _)" triggers a throwError here+ -- Finally fully determine D.Type, (type'==Nothing) meant ambiguously TYPE_MESSAGE or TYPE_ENUM from Parser.hs+ actualType <- case (fType entity,mTypeName) of+ (Just TYPE_GROUP, Just (E'Group {})) -> return TYPE_GROUP+ (Nothing, Just (E'Message {})) -> return TYPE_MESSAGE+ (Nothing, Just (E'Enum {})) -> return TYPE_ENUM+ (Just t, Nothing) -> return t+ (mt,me) -> fqFail ("fqField.actualType: "++show mt++" and "++show (fmap eName me)++" is invalid") fdp entity+ -- Check that a default value of an TYPE_ENUM is valid+ case (mTypeName,D.FieldDescriptorProto.default_value fdp) of+ (Just ee@(E'Enum {eVals = enumVals}),Just enumVal) ->+ let badVal = throwError $ "fqField.default_value: Default enum value is invalid:\n"+ ++unlines ["Value is "++show (toString enumVal)+ ,"Allowed values from "++show (eName ee)+ ," are "++show (M.keys enumVals)+ ,"Descriptor: "++show fdp]+ in case validI enumVal of+ Nothing -> badVal+ Just iVal -> when (M.notMember iVal enumVals) badVal+ _ -> return ()+ consumeUNO $+ if isKey then (fdp { D.FieldDescriptorProto.extendee = newExtendee+ , D.FieldDescriptorProto.type' = Just actualType+ , D.FieldDescriptorProto.type_name = fmap (fiName . fqName) mTypeName })+ else (fdp { D.FieldDescriptorProto.type' = Just actualType+ , D.FieldDescriptorProto.type_name = fmap (fiName . fqName) mTypeName })++fqEnum :: D.EnumDescriptorProto -> RE D.EnumDescriptorProto+fqEnum edp = do+ entity <- resolveRE =<< getJust "fqEnum.name" (D.EnumDescriptorProto.name edp)+ case entity of+ E'Enum {} -> do evdps <- T.mapM consumeUNO (D.EnumDescriptorProto.value edp)+ consumeUNO $ edp { D.EnumDescriptorProto.value = evdps }+ _ -> fqFail "fqEnum.entity: did not resolve to an E'Enum:" edp entity++{- The consumeUNO calls above hide this cut-and-pasted boilerplate -}++class ConsumeUNO a where consumeUNO :: a -> RE a++instance ConsumeUNO D.EnumDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.EnumDescriptorProto.options = Just o })+ (D.EnumDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "EnumOptions" m (D.EnumOptions.uninterpreted_option m)+ return (m' { D.EnumOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.EnumValueDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.EnumValueDescriptorProto.options = Just o })+ (D.EnumValueDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "EnumValueOptions" m (D.EnumValueOptions.uninterpreted_option m)+ return (m' { D.EnumValueOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.MethodDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.MethodDescriptorProto.options = Just o })+ (D.MethodDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "MethodOptions" m (D.MethodOptions.uninterpreted_option m)+ return (m' { D.MethodOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.ServiceDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.ServiceDescriptorProto.options = Just o })+ (D.ServiceDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "ServiceOptions" m (D.ServiceOptions.uninterpreted_option m)+ return (m' { D.ServiceOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.FieldDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.FieldDescriptorProto.options = Just o })+ (D.FieldDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "FieldOptions" m (D.FieldOptions.uninterpreted_option m)+ return (m' { D.FieldOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.FileDescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.FileDescriptorProto.options = Just o })+ (D.FileDescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "FileOptions" m (D.FileOptions.uninterpreted_option m)+ return (m' { D.FileOptions.uninterpreted_option = mempty })++instance ConsumeUNO D.DescriptorProto where+ consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.DescriptorProto.options = Just o })+ (D.DescriptorProto.options a)+ where processOpt m = do m' <- interpretOptions "MessageOptions" m (D.MessageOptions.uninterpreted_option m)+ return (m' { D.MessageOptions.uninterpreted_option = mempty })++{- The boilerplate above feeds interpretOptions to do the real work -}++-- 'interpretOptions' is used by the 'consumeUNO' instances+-- This prepends the ["google","protobuf"] and updates all the options into the ExtField of msg+interpretOptions :: ExtendMessage msg => String -> msg -> Seq D.UninterpretedOption -> RE msg+interpretOptions name msg unos = do+ name' <- getJust ("interpretOptions: invalid name "++show name) (validI name)+ ios <- mapM (interpretOption [IName "google",IName "protobuf",name']) . F.toList $ unos+ let (ExtField ef) = getExtField msg+ ef' = foldl' (\m (k,v) -> seq v $ M.insertWithKey mergeWires k v m) ef ios++ mergeWires k (ExtFromWire wt1 newData) (ExtFromWire wt2 oldData) =+ if wt1 /= wt2 then err $ "interpretOptions.mergeWires : ExtFromWire WireType mismatch while storing new options in extension fields: " ++ show (name,k,(wt1,wt2))+ else ExtFromWire wt2 (mappend oldData newData)+ mergeWires k a b = err $ "interpretOptions.mergeWires : impossible case\n"++show (k,a,b)+ msg' = seq ef' (putExtField (ExtField ef') msg)+ return msg'++-- 'interpretOption' is called by 'interpretOptions'+-- The 'interpretOption' function is quite long because there are two things going on.+-- The first is the actual type must be retrieved from the UninterpretedOption and encoded.+-- The second is that messages/groups holding messages/groups ... holding the above must wrap this.+-- Both of the above might come from extension keys or from field names.+-- And as usual, there are many ways thing could conceivable go wrong or be out of bounds.+--+-- The first parameter must be a name such as ["google","protobuf","FieldOption"]+interpretOption :: [IName String] -> D.UninterpretedOption -> RE (FieldId,ExtFieldValue)+interpretOption optName uno = case F.toList (D.UninterpretedOption.name uno) of+ [] -> iFail $ "Empty name_part"+ (part:parts) -> go Nothing optName part parts+ where+ iFail msg = do env <- ask+ throw $ unlines [ "interpretOption: Failed to handle UninterpretedOption for: "++show optName+ , " environment: "++whereEnv env+ , " value: "++show uno+ , " message: "++msg ]++ -- This takes care of an intermediate message or group type+ go mParent names (D.NamePart { D.NamePart.name_part = name+ , D.NamePart.is_extension = isKey }) (next:rest) = do+ -- get entity (Field or Key) and the TYPE_*+ (fk,entity) <-+ if not isKey+ then case mParent of+ Nothing -> iFail $ "Cannot resolve local (is_extension False) name, no parent; expected (key)."+ Just parent -> do+ entity'field <- resolveHere parent name+ case entity'field of+ E'Field {} -> case mVal entity'field of+ Nothing -> iFail $ "Intermediate entry E'Field is of basic type, not E'Message or E'Group: "++show (names,eName entity'field)+ Just val -> lift val >>= \e -> return (entity'field,e)+ _ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Field: "++show (eName entity'field)+ else do entity'key <- resolveRE name+ case entity'key of+ E'Key {} -> do extendee <- lift (eMsg entity'key)+ when (eName extendee /= names) $+ iFail $ "Intermediate entry E'Key extends wrong type: "++show (names,eName extendee)+ case mVal entity'key of+ Nothing-> iFail $ "Intermediate entry E'Key is of basic type, not E'Message or E'Group: "++show (names,eName entity'key)+ Just val -> lift val >>= \e -> return (entity'key,e)+ _ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Key: "++show (eName entity'key)+ t <- case entity of+ E'Message {} -> return TYPE_MESSAGE+ E'Group {} -> return TYPE_GROUP+ _ -> iFail $ "Intermediate entry is not an E'Message or E'Group: "++show (eName entity)+ -- recursive call to get inner result+ (fid',ExtFromWire wt' raw') <- go (Just entity) (eName entity) next rest+ -- wrap old tag + inner result with outer info+ let tag' = getWireTag (mkWireTag fid' wt')+ bs' = Seq.index raw' 0+ let fid = fNumber fk+ wt = toWireType (FieldType (fromEnum t))+ raw = Seq.singleton . runPut $+ case t of TYPE_MESSAGE -> do putSize (size'Varint tag' + LC.length bs')+ putVarUInt tag'+ putLazyByteString bs'+ TYPE_GROUP -> do putVarUInt tag'+ putLazyByteString bs'+ putVarUInt (succ (getWireTag (mkWireTag fid wt)))+ _ -> fail $ "bug! raw with type "++show t++" should be impossible"+ return (fid,ExtFromWire wt raw)++ -- This takes care of the acutal value of the option, which must be a basic type+ go mParent names (D.NamePart { D.NamePart.name_part = name+ , D.NamePart.is_extension = isKey }) [] = do+ -- get entity (Field or Key) and the TYPE_*+ fk <- if isKey then resolveRE name+ else case mParent of+ Just parent -> resolveHere parent name+ Nothing -> iFail $ "Cannot resolve local (is_extension False) name, no parent; expected (key)."+ case fk of+ E'Field {} | not isKey -> return ()+ E'Key {} | isKey -> do+ ext <- lift (eMsg fk)+ when (eName ext /= names) $ iFail $ "Last entry E'Key extends wrong type: "++show (names,eName ext)+ _ -> iFail $ "Last entity was resolved but was not an E'Field or E'Key: "++show fk+ t <- case (fType fk) of+ Nothing -> return TYPE_ENUM+ Just TYPE_GROUP -> iFail $ "Last entry was a TYPE_GROUP instead of concrete value type"+ Just TYPE_MESSAGE -> {- impossible -} iFail $ "Last entry was a TYPE_MESSAGE instead of concrete value type"+ Just typeCode -> return typeCode+ -- Need to define a polymorphic 'done' to convert actual data type to its wire encoding+ let done :: Wire v => v -> RE (FieldId,ExtFieldValue)+ done v = let ft = FieldType (fromEnum t)+ wt = toWireType ft+ fid = fNumber fk+ in return (fid,ExtFromWire wt (Seq.singleton (runPut (wirePut ft v))))+ -- The actual type and value fed to 'done' depends on the values 't' and 'uno':+ case t of+ TYPE_ENUM ->+ case (mVal fk,D.UninterpretedOption.identifier_value uno) of+ (Just (Right (E'Enum {eVals=enumVals})),Just enumVal) ->+ case validI enumVal of+ Nothing -> iFail $ "invalid D.UninterpretedOption.identifier_value: "++show enumVal+ Just enumIVal -> case M.lookup enumIVal enumVals of+ Nothing -> iFail $ "enumVal lookup failed: "++show (enumIVal,M.keys enumVals)+ Just val -> done (fromEnum val) -- fromEnum :: Int32 -> Int+ (Just (Right (E'Enum {})),Nothing) -> iFail $ "No identifer_value value to lookup in E'Enum"+ (me,_) -> iFail $ "Expected Just E'Enum, got: "++show me+ TYPE_STRING -> do+ bs <- getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno)+ maybe (done (Utf8 bs)) (\i -> iFail $ "Invalid utf8 in string_value at index: "++show i)+ (isValidUTF8 bs)+ TYPE_BYTES -> done =<< getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno)+ TYPE_BOOL -> done =<< bVal+ TYPE_DOUBLE -> done =<< dVal+ TYPE_FLOAT -> done =<< asFloat =<< dVal+ TYPE_INT64 -> done =<< (iVal :: RE Int64)+ TYPE_SFIXED64 -> done =<< (iVal :: RE Int64)+ TYPE_SINT64 -> done =<< (iVal :: RE Int64)+ TYPE_UINT64 -> done =<< (iVal :: RE Word64)+ TYPE_FIXED64 -> done =<< (iVal :: RE Word64)+ TYPE_INT32 -> done =<< (iVal :: RE Int32)+ TYPE_SFIXED32 -> done =<< (iVal :: RE Int32)+ TYPE_SINT32 -> done =<< (iVal :: RE Int32)+ TYPE_UINT32 -> done =<< (iVal :: RE Word32)+ TYPE_FIXED32 -> done =<< (iVal :: RE Word32)+ _ -> iFail $ "bug! go with type "++show t++" should be impossible"++ -- Machinery needed by the final call of go+ bVal :: RE Bool+ bVal = let true = Utf8 (U.fromString "true"); false = Utf8 (U.fromString "false")+ in case D.UninterpretedOption.identifier_value uno of+ Just s | s == true -> return True+ | s == false -> return False+ _ -> iFail "Expected 'true' or 'false' identifier_value"+ dVal :: RE Double+ dVal = case (D.UninterpretedOption.negative_int_value uno+ ,D.UninterpretedOption.positive_int_value uno+ ,D.UninterpretedOption.double_value uno) of+ (_,_,Just d) -> return d+ (_,Just p,_) -> return (fromIntegral p)+ (Just n,_,_) -> return (fromIntegral n)+ _ -> iFail "No numeric value"+ asFloat :: Double -> RE Float+ asFloat d = let fmax :: Ratio Integer+ fmax = (2-(1%2)^(23::Int)) * (2^(127::Int))+ d' = toRational d+ in if (negate fmax <= d') && (d' <= fmax)+ then return (fromRational d')+ else iFail $ "Double out of range for Float: "++show d+ rangeCheck :: forall a. (Bounded a,Integral a) => Integer -> RE a+ rangeCheck i = let r = (toInteger (minBound ::a),toInteger (maxBound :: a))+ in if inRange r i then return (fromInteger i) else iFail $ "Constant out of range: "++show (r,i)+ asInt :: Double -> RE Integer+ asInt x = let (a,b) = properFraction x+ in if b==0 then return a+ else iFail $ "Double value not an integer: "++show x+ iVal :: (Bounded y, Integral y) => RE y+ iVal = case (D.UninterpretedOption.negative_int_value uno+ ,D.UninterpretedOption.positive_int_value uno+ ,D.UninterpretedOption.double_value uno) of+ (_,Just p,_) -> rangeCheck (toInteger p)+ (Just n,_,_) -> rangeCheck (toInteger n)+ (_,_,Just d) -> rangeCheck =<< asInt d+ _ -> iFail "No numeric value"++-- | 'findFile' looks through the current and import directories to find the target file on the system.+-- It also converts the relative path to a standard form to use as the name of the FileDescriptorProto.+findFile :: [LocalFP] -> LocalFP -> IO (Maybe (LocalFP,CanonFP)) -- absolute and canonical parts+findFile paths (LocalFP target) = test paths where+ test [] = return Nothing+ test (LocalFP path:rest) = do+ let fullname = Local.combine path target+ found <- doesFileExist fullname -- stop at first hit+ if not found+ then test rest+ else do truepath <- canonicalizePath path+ truefile <- canonicalizePath fullname+ if truepath `isPrefixOf` truefile+ then do let rel = fpLocalToCanon (LocalFP (Local.makeRelative truepath truefile))+ return (Just (LocalFP truefile,rel))+ else fail $ "file found but it is not below path, cannot make canonical name:\n path: "+ ++show truepath++"\n file: "++show truefile++loadProto :: [LocalFP] -> LocalFP -> IO (Env,[D.FileDescriptorProto])+loadProto protoDirs protoFile = goState (load Set.empty protoFile) where+ goState act = do (env,m) <- runStateT act mempty+ let fromRight (Right x) = x+ fromRight (Left s) = error $ "loadProto failed to resolve a FileDescriptorProto: "++s+ return (env,map (fromRight . top'FDP . fst . getTLS) (M.elems m))+ loadFailed f msg = fail . unlines $ ["Parsing proto:",show (unLocalFP f),"has failed with message",msg]+ load :: Set.Set LocalFP -> LocalFP -> StateT (Map LocalFP Env) IO Env+ load parentsIn file = do+ built <- get+ when (Set.member file parentsIn)+ (loadFailed file (unlines ["imports failed: recursive loop detected"+ ,unlines . map show . M.assocs $ built,show parentsIn]))+ case M.lookup file built of+ Just result -> return result+ Nothing -> do+ mayToRead <- liftIO $ findFile protoDirs file+ case mayToRead of+ Nothing -> loadFailed file (unlines (["loading failed, could not find file: "++show (unLocalFP file)+ ,"Searched paths were:"] ++ map ((" "++).show.unLocalFP) protoDirs))+ Just (toRead,relpath) -> do+ protoContents <- liftIO $ do print ("Loading filepath: "++show (unLocalFP toRead))+ LC.readFile (unLocalFP toRead)+ parsed'fdp <- either (loadFailed toRead . show) return $+ (parseProto (unCanonFP relpath) protoContents)+ packageName <- either (loadFailed toRead . show) (return . map iToString . snd) $+ (checkDIUtf8 =<< getJust "makeTopLevel.packageName" (D.FileDescriptorProto.package parsed'fdp))+ let parents = Set.insert file parentsIn+ importList = map (fpCanonToLocal . CanonFP . toString) . F.toList . D.FileDescriptorProto.dependency $ parsed'fdp+ imports <- mapM (fmap getTL . load parents) importList+ let eEnv = makeTopLevel parsed'fdp packageName imports+ global'env <- either (loadFailed file) return eEnv+ either (loadFailed file) return (top'FDP . getTL $ global'env)+ modify (M.insert file global'env) -- add to memorized results+ return global'env
dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs view
@@ -155,7 +155,7 @@ alex_deflt :: AlexAddr alex_deflt = AlexA# "\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x07\x00\x07\x00\x09\x00\x09\x00\x0d\x00\x0e\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\xff\xff\xff\xff\x2b\x00\x37\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x2b\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# -alex_accept = listArray (0::Int,74) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[],[(AlexAcc (alex_action_13))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_13))],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_4) (alexRightContext 29)),(AlexAcc (alex_action_8))],[],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[],[],[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_13))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_13))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_13))],[],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))]]+alex_accept = listArray (0::Int,74) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[],[(AlexAcc (alex_action_13))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_2) (alexRightContext 20)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_13))],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[(AlexAccPred (alex_action_3) (alexRightContext 25)),(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_7))],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_4) (alexRightContext 29)),(AlexAcc (alex_action_8))],[],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[(AlexAccPred (alex_action_5) (alexRightContext 37)),(AlexAcc (alex_action_9))],[],[],[],[],[(AlexAccSkip)],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_13))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_13))],[],[],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))]] {-# LINE 54 "Text/ProtocolBuffers/ProtoCompile/Lexer.x" #-} line :: AlexPosn -> Int@@ -165,7 +165,7 @@ data Lexed = L_Integer !Int !Integer | L_Double !Int !Double | L_Name !Int !L.ByteString- | L_String !Int !L.ByteString+ | L_String !Int !L.ByteString !L.ByteString | L !Int !Char | L_Error !Int !String deriving (Show,Eq)@@ -175,7 +175,7 @@ L_Integer i _ -> i L_Double i _ -> i L_Name i _ -> i- L_String i _ -> i+ L_String i _ _ -> i L i _ -> i L_Error i _ -> i @@ -200,10 +200,10 @@ parseDouble pos s = maybe (errAt pos "Impossible? parseDouble failed") (L_Double (line pos)) $ mayRead (readSigned readFloat) (ByteString.unpack s) -- The sDecode of the string contents may fail-parseStr pos s = either (errAt pos) (L_String (line pos) . L.pack) - . sDecode . ByteString.unpack- . ByteString.init . ByteString.tail- $ s+parseStr pos s = let middle = ByteString.init . ByteString.tail $ s+ in either (errAt pos) (L_String (line pos) middle . L.pack)+ . sDecode . ByteString.unpack $ middle+ parseName pos s = L_Name (line pos) s parseChar pos s = L (line pos) (ByteString.head s)
hprotoc.cabal view
@@ -1,6 +1,6 @@ name: hprotoc -- Synchronize this version number with Text.ProtocolBuffers.ProtocolCompile.version-version: 0.3.1+version: 1.0.0 cabal-version: >= 1.2 build-type: Simple license: BSD3@@ -24,8 +24,8 @@ Executable hprotoc Main-Is: Text/ProtocolBuffers/ProtoCompile.hs build-tools: alex- ghc-options: -O2 -Wall- build-depends: protocol-buffers == 0.3.1, protocol-buffers-descriptor == 0.3.1+ ghc-options: -Wall+ build-depends: protocol-buffers == 0.4.4, protocol-buffers-descriptor == 0.4.4 build-depends: binary, utf8-string build-depends: parsec, haskell-src if flag(small_base)@@ -47,14 +47,16 @@ Text.ProtocolBuffers.ProtoCompile.Resolve extensions: DeriveDataTypeable, EmptyDataDecls,+ FlexibleContexts FlexibleInstances,+ FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, MagicHash,+ MultiParamTypeClasses, PatternGuards, RankNTypes,+ RecursiveDo, ScopedTypeVariables,- TypeSynonymInstances,- MultiParamTypeClasses,- FunctionalDependencies-+ TypeSynonymInstances+-- PatternSignatures