hprotoc 2.1.9 → 2.1.11
raw patch · 4 files changed
+107/−18 lines, 4 filesdep ~protocol-buffersdep ~protocol-buffers-descriptor
Dependency ranges changed: protocol-buffers, protocol-buffers-descriptor
Files
- Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +5/−1
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +92/−10
- Text/ProtocolBuffers/ProtoCompile/Identifiers.hs +5/−2
- hprotoc.cabal +5/−5
Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {-| Analysis and design of this module If there are SCCs then additional files are inevitable.@@ -109,12 +111,14 @@ import qualified Data.Map as Map import Data.Map(Map) import Data.Maybe(mapMaybe)-import Data.Monoid import qualified Data.Set as Set import Data.Set(Set) import Text.ProtocolBuffers.Basic import Text.ProtocolBuffers.Identifiers import Text.ProtocolBuffers.Reflections+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif import Debug.Trace(trace)
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns, RecordWildCards, CPP #-} -- 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.@@ -53,8 +53,13 @@ nubSort :: Ord a => [a] -> [a] nubSort = map head . group . sort +#if MIN_VERSION_haskell_src_exts(1, 17, 0)+noWhere :: Maybe Binds+noWhere = Nothing+#else noWhere :: Binds noWhere = BDecls []+#endif ($$) :: Exp -> Exp -> Exp ($$) = App@@ -165,9 +170,14 @@ m1 = ModuleName (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn])) m2 = ModuleName (joinMod (parentModule pn)) fromSource = S.member (FMName self,part,o) (rIBoot r)+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ iabs = IAbs NoNamespace (Ident (mName (baseName pn)))+#else+ iabs = IAbs (Ident (mName (baseName pn)))+#endif ans = if m1 == selfMod && part /= KeyFile then Nothing else Just $ ImportDecl src m1 True fromSource False Nothing (Just m2)- (Just (False,[IAbs (Ident (mName (baseName pn)))]))+ (Just (False,[iabs])) in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $ [("selfMod",show selfMod) ,("part",show part)@@ -184,7 +194,11 @@ let o@(FMName _other) = pfKey pfn m1@(ModuleName m1') = ModuleName (joinMod (haskellPrefix' pfn ++ parentModule' pfn)) m2 = ModuleName (joinMod (parentModule' pfn))+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ spec = Just (False,[IVar (Ident (fName (baseName' pfn)))])+#else spec = Just (False,[IVar NoNamespace (Ident (fName (baseName' pfn)))])+#endif kind = getKind r o fromAlt = S.member (FMName self,FMName m1') (rIKey r) m1key = if kind == SplitKeyTypeBoot && fromAlt@@ -406,8 +420,13 @@ = let protoName = protoMod pri (extendees,myKeys) = unzip $ F.toList (extensionKeys pri) m = ModuleName (fqMod protoName)+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ exportKeys = map (EVar . unqualFName . fieldName) myKeys+ exportNames = map (EVar . UnQual . Ident) ["protoInfo","fileDescriptorProto"]+#else exportKeys = map (EVar NoNamespace . unqualFName . fieldName) myKeys exportNames = map (EVar NoNamespace . UnQual . Ident) ["protoInfo","fileDescriptorProto"]+#endif imports = (protoImports ++) . mergeImports $ mapMaybe (importPN result m Normal) $ extendees ++ mapMaybe typeName myKeys@@ -415,11 +434,24 @@ (keysXTypeVal protoName (extensionKeys pri) ++ embed'ProtoInfo pri ++ embed'fdpBS fdpBS) where protoImports = standardImports False (not . Seq.null . extensionKeys $ pri) False ++ [ ImportDecl src (ModuleName "Text.DescriptorProtos.FileDescriptorProto") False False False Nothing Nothing+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ (Just (False,[IAbs NoNamespace (Ident "FileDescriptorProto")]))+#else (Just (False,[IAbs (Ident "FileDescriptorProto")]))+#endif , ImportDecl src (ModuleName "Text.ProtocolBuffers.Reflections") False False False Nothing Nothing+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ (Just (False,[IAbs NoNamespace (Ident "ProtoInfo")]))+#else (Just (False,[IAbs (Ident "ProtoInfo")]))+#endif , ImportDecl src (ModuleName "Text.ProtocolBuffers.WireMessage") True False False Nothing (Just (ModuleName "P'"))- (Just (False,[IVar NoNamespace (Ident "wireGet,getFromBS")])) ]+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ (Just (False,[IVar (Ident "wireGet,getFromBS")]))+#else+ (Just (False,[IVar NoNamespace (Ident "wireGet,getFromBS")]))+#endif+ ] embed'ProtoInfo :: ProtoInfo -> [Decl] embed'ProtoInfo pri = [ myType, myValue ]@@ -465,7 +497,12 @@ [TyVar (Ident "msg'"), TyFun (TyVar (Ident "msg'")) (TyCon un), (TyCon un)] [] dataDecl = DataDecl src DataType [] (baseIdent protoName) [] [] [] mkInst s = InstDecl src Nothing [] [] s [TyCon un] []- in Module src (ModuleName (fqMod protoName)) (modulePragmas $ makeLenses di) Nothing (Just [EAbs un]) minimalImports+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ eabs = EAbs NoNamespace un+#else+ eabs = EAbs un+#endif+ in Module src (ModuleName (fqMod protoName)) (modulePragmas $ makeLenses di) Nothing (Just [eabs]) minimalImports (dataDecl : instMesAPI : map mkInst classes) -- This builds on the output of descriptorBootModule and declares a hs-boot that@@ -474,7 +511,11 @@ descriptorKeyBootModule result di = let Module p1 m@(ModuleName _self) p3 p4 (Just exports) imports decls = descriptorBootModule di (extendees,myKeys) = unzip $ F.toList (keys di)+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ exportKeys = map (EVar . unqualFName . fieldName) myKeys+#else exportKeys = map (EVar NoNamespace . unqualFName . fieldName) myKeys+#endif importTypes = mergeImports . mapMaybe (importPN result m Source) . nubSort $ extendees ++ mapMaybe typeName myKeys declKeys = keysXType (descName di) (keys di)@@ -487,7 +528,11 @@ (extendees,myKeys) = unzip $ F.toList (keys di) mBase = ModuleName (fqMod (descName di)) m = ModuleName (fqMod protoName'Key)+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ exportKeys = map (EVar . unqualFName . fieldName) myKeys+#else exportKeys = map (EVar NoNamespace . unqualFName . fieldName) myKeys+#endif importTypes = mergeImports . mapMaybe (importPN result mBase KeyFile) . nubSort $ extendees ++ mapMaybe typeName myKeys declKeys = keysXTypeVal protoName'Key (keys di)@@ -504,7 +549,11 @@ extendees' = if sepKey then [] else extendees myKeys' = if sepKey then [] else myKeys m = ModuleName (fqMod protoName)+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ exportKeys = map (EVar . unqualFName . fieldName) myKeys+#else exportKeys = map (EVar NoNamespace . unqualFName . fieldName) myKeys+#endif imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $ [ mapMaybe (importPN result m Normal) $ extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di)))@@ -520,8 +569,12 @@ exportLenses :: DescriptorInfo -> [ExportSpec] exportLenses di = if makeLenses di- then map (EVar NoNamespace . unqualFName . stripPrefix . fieldName)- (F.toList (fields di))+ then+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ map (EVar . unqualFName . stripPrefix . fieldName) (F.toList (fields di))+#else+ map (EVar NoNamespace . unqualFName . stripPrefix . fieldName) (F.toList (fields di))+#endif else [] where stripPrefix pfn = pfn { baseNamePrefix' = "" } @@ -539,8 +592,14 @@ , ImportDecl src (ModuleName "Data.Typeable") True False False Nothing (Just (ModuleName "Prelude'")) Nothing , ImportDecl src (ModuleName "Data.Data") True False False Nothing (Just (ModuleName "Prelude'")) Nothing , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName "P'")) Nothing ] ++ lensTH- where ops | ext = map (IVar NoNamespace . Symbol) $ base ++ ["==","<=","&&"]+ where+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ ops | ext = map (IVar . Symbol) $ base ++ ["==","<=","&&"]+ | otherwise = map (IVar . Symbol) base+#else+ ops | ext = map (IVar NoNamespace . Symbol) $ base ++ ["==","<=","&&"] | otherwise = map (IVar NoNamespace . Symbol) base+#endif base | isEnumMod = ["+","/","."] | otherwise = ["+","/"] lensTH | lenses = [ImportDecl src (ModuleName "Control.Lens.TH") True False False Nothing Nothing Nothing]@@ -665,9 +724,15 @@ instanceTextMsg di = InstDecl src Nothing [] [] (private "TextMsg") [TyCon (unqualName (descName di))] [ inst "textPut" [patvar msgVar] genPrintFields- , InsDecl $ FunBind [Match src (Ident "textGet") [] Nothing (UnGuardedRhs parser) (BDecls subparsers)]+ , InsDecl $ FunBind [Match src (Ident "textGet") [] Nothing (UnGuardedRhs parser) bdecls] ]- where flds = F.toList (fields di)+ where+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ bdecls = Just (BDecls subparsers)+#else+ bdecls = BDecls subparsers+#endif+ flds = F.toList (fields di) msgVar = distinctVar "msg" distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var reservedVars = map toPrintName flds@@ -780,7 +845,11 @@ sizeCases = UnGuardedRhs $ cases (lvar "calc'Size") (pvar "prependMessageSize" $$ lvar "calc'Size") (pvar "wireSizeErr" $$ lvar "ft'" $$ lvar "self'")+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ whereCalcSize = Just (BDecls [defun "calc'Size" [] sizes])+#else whereCalcSize = BDecls [defun "calc'Size" [] sizes]+#endif sizes | null sizesList = Lit (Hse.Int 0) | otherwise = Paren (foldl1' (+!) sizesList) where (+!) = mkOp "+"@@ -804,7 +873,11 @@ (Paren $ foldl' App (pvar "wireSize") [ litInt' 10 , lvar "self'" ]) , Qualifier $ lvar "put'Fields" ]) (pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'")+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ wherePutFields = Just (BDecls [defun "put'Fields" [] (Do putStmts)])+#else wherePutFields = BDecls [defun "put'Fields" [] (Do putStmts)]+#endif putStmts = putStmtsContent where putStmtsContent | null putStmtsAll = [Qualifier $ preludevar "return" $$ Con (Special UnitCon)] | otherwise = putStmtsAll@@ -833,7 +906,11 @@ in UnGuardedRhs $ cases (pvar "getBareMessageWith" $$ param) (pvar "getMessageWith" $$ param) (pvar "wireGetErr" $$ lvar "ft'")+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ whereDecls = Just (BDecls [whereUpdateSelf])+#else whereDecls = BDecls [whereUpdateSelf]+#endif whereUpdateSelf = defun "update'Self" [patvar "wire'Tag", patvar "old'Self"] (Case (lvar "wire'Tag") updateAlts) -- update cases are all normal fields then all known extensions then wildcard@@ -843,13 +920,18 @@ -- the wildcard alternative handles new extensions and wildcardAlt = letPair extBranch where letPair = Let (BDecls [PatBind src (PTuple Boxed [patvar "field'Number",patvar "wire'Type"])- (UnGuardedRhs (pvar "splitWireTag" $$ lvar "wire'Tag")) (BDecls [])])+ (UnGuardedRhs (pvar "splitWireTag" $$ lvar "wire'Tag")) bdecls]) extBranch | extensible = If (isAllowedExt (lvar "field'Number")) (argPair (pvar "loadExtension")) unknownBranch | otherwise = unknownBranch unknownBranch = argPair (pvar "unknown") argPair x = x $$ lvar "field'Number" $$ lvar "wire'Type" $$ lvar "old'Self"+#if MIN_VERSION_haskell_src_exts(1, 17, 0)+ bdecls = Nothing+#else+ bdecls = BDecls []+#endif isAllowedExt x = preludevar "or" $$ List ranges where (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp "=="; (FieldId maxHi) = maxBound ranges = map (\ (FieldId lo,FieldId hi) ->
Text/ProtocolBuffers/ProtoCompile/Identifiers.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,TypeSynonymInstances,FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,TypeSynonymInstances,FlexibleContexts,CPP #-}+ -- | This modules collects utility routines related to the different -- incarnations of identifiers in the code. The basic identifier is -- always ASCII, but because of the self gereneted DescriptorProto@@ -21,10 +22,12 @@ import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char import Data.List hiding (uncons)-import Data.Monoid import Data.Set(Set) import qualified Data.Set as S import Text.ProtocolBuffers.Basic+#if __GLASGOW_HASKELL__ < 710+import Data.Monoid+#endif -- | Contains one identifier name newtype IName a = IName {iName::a} deriving (Show,Read,Eq,Ord)
hprotoc.cabal view
@@ -1,5 +1,5 @@ name: hprotoc-version: 2.1.9+version: 2.1.11 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -20,8 +20,8 @@ location: git://github.com/k-bx/protocol-buffers.git Executable hprotoc- build-depends: protocol-buffers == 2.1.9,- protocol-buffers-descriptor == 2.1.9+ build-depends: protocol-buffers == 2.1.11,+ protocol-buffers-descriptor == 2.1.11 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell@@ -69,8 +69,8 @@ TypeSynonymInstances Library- build-depends: protocol-buffers == 2.1.9,- protocol-buffers-descriptor == 2.1.9+ build-depends: protocol-buffers == 2.1.11,+ protocol-buffers-descriptor == 2.1.11 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex