hprotoc (empty) → 0.3.1
raw patch · 11 files changed
+2794/−0 lines, 11 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, binary, bytestring, containers, directory, filepath, haskell-src, mtl, parsec, protocol-buffers, protocol-buffers-descriptor, utf8-string
Files
- LICENSE +10/−0
- Setup.hs +2/−0
- Text/ProtocolBuffers/ProtoCompile.hs +136/−0
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +721/−0
- Text/ProtocolBuffers/ProtoCompile/Instances.hs +79/−0
- Text/ProtocolBuffers/ProtoCompile/Lexer.x +187/−0
- Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs +285/−0
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +461/−0
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +354/−0
- dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs +499/−0
- hprotoc.cabal +60/−0
+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2008, Christopher Edward Kuklewicz+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+ * Neither the name of the copyright holder nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ Text/ProtocolBuffers/ProtoCompile.hs view
@@ -0,0 +1,136 @@+-- | This is the Main module for the command line program+module Main where++import qualified Data.Map as M+import Data.Version+import Language.Haskell.Pretty(prettyPrintStyleMode,Style(..),Mode(..),PPHsMode(..),PPLayout(..))+import System.Console.GetOpt+import System.Environment+import System.Directory+import System.FilePath++import Text.ProtocolBuffers.Reflections(ProtoInfo(..),DescriptorInfo(..),EnumInfo(..))++import Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModule,enumModule)+import Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto)+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]+ , versionTags = [] }++data Options = Options { optPrefix :: String+ , optTarget :: FilePath+ , optInclude :: [FilePath]+ , optProto :: FilePath+ , optVerbose :: Bool+ , optUnknownFields :: 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 }+setVerbose o = o { optVerbose = True }+setUnknown o = o { optUnknownFields = True }++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")+ "directory from which to search for imported proto files (default is pwd); all DIR searched"+ , Option ['o'] ["haskell_out"] (ReqArg (Mutate . setTarget) "DIR")+ "directory to use are root of generated files (default is pwd); last flag"+ , 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))+ "generated messages and groups all support unknown fields"+ , Option ['v'] ["verbose"] (NoArg (Mutate setVerbose))+ "increase amount of printed information"+ , Option [] ["version"] (NoArg (Switch VersionInfo))+ "print out version information"+ ]++usageMsg,versionInfo :: String+usageMsg = usageInfo "Usage: protoCompile [OPTION..] path-to-file.proto ..." optionList++versionInfo = unlines $+ [ "Welcome to protocol-buffers version "++showVersion version+ , "Copyright (c) 2008, Christopher Kuklewicz."+ , "Released under BSD3 style license, see LICENSE file for details."+ , "Some proto files, such as descriptor.proto and unittest*.proto"+ , "are from google's code and are under an Apache 2.0 license."+ , ""+ , "This program reads a .proto file and generates haskell code files."+ , "See http://code.google.com/apis/protocolbuffers/docs/overview.html for more."+ ]++processOptions :: [String] -> Either String [OptionAction]+processOptions argv =+ case getOpt (ReturnInOrder (Run . setProto)) optionList argv of+ (opts,_,[]) -> Right opts+ (_,_,errs) -> Left (unlines errs ++ usageMsg)++defaultOptions :: IO Options+defaultOptions = do+ pwd <- getCurrentDirectory+ return $ Options { optPrefix = "", optTarget = pwd, optInclude = [pwd], optProto = "", optVerbose = False, optUnknownFields = False }++main :: IO ()+main = do+ defs <- defaultOptions+ args <- getArgs+ case processOptions args of+ Left msg -> putStrLn msg+ Right todo -> process defs todo++process :: Options -> [OptionAction] -> IO ()+process options [] = if null (optProto options)+ then do putStrLn "No proto file specified (or empty proto file)"+ putStrLn ""+ putStrLn usageMsg+ else putStrLn "Processing complete, have a nice day."+process options (Mutate f:rest) = process (f options) rest+process options (Run f:rest) = let options' = f options+ in run options' >> process options' rest+process _options (Switch VersionInfo:_) = putStrLn versionInfo+ +mkdirFor :: FilePath -> IO ()+mkdirFor p = createDirectoryIfMissing True (takeDirectory p)++style :: Style+style = Style PageMode 132 0.5++myMode :: PPHsMode+myMode = PPHsMode 2 2 2 2 4 2 True PPOffsideRule False True++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+ let produceMSG di = do+ let file = combine (optTarget options) . joinPath . descFilePath $ di+ print file+ mkdirFor file+ writeFile file (prettyPrintStyleMode style myMode (descriptorModule di))+ produceENM ei = do+ let file = combine (optTarget options) . joinPath . enumFilePath $ ei+ print file+ 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+ print file+ writeFile file (prettyPrintStyleMode style myMode (protoModule protoInfo (serializeFDP fdp)))+
+ Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -0,0 +1,721 @@+-- try "test", "testDesc", and "testLabel" to see sample output+-- +-- Obsolete : Turn *Proto into Language.Haskell.Exts.Syntax from haskell-src-exts package+-- Now cut back to use just Language.Haskell.Syntax, see coments marked YYY for the Exts verision+-- +-- Note that this may eventually also generate hs-boot files to allow+-- for breaking mutual recursion. This is ignored for getting+-- descriptor.proto running.+--+-- Mangling: For the current moment, assume the mangling is done in a prior pass:+-- (*) Uppercase all module names and type names and enum constants+-- (*) lowercase all field names+-- (*) add a prime after all field names than conflict with reserved words+--+-- The names are also assumed to have become fully-qualified, and all+-- the optional type codes have been set.+--+-- default values are an awful mess. They are documented in descriptor.proto as+{-+ // For numeric types, contains the original text representation of the value.+ // For booleans, "true" or "false".+ // For strings, contains the default text contents (not escaped in any way).+ // For bytes, contains the C escaped value. All bytes >= 128 are escaped.+ // TODO(kenton): Base-64 encode?+ optional string default_value = 7;+-}+module Text.ProtocolBuffers.ProtoCompile.Gen(protoModule,descriptorModule,enumModule,prettyPrint) where++import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Reflections(KeyInfo,HsDefault(..),DescriptorInfo(..),ProtoInfo(..),EnumInfo(..),ProtoName(..),FieldInfo(..))++import qualified Data.ByteString.Lazy.Char8 as LC(unpack)+import Data.Char(isUpper)+import qualified Data.Foldable as F(foldr,toList)+import Data.List(sort,sortBy,group,foldl',foldl1')+import Data.Function(on)+import Language.Haskell.Pretty(prettyPrint)+import Language.Haskell.Syntax+import qualified Data.Map as M+import qualified Data.Sequence as Seq(null,length)+import qualified Data.Set as S++--import Debug.Trace(trace)++default (Int)++-- -- -- -- Helper functions++noWhere :: [HsDecl]+noWhere = [] -- YYY noWhere = (HsBDecls [])++($$) :: HsExp -> HsExp -> HsExp+($$) = HsApp++infixl 1 $$++dotPre :: String -> String -> String+dotPre "" x = x -- after this the value of s cannot be []+dotPre s "" = s+dotPre s x@('.':xs) | '.' == last s = s ++ xs -- s cannnot be [], so last is safe+ | otherwise = s ++ x+dotPre s x | '.' == last s = s++x -- s cannnot be [], so last is safe+ | otherwise = s++('.':x)++src :: SrcLoc+src = SrcLoc "No SrcLoc" 0 0++litIntP :: Integral x => x -> HsPat+litIntP x | x<0 = HsPParen $ HsPLit (HsInt (toInteger x))+ | otherwise = HsPLit (HsInt (toInteger x))++litInt :: Integral x => x -> HsExp+litInt x | x<0 = HsParen $ HsLit (HsInt (toInteger x))+ | otherwise = HsLit (HsInt (toInteger x))++typeApp :: String -> HsType -> HsType+typeApp s = HsTyApp (HsTyCon (private s))++pvar :: String -> HsExp+pvar t = HsVar (private t)++lvar :: String -> HsExp+lvar t = HsVar (UnQual (HsIdent t))++private :: String -> HsQName+private t = Qual (Module "P'") (HsIdent t)++inst :: String -> [HsPat] -> HsExp -> HsDecl+inst s p r = HsFunBind [HsMatch src (HsIdent s) p (HsUnGuardedRhs r) noWhere]++fqName :: ProtoName -> String+fqName (ProtoName a b c) = dotPre a (dotPre b c)++qualName :: ProtoName -> HsQName+qualName (ProtoName _prefix "" base) = UnQual (HsIdent base)+qualName (ProtoName _prefix parent base) = Qual (Module parent) (HsIdent base)++unqualName :: ProtoName -> HsQName+unqualName (ProtoName _prefix _parent base) = UnQual (HsIdent base)++mayQualName :: ProtoName -> ProtoName -> HsQName+mayQualName context name@(ProtoName prefix modname base) =+ if fqName context == dotPre prefix modname then UnQual (HsIdent base)+ else qualName name++--------------------------------------------+-- EnumDescriptorProto module creation+--------------------------------------------+{-+enumModule :: String -> D.EnumDescriptorProto -> HsModule+enumModule prefix e+ = let ei = makeEnumInfo prefix e+-}+enumModule :: EnumInfo -> HsModule+enumModule ei+ = let protoName = enumName ei+ in HsModule src (Module (fqName protoName))+ (Just [HsEThingAll (UnQual (HsIdent (baseName protoName)))])+ (standardImports False) (enumDecls ei)++enumDecls :: EnumInfo -> [HsDecl]+enumDecls ei = map ($ ei) [ enumX+ , instanceMergeableEnum+ , instanceBounded+ , instanceDefaultEnum+ , instanceEnum+ , instanceWireEnum+ , instanceGPB . enumName+ , instanceMessageAPI . enumName+ , instanceReflectEnum+ ]++enumX :: EnumInfo -> HsDecl+enumX ei = HsDataDecl src [] (HsIdent (baseName (enumName ei))) [] (map enumValueX (enumValues ei)) derivesEnum+ where enumValueX (_,name) = HsConDecl src (HsIdent name) []++instanceMergeableEnum :: EnumInfo -> HsDecl+instanceMergeableEnum ei + = HsInstDecl src [] (private "Mergeable") [HsTyCon (unqualName (enumName ei))] []++instanceBounded :: EnumInfo -> HsDecl+instanceBounded ei+ = HsInstDecl src [] (private "Bounded") [HsTyCon (unqualName (enumName ei))] + [set "minBound" (head values),set "maxBound" (last values)] -- values cannot be null in a well formed enum+ where values = enumValues ei+ set f (_,n) = inst f [] (HsCon (UnQual (HsIdent n)))++{- from google's descriptor.h, about line 346:++ // Get the field default value if cpp_type() == CPPTYPE_ENUM. If no+ // explicit default was defined, the default is the first value defined+ // in the enum type (all enum types are required to have at least one value).+ // This never returns NULL.++-}+instanceDefaultEnum :: EnumInfo -> HsDecl+instanceDefaultEnum ei+ = HsInstDecl src [] (private "Default") [HsTyCon (unqualName (enumName ei))]+ [ inst "defaultValue" [] firstValue ]+ where firstValue :: HsExp+ firstValue = case enumValues ei of+ (:) (_,n) _ -> HsCon (UnQual (HsIdent n))+ [] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei++instanceEnum :: EnumInfo -> HsDecl+instanceEnum ei+ = HsInstDecl src [] (private "Enum") [HsTyCon (unqualName (enumName ei))]+ (map HsFunBind [fromEnum',toEnum',succ',pred'])+ where values = enumValues ei+ fromEnum' = map fromEnum'one values+ fromEnum'one (v,n) = HsMatch src (HsIdent "fromEnum") [HsPApp (UnQual (HsIdent n)) []]+ (HsUnGuardedRhs (litInt (getEnumCode v))) noWhere+ toEnum' = map toEnum'one values+ toEnum'one (v,n) = HsMatch src (HsIdent "toEnum") [litIntP (getEnumCode v)] -- enums cannot be negative so no parenthesis are required to protect a negative sign+ (HsUnGuardedRhs (HsCon (UnQual (HsIdent n)))) noWhere+ succ' = zipWith (equate "succ") values (tail values)+ pred' = zipWith (equate "pred") (tail values) values+ equate f (_,n1) (_,n2) = HsMatch src (HsIdent f) [HsPApp (UnQual (HsIdent n1)) []]+ (HsUnGuardedRhs (HsCon (UnQual (HsIdent n2)))) noWhere++-- fromEnum TYPE_ENUM == 14 :: Int+instanceWireEnum :: EnumInfo -> HsDecl+instanceWireEnum ei+ = HsInstDecl src [] (private "Wire") [HsTyCon (unqualName (enumName ei))]+ [ withName "wireSize", withName "wirePut", withGet, withGetErr ]+ where withName foo = inst foo [HsPVar (HsIdent "ft'"),HsPVar (HsIdent "enum")] rhs+ where rhs = pvar foo $$ lvar "ft'" $$+ (HsParen $ pvar "fromEnum" $$ lvar "enum")+ withGet = inst "wireGet" [litIntP 14] rhs+ where rhs = pvar "fmap" $$ pvar "toEnum" $$+ (HsParen $ pvar "wireGet" $$ HsLit (HsInt 14))+ withGetErr = inst "wireGet" [HsPVar (HsIdent "ft'")] rhs+ where rhs = pvar "wireGetErr" $$ lvar "ft'"++instanceGPB :: ProtoName -> HsDecl+instanceGPB protoName+ = HsInstDecl src [] (private "GPB") [HsTyCon (unqualName protoName)] []++instanceReflectEnum :: EnumInfo -> HsDecl+instanceReflectEnum ei+ = HsInstDecl src [] (private "ReflectEnum") [HsTyCon (unqualName (enumName ei))]+ [ inst "reflectEnum" [] ascList+ , inst "reflectEnumInfo" [ HsPWildCard ] ei' ]+ where (ProtoName a b c) = enumName ei+ values = enumValues ei+ ascList,ei',protoNameExp :: HsExp+ ascList = HsList (map one values)+ where one (v,ns) = HsTuple [litInt (getEnumCode v),HsLit (HsString ns),HsCon (UnQual (HsIdent ns))]+ ei' = foldl' HsApp (HsCon (private "EnumInfo")) [protoNameExp+ ,HsList $ map (HsLit . HsString) (enumFilePath ei)+ ,HsList (map two values)]+ where two (v,ns) = HsTuple [litInt (getEnumCode v),HsLit (HsString ns)]+ protoNameExp = HsParen $ foldl' HsApp (HsCon (private "ProtoName")) . map (HsLit . HsString) $ [a,b,c]++--------------------------------------------+-- DescriptorProto module creation is unfinished+-- There are difficult namespace issues+--------------------------------------------++hasExt :: DescriptorInfo -> Bool+hasExt di = not (null (extRanges di))++protoModule :: ProtoInfo -> ByteString -> HsModule+protoModule pri@(ProtoInfo protoName _ _ keyInfos _ _ _) fdpBS+ = let exportKeys = map (HsEVar . UnQual . HsIdent . baseName . fieldName . snd) (F.toList keyInfos)+ exportNames = map (HsEVar . UnQual . HsIdent) ["protoInfo","fileDescriptorProto"]+ imports = protoImports ++ map formatImport (protoImport pri)+ in HsModule src (Module (fqName protoName)) (Just (exportKeys++exportNames)) imports (keysX protoName keyInfos ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)+ where protoImports = standardImports (not . Seq.null . extensionKeys $ pri) +++ [ HsImportDecl src (Module "Text.DescriptorProtos.FileDescriptorProto") False Nothing+ (Just (False,[HsIAbs (HsIdent "FileDescriptorProto")]))+ , HsImportDecl src (Module "Text.ProtocolBuffers.Reflections") False Nothing+ (Just (False,[HsIAbs (HsIdent "ProtoInfo")]))+ , HsImportDecl src (Module "Text.ProtocolBuffers.WireMessage") True (Just (Module "P'"))+ (Just (False,[HsIVar (HsIdent "wireGet,getFromBS")]))+ ]+ formatImport (m,t) = HsImportDecl src (Module (dotPre (haskellPrefix protoName) (dotPre m t))) True+ (Just (Module m)) (Just (False,[HsIAbs (HsIdent t)]))++protoImport :: ProtoInfo -> [(String,String)]+protoImport (ProtoInfo protoName _ _ keyInfos _ _ _)+ = map head . group . sort + . filter (selfName /=)+ . concatMap withMod+ $ allNames+ where selfName = (parentModule protoName, baseName protoName)+ withMod (ProtoName _prefix "" _base) = []+ withMod (ProtoName _prefix modname base) = [(modname,base)]+ allNames = F.foldr (\(e,fi) rest -> e : addName fi rest) [] keyInfos+ addName fi rest = maybe rest (:rest) (typeName fi)++embed'ProtoInfo :: ProtoInfo -> [HsDecl]+embed'ProtoInfo pri = [ myType, myValue ]+ where myType = HsTypeSig src [ HsIdent "protoInfo" ] (HsQualType [] (HsTyCon (UnQual (HsIdent "ProtoInfo"))))+ myValue = HsPatBind src (HsPApp (UnQual (HsIdent "protoInfo")) []) (HsUnGuardedRhs $+ pvar "read" $$ HsLit (HsString (show pri))) noWhere++embed'fdpBS :: ByteString -> [HsDecl]+embed'fdpBS bs = [ myType, myValue ]+ where myType = HsTypeSig src [ HsIdent "fileDescriptorProto" ] (HsQualType [] (HsTyCon (UnQual (HsIdent "FileDescriptorProto"))))+ myValue = HsPatBind src (HsPApp (UnQual (HsIdent "fileDescriptorProto")) []) (HsUnGuardedRhs $+ pvar "getFromBS" $$+ HsParen (pvar "wireGet" $$ litInt 11) $$ + HsParen (pvar "pack" $$ HsLit (HsString (LC.unpack bs)))) noWhere++descriptorModule :: DescriptorInfo -> HsModule+descriptorModule di+ = let protoName = descName di+ un = UnQual . HsIdent . baseName $ protoName+ imports = standardImports (hasExt di) ++ map formatImport (toImport di)+ exportKeys = map (HsEVar . UnQual . HsIdent . baseName . fieldName . snd) (F.toList (keys di))+ formatImport ((a,b),s) = HsImportDecl src (Module a) True (Just (Module b)) (Just (False,+ map (HsIAbs . HsIdent) (S.toList s)))+ in HsModule src (Module (fqName protoName))+ (Just (HsEThingAll un : exportKeys))+ imports (descriptorX di : (keysX protoName (keys di) ++ instancesDescriptor di))++standardImports :: Bool -> [HsImportDecl]+standardImports ext =+ [ HsImportDecl src (Module "Prelude") False Nothing (Just (False,ops))+ , HsImportDecl src (Module "Prelude") True (Just (Module "P'")) Nothing+ , HsImportDecl src (Module "Text.ProtocolBuffers.Header") True (Just (Module "P'")) Nothing ]+ where ops | ext = map (HsIVar . HsSymbol) ["+","<=","&&"," || "]+ | otherwise = map (HsIVar . HsSymbol) ["+"]++toImport :: DescriptorInfo -> [((String,String),S.Set String)]+toImport di+ = M.assocs . M.fromListWith S.union . filter isForeign . map withMod $ allNames+ where isForeign = let here = fqName protoName+ in (\((a,_),_) -> a/=here)+ protoName = descName di+ withMod p@(ProtoName prefix modname base) | isUpper (head base) = ((fqName p,modname),S.singleton base)+ | otherwise = ((dotPre prefix modname,modname),S.singleton base)+ allNames = F.foldr addName keyNames (fields di)+ keyNames = F.foldr (\(e,fi) rest -> e : addName fi rest) keysKnown (keys di)+ keysKnown = F.foldr (\fi rest -> fieldName fi : rest) [] (knownKeys di)+-- keysKnown = F.foldr (\fi rest -> addName fi (fieldName fi : rest)) [] (knownKeys di)+ addName fi rest = maybe rest (:rest) (typeName fi)++keysX :: ProtoName -> Seq KeyInfo -> [HsDecl]+keysX self i = concatMap (makeKey self) . F.toList $ i++makeKey :: ProtoName -> KeyInfo -> [HsDecl]+makeKey self (extendee,f) = [ keyType, keyVal ]+ where keyType = HsTypeSig src [ HsIdent (baseName . fieldName $ f) ] (HsQualType [] (foldl1 HsTyApp . map HsTyCon $+ [ private "Key", private labeled+ , if extendee /= self then qualName extendee else unqualName extendee+ , typeQName ]))+ labeled | canRepeat f = "Seq"+ | otherwise = "Maybe"+ typeNumber = getFieldType . typeCode $ f+ typeQName :: HsQName+ typeQName = case useType typeNumber of+ Just s -> private s+ Nothing -> case typeName f of+ Just s | self /= s -> qualName s+ | otherwise -> unqualName s+ Nothing -> error $ "No Name for Field!\n" ++ show f+ keyVal = HsPatBind src (HsPApp (UnQual (HsIdent (baseName (fieldName f)))) []) (HsUnGuardedRhs+ (pvar "Key" $$ litInt (getFieldId (fieldNumber f))+ $$ litInt typeNumber+ $$ maybe (pvar "Nothing") (HsParen . (pvar "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f)+ )) noWhere++defToSyntax :: FieldType -> HsDefault -> HsExp+defToSyntax tc x =+ case x of+ HsDef'Bool b -> HsCon (private (show b))+ HsDef'ByteString bs -> (if tc == 9 then (\xx -> HsParen (pvar "Utf8" $$ xx)) else id) $+ (HsParen $ pvar "pack" $$ HsLit (HsString (LC.unpack bs)))+ HsDef'Rational r | r < 0 -> HsParen $ HsLit (HsFrac r)+ | otherwise -> HsLit (HsFrac r)+ HsDef'Integer i | i < 0 -> HsParen $ HsLit (HsInt i)+ | otherwise -> HsLit (HsInt i)+ HsDef'Enum s -> HsParen $ pvar "read" $$ HsLit (HsString s)++descriptorX :: DescriptorInfo -> HsDecl+descriptorX di = HsDataDecl src [] name [] [con] derives+ where self = descName di+ name = HsIdent (baseName self)+ con = HsRecDecl src name eFields+ where eFields = F.foldr ((:) . fieldX) end (fields di)+ end = (if hasExt di then (extfield:) else id) + $ (if storeUnknown di then [unknownField] else [])+ extfield :: ([HsName],HsBangType)+ extfield = ([HsIdent "ext'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "ExtField"))))+ unknownField :: ([HsName],HsBangType)+ unknownField = ([HsIdent "unknown'field"],HsUnBangedTy (HsTyCon (Qual (Module "P'") (HsIdent "UnknownField"))))+ fieldX :: FieldInfo -> ([HsName],HsBangType)+ fieldX fi = ([HsIdent (baseName $ fieldName fi)],HsUnBangedTy (labeled (HsTyCon typed)))+ where labeled | canRepeat fi = typeApp "Seq"+ | isRequired fi = id+ | otherwise = typeApp "Maybe"+ typed :: HsQName+ typed = case useType (getFieldType (typeCode fi)) of+ Just s -> private s+ Nothing -> case typeName fi of+ Just s | self /= s -> qualName s+ | otherwise -> unqualName s+ Nothing -> error $ "No Name for Field!\n" ++ show fi++instancesDescriptor :: DescriptorInfo -> [HsDecl]+instancesDescriptor di = map ($ di) $+ (if hasExt di then (instanceExtendMessage:) else id) $+ (if storeUnknown di then (instanceUnknownMessage:) else id) $+ [ instanceMergeable+ , instanceDefault+ , instanceWireDescriptor+ , instanceMessageAPI . descName+ , instanceGPB . descName + , instanceReflectDescriptor+ ]++instanceExtendMessage :: DescriptorInfo -> HsDecl+instanceExtendMessage di+ = HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ [ inst "getExtField" [] (lvar "ext'field")+ , inst "putExtField" [HsPVar (HsIdent "e'f"),HsPVar (HsIdent "msg")] putextfield+ , inst "validExtRanges" [ HsPVar (HsIdent "msg") ] (pvar "extRanges" $$ (HsParen $ pvar "reflectDescriptorInfo" $$ lvar "msg"))+ ]+ where putextfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "ext'field")) (lvar "e'f") ]++instanceUnknownMessage :: DescriptorInfo -> HsDecl+instanceUnknownMessage di+ = HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ [ inst "getUnknownField" [] (lvar "unknown'field")+ , inst "putUnknownField" [HsPVar (HsIdent "u'f"),HsPVar (HsIdent "msg")] putunknownfield+ ]+ where putunknownfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "unknown'field")) (lvar "u'f") ]++instanceMergeable :: DescriptorInfo -> HsDecl+instanceMergeable di+ = HsInstDecl src [] (private "Mergeable") [HsTyCon un]+ [ inst "mergeEmpty" [] (foldl' HsApp (HsCon un) (replicate len (HsCon (private "mergeEmpty"))))+ , inst "mergeAppend" [HsPApp un patternVars1, HsPApp un patternVars2]+ (foldl' HsApp (HsCon un) (zipWith append vars1 vars2))+ ]+ where un = UnQual (HsIdent (baseName (descName di)))+ len = (if hasExt di then succ else id)+ $ (if storeUnknown di then succ else id)+ $ Seq.length (fields di)+ patternVars1,patternVars2 :: [HsPat]+ patternVars1 = take len inf+ where inf = map (\n -> HsPVar (HsIdent ("x'" ++ show n))) [1..]+ patternVars2 = take len inf+ where inf = map (\n -> HsPVar (HsIdent ("y'" ++ show n))) [1..]+ vars1,vars2 :: [HsExp]+ vars1 = take len inf+ where inf = map (\n -> lvar ("x'" ++ show n)) [1..]+ vars2 = take len inf+ where inf = map (\n -> lvar ("y'" ++ show n)) [1..]+ append x y = HsParen $ pvar "mergeAppend" $$ x $$ y++instanceDefault :: DescriptorInfo -> HsDecl+instanceDefault di+ = HsInstDecl src [] (private "Default") [HsTyCon un]+ [ inst "defaultValue" [] (foldl' HsApp (HsCon un) deflistExt) ]+ where un = UnQual (HsIdent (baseName (descName di)))+ deflistExt = F.foldr ((:) . defX) end (fields di)+ end = (if hasExt di then (pvar "defaultValue":) else id) + $ (if storeUnknown di then [pvar "defaultValue"] else [])++ defX :: FieldInfo -> HsExp+ defX fi | isRequired fi = dv1+ | otherwise = dv2+ where dv1 = case hsDefault fi of+ Nothing -> pvar "defaultValue"+ Just hsdef -> defToSyntax (typeCode fi) hsdef+ dv2 = case hsDefault fi of+ Nothing -> pvar "defaultValue"+ Just hsdef -> HsParen $ HsCon (private "Just") $$ defToSyntax (typeCode fi) hsdef++instanceMessageAPI :: ProtoName -> HsDecl+instanceMessageAPI protoName+ = HsInstDecl src [] (private "MessageAPI") [HsTyVar (HsIdent "msg'"), HsTyFun (HsTyVar (HsIdent "msg'")) (HsTyCon un), (HsTyCon un)]+ [ inst "getVal" [HsPVar (HsIdent "m'"),HsPVar (HsIdent "f'")] (HsApp (lvar "f'" ) (lvar "m'")) ]+ where un = UnQual (HsIdent (baseName protoName))++mkOp :: String -> HsExp -> HsExp -> HsExp+mkOp s a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol s))) b++instanceWireDescriptor :: DescriptorInfo -> HsDecl+instanceWireDescriptor di@(DescriptorInfo { descName = protoName+ , fields = fieldInfos+ , extRanges = allowedExts+ , knownKeys = fieldExts })+ = let me = unqualName protoName+ extensible = not (null allowedExts)+ len = (if extensible then succ else id) + $ (if storeUnknown di then succ else id)+ $ Seq.length fieldInfos+ mine = HsPApp me . take len . map (\n -> HsPVar (HsIdent ("x'" ++ show n))) $ [1..]+ vars = take len . map (\n -> lvar ("x'" ++ show n)) $ [1..]+ mExt | extensible = Just (vars !! Seq.length fieldInfos)+ | otherwise = Nothing+ mUnknown | storeUnknown di = Just (last vars)+ | otherwise = Nothing++ -- first case is for Group behavior, second case is for Message behavior, last is error handler+ cases g m e = HsCase (lvar "ft'") [ HsAlt src (litIntP 10) (HsUnGuardedAlt g) noWhere+ , HsAlt src (litIntP 11) (HsUnGuardedAlt m) noWhere+ , HsAlt src HsPWildCard (HsUnGuardedAlt e) noWhere+ ]++ sizeCases = HsUnGuardedRhs $ cases (lvar "calc'Size") + (pvar "prependMessageSize" $$ lvar "calc'Size")+ (pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")+ whereCalcSize = [HsFunBind [HsMatch src (HsIdent "calc'Size") [] (HsUnGuardedRhs sizes) noWhere]]+ sizes | null sizesList = HsLit (HsInt 0)+ | otherwise = HsParen (foldl1' (+!) sizesList)+ where (+!) = mkOp "+"+ sizesList | Just v <- mUnknown = sizesListExt ++ [ pvar "wireSizeUnknownField" $$ v ]+ | otherwise = sizesListExt+ sizesListExt | Just v <- mExt = sizesListFields ++ [ pvar "wireSizeExtField" $$ v ] + | otherwise = sizesListFields+ sizesListFields = zipWith toSize vars . F.toList $ fieldInfos+ toSize var fi = let f = if isRequired fi then "wireSizeReq"+ else if canRepeat fi then "wireSizeRep"+ else "wireSizeOpt"+ in foldl' HsApp (pvar f) [ litInt (wireTagLength fi)+ , litInt (getFieldType (typeCode fi))+ , var]++ putCases = HsUnGuardedRhs $ cases+ (lvar "put'Fields")+ (HsDo [ HsQualifier $ pvar "putSize" $$+ (HsParen $ foldl' HsApp (pvar "wireSize") [ litInt 10 , lvar "self'" ])+ , HsQualifier $ lvar "put'Fields" ])+ (pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")+ wherePutFields = [HsFunBind [HsMatch src (HsIdent "put'Fields") [] (HsUnGuardedRhs (HsDo putStmts)) noWhere]]+ putStmts = putStmtsContent+ where putStmtsContent | null putStmtsAll = [HsQualifier $ pvar "return" $$ HsCon (Special HsUnitCon)]+ | otherwise = putStmtsAll+ putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ HsQualifier $ pvar "wirePutUnknownField" $$ v ]+ | otherwise = putStmtsListExt+ putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ HsQualifier $ pvar "wirePutExtField" $$ v ]+ | otherwise = sortedPutStmtsList+ sortedPutStmtsList = map snd -- remove number+ . sortBy (compare `on` fst) -- sort by number+ . zip (map fieldNumber . F.toList $ fieldInfos) -- add number as fst+ $ putStmtsList+ putStmtsList = zipWith toPut vars . F.toList $ fieldInfos+ toPut var fi = let f = if isRequired fi then "wirePutReq"+ else if canRepeat fi then "wirePutRep"+ else "wirePutOpt"+ in HsQualifier $+ foldl' HsApp (pvar f) [ litInt (getWireTag (wireTag fi))+ , litInt (getFieldType (typeCode fi))+ , var]++ getCases = HsUnGuardedRhs $ cases+ (pvar "getBareMessageWith" $$ otherField $$ lvar "update'Self")+ (pvar "getMessageWith" $$ otherField $$ lvar "update'Self")+ (pvar "wireGetErr" $$ lvar "ft'")+ whereDecls | extensible = [whereUpdateSelf,processExt]+ | otherwise = [whereUpdateSelf]+ whereUpdateSelf = HsFunBind [HsMatch src (HsIdent "update'Self")+ [HsPVar (HsIdent "field'Number") ,HsPVar (HsIdent "old'Self")]+ (HsUnGuardedRhs (HsCase (lvar "field'Number") updateAlts)) noWhere]+ otherField | extensible = lvar "other'Field"+ | otherwise = processUnknown+ processUnknown | storeUnknown di = pvar "loadUnknown"+ | otherwise = pvar "unknown"+ processExt =+ HsFunBind [HsMatch src (HsIdent "other'Field")+ [HsPVar (HsIdent "field'Number"), HsPVar (HsIdent "wire'Type"), HsPVar (HsIdent "old'Self")]+ (HsUnGuardedRhs (HsParen (HsIf (isAllowed (lvar "field'Number"))+ (pvar "loadExtension")+ (processUnknown))+ $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self")) noWhere]+ isAllowed x = pvar "or" $$ HsList ranges where+ (<=!) = mkOp "<="; (&&!) = mkOp "&&";+ ranges = map (\(FieldId lo,FieldId hi) -> if hi < maxHi then (litInt lo <=! x) &&! (x <=! litInt hi)+ else litInt lo <=! x) allowedExts+ where FieldId maxHi = maxBound+ updateAlts = map toUpdate (F.toList fieldInfos)+ ++ (if extensible && (not (Seq.null fieldExts)) then map toUpdateExt (F.toList fieldExts) else [])+ ++ [HsAlt src HsPWildCard (HsUnGuardedAlt $+ pvar "unknownField" $$ (lvar "field'Number")) noWhere]+ toUpdateExt fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $+ pvar "wireGetKey" $$ HsVar (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere+ -- fieldIds cannot be negative so no parenthesis are required to protect a negative sign+ toUpdate fi = HsAlt src (litIntP . getFieldId . fieldNumber $ fi) (HsUnGuardedAlt $ + pvar "fmap" $$ (HsParen $ HsLambda src [HsPVar (HsIdent "new'Field")] $+ HsRecUpdate (lvar "old'Self") [HsFieldUpdate (UnQual . HsIdent . baseName . fieldName $ fi)+ (labelUpdate fi)])+ $$ (HsParen (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . baseName . fieldName $ fi) $$ lvar "old'Self")+ $$ lvar "new'Field"+ | isRequired fi = qMerge (lvar "new'Field")+ | otherwise = qMerge (HsCon (private "Just") $$ lvar "new'Field")+ where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,11] =+ pvar "mergeAppend" $$ HsParen ((lvar . baseName . fieldName $ fi) $$ lvar "old'Self") $$ (HsParen x)+ | otherwise = x++ in HsInstDecl src [] (private "Wire") [HsTyCon me]+ [ HsFunBind [HsMatch src (HsIdent "wireSize") [HsPVar (HsIdent "ft'"),HsPAsPat (HsIdent "self'") (HsPParen mine)] sizeCases whereCalcSize]+ , HsFunBind [HsMatch src (HsIdent "wirePut") [HsPVar (HsIdent "ft'"),HsPAsPat (HsIdent "self'") (HsPParen mine)] putCases wherePutFields]+ , HsFunBind [HsMatch src (HsIdent "wireGet") [HsPVar (HsIdent "ft'")] getCases whereDecls]+ ]++-- TODO : Encode allow as a proper set of numbers!+instanceReflectDescriptor :: DescriptorInfo -> HsDecl+instanceReflectDescriptor di+ = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (HsIdent (baseName (descName di))))]+ [ inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ]+ where -- massive shortcut through show and read+ rdi :: HsExp+ rdi = pvar "read" $$ HsLit (HsString (show di))++------------------------------------------------------------------++derives,derivesEnum :: [HsQName]+derives = map private ["Show","Eq","Ord","Typeable"]+derivesEnum = map private ["Read","Show","Eq","Ord","Typeable"]++useType :: Int -> Maybe String+useType 1 = Just "Double"+useType 2 = Just "Float"+useType 3 = Just "Int64"+useType 4 = Just "Word64"+useType 5 = Just "Int32"+useType 6 = Just "Word64"+useType 7 = Just "Word32"+useType 8 = Just "Bool"+useType 9 = Just "Utf8"+useType 10 = Nothing+useType 11 = Nothing+useType 12 = Just "ByteString"+useType 13 = Just "Word32"+useType 14 = Nothing+useType 15 = Just "Int32"+useType 16 = Just "Int64"+useType 17 = Just "Int32"+useType 18 = Just "Int64"+useType x = error $ "Text.ProtocolBuffers.Gen: Impossible? useType Unknown type code "++show x++-----------------------+{-+test = putStrLn . prettyPrint . descriptorModule False "Text" $ d'++testDesc = putStrLn . prettyPrint . descriptorModule False "Text" $ genFieldOptions++testLabel = putStrLn . prettyPrint $ enumModule "Text" labelTest+testType = putStrLn . prettyPrint $ enumModule "Text" t++-- testing+utf8FromString = Utf8 . U.fromString++-- try and generate a small replacement for my manual file+genFieldOptions :: D.DescriptorProto.DescriptorProto+genFieldOptions =+ defaultValue+ { D.DescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldOptions") + , D.DescriptorProto.field = Seq.fromList+ [ defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "ctype")+ , D.FieldDescriptorProto.number = Just 1+ , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+ , D.FieldDescriptorProto.type' = Just TYPE_ENUM+ , D.FieldDescriptorProto.type_name = Just (utf8FromString "DescriptorProtos.FieldOptions.CType")+ , D.FieldDescriptorProto.default_value = Nothing+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "experimental_map_key")+ , D.FieldDescriptorProto.number = Just 9+ , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+ , D.FieldDescriptorProto.type' = Just TYPE_STRING+ , D.FieldDescriptorProto.default_value = Nothing+ }+ ]+ }++-- test several features+d' :: D.DescriptorProto.DescriptorProto+d' = defaultValue+ { D.DescriptorProto.name = Just (utf8FromString "SomeMod.ServiceOptions") + , D.DescriptorProto.field = Seq.fromList+ [ defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "fieldString")+ , D.FieldDescriptorProto.number = Just 1+ , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+ , D.FieldDescriptorProto.type' = Just TYPE_STRING+ , D.FieldDescriptorProto.default_value = Just (utf8FromString "Hello World")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "fieldDouble")+ , D.FieldDescriptorProto.number = Just 4+ , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+ , D.FieldDescriptorProto.type' = Just TYPE_DOUBLE+ , D.FieldDescriptorProto.default_value = Just (utf8FromString "+5.5e-10")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "fieldBytes")+ , D.FieldDescriptorProto.number = Just 2+ , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+ , D.FieldDescriptorProto.type' = Just TYPE_STRING+ , D.FieldDescriptorProto.default_value = Just (utf8FromString . map toEnum $ [0,5..255])+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "fieldInt64")+ , D.FieldDescriptorProto.number = Just 3+ , D.FieldDescriptorProto.label = Just LABEL_REQUIRED+ , D.FieldDescriptorProto.type' = Just TYPE_INT64+ , D.FieldDescriptorProto.default_value = Just (utf8FromString "-0x40")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "fieldBool")+ , D.FieldDescriptorProto.number = Just 5+ , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+ , D.FieldDescriptorProto.type' = Just TYPE_STRING+ , D.FieldDescriptorProto.default_value = Just (utf8FromString "False")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "field2TestSelf")+ , D.FieldDescriptorProto.number = Just 6+ , D.FieldDescriptorProto.label = Just LABEL_OPTIONAL+ , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+ , D.FieldDescriptorProto.type_name = Just (utf8FromString "ServiceOptions")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "field3TestQualified")+ , D.FieldDescriptorProto.number = Just 7+ , D.FieldDescriptorProto.label = Just LABEL_REPEATED+ , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+ , D.FieldDescriptorProto.type_name = Just (utf8FromString "A.B.C.Label")+ }+ , defaultValue+ { D.FieldDescriptorProto.name = Just (utf8FromString "field4TestUnqualified")+ , D.FieldDescriptorProto.number = Just 8+ , D.FieldDescriptorProto.label = Just LABEL_REPEATED+ , D.FieldDescriptorProto.type' = Just TYPE_MESSAGE+ , D.FieldDescriptorProto.type_name = Just (utf8FromString "Maybe")+ }+ ]+ }++labelTest :: D.EnumDescriptorProto.EnumDescriptorProto+labelTest = defaultValue+ { D.EnumDescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldDescriptorProto.Label")+ , D.EnumDescriptorProto.value = Seq.fromList+ [ defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_OPTIONAL")+ , D.EnumValueDescriptorProto.number = Just 1 }+ , defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_REQUIRED")+ , D.EnumValueDescriptorProto.number = Just 2 }+ , defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString "LABEL_REPEATED")+ , D.EnumValueDescriptorProto.number = Just 3 }+ ]+ }++t :: D.EnumDescriptorProto.EnumDescriptorProto+t = defaultValue { D.EnumDescriptorProto.name = Just (utf8FromString "DescriptorProtos.FieldDescriptorProto.Type")+ , D.EnumDescriptorProto.value = Seq.fromList . zipWith make [1..] $ names }+ where make :: Int32 -> String -> D.EnumValueDescriptorProto+ make i s = defaultValue { D.EnumValueDescriptorProto.name = Just (utf8FromString s)+ , D.EnumValueDescriptorProto.number = Just i }+ names = ["TYPE_DOUBLE","TYPE_FLOAT","TYPE_INT64","TYPE_UINT64","TYPE_INT32"+ ,"TYPE_FIXED64","TYPE_FIXED32","TYPE_BOOL","TYPE_STRING","TYPE_GROUP"+ ,"TYPE_MESSAGE","TYPE_BYTES","TYPE_UINT32","TYPE_ENUM","TYPE_SFIXED32"+ ,"TYPE_SFIXED64","TYPE_SINT32","TYPE_SINT64"]+-}
+ Text/ProtocolBuffers/ProtoCompile/Instances.hs view
@@ -0,0 +1,79 @@+module Text.ProtocolBuffers.ProtoCompile.Instances(showsType,parseType,showsLabel,parseLabel) where++import Text.ParserCombinators.ReadP+import Text.DescriptorProtos.FieldDescriptorProto.Type(Type(..))+import Text.DescriptorProtos.FieldDescriptorProto.Label(Label(..))++{-+instance Show Type where+ showsPrec _ = showsType++instance Read Type where+ readsPrec _ = readP_to_S readType+-}++showsLabel :: Label -> ShowS+showsLabel LABEL_OPTIONAL s = "optional" ++ s+showsLabel LABEL_REQUIRED s = "required" ++ s+showsLabel LABEL_REPEATED s = "repeated" ++ s++showsType :: Type -> ShowS+showsType TYPE_DOUBLE s = "double" ++ s+showsType TYPE_FLOAT s = "float" ++ s+showsType TYPE_INT64 s = "int64" ++ s+showsType TYPE_UINT64 s = "uint64" ++ s+showsType TYPE_INT32 s = "int32" ++ s+showsType TYPE_FIXED64 s = "fixed64" ++ s+showsType TYPE_FIXED32 s = "fixed32" ++ s+showsType TYPE_BOOL s = "bool" ++ s+showsType TYPE_STRING s = "string" ++ s+showsType TYPE_GROUP s = "group" ++ s+showsType TYPE_MESSAGE s = "message" ++ s+showsType TYPE_BYTES s = "bytes" ++ s+showsType TYPE_UINT32 s = "uint32" ++ s+showsType TYPE_ENUM s = "enum" ++ s+showsType TYPE_SFIXED32 s = "sfixed32" ++ s+showsType TYPE_SFIXED64 s = "sfixed64" ++ s+showsType TYPE_SINT32 s = "sint32" ++ s+showsType TYPE_SINT64 s = "sint64" ++ s++parseType :: String -> Maybe Type+parseType s = case readP_to_S readType s of+ [(val,[])] -> Just val+ _ -> Nothing++parseLabel :: String -> Maybe Label+parseLabel s = case readP_to_S readLabel s of+ [(val,[])] -> Just val+ _ -> Nothing++readLabel :: ReadP Label+readLabel = choice [ return LABEL_OPTIONAL << string "optional"+ , return LABEL_REQUIRED << string "required"+ , return LABEL_REPEATED << string "repeated"+ ]++readType :: ReadP Type+readType = choice [ return TYPE_DOUBLE << string "double"+ , return TYPE_FLOAT << string "float"+ , return TYPE_INT64 << string "int64"+ , return TYPE_UINT64 << string "uint64"+ , return TYPE_INT32 << string "int32"+ , return TYPE_FIXED64 << string "fixed64"+ , return TYPE_FIXED32 << string "fixed32"+ , 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"+ ]++(<<) :: Monad m => m a -> m b -> m a+(<<) = flip (>>)+
+ Text/ProtocolBuffers/ProtoCompile/Lexer.x view
@@ -0,0 +1,187 @@+{+{-# OPTIONS_GHC -Wwarn #-}+module Text.ProtocolBuffers.ProtoCompile.Lexer (Lexed(..), alexScanTokens,getLinePos) where++import Control.Monad.Error()+import Codec.Binary.UTF8.String(encode)+import qualified Data.ByteString.Lazy as L+import Data.Char(ord,isHexDigit,isOctDigit,toLower)+import Data.Word(Word8)+import Numeric(readHex,readOct,readDec,readSigned,readFloat)++}++%wrapper "posn-bytestring"++@inComment = ([^\*] | $white)+ | ([\*]+ [^\/])+@comment = [\/] [\*] (@inComment)* [\*]+ [\/] | "//".* | "#".*++$d = [0-9]+@decInt = [\-]?[1-9]$d*+@hexInt = [\-]?0[xX]([A-Fa-f0-9])++@octInt = [\-]?0[0-7]*+@doubleLit = [\-]?$d+(\.$d+)?([Ee][\+\-]?$d+)?++@ident1 = [A-Za-z_][A-Za-z0-9_]*+@ident = [\.]?@ident1([\.]@ident1)*+@notChar = [^A-Za-z0-9_]++@hexEscape = \\[Xx][A-Fa-f0-9]{1,2}+@octEscape = \\0?[0-7]{1,3}+@charEscape = \\[abfnrtv\\\?'\"]+@inStr = @hexEscape | @octEscape | @charEscape | [^'\"\0\n]+@strLit = ['] (@inStr | [\"])* ['] | [\"] (@inStr | ['])* [\"]++$special = [=\(\)\,\;\[\]\{\}]++:-++ $white+ ;+ @comment ;+ @decInt / @notChar { parseDec }+ @octInt / @notChar { parseOct }+ @hexInt / @notChar { parseHex }+ @doubleLit / @notChar { parseDouble }+ @decInt { dieAt "decimal followed by invalid character" }+ @octInt { dieAt "octal followed by invalid character" }+ @hexInt { dieAt "hex followed by invalid character" }+ @doubleLit { dieAt "floating followed by invalid character" }+ @strLit { parseStr }+ @ident { parseName }+ $special { parseChar }+ . { wtfAt }++{+line :: AlexPosn -> Int+line (AlexPn _byte lineNum _col) = lineNum+{-# INLINE line #-}++data Lexed = L_Integer !Int !Integer+ | L_Double !Int !Double+ | L_Name !Int !L.ByteString+ | L_String !Int !L.ByteString+ | L !Int !Char+ | L_Error !Int !String+ deriving (Show,Eq)++getLinePos :: Lexed -> Int+getLinePos x = case x of+ L_Integer i _ -> i+ L_Double i _ -> i+ L_Name i _ -> i+ L_String i _ -> i+ L i _ -> i+ L_Error i _ -> i++-- 'errAt' is the only access to L_Error, so I can see where it is created with pos+errAt pos msg = L_Error (line pos) $ "Lexical error (in Text.ProtocolBuffers.Lexer): "++ msg ++ ", at "++see pos where+ see (AlexPn char lineNum col) = "character "++show char++" line "++show lineNum++" column "++show col++"."+dieAt msg pos _s = errAt pos msg+wtfAt pos s = errAt pos $ "unknown character "++show c++" (decimal "++show (ord c)++")"+ where (c:_) = ByteString.unpack s++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++-- Given the regexps above, the "parse* failed" messages should be impossible.+parseDec pos s = maybe (errAt pos "Impossible? parseDec failed")+ (L_Integer (line pos)) $ mayRead (readSigned readDec) (ByteString.unpack s)+parseOct pos s = maybe (errAt pos "Impossible? parseOct failed")+ (L_Integer (line pos)) $ mayRead (readSigned readOct) (ByteString.unpack s)+parseHex pos s = maybe (errAt pos "Impossible? parseHex failed")+ (L_Integer (line pos)) $ mayRead (readSigned (readHex . drop 2)) (ByteString.unpack s)+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+parseName pos s = L_Name (line pos) s+parseChar pos s = L (line pos) (ByteString.head s)++-- Generalization of concat . unfoldr to monadic-Either form:+op :: ( [Char] -> Either String (Maybe ([Word8],[Char]))) -> [Char] -> Either String [Word8]+op one = go id where+ go f cs = case one cs of+ Left msg -> Left msg+ Right Nothing -> Right (f [])+ Right (Just (ws,cs')) -> go (f . (ws++)) cs'++-- Put this mess in the lexer, so the rest of the code can assume+-- everything is saner. The input is checked to really be "Char8"+-- values in the range [0..255] and to be c-escaped (in order to+-- render binary information printable). This decodes the c-escaping+-- and returns the binary data as Word8.+-- +-- A decoding error causes (Left msg) to be returned.+sDecode :: [Char] -> Either String [Word8]+sDecode = op one where+ one :: [Char] -> Either String (Maybe ([Word8],[Char]))+ one ('\\':xs) = unescape xs+ one (x:xs) = do x' <- checkChar8 x+ return $ Just (x',xs) -- main case of unescaped value+ one [] = return Nothing+ unescape [] = Left "cannot understand a string that ends with a backslash"+ unescape ys | 1 <= len =+ case mayRead readOct oct of+ Just w -> do w' <- checkByte w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode octal sequence "++ys+ where oct = takeWhile isOctDigit (take 3 ys)+ len = length oct+ rest = drop len ys+ unescape (x:ys) | 'x' == toLower x && 1 <= len =+ case mayRead readHex hex of+ Just w -> do w' <- checkByte w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode hex sequence "++ys+ where hex = takeWhile isHexDigit (take 2 ys)+ len = length hex+ rest = drop len ys + unescape ('u':ys) | ok =+ case mayRead readHex hex of+ Just w -> do w' <- checkUnicode w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode 4 char unicode sequence "++ys+ where ok = all isHexDigit hex && 4 == length hex+ (hex,rest) = splitAt 4 ys+ unescape ('U':ys) | ok =+ case mayRead readHex hex of+ Just w -> do w' <- checkUnicode w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode 8 char unicode sequence "++ys+ where ok = all isHexDigit hex && 8 == length hex+ (hex,rest) = splitAt 8 ys+ unescape (x:xs) = do x' <- decode x+ return $ Just ([x'],xs)+ decode :: Char -> Either String Word8+ decode 'a' = return 7+ decode 'b' = return 8+ decode 't' = return 9+ decode 'n' = return 10+ decode 'v' = return 11+ decode 'f' = return 12+ decode 'r' = return 13+ decode '\"' = return 34+ decode '\'' = return 39+ decode '?' = return 63 -- C99 rule : "\?" is '?'+ decode '\\' = return 92+ decode x | toLower x == 'x' = Left "cannot understand your 'xX' hexadecimal escaped value"+ decode x | toLower x == 'u' = Left "cannot understand your 'uU' unicode UTF-8 hexadecimal escaped value"+ decode _ = Left "cannot understand your backslash-escaped value"+ checkChar8 :: Char -> Either String [Word8]+ checkChar8 c | (0 <= i) && (i <= 255) = Right [toEnum i]+ | otherwise = Left $ "found Char out of range 0..255, value="++show (ord c)+ where i = fromEnum c+ checkByte :: Integer -> Either String [Word8]+ checkByte i | (0 <= i) && (i <= 255) = Right [fromInteger i]+ | otherwise = Left $ "found Oct/Hex Int out of range 0..255, value="++show i+ checkUnicode :: Integer -> Either String [Word8]+ checkUnicode i | (0 <= i) && (i <= 127) = Right [fromInteger i]+ | i <= maxChar = Right $ encode [ toEnum . fromInteger $ i ]+ | otherwise = Left $ "found Unicode Char out of range 0..0x10FFFF, value="++show i+ where maxChar = toInteger (fromEnum (maxBound ::Char)) -- 0x10FFFF++}
+ Text/ProtocolBuffers/ProtoCompile/MakeReflections.hs view
@@ -0,0 +1,285 @@+-- | The 'MakeReflections' module takes the 'FileDescriptorProto'+-- output from 'Resolve' and produces a 'ProtoInfo' from+-- 'Reflections'. This also takes a Haskell module prefix and the+-- proto's package namespace as input. The output is suitable+-- for passing to the 'Gen' module to produce the files.+--+-- This acheives several things: It moves the data from a nested tree+-- to flat lists and maps. It moves the group information from the+-- parent Descriptor to the actual Descriptor. It moves the data out+-- of Maybe types. It converts Utf8 to String. Keys known to extend+-- 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++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.DescriptorProto(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.DescriptorProto.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) +import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..)) +import qualified Text.DescriptorProtos.FieldDescriptorProto.Label as D.FieldDescriptorProto(Label)+import Text.DescriptorProtos.FieldDescriptorProto.Label as D.FieldDescriptorProto.Label(Label(..))+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 Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Reflections+import Text.ProtocolBuffers.WireMessage(size'Varint,toWireTag,runPut)++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 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)++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)++serializeFDP :: D.FileDescriptorProto -> ByteString+serializeFDP fdp = LC.empty -- XXX runPut (wirePut 11 fdp)++makeProtoInfo :: Bool -> String -> [String] -> D.FileDescriptorProto -> ProtoInfo+makeProtoInfo unknownField prefix names+ 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))+ . 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)+ allKeys = M.fromListWith mappend . map (\(k,a) -> (k,Seq.singleton a))+ . F.toList . mconcat $ keyInfos : map keys allMessages++ processMSG 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)+ (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++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)]+ enumVals = F.foldr ((:) . oneValue) [] value+ where oneValue :: D.EnumValueDescriptorProto -> (EnumCode,String)+ oneValue (D.EnumValueDescriptorProto.EnumValueDescriptorProto+ { D.EnumValueDescriptorProto.name = Just name+ , D.EnumValueDescriptorProto.number = Just number })+ = (EnumCode number,toString 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)++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+ 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+ extRangeList = concatMap check unchecked+ where check x@(lo,hi) | hi < lo = []+ | hi<19000 || 19999<lo = [x]+ | otherwise = concatMap check [(lo,18999),(20000,hi)]+ unchecked = F.foldr ((:) . extToPair) [] extension_range+ extToPair (D.DescriptorProto.ExtensionRange+ { D.DescriptorProto.ExtensionRange.start = start+ , D.DescriptorProto.ExtensionRange.end = end }) =+ (maybe minBound FieldId start, maybe maxBound FieldId end)+makeDescriptorInfo _ prefix msgIsGroup unknownField d =+ imp $ "No name passed in dp passed to makeDescriptorInfo: "++show (prefix,msgIsGroup,unknownField,d)++keyExtendee :: String -> D.FieldDescriptorProto.FieldDescriptorProto -> ProtoName+keyExtendee prefix f+ = case D.FieldDescriptorProto.extendee f of+ Nothing -> imp $ "keyExtendee expected Just but found Nothing: "++show (prefix,f)+ Just extName -> toProtoName prefix extName++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 })+ = fieldInfo+ where mayDef = parseDefaultValue f+ fieldInfo = let fullName = ProtoName prefix (dotPre modName parent) (toString name)+ fieldId = (FieldId (fromIntegral number))+ fieldType = (FieldType (fromEnum type'))+ wt = toWireTag fieldId fieldType+ wtLength = size'Varint (getWireTag wt)+ in FieldInfo fullName+ fieldId+ wt+ wtLength+ (label == LABEL_REQUIRED)+ (label == LABEL_REPEATED)+ fieldType+ (fmap (toProtoName prefix) mayTypeName)+ (fmap utf8 mayRawDef)+ mayDef+toFieldInfo pn f = imp $ "Not enough information defined in field passed to toFieldInfo: "++show(pn,f)++-- "Nothing" means no value specified+-- A failure to parse a provided value will result in an error at the moment+parseDefaultValue :: D.FieldDescriptorProto -> Maybe HsDefault+parseDefaultValue f@(D.FieldDescriptorProto.FieldDescriptorProto+ { D.FieldDescriptorProto.type' = type'+ , D.FieldDescriptorProto.default_value = mayRawDef })+ = do bs <- mayRawDef+ t <- type'+ todo <- case t of+ TYPE_MESSAGE -> Nothing+ TYPE_GROUP -> Nothing+ TYPE_ENUM -> Just parseDefEnum+ TYPE_BOOL -> Just parseDefBool+ TYPE_BYTES -> Just parseDefBytes+ TYPE_DOUBLE -> Just parseDefDouble+ TYPE_FLOAT -> Just parseDefFloat+ TYPE_STRING -> Just parseDefString+ _ -> Just parseDefInteger+ case todo (utf8 bs) of+ Nothing -> error $ "Could not parse as type "++ show t ++"the default value "++ show mayRawDef ++" for field "++show f+ Just value -> return value++--- From here down is code used to parse the format of the default values in the .proto files++parseDefEnum :: ByteString -> Maybe HsDefault+parseDefEnum = Just . HsDef'Enum . U.toString++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++parseDefDouble :: ByteString -> Maybe HsDefault+parseDefDouble bs = fmap (HsDef'Rational . toRational) + . mayRead reads' . U.toString $ bs+ where reads' :: ReadS Double+ reads' = readSigned' reads++parseDefFloat :: ByteString -> Maybe HsDefault+parseDefFloat bs = fmap (HsDef'Rational . toRational) + . mayRead reads' . U.toString $ bs+ where reads' :: ReadS Float+ reads' = readSigned' reads++parseDefString :: ByteString -> Maybe HsDefault+parseDefString bs = Just (HsDef'ByteString bs)++parseDefBytes :: ByteString -> Maybe HsDefault+parseDefBytes bs = Just (HsDef'ByteString bs)++parseDefInteger :: ByteString -> Maybe HsDefault+parseDefInteger bs = fmap HsDef'Integer . mayRead checkSign . U.toString $ bs+ where checkSign = readSigned' checkBase+ checkBase ('0':'x':xs) = readHex xs+ checkBase ('0':xs) = readOct xs+ checkBase xs = readDec xs++parseDefBool :: ByteString -> Maybe HsDefault+parseDefBool bs | bs == U.fromString "true" = Just (HsDef'Bool True)+ | bs == U.fromString "false" = Just (HsDef'Bool False)+ | otherwise = Nothing++-- The Numeric.readSigned does not handle '+' for some odd reason+readSigned' :: (Num a) => ([Char] -> [(a, t)]) -> [Char] -> [(a, t)]+readSigned' f ('-':xs) = map (\(v,s) -> (-v,s)) . f $ xs+readSigned' f ('+':xs) = f xs+readSigned' f xs = f xs
+ Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -0,0 +1,461 @@+module Text.ProtocolBuffers.ProtoCompile.Parser(pbParse,parseProto,filename1,filename2) 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(EnumValueDescriptorProto))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto(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 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(FileOptions(..))+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(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))++import Text.ProtocolBuffers.Basic+import Text.ProtocolBuffers.Header(ByteString,Int32,Int64,Word32,Word64+ ,mergeEmpty,ReflectEnum(reflectEnumInfo),enumName)++import Text.ProtocolBuffers.ProtoCompile.Lexer(Lexed(..),alexScanTokens,getLinePos)+import Text.ProtocolBuffers.ProtoCompile.Instances(parseLabel,parseType)++import Control.Monad(when,liftM3)+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 Data.Ix(inRange)+import Data.Maybe(fromMaybe)+import Data.Sequence((|>))+import Text.ParserCombinators.Parsec(GenParser,ParseError,runParser,sourceName+ ,getInput,setInput,getPosition,setPosition,getState,setState+ ,(<?>),(<|>),option,token,choice,between,eof,unexpected,skipMany)+import Text.ParserCombinators.Parsec.Pos(newPos)+import Data.Word(Word8)++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+ ipos = case lexed of+ [] -> setPosition (newPos filename 0 0)+ (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}++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++true,false :: ByteString+true = U.fromString "true"+false = U.fromString "false"++-- Use 'token' via 'tok' to make all the parsers for the Lexed values+tok :: (Lexed -> Maybe a) -> P s a+tok f = token show (\lexed -> newPos "" (getLinePos lexed) 0) f++pChar :: Char -> P s ()+pChar c = tok (\l-> case l of L _ x -> if (x==c) then return () else Nothing+ _ -> Nothing) <?> ("character "++show c)++eol :: 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+ _ -> 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+ _ -> fail "quoted string literal (UTF-8)")++intLit :: (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)"+ 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+ L_Integer _ x -> return (fromInteger x)+ _ -> Nothing) <?> "double (or integer) literal"++ident,ident1,ident_package :: P s Utf8+ident = tok (\l-> case l of L_Name _ x -> return (Utf8 x)+ _ -> Nothing) <?> "identifier (perhaps dotted)"++ident1 = tok (\l-> case l of L_Name _ x | LC.notElem '.' x -> return (Utf8 x)+ _ -> Nothing) <?> "identifier (not dotted)"++ident_package = tok (\l-> case l of L_Name _ x | LC.head x /= '.' -> return (Utf8 x)+ _ -> Nothing) <?> "package name (no leading dot)"++boolLit :: P s Bool+boolLit = tok (\l-> case l of L_Name _ x | x == true -> return True+ | x == false -> return False+ _ -> Nothing) <?> "boolean literal ('true' or 'false')"++enumLit :: forall s a. (Read a,ReflectEnum a) => P s a -- This is very polymorphic, and with a good error message+enumLit = do+ s <- fmap' utf8ToString ident1+ case mayRead reads s of+ Just x -> return x+ Nothing -> let self = enumName (reflectEnumInfo (undefined :: a))+ in unexpected $ "Enum value not recognized: "++show s++", wanted enum value of type "++show self++-- 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 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+ where getStatus = liftM3 (,,) getState getInput getPosition+ indent = unlines . map (\s -> ' ':' ':s) . lines++{-# INLINE return' #-}+return' :: (Monad m) => a -> m a+return' a = return $! a++{-# INLINE fmap' #-}+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+update' f = getState >>= \s -> setState $! (f s)++parser :: P D.FileDescriptorProto D.FileDescriptorProto +parser = proto >> getState+ where proto = eof <|> (choice [ eol+ , importFile+ , package+ , fileOption+ , message upTopMsg+ , enum upTopEnum+ , extend upTopMsg upTopField+ , 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})++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})++pOption :: P s String+pOption = pName (U.fromString "option") >> fmap utf8ToString ident1 >>= \optName -> pChar '=' >> return optName++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++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})++-- subMessage is also used to parse group declarations+subMessage,messageOption,extensions :: P D.DescriptorProto.DescriptorProto ()+subMessage = (pChar '}') <|> (choice [ eol+ , field upNestedMsg Nothing >>= upMsgField+ , message upNestedMsg+ , enum upNestedEnum+ , extensions+ , extend upNestedMsg upMsgField+ , 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})++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++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 upGroup maybeExtendee = do + let allowedLabels = case maybeExtendee of+ Nothing -> ["optional","repeated","required"]+ Just {} -> ["optional","repeated"] -- cannot declare a required extension+ sLabel <- choice . map (pName . U.fromString) $ allowedLabels+ theLabel <- maybe (fail ("not a valid Label :"++show sLabel)) return (parseLabel (utf8ToString sLabel))+ sType <- ident+ let (maybeTypeCode,maybeTypeName) = case parseType (utf8ToString sType) of+ 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+ }++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++-- This does a type and range safe parsing of the default value,+-- except for enum constants which cannot be checked (the definition+-- may not have been parsed yet).+--+-- Double and Float are checked to be not-Nan and not-Inf. The+-- int-like types are checked to be within the corresponding range.+constant :: Maybe Type -> P s ByteString+constant Nothing = fmap utf8 ident1 -- hopefully a matching enum; forget about Utf8+constant (Just t) =+ case t of+ TYPE_DOUBLE -> do d <- doubleLit+ when (isNaN d || isInfinite d)+ (fail $ "default floating point literal "++show d++" is out of range for type "++show t)+ return' (U.fromString . show $ d)+ TYPE_FLOAT -> do d <- doubleLit+ let fl :: Float+ fl = read (show d)+ when (isNaN fl || isInfinite fl || (d==0) /= (fl==0))+ (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_ENUM -> fmap utf8 ident1 -- IMPOSSIBLE : SHOULD HAVE HAD Maybe Type PARAMETER match Nothing+ TYPE_SFIXED32 -> f (undefined :: Int32)+ TYPE_SINT32 -> f (undefined :: Int32)+ TYPE_INT32 -> f (undefined :: Int32)+ TYPE_SFIXED64 -> f (undefined :: Int64)+ TYPE_SINT64 -> f (undefined :: Int64)+ TYPE_INT64 -> f (undefined :: Int64)+ TYPE_FIXED32 -> f (undefined :: Word32)+ TYPE_UINT32 -> f (undefined :: Word32)+ TYPE_FIXED64 -> f (undefined :: Word64)+ TYPE_UINT64 -> f (undefined :: Word64)+ where f :: (Bounded a,Integral a) => a -> P s ByteString+ f u = do let range = (toInteger (minBound `asTypeOf` u),toInteger (maxBound `asTypeOf` u))+ i <- intLit+ when (not (inRange range i))+ (fail $ "default integer value "++show i++" is out of range for type "++show t)+ return' (U.fromString . show $ i)++-- Returns Nothing if valid, and the position of the error if invalid+isValidUTF8 :: ByteString -> Maybe Int+isValidUTF8 ws = go 0 (L.unpack ws) 0 where+ go :: Int -> [Word8] -> Int -> Maybe Int+ go 0 [] _ = Nothing+ go 0 (x:xs) n | x <= 127 = go 0 xs $! succ n -- binary 01111111+ | x <= 193 = Just n -- binary 11000001, decodes to <=127, should not be here+ | x <= 223 = go 1 xs $! succ n -- binary 11011111+ | x <= 239 = go 2 xs $! succ n -- binary 11101111+ | x <= 243 = go 3 xs $! succ n -- binary 11110011+ | x == 244 = high xs $! succ n -- binary 11110100+ | otherwise = Just n+ go i (x:xs) n | 128 <= x && x <= 191 = go (pred i) xs $! succ n+ go _ _ n = Just n+ -- leading 3 bits are 100, so next 6 are at most 001111, i.e. 10001111+ high (x:xs) n | 128 <= x && x <= 143 = go 2 xs $! succ n+ | otherwise = Just n+ high [] n = Just n++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})++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})++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++extensions = pName (U.fromString "extensions") >> do+ start <- fmap Just 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+ }+ 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})+ 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++{-+-- see google's stubs/strutil.cc lines 398-449/1121 and C99 specification+-- This mainly targets three digit octal codes+cEncode :: [Word8] -> [Char]+cEncode = concatMap one where+ one :: Word8 -> [Char]+ one x | (32 <= x) && (x < 127) = [toEnum . fromEnum $ x] -- main case of unescaped value+ one 9 = sl 't'+ one 10 = sl 'n'+ one 13 = sl 'r'+ one 34 = sl '"'+ one 39 = sl '\''+ one 92 = sl '\\'+ one 0 = '\\':"000"+ one x | x < 8 = '\\':'0':'0':(showOct x "")+ | x < 64 = '\\':'0':(showOct x "")+ | otherwise = '\\':(showOct x "")+ sl c = ['\\',c]+-}
+ Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -0,0 +1,354 @@+-- | Text.ProtocolBuffers.Resolve takes the output of Text.ProtocolBuffers.Parse and runs all+-- the preprocessing and sanity checks that precede Text.ProtocolBuffers.Gen creating modules.+--+-- Currently this involves mangling the names, building a NameSpace (or [NameSpace]), and making+-- all the names fully qualified (and setting TYPE_MESSAGE or TYPE_ENUM) as appropriate.+-- Field names are also checked against a list of reserved words, appending a single quote+-- to disambiguate.+-- All names from Parser should start with a letter, but _ is also handled by replacing with U' or u'.+-- Anything else will trigger a "subborn ..." error.+-- Name resolution failure are not handled elegantly: it will kill the system with a long error message.+--+-- TODO: treat names with leading "." as already "fully-qualified"+-- make sure the optional fields that will be needed are not Nothing (or punt to Reflections.hs)+-- look for repeated use of the same name (before and after mangling)+module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,resolveFDP) where++import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto)+import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))+import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))+import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto)+import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..))+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto)+import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..))+import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto(Type)+import Text.DescriptorProtos.FieldDescriptorProto.Type as D.FieldDescriptorProto.Type(Type(..))+import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto(FileDescriptorProto))+import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))+import qualified Text.DescriptorProtos.FileOptions as D.FileOptions(FileOptions(..))+import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto)+import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..))+import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))++import Text.ProtocolBuffers.Header+import Text.ProtocolBuffers.ProtoCompile.Parser++import Control.Monad.State+import Data.Char+import Data.Ix(inRange)+import qualified Data.Foldable as F+import qualified Data.Set as Set+import Data.Maybe(fromMaybe,catMaybes)+import Data.Monoid(Monoid(..))+import Data.Map(Map)+import qualified Data.Map as M+import Data.List(unfoldr,span,inits,foldl')+import qualified Data.ByteString.Lazy.UTF8 as U+import qualified Data.ByteString.Lazy.Char8 as LC+import System.Directory+import System.FilePath++err :: forall b. String -> b+err s = error $ "Text.ProtocolBuffers.Resolve fatal error encountered, message:\n"++indent s+ where indent = unlines . map (\str -> ' ':' ':str) . lines++encodeModuleNames :: [String] -> Utf8+encodeModuleNames [] = Utf8 mempty+encodeModuleNames xs = Utf8 . U.fromString . foldr1 (\a b -> a ++ '.':b) $ xs++mangleCap :: Maybe Utf8 -> [String]+mangleCap = mangleModuleNames . fromMaybe (Utf8 mempty)+ where mangleModuleNames :: Utf8 -> [String]+ mangleModuleNames bs = map mangleModuleName . splitDot . toString $ bs+ splitDot :: String -> [String]+ splitDot = unfoldr s where+ s ('.':xs) = s xs+ s [] = Nothing+ s xs = Just (span ('.'/=) xs)++mangleCap1 :: Maybe Utf8 -> String+mangleCap1 Nothing = ""+mangleCap1 (Just u) = mangleModuleName . toString $ u++mangleEnums :: Seq D.EnumValueDescriptorProto -> Seq D.EnumValueDescriptorProto+mangleEnums s = fmap fixEnum s+ where fixEnum v = v { D.EnumValueDescriptorProto.name = mangleEnum (D.EnumValueDescriptorProto.name v)}++mangleEnum :: Maybe Utf8 -> Maybe Utf8+mangleEnum = fmap (Utf8 . U.fromString . mangleModuleName . toString)++mangleModuleName :: String -> String+mangleModuleName [] = "Empty'Name" -- XXX+mangleModuleName ('_':xs) = "U'"++xs+mangleModuleName (x:xs) | isLower x = let x' = toUpper x+ in if isLower x' then err ("subborn lower case"++show (x:xs))+ else x': xs+mangleModuleName xs = xs++mangleFieldName :: Maybe Utf8 -> Maybe Utf8+mangleFieldName = fmap (Utf8 . U.fromString . fixname . toString)+ where fixname [] = "empty'name" -- XXX+ fixname ('_':xs) = "u'"++xs+ fixname (x:xs) | isUpper x = let x' = toLower x+ in if isUpper x' then err ("stubborn upper case: "++show (x:xs))+ else fixname (x':xs)+ fixname xs | xs `elem` reserved = xs ++ "'"+ fixname xs = xs+ reserved :: [String]+ reserved = ["case","class","data","default","deriving","do","else","foreign"+ ,"if","import","in","infix","infixl","infixr","instance"+ ,"let","module","newtype","of","then","type","where"] -- also reserved is "_"++checkER :: [(Int32,Int32)] -> Int32 -> Bool+checkER ers fid = any (`inRange` fid) ers++extRangeList :: D.DescriptorProto -> [(Int32,Int32)]+extRangeList d = concatMap check unchecked+ where check x@(lo,hi) | hi < lo = []+ | hi<19000 || 19999<lo = [x]+ | otherwise = concatMap check [(lo,18999),(20000,hi)]+ unchecked = F.foldr ((:) . extToPair) [] (D.DescriptorProto.extension_range d)+ extToPair (D.ExtensionRange+ { D.ExtensionRange.start = start+ , D.ExtensionRange.end = end }) =+ (getFieldId $ maybe minBound FieldId start, getFieldId $ maybe maxBound FieldId end)++newtype NameSpace = NameSpace {unNameSpace::(Map String ([String],NameType,Maybe NameSpace))}+ deriving (Show,Read)+data NameType = Message [(Int32,Int32)] | Enumeration [Utf8] | Service | Void + deriving (Show,Read)++type Context = [NameSpace]++seeContext :: Context -> [String] +seeContext cx = map ((++"[]") . concatMap (\k -> show k ++ ", ") . M.keys . unNameSpace) cx++toString :: Utf8 -> String+toString = U.toString . utf8++findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findFile paths target = do+ let test [] = return Nothing+ test (path:rest) = do+ let fullname = combine path target+ found <- doesFileExist fullname+ if found then return (Just fullname)+ else test rest+ test paths++-- loadProto is a slight kludge. It takes a single search directory+-- and an initial .proto file path relative to this directory. It+-- loads this file and then chases the imports. If an import loop is+-- detected then it aborts. A state monad is used to memorize+-- previous invocations of 'load'. A progress message of the filepath+-- is printed before reading a new .proto file.+--+-- The "contexts" collected and used to "resolveWithContext" can+-- contain duplicates: File A imports B and C, and File B imports C+-- will cause the context for C to be included twice in contexts.+--+-- The result type of loadProto is enough for now, but may be changed+-- in the future. It returns a map from the files (relative to the+-- search directory) to a pair of the resolved descriptor and a set of+-- directly imported files. The dependency tree is thus implicit.+loadProto :: [FilePath] -> FilePath -> IO (Map FilePath (D.FileDescriptorProto,Set.Set FilePath,[String]))+loadProto protoDirs protoFile = fmap answer $ execStateT (load Set.empty protoFile) mempty where+ answer built = fmap snd built -- drop the fst Context from the pair in the memorized map+ loadFailed f msg = fail . unlines $ ["Parsing proto:",f,"has failed with message",msg]+ load :: Set.Set FilePath -- set of "parents" that is used by load to detect an import loop. Not memorized.+ -> FilePath -- the FilePath to load and resolve (may used memorized result of load)+ -> StateT (Map FilePath (Context,(D.FileDescriptorProto,Set.Set FilePath,[String]))) -- memorized results of load+ IO (Context -- Only used during load. This is the view of the file as an imported namespace.+ ,(D.FileDescriptorProto -- This is the resolved version of the FileDescriptorProto+ ,Set.Set FilePath+ ,[String])) -- This is the list of file directly imported by the FilePath argument+ load parentsIn file = do+ built <- get -- to check memorized results+ when (Set.member file parentsIn)+ (loadFailed file (unlines ["imports failed: recursive loop detected"+ ,unlines . map show . M.assocs $ built,show parentsIn]))+ let parents = Set.insert file parentsIn+ case M.lookup file built of+ Just result -> return result+ Nothing -> do+ mayToRead <- liftIO $ findFile protoDirs file+ when (Nothing == mayToRead) $+ loadFailed file (unlines (["loading failed, could not find file: "++show file+ ,"Searched paths were:"] ++ map (" "++) protoDirs))+ let (Just toRead) = mayToRead+ proto <- liftIO $ do print ("Loading filepath: "++toRead)+ LC.readFile toRead+ parsed <- either (loadFailed toRead . show) return (parseProto toRead proto)+ let (context,imports,names) = toContext parsed+ contexts <- fmap (concatMap fst) -- keep only the fst Context's+ . mapM (load parents) -- recursively chase imports+ . Set.toList $ imports+ let result = ( withPackage context parsed ++ contexts+ , ( resolveWithContext (context++contexts) parsed+ , imports+ , names ) )+ -- add to memorized results, the "load" above may have updated/invalidated the "built <- get" state above+ modify (\built' -> M.insert file result built')+ return result++-- Imported names must be fully qualified in the .proto file by the+-- target's package name, but the resolved name might be fully+-- quilified by something else (e.g. one of the java options).+withPackage :: Context -> D.FileDescriptorProto -> Context+withPackage (cx:_) (D.FileDescriptorProto {D.FileDescriptorProto.package=Just package}) =+ let prepend = mangleCap1 . Just $ package+ in [NameSpace (M.singleton prepend ([prepend],Void,Just cx))]+withPackage (_:_) (D.FileDescriptorProto {D.FileDescriptorProto.name=n}) = err $+ "withPackage given an imported FDP without a package declaration: "++show n+withPackage [] (D.FileDescriptorProto {D.FileDescriptorProto.name=n}) = err $+ "withPackage given an empty context: "++show n++resolveFDP :: D.FileDescriptorProto.FileDescriptorProto+ -> (D.FileDescriptorProto.FileDescriptorProto, [String])+resolveFDP fdpIn =+ let (context,_,names) = toContext fdpIn+ in (resolveWithContext context fdpIn,names)+ +-- process to get top level context for FDP and list of its imports+toContext :: D.FileDescriptorProto -> (Context,Set.Set FilePath,[String])+toContext protoIn =+ let prefix :: [String]+ prefix = mangleCap . msum $+ [ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options protoIn)+ , D.FileOptions.java_package =<< (D.FileDescriptorProto.options protoIn)+ , D.FileDescriptorProto.package protoIn]+ -- Make top-most root NameSpace+ nameSpace = fromMaybe (NameSpace mempty) $ foldr addPrefix protoNames $ zip prefix (tail (inits prefix))+ where addPrefix (s1,ss) ns = Just . NameSpace $ M.singleton s1 (ss,Void,ns)+ protoNames | null protoMsgs = Nothing+ | otherwise = Just . NameSpace . M.fromList $ protoMsgs+ where protoMsgs = F.foldr ((:) . msgNames prefix) protoEnums (D.FileDescriptorProto.message_type protoIn)+ protoEnums = F.foldr ((:) . enumNames prefix) protoServices (D.FileDescriptorProto.enum_type protoIn)+ protoServices = F.foldr ((:) . serviceNames prefix) [] (D.FileDescriptorProto.service protoIn)+ msgNames context dIn =+ let s1 = mangleCap1 (D.DescriptorProto.name dIn)+ ss' = context ++ [s1]+ dNames | null dMsgs = Nothing+ | otherwise = Just . NameSpace . M.fromList $ dMsgs+ dMsgs = F.foldr ((:) . msgNames ss') dEnums (D.DescriptorProto.nested_type dIn)+ dEnums = F.foldr ((:) . enumNames ss') [] (D.DescriptorProto.enum_type dIn)+ in ( s1 , (ss',Message (extRangeList dIn),dNames) )+ enumNames context eIn = -- XXX todo mangle enum names ? No+ let s1 = mangleCap1 (D.EnumDescriptorProto.name eIn)+ values :: [Utf8]+ values = catMaybes $ map D.EnumValueDescriptorProto.name (F.toList (D.EnumDescriptorProto.value eIn))+ in ( s1 , (context ++ [s1],Enumeration values,Nothing) )+ serviceNames context sIn =+ let s1 = mangleCap1 (D.ServiceDescriptorProto.name sIn)+ in ( s1 , (context ++ [s1],Service,Nothing) )+ -- Context stack for resolving the top level declarations+ protoContext :: Context+ protoContext = foldl' (\nss@(NameSpace ns:_) pre -> case M.lookup pre ns of+ Just (_,Void,Just ns1) -> (ns1:nss)+ _ -> nss) [nameSpace] prefix+ in ( protoContext+ , Set.fromList (map toString (F.toList (D.FileDescriptorProto.dependency protoIn)))+ , prefix+ )++resolveWithContext :: Context -> D.FileDescriptorProto -> D.FileDescriptorProto+resolveWithContext protoContext protoIn =+ let rerr msg = err $ "Failure while resolving file descriptor proto whose name is "+ ++ maybe "<empty name>" toString (D.FileDescriptorProto.name protoIn)++"\n"+ ++ msg+ descend :: Context -> Maybe Utf8 -> Context -- XXX todo take away the maybe + descend cx@(NameSpace n:_) name =+ case M.lookup mangled n of+ Just (_,_,Nothing) -> cx+ Just (_,_,Just ns1) -> ns1:cx+ x -> rerr $ "*** Name resolution failed when descending:\n"++unlines (mangled : show x : "KNOWN NAMES" : seeContext cx)+ where mangled = mangleCap1 name -- XXX empty on nothing?+ descend [] _ = []+ resolve :: Context -> Maybe Utf8 -> Maybe Utf8+ resolve _context Nothing = Nothing+ resolve context (Just bs) = fmap fst (resolveWithNameType context bs)+ resolveWithNameType :: Context -> Utf8 -> Maybe (Utf8,NameType)+ resolveWithNameType context bsIn =+ let nameIn = mangleCap (Just bsIn)+ errMsg = "*** Name resolution failed:\n"+ ++unlines ["Unmangled name: "++show bsIn+ ,"Mangled name: "++show nameIn+ ,"List of known names:"]+ ++ unlines (seeContext context)+ resolver [] (NameSpace _cx) = rerr $ "Impossible? case in Text.ProtocolBuffers.Resolve.resolveWithNameType.resolver []\n" ++ errMsg+ resolver [name] (NameSpace cx) = case M.lookup name cx of+ Nothing -> Nothing+ Just (fqName,nameType,_) -> Just (encodeModuleNames fqName,nameType)+ resolver (name:rest) (NameSpace cx) = case M.lookup name cx of+ Nothing -> Nothing+ Just (_,_,Nothing) -> Nothing+ Just (_,_,Just cx') -> resolver rest cx'+ in case msum . map (resolver nameIn) $ context of+ Nothing -> rerr errMsg+ Just x -> Just x+ processFDP fdp = fdp+ { D.FileDescriptorProto.message_type = fmap (processMSG protoContext) (D.FileDescriptorProto.message_type fdp)+ , D.FileDescriptorProto.enum_type = fmap (processENM protoContext) (D.FileDescriptorProto.enum_type fdp)+ , D.FileDescriptorProto.service = fmap (processSRV protoContext) (D.FileDescriptorProto.service fdp)+ , D.FileDescriptorProto.extension = fmap (processFLD protoContext Nothing) (D.FileDescriptorProto.extension fdp) }+ processMSG cx msg = msg+ { D.DescriptorProto.name = self+ , D.DescriptorProto.field = fmap (processFLD cx' self) (D.DescriptorProto.field msg)+ , D.DescriptorProto.extension = fmap (processFLD cx' self) (D.DescriptorProto.extension msg)+ , D.DescriptorProto.nested_type = fmap (processMSG cx') (D.DescriptorProto.nested_type msg)+ , D.DescriptorProto.enum_type = fmap (processENM cx') (D.DescriptorProto.enum_type msg) }+ where cx' = descend cx (D.DescriptorProto.name msg)+ self = resolve cx (D.DescriptorProto.name msg)+ processFLD cx mp f = f { D.FieldDescriptorProto.name = mangleFieldName (D.FieldDescriptorProto.name f)+ , D.FieldDescriptorProto.type' = new_type'+ , D.FieldDescriptorProto.type_name = if new_type' == Just TYPE_GROUP+ then groupName+ else fmap fst r2+ , D.FieldDescriptorProto.default_value = checkEnumDefault+ , D.FieldDescriptorProto.extendee = fmap newExt (D.FieldDescriptorProto.extendee f)}+ where newExt :: Utf8 -> Utf8+ newExt orig = let e2 = resolveWithNameType cx orig+ in case (e2,D.FieldDescriptorProto.number f) of+ (Just (newName,Message ers),Just fid) ->+ if checkER ers fid then newName+ else rerr $ "*** Name resolution found an extension field that is out of the allowed extension ranges: "++show f ++ "\n has a number "++ show fid ++" not in one of the valid ranges: " ++ show ers+ (Just _,_) -> rerr $ "*** Name resolution found wrong type for "++show orig++" : "++show e2+ (Nothing,Just {}) -> rerr $ "*** Name resolution failed for the extendee: "++show f+ (_,Nothing) -> rerr $ "*** No field id number for the extension field: "++show f+ r2 = fmap (fromMaybe (rerr $ "*** Name resolution failed for the type_name of extension field: "++show f)+ . (resolveWithNameType cx))+ (D.FieldDescriptorProto.type_name f)+ t (Message {}) = TYPE_MESSAGE+ t (Enumeration {}) = TYPE_ENUM+ t _ = rerr $ unlines [ "Problem found: processFLD cannot resolve type_name to Void or Service"+ , " The parent message is "++maybe "<no message>" toString mp+ , " The field name is "++maybe "<no field name>" toString (D.FieldDescriptorProto.name f)]+ new_type' = (D.FieldDescriptorProto.type' f) `mplus` (fmap (t.snd) r2)+ checkEnumDefault = case (D.FieldDescriptorProto.default_value f,fmap snd r2) of+ (Just name,Just (Enumeration values)) | name `elem` values -> mangleEnum (Just name)+ | otherwise ->+ rerr $ unlines ["Problem found: default enumeration value not recognized:"+ ," The parent message is "++maybe "<no message>" toString mp+ ," field name is "++maybe "" toString (D.FieldDescriptorProto.name f)+ ," bad enum name is "++show (toString name)+ ," possible enum values are "++show (map toString values)]+ (Just def,_) | new_type' == Just TYPE_MESSAGE+ || new_type' == Just TYPE_GROUP ->+ rerr $ "Problem found: You set a default value for a MESSAGE or GROUP: "++unlines [show def,show f]+ (maybeDef,_) -> maybeDef+ + groupName = case mp of+ Nothing -> resolve cx (D.FieldDescriptorProto.name f)+ Just p -> do n <- D.FieldDescriptorProto.name f+ return (Utf8 . U.fromString . (toString p++) . ('.':) . mangleModuleName . toString $ n)++ processENM cx e = e { D.EnumDescriptorProto.name = resolve cx (D.EnumDescriptorProto.name e)+ , D.EnumDescriptorProto.value = mangleEnums (D.EnumDescriptorProto.value e) }+ processSRV cx s = s { D.ServiceDescriptorProto.name = resolve cx (D.ServiceDescriptorProto.name s)+ , D.ServiceDescriptorProto.method = fmap (processMTD cx) (D.ServiceDescriptorProto.method s) }+ processMTD cx m = m { D.MethodDescriptorProto.name = mangleFieldName (D.MethodDescriptorProto.name m)+ , D.MethodDescriptorProto.input_type = resolve cx (D.MethodDescriptorProto.input_type m)+ , D.MethodDescriptorProto.output_type = resolve cx (D.MethodDescriptorProto.output_type m) }+ in processFDP protoIn
+ dist/build/hprotoc/hprotoc-tmp/Text/ProtocolBuffers/ProtoCompile/Lexer.hs view
@@ -0,0 +1,499 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LINE 1 "Text/ProtocolBuffers/ProtoCompile/Lexer.x" #-}++{-# OPTIONS_GHC -Wwarn #-}+module Text.ProtocolBuffers.ProtoCompile.Lexer (Lexed(..), alexScanTokens,getLinePos) where++import Control.Monad.Error()+import Codec.Binary.UTF8.String(encode)+import qualified Data.ByteString.Lazy as L+import Data.Char(ord,isHexDigit,isOctDigit,toLower)+import Data.Word(Word8)+import Numeric(readHex,readOct,readDec,readSigned,readFloat)+++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++++import qualified Data.ByteString.Lazy.Char8 as ByteString++++-- -----------------------------------------------------------------------------+-- The input type++{-# LINE 29 "templates/wrappers.hs" #-}+++type AlexInput = (AlexPosn, -- current position,+ Char, -- previous char+ ByteString.ByteString) -- current input string++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p,c,s) = c++alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (p,_,cs) | ByteString.null cs = Nothing+ | otherwise = let c = ByteString.head cs+ cs' = ByteString.tail cs+ p' = alexMove p c+ in p' `seq` cs' `seq` Just (c, (p', c, cs'))+++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text. It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++data AlexPosn = AlexPn !Int !Int !Int+ deriving (Eq,Show)++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1)+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1+alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1)+++-- -----------------------------------------------------------------------------+-- Default monad++{-# LINE 150 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++{-# LINE 233 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper++{-# LINE 255 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++{-# LINE 277 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.++{-# LINE 294 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version+++--alexScanTokens :: ByteString -> [token]+alexScanTokens str = go (alexStartPos,'\n',str)+ where go inp@(pos,_,str) =+ case alexScan inp 0 of+ AlexEOF -> []+ AlexError _ -> error "lexical error"+ AlexSkip inp' len -> go inp'+ AlexToken inp' len act -> act pos (ByteString.take (fromIntegral len) str) : go inp'++++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.++alex_base :: AlexAddr+alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x02\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xff\xff\x07\x00\x00\x00\x08\x00\x00\x00\x09\x00\x00\x00\x0a\x00\x00\x00\xed\xff\xff\xff\x6a\x00\x00\x00\xeb\xff\xff\xff\xec\xff\xff\xff\xef\xff\xff\xff\xf4\xff\xff\xff\x4d\x00\x00\x00\x6c\x00\x00\x00\x85\x00\x00\x00\x76\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x0d\x01\x00\x00\x43\x01\x00\x00\x79\x01\x00\x00\x00\x00\x00\x00\xc4\x01\x00\x00\xdb\x01\x00\x00\x18\x02\x00\x00\x00\x00\x00\x00\x65\x02\x00\x00\x6f\x02\x00\x00\x8f\x00\x00\x00\x01\x01\x00\x00\x59\x01\x00\x00\x63\x01\x00\x00\xa5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x47\x01\x00\x00\x49\x01\x00\x00\x57\x01\x00\x00\x20\x03\x00\x00\x37\x03\x00\x00\x6f\x03\x00\x00\x58\x01\x00\x00\x87\x03\x00\x00\xb6\x03\x00\x00\xcc\x03\x00\x00\xe4\x03\x00\x00\xfa\x03\x00\x00\x5a\x01\x00\x00\x4a\x01\x00\x00\x4b\x01\x00\x00\x05\x04\x00\x00\x42\x04\x00\x00\x4d\x04\x00\x00\x7d\x01\x00\x00\x8b\x04\x00\x00\x96\x04\x00\x00\xa1\x04\x00\x00\xac\x04\x00\x00\xcf\x04\x00\x00\x19\x02\x00\x00\xeb\x04\x00\x00\x38\x05\x00\x00\x85\x05\x00\x00\xd2\x05\x00\x00\x1f\x06\x00\x00\x59\x06\x00\x00\x93\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\x03\x00\x02\x00\x03\x00\x03\x00\x03\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0b\x00\x0a\x00\x03\x00\x0b\x00\x36\x00\x08\x00\x05\x00\x02\x00\x0c\x00\x2a\x00\x49\x00\x49\x00\x02\x00\x06\x00\x49\x00\x13\x00\x47\x00\x0f\x00\x17\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x49\x00\x00\x00\x49\x00\x00\x00\x43\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x49\x00\xff\xff\x49\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x22\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\xff\xff\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x22\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x16\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x10\x00\x27\x00\x23\x00\x23\x00\x22\x00\xff\xff\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1f\x00\x1f\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x22\x00\x23\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1f\x00\x1f\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\xff\xff\x1c\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x27\x00\x27\x00\x00\x00\x1c\x00\x27\x00\x22\x00\x23\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1f\x00\x1f\x00\xff\xff\x27\x00\x27\x00\x00\x00\x27\x00\x00\x00\xff\xff\x24\x00\x1c\x00\x24\x00\xff\xff\x23\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x2d\x00\x39\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\x2d\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\xff\xff\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x39\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x30\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\x31\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\xff\xff\x00\x00\x2d\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x2c\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\xff\xff\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\xff\xff\x00\x00\x00\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\xff\xff\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x2d\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x2d\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x29\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\xff\xff\xff\xff\x27\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\xff\xff\x00\x00\x27\x00\x00\x00\x38\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x27\x00\x00\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x27\x00\xff\xff\x00\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\x40\x00\xff\xff\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x48\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x48\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x48\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x48\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x2a\x00\x2a\x00\x2a\x00\x20\x00\x2a\x00\x22\x00\x23\x00\x2f\x00\x20\x00\x2a\x00\x27\x00\x28\x00\x29\x00\x20\x00\x2f\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x0a\x00\x7d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x0a\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x27\x00\x45\x00\x65\x00\x2e\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2e\x00\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x0a\x00\x45\x00\x0a\x00\x0a\x00\x0a\x00\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0a\x00\xff\xff\x0a\x00\x58\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\x22\x00\x22\x00\xff\xff\x78\x00\x27\x00\x2e\x00\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\x27\x00\x27\x00\xff\xff\x27\x00\xff\xff\x0a\x00\x2b\x00\x78\x00\x2d\x00\x0a\x00\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\x5c\x00\x5c\x00\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5c\x00\x5c\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x0a\x00\x0a\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x0a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x78\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x00\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x00\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x00\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x5c\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5c\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x22\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x0a\x00\x00\x00\x22\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x22\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x22\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x22\x00\x00\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++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))]]+{-# LINE 54 "Text/ProtocolBuffers/ProtoCompile/Lexer.x" #-}++line :: AlexPosn -> Int+line (AlexPn _byte lineNum _col) = lineNum+{-# INLINE line #-}++data Lexed = L_Integer !Int !Integer+ | L_Double !Int !Double+ | L_Name !Int !L.ByteString+ | L_String !Int !L.ByteString+ | L !Int !Char+ | L_Error !Int !String+ deriving (Show,Eq)++getLinePos :: Lexed -> Int+getLinePos x = case x of+ L_Integer i _ -> i+ L_Double i _ -> i+ L_Name i _ -> i+ L_String i _ -> i+ L i _ -> i+ L_Error i _ -> i++-- 'errAt' is the only access to L_Error, so I can see where it is created with pos+errAt pos msg = L_Error (line pos) $ "Lexical error (in Text.ProtocolBuffers.Lexer): "++ msg ++ ", at "++see pos where+ see (AlexPn char lineNum col) = "character "++show char++" line "++show lineNum++" column "++show col++"."+dieAt msg pos _s = errAt pos msg+wtfAt pos s = errAt pos $ "unknown character "++show c++" (decimal "++show (ord c)++")"+ where (c:_) = ByteString.unpack s++{-# INLINE mayRead #-}+mayRead :: ReadS a -> String -> Maybe a+mayRead f s = case f s of [(a,"")] -> Just a; _ -> Nothing++-- Given the regexps above, the "parse* failed" messages should be impossible.+parseDec pos s = maybe (errAt pos "Impossible? parseDec failed")+ (L_Integer (line pos)) $ mayRead (readSigned readDec) (ByteString.unpack s)+parseOct pos s = maybe (errAt pos "Impossible? parseOct failed")+ (L_Integer (line pos)) $ mayRead (readSigned readOct) (ByteString.unpack s)+parseHex pos s = maybe (errAt pos "Impossible? parseHex failed")+ (L_Integer (line pos)) $ mayRead (readSigned (readHex . drop 2)) (ByteString.unpack s)+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+parseName pos s = L_Name (line pos) s+parseChar pos s = L (line pos) (ByteString.head s)++-- Generalization of concat . unfoldr to monadic-Either form:+op :: ( [Char] -> Either String (Maybe ([Word8],[Char]))) -> [Char] -> Either String [Word8]+op one = go id where+ go f cs = case one cs of+ Left msg -> Left msg+ Right Nothing -> Right (f [])+ Right (Just (ws,cs')) -> go (f . (ws++)) cs'++-- Put this mess in the lexer, so the rest of the code can assume+-- everything is saner. The input is checked to really be "Char8"+-- values in the range [0..255] and to be c-escaped (in order to+-- render binary information printable). This decodes the c-escaping+-- and returns the binary data as Word8.+-- +-- A decoding error causes (Left msg) to be returned.+sDecode :: [Char] -> Either String [Word8]+sDecode = op one where+ one :: [Char] -> Either String (Maybe ([Word8],[Char]))+ one ('\\':xs) = unescape xs+ one (x:xs) = do x' <- checkChar8 x+ return $ Just (x',xs) -- main case of unescaped value+ one [] = return Nothing+ unescape [] = Left "cannot understand a string that ends with a backslash"+ unescape ys | 1 <= len =+ case mayRead readOct oct of+ Just w -> do w' <- checkByte w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode octal sequence "++ys+ where oct = takeWhile isOctDigit (take 3 ys)+ len = length oct+ rest = drop len ys+ unescape (x:ys) | 'x' == toLower x && 1 <= len =+ case mayRead readHex hex of+ Just w -> do w' <- checkByte w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode hex sequence "++ys+ where hex = takeWhile isHexDigit (take 2 ys)+ len = length hex+ rest = drop len ys + unescape ('u':ys) | ok =+ case mayRead readHex hex of+ Just w -> do w' <- checkUnicode w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode 4 char unicode sequence "++ys+ where ok = all isHexDigit hex && 4 == length hex+ (hex,rest) = splitAt 4 ys+ unescape ('U':ys) | ok =+ case mayRead readHex hex of+ Just w -> do w' <- checkUnicode w+ return $ Just (w',rest)+ Nothing -> Left $ "failed to decode 8 char unicode sequence "++ys+ where ok = all isHexDigit hex && 8 == length hex+ (hex,rest) = splitAt 8 ys+ unescape (x:xs) = do x' <- decode x+ return $ Just ([x'],xs)+ decode :: Char -> Either String Word8+ decode 'a' = return 7+ decode 'b' = return 8+ decode 't' = return 9+ decode 'n' = return 10+ decode 'v' = return 11+ decode 'f' = return 12+ decode 'r' = return 13+ decode '\"' = return 34+ decode '\'' = return 39+ decode '?' = return 63 -- C99 rule : "\?" is '?'+ decode '\\' = return 92+ decode x | toLower x == 'x' = Left "cannot understand your 'xX' hexadecimal escaped value"+ decode x | toLower x == 'u' = Left "cannot understand your 'uU' unicode UTF-8 hexadecimal escaped value"+ decode _ = Left "cannot understand your backslash-escaped value"+ checkChar8 :: Char -> Either String [Word8]+ checkChar8 c | (0 <= i) && (i <= 255) = Right [toEnum i]+ | otherwise = Left $ "found Char out of range 0..255, value="++show (ord c)+ where i = fromEnum c+ checkByte :: Integer -> Either String [Word8]+ checkByte i | (0 <= i) && (i <= 255) = Right [fromInteger i]+ | otherwise = Left $ "found Oct/Hex Int out of range 0..255, value="++show i+ checkUnicode :: Integer -> Either String [Word8]+ checkUnicode i | (0 <= i) && (i <= 127) = Right [fromInteger i]+ | i <= maxChar = Right $ encode [ toEnum . fromInteger $ i ]+ | otherwise = Left $ "found Unicode Char out of range 0..0x10FFFF, value="++show i+ where maxChar = toInteger (fromEnum (maxBound ::Char)) -- 0x10FFFF+++alex_action_2 = parseDec +alex_action_3 = parseOct +alex_action_4 = parseHex +alex_action_5 = parseDouble +alex_action_6 = dieAt "decimal followed by invalid character" +alex_action_7 = dieAt "octal followed by invalid character" +alex_action_8 = dieAt "hex followed by invalid character" +alex_action_9 = dieAt "floating followed by invalid character" +alex_action_10 = parseStr +alex_action_11 = parseName +alex_action_12 = parseChar +alex_action_13 = wtfAt +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 35 "templates/GenericTemplate.hs" #-}++{-# LINE 45 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+ = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+ = case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, input') ->+ case alexGetChar input of+ Nothing -> ++++ AlexEOF+ Just _ ->++++ AlexError input'++ (AlexLastSkip input len, _) ->++++ AlexSkip input len++ (AlexLastAcc k input len, _) ->++++ AlexToken input len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ let + new_acc = check_accs (alex_accept `quickIndex` (I# (s)))+ in+ new_acc `seq`+ case alexGetChar input of+ Nothing -> (new_acc, input)+ Just (c, new_input) -> ++++ let+ base = alexIndexInt32OffAddr alex_base s+ (I# (ord_c)) = ord c+ offset = (base +# ord_c)+ check = alexIndexInt16OffAddr alex_check offset+ + new_s = if (offset >=# 0#) && (check ==# ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of + -1# -> (new_acc, input)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc++ where+ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a pred : rest)+ | pred user orig_input (I# (len)) input+ = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred pred : rest)+ | pred user orig_input (I# (len)) input+ = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+ = AlexNone+ | AlexLastAcc a !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc a user+ = AlexAcc a+ | AlexAccSkip+ | AlexAccPred a (AlexAccPred user)+ | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+ = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ hprotoc.cabal view
@@ -0,0 +1,60 @@+name: hprotoc+-- Synchronize this version number with Text.ProtocolBuffers.ProtocolCompile.version+version: 0.3.1+cabal-version: >= 1.2+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (c) 2008 Christopher Edward Kuklewicz+author: Christopher Edward Kuklewicz+maintainer: Chris Kuklewicz <protobuf@personal.mightyreason.com>+stability: Experimental+homepage: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/protocol-buffers+package-url: http://darcs.haskell.org/packages/protocol-buffers2/+synopsis: Parse Google Protocol Buffer specifications+description: Parse http://code.google.com/apis/protocolbuffers/docs/proto.html+ and perhaps general haskell code to use them+category: Text+Tested-With: GHC ==6.8.3+extra-source-files:++flag small_base+ description: Choose the new smaller, split-up base package.++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+ build-depends: binary, utf8-string+ build-depends: parsec, haskell-src+ if flag(small_base)+ build-depends: base >= 3,+ containers,+ bytestring,+ array,+ filepath,+ directory,+ mtl,+ QuickCheck+ else+ build-depends: base < 3+ other-modules: Text.ProtocolBuffers.ProtoCompile.Gen+ Text.ProtocolBuffers.ProtoCompile.Instances+ Text.ProtocolBuffers.ProtoCompile.Lexer+ Text.ProtocolBuffers.ProtoCompile.MakeReflections+ Text.ProtocolBuffers.ProtoCompile.Parser+ Text.ProtocolBuffers.ProtoCompile.Resolve+ extensions: DeriveDataTypeable,+ EmptyDataDecls,+ FlexibleInstances,+ GADTs,+ GeneralizedNewtypeDeriving,+ MagicHash,+ PatternGuards,+ RankNTypes,+ ScopedTypeVariables,+ TypeSynonymInstances,+ MultiParamTypeClasses,+ FunctionalDependencies+