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 @@ -577,7 +577,10 @@ descriptorBootModule di = let protoName = descName di un = unqualName protoName - classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Typeable",prelude "Data", prelude "Generic" + classes = [prelude "Show",prelude "Eq",prelude "Ord",prelude "Data", prelude "Generic" +#if __GLASGOW_HASKELL__ < 780 + ,prelude "Typeable" +#endif ,private "Mergeable",private "Default" ,private "Wire",private "GPB",private "ReflectDescriptor" , private "TextType", private "TextMsg" @@ -586,7 +589,12 @@ ++ if storeUnknown di then [private "UnknownMessage"] else [] instMesAPI = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI") [TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) Nothing - dataDecl = DataDecl () (DataType ()) Nothing (DHead () (baseIdent protoName)) [] mzero + dataDecl = DataDecl () (DataType ()) Nothing (DHead () (baseIdent protoName)) [] $ +#if __GLASGOW_HASKELL__ >= 780 + pure derivesTypeable +#else + mzero +#endif mkInst s = InstDecl () Nothing (mkSimpleIRule s [TyCon () un]) Nothing eabs = EAbs () (NoNamespace ()) un in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing (Just (ExportSpecList () [eabs])))) (modulePragmas $ makeLenses di) minimalImports @@ -1003,17 +1011,24 @@ -- wirePut generation putCases = UnGuardedRhs () $ cases (lvar "put'Fields") - (Do () [ Qualifier () $ pvar "putSize" $$ - (Paren () $ foldl' (App ()) (pvar "wireSize") [ litInt' 10 , lvar "self'" ]) - , Qualifier () $ lvar "put'Fields" ]) + (lvar "put'FieldsSized") (pvar "wirePutErr" $$ lvar "ft'" $$ lvar "self'") - wherePutFields = Just (BDecls () [defun "put'Fields" [] (Do () putStmts)]) - putStmts = putStmtsContent - where putStmtsContent | null putStmtsAll = [Qualifier () $ preludevar "return" $$ Con () (Special () (UnitCon ()))] - | otherwise = putStmtsAll - putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ Qualifier () $ pvar "wirePutUnknownField" $$ v ] - | otherwise = putStmtsListExt - putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ Qualifier () $ pvar "wirePutExtField" $$ v ] + wherePutFields = Just (BDecls () + [ defun "put'Fields" [] (pvar "sequencePutWithSize" $$ List () putStmts) + , defun "put'FieldsSized" [] $ + Let () (BDecls () + [ defun "size'" [] (preludevar "fst" $$ Paren () (pvar "runPutM" $$ lvar "put'Fields")) + , defun "put'Size" [] + (Do () [ Qualifier () $ pvar "putSize" $$ lvar "size'" + , Qualifier () $ preludevar "return" $$ Paren () (pvar "size'WireSize" $$ lvar "size'") + ]) + ]) + (pvar "sequencePutWithSize" $$ List () [lvar "put'Size", lvar "put'Fields"]) + ]) + putStmts = putStmtsAll + where putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ pvar "wirePutUnknownFieldWithSize" $$ v ] + | otherwise = putStmtsListExt + putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ pvar "wirePutExtFieldWithSize" $$ v ] | otherwise = sortedPutStmtsList sortedPutStmtsList = map snd -- remove number . sortBy (compare `on` fst) -- sort by number @@ -1021,23 +1036,21 @@ putStmtsList = concat . zipWith toPut vars . F.toList $ fmap Left fieldInfos >< fmap Right oneofInfos toPut var (Left fi) - = let f = if isPacked fi then "wirePutPacked" - else if isRequired fi then "wirePutReq" - else if canRepeat fi then "wirePutRep" - else "wirePutOpt" + = let f = if isPacked fi then "wirePutPackedWithSize" + else if isRequired fi then "wirePutReqWithSize" + else if canRepeat fi then "wirePutRepWithSize" + else "wirePutOptWithSize" in [(fieldNumber fi, - Qualifier () $ foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi)) , litInt (getFieldType (typeCode fi)) , var] )] - toPut var (Right oi) = map (toPut' var) . F.toList . oneofFields $ oi - where toPut' var r@(n,fi) - = let f = "wirePutOpt" + toPut var (Right oi) = map toPut' . F.toList . oneofFields $ oi + where toPut' r@(_n,fi) + = let f = "wirePutOptWithSize" var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var in (fieldNumber fi - ,Qualifier () $ - foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi)) + , foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi)) , litInt (getFieldType (typeCode fi)) , var'] ) @@ -1171,7 +1184,7 @@ in InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () me]) . Just . map (InsDecl ()) $ [ FunBind () [Match () (Ident () "wireSize") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] sizeCases whereCalcSize] - , FunBind () [Match () (Ident () "wirePut") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] putCases wherePutFields] + , FunBind () [Match () (Ident () "wirePutWithSize") [patvar "ft'",PAsPat () (Ident () "self'") (PParen () mine)] putCases wherePutFields] , FunBind () [Match () (Ident () "wireGet") [patvar "ft'"] getCases whereDecls] ] @@ -1207,9 +1220,10 @@ mkDeriving xs = Deriving () (map (\x -> mkSimpleIRule x []) xs) #endif -derives,derivesEnum :: Deriving () +derives,derivesEnum,derivesTypeable :: Deriving () derives = mkDeriving $ map prelude ["Show","Eq","Ord","Typeable","Data","Generic"] derivesEnum = mkDeriving $ map prelude ["Read","Show","Eq","Ord","Typeable","Data","Generic"] +derivesTypeable = mkDeriving $ [prelude "Typeable"] -- All of these type names are also exported by Text.ProtocolBuffers.Header via Text.ProtocolBuffers.Basic useType :: Int -> Maybe String diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -1,12 +1,12 @@ name: hprotoc -version: 2.4.10 +version: 2.4.11 cabal-version: >= 1.6 build-type: Simple license: BSD3 license-file: LICENSE copyright: (c) 2008-2015 Christopher Edward Kuklewicz author: Christopher Edward Kuklewicz -maintainer: Kostiantyn Rybnikov +maintainer: Timo von Holtz , Kostiantyn Rybnikov homepage: https://github.com/k-bx/protocol-buffers package-url: http://hackage.haskell.org/package/hprotoc synopsis: Parse Google Protocol Buffer specifications @@ -20,8 +20,8 @@ location: git://github.com/k-bx/protocol-buffers.git Executable hprotoc - build-depends: protocol-buffers == 2.4.10, - protocol-buffers-descriptor == 2.4.10 + build-depends: protocol-buffers == 2.4.11, + protocol-buffers-descriptor == 2.4.11 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell @@ -55,7 +55,7 @@ Text.ProtocolBuffers.ProtoCompile.Resolve extensions: DeriveDataTypeable, EmptyDataDecls, - FlexibleContexts + FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, @@ -69,8 +69,8 @@ TypeSynonymInstances Library - build-depends: protocol-buffers == 2.4.10, - protocol-buffers-descriptor == 2.4.10 + build-depends: protocol-buffers == 2.4.11, + protocol-buffers-descriptor == 2.4.11 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex @@ -83,7 +83,7 @@ containers, directory >= 1.0.0.1, filepath >= 1.1.0.0, - haskell-src-exts >= 1.16.0 && < 1.21, + haskell-src-exts >= 1.18 && < 1.21, mtl, parsec, utf8-string