diff --git a/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs --- a/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs +++ b/Text/ProtocolBuffers/ProtoCompile/BreakRecursion.hs @@ -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) 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,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) -> diff --git a/Text/ProtocolBuffers/ProtoCompile/Identifiers.hs b/Text/ProtocolBuffers/ProtoCompile/Identifiers.hs --- a/Text/ProtocolBuffers/ProtoCompile/Identifiers.hs +++ b/Text/ProtocolBuffers/ProtoCompile/Identifiers.hs @@ -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) diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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