diff --git a/Text/ProtocolBuffers/ProtoCompile.hs b/Text/ProtocolBuffers/ProtoCompile.hs --- a/Text/ProtocolBuffers/ProtoCompile.hs +++ b/Text/ProtocolBuffers/ProtoCompile.hs @@ -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))) - diff --git a/Text/ProtocolBuffers/ProtoCompile/Gen.hs b/Text/ProtocolBuffers/ProtoCompile/Gen.hs --- a/Text/ProtocolBuffers/ProtoCompile/Gen.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Gen.hs @@ -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"] --} diff --git a/Text/ProtocolBuffers/ProtoCompile/Instances.hs b/Text/ProtocolBuffers/ProtoCompile/Instances.hs --- a/Text/ProtocolBuffers/ProtoCompile/Instances.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Instances.hs @@ -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 (>>) diff --git a/Text/ProtocolBuffers/ProtoCompile/Lexer.x b/Text/ProtocolBuffers/ProtoCompile/Lexer.x --- a/Text/ProtocolBuffers/ProtoCompile/Lexer.x +++ b/Text/ProtocolBuffers/ProtoCompile/Lexer.x @@ -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) diff --git a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs --- a/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +++ b/Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs @@ -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 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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Parser.hs b/Text/ProtocolBuffers/ProtoCompile/Parser.hs --- a/Text/ProtocolBuffers/ProtoCompile/Parser.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Parser.hs @@ -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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs --- a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs @@ -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 [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 "" 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 "" toString mp - , " The field name is "++maybe "" 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 "" 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 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 <> 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 diff --git a/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs b/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs --- a/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs +++ b/dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs @@ -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) diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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