diff --git a/Text/ProtocolBuffers/ProtoCompile.hs b/Text/ProtocolBuffers/ProtoCompile.hs --- a/Text/ProtocolBuffers/ProtoCompile.hs +++ b/Text/ProtocolBuffers/ProtoCompile.hs @@ -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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Gen.hs b/Text/ProtocolBuffers/ProtoCompile/Gen.hs --- a/Text/ProtocolBuffers/ProtoCompile/Gen.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Gen.hs @@ -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)]) ------------------------------------------------------------------ diff --git a/Text/ProtocolBuffers/ProtoCompile/Parser.hs b/Text/ProtocolBuffers/ProtoCompile/Parser.hs --- a/Text/ProtocolBuffers/ProtoCompile/Parser.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Parser.hs @@ -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 diff --git a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs --- a/Text/ProtocolBuffers/ProtoCompile/Resolve.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Resolve.hs @@ -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) diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -1,6 +1,6 @@ name: hprotoc -- Synchronize this version number with Text.ProtocolBuffers.ProtocolCompile.version -version: 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