hprotoc 1.0.1 → 1.2.1
raw patch · 5 files changed
+188/−161 lines, 5 filesdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
Files
- Text/ProtocolBuffers/ProtoCompile.hs +3/−4
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +173/−124
- Text/ProtocolBuffers/ProtoCompile/Parser.hs +1/−22
- Text/ProtocolBuffers/ProtoCompile/Resolve.hs +9/−9
- hprotoc.cabal +2/−2
Text/ProtocolBuffers/ProtoCompile.hs view
@@ -32,7 +32,7 @@ -- | Version of protocol-buffers. -- The version tags that I have used are ["unreleased"] version :: Version-version = Version { versionBranch = [1,0,0]+version = Version { versionBranch = [1,2,1] , versionTags = [] } data Options = Options { optPrefix :: [MName String]@@ -83,7 +83,7 @@ optionList :: [OptDescr OptionAction] optionList = [ Option ['a'] ["as"] (ReqArg (Mutate . setAs) "FILEPATH=MODULE")- "assign prefix module to imported prot file: --as decriptor.proto=Text"+ "assign prefix module to imported prot file: --as descriptor.proto=Text" , Option ['I'] ["proto_path"] (ReqArg (Mutate . setInclude) "DIR") "directory from which to search for imported proto files (default is pwd); all DIR searched" , Option ['d'] ["haskell_out"] (ReqArg (Mutate . setTarget) "DIR")@@ -178,9 +178,8 @@ run :: Options -> IO () run options = do- print options (env,fdps) <- loadProto (optInclude options) (optProto options)- print "Proto files loaded"+ print "All proto files loaded" let fdp = either error id . top'FDP . fst . getTLS $ env when (not (optDryRun options)) $ dump (optImports options) (optDesc options) fdp fdps nameMap <- either error return $ makeNameMaps (optPrefix options) (optAs options) env
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -1,11 +1,9 @@--- 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--- +-- This module uses the Reflection data structures (ProtoInfo,EnumInfo,DescriptorInfo) to+-- build an AST using Language.Haskell.Syntax. This get quite verbose, so a large number+-- of helper functions (and operators) are defined to aid in specifying the output code.+-- -- Note that this may eventually also generate hs-boot files to allow--- for breaking mutual recursion. This is ignored for getting--- descriptor.proto running.+-- for breaking mutual recursion. -- -- Mangling: For the current moment, assume the mangling is done in a prior pass: -- (*) Uppercase all module names and type names and enum constants@@ -15,15 +13,6 @@ -- 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@@ -32,7 +21,7 @@ import qualified Data.ByteString.Lazy.Char8 as LC(unpack) import qualified Data.Foldable as F(foldr,toList)-import Data.List(sortBy,foldl',foldl1')+import Data.List(sortBy,foldl',foldl1',sort) import Data.Function(on) import Language.Haskell.Pretty(prettyPrint) import Language.Haskell.Syntax@@ -57,6 +46,9 @@ src :: SrcLoc src = SrcLoc "No SrcLoc" 0 0 +litStr :: String -> HsExp+litStr = HsLit . HsString+ litIntP :: Integral x => x -> HsPat litIntP x | x<0 = HsPParen $ HsPLit (HsInt (toInteger x)) | otherwise = HsPLit (HsInt (toInteger x))@@ -68,18 +60,39 @@ typeApp :: String -> HsType -> HsType typeApp s = HsTyApp (HsTyCon (private s)) +private :: String -> HsQName+private t = Qual (Module "P'") (HsIdent t)++local :: String -> HsQName+local t = UnQual (HsIdent t)+ pvar :: String -> HsExp pvar t = HsVar (private t) +pcon :: String -> HsExp+pcon t = HsCon (private t)+ lvar :: String -> HsExp-lvar t = HsVar (UnQual (HsIdent t))+lvar t = HsVar (local t) -private :: String -> HsQName-private t = Qual (Module "P'") (HsIdent t)+lcon :: String -> HsExp+lcon t = HsCon (local t) +var :: String -> HsPat+var t = HsPVar (HsIdent t)++match :: String -> [HsPat] -> HsExp -> HsMatch+match s p r = HsMatch src (HsIdent s) p (HsUnGuardedRhs r) noWhere+ inst :: String -> [HsPat] -> HsExp -> HsDecl-inst s p r = HsFunBind [HsMatch src (HsIdent s) p (HsUnGuardedRhs r) noWhere]+inst s p r = HsFunBind [match s p r] +mkOp :: String -> HsExp -> HsExp -> HsExp+mkOp s a b = HsInfixApp a (HsQVarOp (UnQual (HsSymbol s))) b++compose :: HsExp -> HsExp -> HsExp+compose = mkOp "."+ fqMod :: ProtoName -> String fqMod (ProtoName _ a b c) = fmName $ foldr dotFM (promoteFM c) . map promoteFM $ a++b @@ -112,24 +125,20 @@ -------------------------------------------- -- 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 (fqMod protoName)) (Just [HsEThingAll (UnQual (baseIdent protoName))])- (standardImports False) (enumDecls ei)+ (standardImports True False) (enumDecls ei) enumDecls :: EnumInfo -> [HsDecl] enumDecls ei = map ($ ei) [ enumX , instanceMergeableEnum , instanceBounded- , instanceDefaultEnum- , instanceEnum+ , instanceDefaultEnum ]+ ++ declToEnum ei +++ map ($ ei) [ instanceEnum , instanceWireEnum , instanceGPB . enumName , instanceMessageAPI . enumName@@ -149,7 +158,7 @@ = 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)))+ set f (_,n) = inst f [] (lcon n) {- from google's descriptor.h, about line 346: @@ -165,37 +174,47 @@ [ inst "defaultValue" [] firstValue ] where firstValue :: HsExp firstValue = case enumValues ei of- (:) (_,n) _ -> HsCon (UnQual (HsIdent n))+ (:) (_,n) _ -> lcon n [] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei +declToEnum :: EnumInfo -> [HsDecl]+declToEnum ei = [ HsTypeSig src [HsIdent "toMaybe'Enum"]+ (HsQualType [] (HsTyFun (HsTyCon (private "Int"))+ (typeApp "Maybe" (HsTyCon (unqualName (enumName ei))))))+ , HsFunBind (map toEnum'one values ++ [final]) ]+ where values = enumValues ei+ toEnum'one (v,n) = match "toMaybe'Enum" [litIntP (getEnumCode v)] (pcon "Just" $$ lcon n)+ final = match "toMaybe'Enum" [HsPWildCard] (pcon "Nothing")+ 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'one (v,n) = match "fromEnum" [HsPApp (local n) []] (litInt (getEnumCode v))+ toEnum' = [ match "toEnum" [] (compose mayErr (lvar "toMaybe'Enum")) ]+ mayErr = pvar "fromMaybe" $$ (HsParen (pvar "error" $$ (litStr $ + "hprotoc generated code: toEnum failure for type "++ fqMod (enumName ei))))+ succ' = zipWith (equate "succ") values (tail values) +++ [ match "succ" [HsPWildCard] (pvar "error" $$ (litStr $ + "hprotoc generated code: succ failure for type "++ fqMod (enumName ei))) ]+ pred' = zipWith (equate "pred") (tail values) values +++ [ match "pred" [HsPWildCard] (pvar "error" $$ (litStr $ + "hprotoc generated code: pred failure for type "++ fqMod (enumName ei))) ]+ equate f (_,n1) (_,n2) = match f [HsPApp (local n1) []] (lcon n2) -- 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 withName foo = inst foo [var "ft'",var "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 "wireGetEnum" $$ lvar "toMaybe'Enum"+ withGetErr = inst "wireGet" [var "ft'"] rhs where rhs = pvar "wireGetErr" $$ lvar "ft'" instanceGPB :: ProtoName -> HsDecl@@ -208,28 +227,33 @@ [ inst "reflectEnum" [] ascList , inst "reflectEnumInfo" [ HsPWildCard ] ei' ] where (ProtoName xxx a b c) = enumName ei- xxx'Exp = HsParen $ pvar "pack" $$ HsLit (HsString (LC.unpack (utf8 (fiName xxx))))+ xxx'Exp = HsParen $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx))) 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 (HsVar (private "makePNF")) [ xxx'Exp, mList a, mList b, HsLit (HsString (mName c)) ]- where mList = HsList . map (HsLit . HsString . mName)+ where one (v,ns) = HsTuple [litInt (getEnumCode v),litStr ns,lcon ns]+ ei' = foldl' HsApp (pcon "EnumInfo") [protoNameExp+ ,HsList $ map litStr (enumFilePath ei)+ ,HsList (map two values)]+ where two (v,ns) = HsTuple [litInt (getEnumCode v),litStr ns]+ protoNameExp = HsParen $ foldl' HsApp (pvar "makePNF")+ [ xxx'Exp, mList a, mList b, litStr (mName c) ]+ where mList = HsList . map (litStr . mName) hasExt :: DescriptorInfo -> Bool hasExt di = not (null (extRanges di)) +--------------------------------------------+-- FileDescriptorProto module creation+--------------------------------------------+ protoModule :: ProtoInfo -> ByteString -> HsModule protoModule pri@(ProtoInfo protoName _ _ keyInfos _ _ _) fdpBS = let exportKeys = map (HsEVar . UnQual . baseIdent' . fieldName . snd) (F.toList keyInfos) exportNames = map (HsEVar . UnQual . HsIdent) ["protoInfo","fileDescriptorProto"] imports = protoImports ++ map formatImport (protoImport pri) in HsModule src (Module (fqMod protoName)) (Just (exportKeys++exportNames)) imports (keysX protoName keyInfos ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS)- where protoImports = standardImports (not . Seq.null . extensionKeys $ pri) +++ where protoImports = standardImports False (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@@ -253,23 +277,26 @@ 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+ where myType = HsTypeSig src [ HsIdent "protoInfo" ] (HsQualType [] (HsTyCon (local "ProtoInfo")))+ myValue = HsPatBind src (HsPApp (local "protoInfo") []) (HsUnGuardedRhs $+ pvar "read" $$ litStr (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 $+ where myType = HsTypeSig src [ HsIdent "fileDescriptorProto" ] (HsQualType [] (HsTyCon (local "FileDescriptorProto")))+ myValue = HsPatBind src (HsPApp (local "fileDescriptorProto") []) (HsUnGuardedRhs $ pvar "getFromBS" $$ HsParen (pvar "wireGet" $$ litInt 11) $$ - HsParen (pvar "pack" $$ HsLit (HsString (LC.unpack bs)))) noWhere+ HsParen (pvar "pack" $$ litStr (LC.unpack bs))) noWhere +--------------------------------------------+-- DescriptorProto module creation+-------------------------------------------- descriptorModule :: DescriptorInfo -> HsModule descriptorModule di = let protoName = descName di un = UnQual . baseIdent $ protoName- imports = standardImports (hasExt di) ++ map formatImport (toImport di)+ imports = standardImports False (hasExt di) ++ map formatImport (toImport di) exportKeys = map (HsEVar . UnQual . baseIdent' . fieldName . snd) (F.toList (keys di)) formatImport ((a,b),s) = HsImportDecl src (Module a) True asM (Just (False, map (HsIAbs . HsIdent) (S.toList s))) where asM | a==b = Nothing@@ -278,13 +305,15 @@ (Just (HsEThingAll un : exportKeys)) imports (descriptorX di : (keysX protoName (keys di) ++ instancesDescriptor di)) -standardImports :: Bool -> [HsImportDecl]-standardImports ext =+standardImports :: Bool -> Bool -> [HsImportDecl]+standardImports en 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) ["+"]+ where ops | ext = map (HsIVar . HsSymbol) $ base ++ ["==","<=","&&"," || "]+ | otherwise = map (HsIVar . HsSymbol) base+ base | en = ["+","."]+ | otherwise = ["+"] toImport :: DescriptorInfo -> [((String,String),S.Set String)] toImport di@@ -321,20 +350,21 @@ keyVal = HsPatBind src (HsPApp (UnQual (baseIdent' . fieldName $ f)) []) (HsUnGuardedRhs (pvar "Key" $$ litInt (getFieldId (fieldNumber f)) $$ litInt typeNumber- $$ maybe (pvar "Nothing") (HsParen . (pvar "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f)+ $$ 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'Bool b -> pcon (show b) HsDef'ByteString bs -> (if tc == 9 then (\xx -> HsParen (pvar "Utf8" $$ xx)) else id) $- (HsParen $ pvar "pack" $$ HsLit (HsString (LC.unpack bs)))+ (HsParen $ pvar "pack" $$ litStr (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)+ HsDef'Integer i -> litInt i + HsDef'Enum s -> HsParen $ pvar "read" $$ litStr s descriptorX :: DescriptorInfo -> HsDecl descriptorX di = HsDataDecl src [] name [] [con] derives@@ -377,23 +407,23 @@ instanceExtendMessage di = HsInstDecl src [] (private "ExtendMessage") [HsTyCon (UnQual (baseIdent (descName di)))] [ inst "getExtField" [] (lvar "ext'field")- , inst "putExtField" [HsPVar (HsIdent "e'f"),HsPVar (HsIdent "msg")] putextfield- , inst "validExtRanges" [ HsPVar (HsIdent "msg") ] (pvar "extRanges" $$ (HsParen $ pvar "reflectDescriptorInfo" $$ lvar "msg"))+ , inst "putExtField" [var "e'f", var "msg"] putextfield+ , inst "validExtRanges" [var "msg"] (pvar "extRanges" $$ (HsParen $ pvar "reflectDescriptorInfo" $$ lvar "msg")) ]- where putextfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "ext'field")) (lvar "e'f") ]+ where putextfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (local "ext'field") (lvar "e'f") ] instanceUnknownMessage :: DescriptorInfo -> HsDecl instanceUnknownMessage di = HsInstDecl src [] (private "UnknownMessage") [HsTyCon (UnQual (baseIdent (descName di)))] [ inst "getUnknownField" [] (lvar "unknown'field")- , inst "putUnknownField" [HsPVar (HsIdent "u'f"),HsPVar (HsIdent "msg")] putunknownfield+ , inst "putUnknownField" [var "u'f",var "msg"] putunknownfield ]- where putunknownfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (UnQual (HsIdent "unknown'field")) (lvar "u'f") ]+ where putunknownfield = HsRecUpdate (lvar "msg") [ HsFieldUpdate (local "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 "mergeEmpty" [] (foldl' HsApp (HsCon un) (replicate len (pcon "mergeEmpty"))) , inst "mergeAppend" [HsPApp un patternVars1, HsPApp un patternVars2] (foldl' HsApp (HsCon un) (zipWith append vars1 vars2)) ]@@ -403,9 +433,9 @@ $ Seq.length (fields di) patternVars1,patternVars2 :: [HsPat] patternVars1 = take len inf- where inf = map (\n -> HsPVar (HsIdent ("x'" ++ show n))) [1..]+ where inf = map (\n -> var ("x'" ++ show n)) [1..] patternVars2 = take len inf- where inf = map (\n -> HsPVar (HsIdent ("y'" ++ show n))) [1..]+ where inf = map (\n -> var ("y'" ++ show n)) [1..] vars1,vars2 :: [HsExp] vars1 = take len inf where inf = map (\n -> lvar ("x'" ++ show n)) [1..]@@ -430,17 +460,15 @@ Just hsdef -> defToSyntax (typeCode fi) hsdef dv2 = case hsDefault fi of Nothing -> pvar "defaultValue"- Just hsdef -> HsParen $ HsCon (private "Just") $$ defToSyntax (typeCode fi) hsdef+ Just hsdef -> HsParen $ pcon "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'")) ]+ = HsInstDecl src [] (private "MessageAPI")+ [HsTyVar (HsIdent "msg'"), HsTyFun (HsTyVar (HsIdent "msg'")) (HsTyCon un), (HsTyCon un)]+ [ inst "getVal" [var "m'",var "f'"] (HsApp (lvar "f'" ) (lvar "m'")) ] where un = UnQual (baseIdent 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@@ -451,7 +479,7 @@ 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..]+ mine = HsPApp me . take len . map (\n -> var ("x'" ++ show n)) $ [1..] vars = take len . map (\n -> lvar ("x'" ++ show n)) $ [1..] mExt | extensible = Just (vars !! Seq.length fieldInfos) | otherwise = Nothing@@ -461,13 +489,13 @@ -- 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+ , 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]]+ whereCalcSize = [inst "calc'Size" [] sizes] sizes | null sizesList = HsLit (HsInt 0) | otherwise = HsParen (foldl1' (+!) sizesList) where (+!) = mkOp "+"@@ -489,7 +517,7 @@ (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]]+ wherePutFields = [inst "put'Fields" [] (HsDo putStmts)] putStmts = putStmtsContent where putStmtsContent | null putStmtsAll = [HsQualifier $ pvar "return" $$ HsCon (Special HsUnitCon)] | otherwise = putStmtsAll@@ -511,64 +539,85 @@ , var] getCases = HsUnGuardedRhs $ cases- (pvar "getBareMessageWith" $$ otherField $$ lvar "update'Self")- (pvar "getMessageWith" $$ otherField $$ lvar "update'Self")+ (pvar "getBareMessageWith" $$ lvar "check'allowed")+ (pvar "getMessageWith" $$ lvar "check'allowed") (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)+ whereDecls = [whereUpdateSelf,whereAllowed,whereCheckAllowed]+ whereAllowed = inst "allowed'wire'Tags" [] (pvar "fromDistinctAscList" $$ HsList (map litInt allowed))+ allowed = sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di)] +++ [ getWireTag (wireTag f) | f <- F.toList (knownKeys di)]+ locals = ["wire'Tag","field'Number","wire'Type","old'Self"]+ whereCheckAllowed = inst "check'allowed" (map var locals) process+ where process = if storeUnknown di then catchUn updateBranch else updateBranch+ catchUn s = pvar "catchError" $$ HsParen s+ $$ HsParen (HsLambda src [HsPWildCard] (args (pvar "loadUnknown")))+ updateBranch | null allowed = extBranch+ | otherwise = HsIf (pvar "member" $$ lvar "wire'Tag" $$ lvar "allowed'wire'Tags")+ (lvar "update'Self" $$ lvar "field'Number" $$ lvar "old'Self")+ extBranch+ extBranch | extensible = HsIf (isAllowedExt (lvar "field'Number"))+ (args (pvar "loadExtension"))+ unknownBranch+ | otherwise = unknownBranch+ unknownBranch =args (pvar "unknown")+ args x = x $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self"+ isAllowedExt x = pvar "or" $$ HsList ranges where+ (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp ("==")+ ranges = map (\(FieldId lo,FieldId hi) -> if hi < maxHi+ then if lo == hi+ then (x ==! litInt lo)+ else (litInt lo <=! x) &&! (x <=! litInt hi) else litInt lo <=! x) allowedExts where FieldId maxHi = maxBound+ whereUpdateSelf = inst "update'Self" [var "field'Number", var "old'Self"]+ (HsCase (lvar "field'Number") updateAlts) 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]+ pvar "unknownField" $$ (lvar "old'Self") $$ (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 . baseIdent' . fieldName $ fi)- (labelUpdate fi)])+ pvar "fmap" $$ (HsParen $ HsLambda src [var "new'Field"] $+ HsRecUpdate (lvar "old'Self")+ [HsFieldUpdate (UnQual . baseIdent' . fieldName $ fi)+ (labelUpdate fi)]) $$ (HsParen (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere- labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . fName . baseName' . fieldName $ fi) $$ lvar "old'Self")+ labelUpdate fi | canRepeat fi = pvar "append" $$ HsParen ((lvar . fName . baseName' . fieldName $ fi)+ $$ lvar "old'Self") $$ lvar "new'Field" | isRequired fi = qMerge (lvar "new'Field")- | otherwise = qMerge (HsCon (private "Just") $$ lvar "new'Field")+ | otherwise = qMerge (pcon "Just" $$ lvar "new'Field") where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,11] =- pvar "mergeAppend" $$ HsParen ((lvar . fName . baseName' . fieldName $ fi) $$ lvar "old'Self") $$ (HsParen x)+ pvar "mergeAppend" $$ HsParen ( (lvar . fName . baseName' . fieldName $ fi)+ $$ lvar "old'Self" )+ $$ HsParen x | otherwise = x-+ -- in the above, the [10,11] check optimizes using the+ -- knowledge that only TYPE_MESSAGE and TYPE_GROUP have merges+ -- that are not right-biased replacements. The "append" uses+ -- knowledge of how all repeated fields get merged. 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]+ [ HsFunBind [HsMatch src (HsIdent "wireSize") [var "ft'",HsPAsPat (HsIdent "self'") (HsPParen mine)] sizeCases whereCalcSize]+ , HsFunBind [HsMatch src (HsIdent "wirePut") [var "ft'",HsPAsPat (HsIdent "self'") (HsPParen mine)] putCases wherePutFields]+ , HsFunBind [HsMatch src (HsIdent "wireGet") [var "ft'"] getCases whereDecls] ] --- TODO : Encode allow as a proper set of numbers! instanceReflectDescriptor :: DescriptorInfo -> HsDecl instanceReflectDescriptor di = HsInstDecl src [] (private "ReflectDescriptor") [HsTyCon (UnQual (baseIdent (descName di)))]- [ inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ]+ [ inst "getMessageInfo" [HsPWildCard] gmi+ , inst "reflectDescriptorInfo" [ HsPWildCard ] rdi ] where -- massive shortcut through show and read rdi :: HsExp- rdi = pvar "read" $$ HsLit (HsString (show di))+ rdi = pvar "read" $$ litStr (show di) -- cheat using show and read+ gmi,reqId,allId :: HsExp+ gmi = pcon "GetMessageInfo" $$ HsParen reqId $$ HsParen allId+ reqId = pvar "fromDistinctAscList" $$+ HsList (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di), isRequired f])+ allId = pvar "fromDistinctAscList" $$+ HsList (map litInt . sort $ [ getWireTag (wireTag f) | f <- F.toList (fields di)] +++ [ getWireTag (wireTag f) | f <- F.toList (knownKeys di)]) ------------------------------------------------------------------
Text/ProtocolBuffers/ProtoCompile/Parser.hs view
@@ -6,7 +6,7 @@ -- -- The inernals have been updated to handle Google's protobuf version -- 2.0.2 formats.-module Text.ProtocolBuffers.ProtoCompile.Parser(parseProto,isValidUTF8) where+module Text.ProtocolBuffers.ProtoCompile.Parser(parseProto) where import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto) import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))@@ -53,7 +53,6 @@ import Text.ProtocolBuffers.ProtoCompile.Instances(parseLabel,parseType) import Control.Monad(when,liftM2,liftM3,replicateM)-import qualified Data.ByteString.Lazy as L(unpack) import qualified Data.ByteString.Lazy.Char8 as LC(notElem,head) import qualified Data.ByteString.Lazy.UTF8 as U(fromString,toString) import Data.Char(isUpper,toLower)@@ -66,7 +65,6 @@ ,getInput,setInput,getPosition,setPosition,getState,setState ,(<?>),(<|>),token,choice,between,eof,unexpected,skipMany) import Text.ParserCombinators.Parsec.Pos(newPos)-import Data.Word(Word8) -- import Debug.Trace(trace) @@ -388,25 +386,6 @@ 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 fieldOption :: Maybe Type -> P D.FieldDescriptorProto () fieldOption mt = liftM2 (,) pOptionE getOld >>= setOption >>= setNew where
Text/ProtocolBuffers/ProtoCompile/Resolve.hs view
@@ -245,7 +245,7 @@ , "which parses as "++show (isGlobal,xs) , "in environment: "++(whereEnv envIn) , "allowed: "++show (allowed envIn)]- Just e@(E'Error {}) -> throw (show e)+ Just (E'Error s _es) -> throw s Just e -> return e resolveRE :: Utf8 -> RE Entity@@ -267,7 +267,7 @@ expectMGE :: Either ErrStr Entity -> Either ErrStr Entity expectMGE ee@(Left {}) = ee expectMGE ee@(Right e) = if isMGE e then ee- else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow e+ else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e) -- cannot show all of "e" because this will loop and hang the hprotoc program where isMGE e' = case e' of E'Message {} -> True E'Group {} -> True E'Enum {} -> True@@ -277,7 +277,7 @@ expectM :: Either ErrStr Entity -> Either ErrStr Entity expectM ee@(Left {}) = ee expectM ee@(Right e) = if isMGE e then ee- else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e)+ else Left $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e) -- cannot show all of "e" because this will loop and hang the hprotoc program where isMGE e' = case e' of E'Message {} -> True _ -> False @@ -515,7 +515,7 @@ return (self,entity) entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,Entity)-entityField isKey fdp = annErr ("entityField "++show fdp) $ do+entityField isKey fdp = annErr ("entityField "++show (D.FieldDescriptorProto.name fdp)) $ do (self,names) <- getNames "entityField.name" D.FieldDescriptorProto.name fdp let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp) when (isKey/=isKey') $@@ -551,7 +551,7 @@ return () entityService :: D.ServiceDescriptorProto -> SE (IName String,Entity)-entityService sdp = mdo+entityService sdp = annErr ("entityService "++show (D.ServiceDescriptorProto.name sdp)) $ mdo (self,names) <- getNames "entityService.name" D.ServiceDescriptorProto.name sdp let entity = E'Service names (M.fromListWithKey unique methods) (badMethods,methods) <- descend names entity $@@ -589,7 +589,7 @@ fqFail :: Show a => String -> a -> Entity -> RE b fqFail msg dp entity = do env <- ask- throw $ unlines [ msg, "resolving: "++show dp, "in environment: "++whereEnv env, "found: "++show entity ]+ throw $ unlines [ msg, "resolving: "++show dp, "in environment: "++whereEnv env, "found: "++show (eName entity) ] fqFileDP :: D.FileDescriptorProto -> RE D.FileDescriptorProto fqFileDP fdp = do@@ -603,7 +603,7 @@ , D.FileDescriptorProto.extension = newKeys } fqMessage :: D.DescriptorProto -> RE D.DescriptorProto-fqMessage dp = do+fqMessage dp = annErr ("fqMessage "++show (D.DescriptorProto.name dp)) $ do entity <- resolveRE =<< getJust "fqMessage.name" (D.DescriptorProto.name dp) case entity of E'Message {} -> return ()@@ -620,7 +620,7 @@ , D.DescriptorProto.enum_type = newEnums } fqService :: D.ServiceDescriptorProto -> RE D.ServiceDescriptorProto-fqService sdp = do+fqService sdp = annErr ("fqService "++show (D.ServiceDescriptorProto.name sdp)) $ do entity <- resolveRE =<< getJust "fqService.name" (D.ServiceDescriptorProto.name sdp) case entity of E'Service {} -> do newMethods <- local (Local entity) $ T.mapM fqMethod (D.ServiceDescriptorProto.method sdp)@@ -648,7 +648,7 @@ -- TYPE_ENUM, and if it is the latter then any default value string is -- checked for validity. fqField :: Bool -> D.FieldDescriptorProto -> RE D.FieldDescriptorProto-fqField isKey fdp = annErr ("fqField "++show fdp) $ do+fqField isKey fdp = annErr ("fqField "++show (D.FieldDescriptorProto.name fdp)) $ do let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp) when (isKey/=isKey') $ ask >>= \env -> throwError $ "fqField.isKey: Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),whereEnv env,fdp)
hprotoc.cabal view
@@ -1,6 +1,6 @@ name: hprotoc -- Synchronize this version number with Text.ProtocolBuffers.ProtocolCompile.version-version: 1.0.1+version: 1.2.1 cabal-version: >= 1.2 build-type: Simple license: BSD3@@ -25,7 +25,7 @@ Main-Is: Text/ProtocolBuffers/ProtoCompile.hs build-tools: alex ghc-options: -Wall- build-depends: protocol-buffers == 1.0.1, protocol-buffers-descriptor == 1.0.1+ build-depends: protocol-buffers == 1.2.1, protocol-buffers-descriptor == 1.2.1 build-depends: binary, utf8-string build-depends: parsec, haskell-src, containers,bytestring,array,filepath,directory,mtl,QuickCheck