hprotoc 2.4.4 → 2.4.5
raw patch · 2 files changed
+447/−529 lines, 2 filesdep ~haskell-src-extsdep ~protocol-buffersdep ~protocol-buffers-descriptorPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: haskell-src-exts, protocol-buffers, protocol-buffers-descriptor
API changes (from Hackage documentation)
Files
- Text/ProtocolBuffers/ProtoCompile/Gen.hs +441/−523
- hprotoc.cabal +6/−6
Text/ProtocolBuffers/ProtoCompile/Gen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards, CPP #-}+{-# LANGUAGE NamedFieldPuns, RecordWildCards, ViewPatterns #-} -- 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.@@ -52,64 +52,53 @@ nubSort :: Ord a => [a] -> [a] nubSort = map head . group . sort -#if MIN_VERSION_haskell_src_exts(1, 17, 0)-noWhere :: Maybe Binds+noWhere :: Maybe (Binds ()) noWhere = Nothing-#else-noWhere :: Binds-noWhere = BDecls []-#endif -#if MIN_VERSION_haskell_src_exts(1, 17, 0)-whereBinds :: Binds -> Maybe Binds+whereBinds :: Binds () -> Maybe (Binds ()) whereBinds = Just-#else-whereBinds :: Binds -> Binds-whereBinds = id-#endif -($$) :: Exp -> Exp -> Exp-($$) = App+($$) :: Exp () -> Exp () -> Exp ()+($$) = App () infixl 1 $$ -src :: SrcLoc-src = SrcLoc "No SrcLoc" 0 0--litStr :: String -> Exp-litStr = Lit . Hse.String+litStr :: String -> Exp ()+litStr s = Lit () $ Hse.String () s s -litIntP :: Integral x => x -> Pat-litIntP x | x<0 = PParen $ PLit Signless (Hse.Int (toInteger x))- | otherwise = PLit Signless (Hse.Int (toInteger x))+litIntP :: Integral x => x -> Pat ()+litIntP (toInteger -> x)+ | x<0 = PParen () $ PLit () (Signless ()) (Hse.Int () x (show x))+ | otherwise = PLit () (Signless ()) (Hse.Int () x (show x)) -- Pin down the type inference-litIntP' :: Int -> Pat+litIntP' :: Int -> Pat () litIntP' = litIntP -litInt :: Integral x => x -> Exp-litInt x | x<0 = Paren $ Lit (Hse.Int (toInteger x))- | otherwise = Lit (Hse.Int (toInteger x))+litInt :: Integral x => x -> Exp ()+litInt (toInteger -> x)+ | x<0 = Paren () $ Lit () (Hse.Int () x (show x))+ | otherwise = Lit () (Hse.Int () x (show x)) -litInt' :: Int -> Exp+litInt' :: Int -> Exp () litInt' = litInt -typeApp :: String -> Type -> Type-typeApp s = TyApp (TyCon (private s))+typeApp :: String -> Type () -> Type ()+typeApp s = TyApp () (TyCon () (private s)) -- private is for Text.ProtocolBuffers.Header, prelude is for Prelude, local is unqualified-private :: String -> QName-private t = Qual (ModuleName "P'") (Ident t)+private :: String -> QName ()+private t = Qual () (ModuleName () "P'") (Ident () t) -prelude :: String -> QName-prelude t = Qual (ModuleName "Prelude'") (Ident t)+prelude :: String -> QName ()+prelude t = Qual () (ModuleName () "Prelude'") (Ident () t) -local :: String -> QName-local t = UnQual (Ident t)+local :: String -> QName ()+local t = UnQual () (Ident () t) -localField :: DescriptorInfo -> String -> QName-localField di t = UnQual (fieldIdent di t)+localField :: DescriptorInfo -> String -> QName ()+localField di t = UnQual () (fieldIdent di t) -- pvar and preludevar and lvar are for lower-case identifiers isVar :: String -> Bool@@ -120,49 +109,49 @@ isCon (x:_) = isUpper x isCon _ = False -pvar :: String -> Exp-pvar t | isVar t = Var (private t)+pvar :: String -> Exp ()+pvar t | isVar t = Var () (private t) | otherwise = error $ "hprotoc Gen.hs assertion failed: pvar expected lower-case first letter in " ++ show t -preludevar :: String -> Exp-preludevar t | isVar t = Var (prelude t)+preludevar :: String -> Exp ()+preludevar t | isVar t = Var () (prelude t) | otherwise = error $ "hprotoc Gen.hs assertion failed: preludevar expected lower-case first letter in " ++ show t -lvar :: String -> Exp-lvar t | isVar t = Var (local t)+lvar :: String -> Exp ()+lvar t | isVar t = Var () (local t) | otherwise = error $ "hprotoc Gen.hs assertion failed: lvar expected lower-case first letter in " ++ show t -- pcon and preludecon and lcon are for upper-case identifiers-pcon :: String -> Exp-pcon t | isCon t = Con (private t)+pcon :: String -> Exp ()+pcon t | isCon t = Con () (private t) | otherwise = error $ "hprotoc Gen.hs assertion failed: pcon expected upper-case first letter in " ++ show t -preludecon :: String -> Exp-preludecon t | isCon t = Con (prelude t)+preludecon :: String -> Exp ()+preludecon t | isCon t = Con () (prelude t) | otherwise = error $ "hprotoc Gen.hs assertion failed: preludecon expected upper-case first letter in " ++ show t -lcon :: String -> Exp-lcon t | isCon t = Con (local t)+lcon :: String -> Exp ()+lcon t | isCon t = Con () (local t) | otherwise = error $ "hprotoc Gen.hs assertion failed: lcon expected upper-case first letter in " ++ show t -- patvar is a pattern that binds a new lower-case variable name-patvar :: String -> Pat-patvar t | isVar t = PVar (Ident t)+patvar :: String -> Pat ()+patvar t | isVar t = PVar () (Ident () t) | otherwise = error $ "hprotoc Gen.hs assertion failed: patvar expected lower-case first letter in " ++ show t -match :: String -> [Pat] -> Exp -> Match-match s p r = Match src (Ident s) p Nothing (UnGuardedRhs r) noWhere+match :: String -> [Pat ()] -> Exp () -> Match ()+match s p r = Match () (Ident () s) p (UnGuardedRhs () r) noWhere -inst :: String -> [Pat] -> Exp -> InstDecl-inst s p r = InsDecl $ FunBind [match s p r]+inst :: String -> [Pat ()] -> Exp () -> InstDecl ()+inst s p r = InsDecl () $ FunBind () [match s p r] -defun :: String -> [Pat] -> Exp -> Decl-defun s p r = FunBind [match s p r]+defun :: String -> [Pat ()] -> Exp () -> Decl ()+defun s p r = FunBind () [match s p r] -mkOp :: String -> Exp -> Exp -> Exp-mkOp s a b = InfixApp a (QVarOp (UnQual (Symbol s))) b+mkOp :: String -> Exp () -> Exp () -> Exp ()+mkOp s a b = InfixApp () a (QVarOp () (UnQual () (Symbol () s))) b -compose :: Exp -> Exp -> Exp+compose :: Exp () -> Exp () -> Exp () compose = mkOp "." fqMod :: ProtoName -> String@@ -172,20 +161,16 @@ -- current MKey (pKey of protoName, no 'Key appended), and Part to -- identify the module being created. The ProtoName is the target -- TYPE that is needed.-importPN :: Result -> ModuleName -> Part -> ProtoName -> Maybe ImportDecl-importPN r selfMod@(ModuleName self) part pn =+importPN :: Result -> ModuleName () -> Part -> ProtoName -> Maybe (ImportDecl ())+importPN r selfMod@(ModuleName () self) part pn = let o = pKey pn- m1 = ModuleName (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))- m2 = ModuleName (joinMod (parentModule pn))+ 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+ iabs = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn))) ans = if m1 == selfMod && part /= KeyFile then Nothing- else Just $ ImportDecl src m1 True fromSource False Nothing (Just m2)- (Just (False,[iabs]))+ else Just $ ImportDecl () m1 True fromSource False Nothing (Just m2)+ (Just (ImportSpecList () False [iabs])) in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $ [("selfMod",show selfMod) ,("part",show part)@@ -197,16 +182,12 @@ ,("ans",show ans)]) $ ans -importPFN :: Result -> ModuleName -> ProtoFName -> Maybe ImportDecl-importPFN r m@(ModuleName self) pfn =+importPFN :: Result -> ModuleName () -> ProtoFName -> Maybe (ImportDecl ())+importPFN r m@(ModuleName () self) pfn = 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+ m1@(ModuleName () m1') = ModuleName () (joinMod (haskellPrefix' pfn ++ parentModule' pfn))+ m2 = ModuleName () (joinMod (parentModule' pfn))+ spec = Just (ImportSpecList () False [IVar () (Ident () (fName (baseName' pfn)))]) kind = getKind r o fromAlt = S.member (FMName self,FMName m1') (rIKey r) m1key = if kind == SplitKeyTypeBoot && fromAlt@@ -217,7 +198,7 @@ | otherwise = Nothing sourceFlag = (kind == KeyTypeBoot) && fromAlt ans = if not qualifiedFlag && kind /= SplitKeyTypeBoot then Nothing else Just $- ImportDecl src m1key qualifiedFlag sourceFlag False Nothing qualifiedName spec+ ImportDecl () m1key qualifiedFlag sourceFlag False Nothing qualifiedName spec in ecart (unlines . map (\ (a,b) -> a ++ " = "++b) $ [("m",show m) ,("pfn",show pfn)@@ -229,75 +210,70 @@ ans -importO :: Result -> ModuleName -> Part -> OneofInfo -> Maybe [ImportDecl]-importO r selfMod@(ModuleName self) part oi =+importO :: Result -> ModuleName () -> Part -> OneofInfo -> Maybe [ImportDecl ()]+importO r selfMod@(ModuleName () self) part oi = let pn = oneofName oi o = pKey pn- m1 = ModuleName (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))- m2 = ModuleName (joinMod (parentModule pn))- m3 = ModuleName (joinMod (parentModule pn ++ [baseName pn]))+ m1 = ModuleName () (joinMod (haskellPrefix pn ++ parentModule pn ++ [baseName pn]))+ m2 = ModuleName () (joinMod (parentModule pn))+ m3 = ModuleName () (joinMod (parentModule pn ++ [baseName pn])) fromSource = S.member (FMName self,part,o) (rIBoot r)-#if MIN_VERSION_haskell_src_exts(1, 17, 0)- iabs1 = IAbs NoNamespace (Ident (mName (baseName pn)))- iabsget = map (IAbs NoNamespace . Ident . fst . oneofGet) . F.toList . oneofFields $ oi-#else- iabs1 = IAbs (Ident (mName (baseName pn)))- iabsget = map (IAbs . Ident . fst . oneofGet) . F.toList . oneofFields $ oi-#endif- ithall = IThingAll (Ident (mName (baseName pn)))+ iabs1 = IAbs () (NoNamespace ()) (Ident () (mName (baseName pn)))+ iabsget = map (IAbs () (NoNamespace ()) . Ident () . fst . oneofGet) . F.toList . oneofFields $ oi+ ithall = IThingAll () (Ident () (mName (baseName pn))) - ans1 = ImportDecl src m1 True fromSource False Nothing (Just m2)- (Just (False,[iabs1]))- ans2 = ImportDecl src m1 True fromSource False Nothing (Just m3)- (Just (False,ithall:iabsget))+ ans1 = ImportDecl () m1 True fromSource False Nothing (Just m2)+ (Just (ImportSpecList () False [iabs1]))+ ans2 = ImportDecl () m1 True fromSource False Nothing (Just m3)+ (Just (ImportSpecList () False (ithall:iabsget))) in if m1 == selfMod && part /= KeyFile then Nothing else Just [ans1,ans2] -- Several items might be taken from the same module, combine these statements-mergeImports :: [ImportDecl] -> [ImportDecl]+mergeImports :: [ImportDecl ()] -> [ImportDecl ()] mergeImports importsIn =- let idKey ImportDecl{..} = (importModule,importQualified,importSrc,importAs,fmap fst importSpecs)- mergeImports' ImportDecl{importSpecs=Just(hiding,xs), ..} ImportDecl{importSpecs=Just(_,ys)} =- ImportDecl{importSpecs=Just (hiding, xs `union` ys), ..}+ let idKey ImportDecl{..} = (importModule,importQualified,importSrc,importAs,fmap (\(ImportSpecList _ _ xs) -> xs) importSpecs)+ mergeImports' ImportDecl{importSpecs=Just (ImportSpecList () hiding xs), ..} ImportDecl{importSpecs=Just (ImportSpecList () _ ys)} =+ ImportDecl{importSpecs=Just (ImportSpecList () hiding (xs `union` ys)), ..} mergeImports' i _ = i -- identical, so drop one combined = M.fromListWith mergeImports' . map (\ i -> (idKey i,i)) $ importsIn in M.elems combined -keyFile :: ModuleName -> ModuleName-keyFile (ModuleName s) = ModuleName (s++"'Key")+keyFile :: ModuleName () -> ModuleName ()+keyFile (ModuleName () s) = ModuleName () (s++"'Key") joinMod :: [MName String] -> String joinMod [] = "" joinMod ms = fmName $ foldr1 dotFM . map promoteFM $ ms -baseIdent :: ProtoName -> Name-baseIdent = Ident . mName . baseName-baseIdent' :: ProtoFName -> Name-baseIdent' pfn = Ident $ baseNamePrefix' pfn ++ fName (baseName' pfn)+baseIdent :: ProtoName -> Name ()+baseIdent = Ident () . mName . baseName+baseIdent' :: ProtoFName -> Name ()+baseIdent' pfn = Ident () $ baseNamePrefix' pfn ++ fName (baseName' pfn) -fieldIdent :: DescriptorInfo -> String -> Name-fieldIdent di str | makeLenses di = Ident ('_':str)- | otherwise = Ident str+fieldIdent :: DescriptorInfo -> String -> Name ()+fieldIdent di str | makeLenses di = Ident () ('_':str)+ | otherwise = Ident () str -qualName :: ProtoName -> QName-qualName p@(ProtoName _ _prefix [] _base) = UnQual (baseIdent p)-qualName p@(ProtoName _ _prefix (parents) _base) = Qual (ModuleName (joinMod parents)) (baseIdent p)+qualName :: ProtoName -> QName ()+qualName p@(ProtoName _ _prefix [] _base) = UnQual () (baseIdent p)+qualName p@(ProtoName _ _prefix (parents) _base) = Qual () (ModuleName () (joinMod parents)) (baseIdent p) -qualFName :: ProtoFName -> QName-qualFName p@(ProtoFName _ _prefix [] _base _basePrefix) = UnQual (baseIdent' p)-qualFName p@(ProtoFName _ _prefix parents _base _basePrefix) = Qual (ModuleName (joinMod parents)) (baseIdent' p)+qualFName :: ProtoFName -> QName ()+qualFName p@(ProtoFName _ _prefix [] _base _basePrefix) = UnQual () (baseIdent' p)+qualFName p@(ProtoFName _ _prefix parents _base _basePrefix) = Qual () (ModuleName () (joinMod parents)) (baseIdent' p) -unqualName :: ProtoName -> QName-unqualName p = UnQual (baseIdent p)+unqualName :: ProtoName -> QName ()+unqualName p = UnQual () (baseIdent p) -unqualFName :: ProtoFName -> QName-unqualFName p = UnQual (baseIdent' p)+unqualFName :: ProtoFName -> QName ()+unqualFName p = UnQual () (baseIdent' p) -mayQualName :: ProtoName -> ProtoFName -> QName+mayQualName :: ProtoName -> ProtoFName -> QName () mayQualName (ProtoName _ c'prefix c'parents c'base) name@(ProtoFName _ prefix parents _base _basePrefix) = if joinMod (c'prefix++c'parents++[c'base]) == joinMod (prefix++parents)- then UnQual (baseIdent' name) -- name is local, make UnQual+ then UnQual () (baseIdent' name) -- name is local, make UnQual else qualFName name -- name is imported, make Qual @@ -305,22 +281,22 @@ -- utility for OneofInfo -------------------------------------------- -oneofCon :: (ProtoName,FieldInfo) -> Exp-oneofCon (name,_) = Con (qualName name)+oneofCon :: (ProtoName,FieldInfo) -> Exp ()+oneofCon (name,_) = Con () (qualName name) -oneofPat :: (ProtoName,FieldInfo) -> (Pat,Pat)+oneofPat :: (ProtoName,FieldInfo) -> (Pat (),Pat ()) oneofPat (name,fi) =- let fName@(Ident fname) = baseIdent' (fieldName fi)- in (PApp (qualName name) [PVar fName],PApp (unqualName name) [PVar fName])+ let fName@(Ident () fname) = baseIdent' (fieldName fi)+ in (PApp () (qualName name) [PVar () fName],PApp () (unqualName name) [PVar () fName]) -oneofRec :: (ProtoName,FieldInfo) -> (Exp,Exp)+oneofRec :: (ProtoName,FieldInfo) -> (Exp (),Exp ()) oneofRec (_,fi) =- let fName@(Ident fname) = baseIdent' (fieldName fi)+ let fName@(Ident () fname) = baseIdent' (fieldName fi) in (litStr fname,lvar fname) oneofGet :: (ProtoName,FieldInfo) -> (String,ProtoName) oneofGet (p,fi) =- let Ident fname = baseIdent' (fieldName fi)+ let Ident () fname = baseIdent' (fieldName fi) unqual = "get'" ++ fname p' = p { baseName = MName unqual } in (unqual,p')@@ -328,12 +304,12 @@ -------------------------------------------- -- Define LANGUAGE options as [ModulePramga] ---------------------------------------------modulePragmas :: Bool -> [ModulePragma]+modulePragmas :: Bool -> [ModulePragma ()] modulePragmas templateHaskell =- [ LanguagePragma src (map Ident $+ [ LanguagePragma () (map (Ident ()) $ thPragma ++ ["BangPatterns","DeriveDataTypeable","DeriveGeneric","FlexibleInstances","MultiParamTypeClasses"] )- , OptionsPragma src (Just GHC) " -fno-warn-unused-imports "+ , OptionsPragma () (Just GHC) " -fno-warn-unused-imports " ] where thPragma | templateHaskell = ["TemplateHaskell"] | otherwise = []@@ -341,48 +317,48 @@ -------------------------------------------- -- OneofDescriptorProto module creation ---------------------------------------------oneofModule :: Result -> OneofInfo -> Module+oneofModule :: Result -> OneofInfo -> Module () oneofModule result oi- = Module src (ModuleName (fqMod protoName)) (modulePragmas $ oneofMakeLenses oi) Nothing- Nothing imports (oneofDecls oi)+ = Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing Nothing)) (modulePragmas $ oneofMakeLenses oi)+ imports (oneofDecls oi) where protoName = oneofName oi typs = mapMaybe typeName . F.toList . fmap snd . oneofFields $ oi imports = (standardImports False False (oneofMakeLenses oi))- ++ (mergeImports (mapMaybe (importPN result (ModuleName (fqMod protoName)) Normal) typs))+ ++ (mergeImports (mapMaybe (importPN result (ModuleName () (fqMod protoName)) Normal) typs)) -oneofDecls :: OneofInfo -> [Decl]+oneofDecls :: OneofInfo -> [Decl ()] oneofDecls oi = (oneofX oi : oneofFuncs oi) ++ lenses ++ instances where- mkPrisms = Var (Qual (ModuleName "Control.Lens.TH") (Ident "makePrisms"))- lenses | oneofMakeLenses oi = [SpliceDecl src (mkFun $$ TypQuote (unqualName (oneofName oi))) |+ mkPrisms = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makePrisms"))+ lenses | oneofMakeLenses oi = [SpliceDecl () (mkFun $$ TypQuote () (unqualName (oneofName oi))) | mkFun <- [mkLenses, mkPrisms]] | otherwise = [] instances = [ instanceDefaultOneof oi , instanceMergeableOneof oi ] -oneofX :: OneofInfo -> Decl-oneofX oi = DataDecl src DataType [] (baseIdent (oneofName oi)) []+oneofX :: OneofInfo -> Decl ()+oneofX oi = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (oneofName oi))) (map oneofValueX (F.toList (oneofFields oi) ))- derives- where oneofValueX (pname,fi) = QualConDecl src [] [] con- where con = RecDecl (baseIdent pname) [fieldX]- fieldX = ([baseIdent' . fieldName $ fi], TyParen (TyCon typed ))+ (Just derives)+ where oneofValueX (pname,fi) = QualConDecl () Nothing Nothing con+ where con = RecDecl () (baseIdent pname) [fieldX]+ fieldX = FieldDecl () [baseIdent' . fieldName $ fi] (TyParen () (TyCon () typed )) typed = case useType (getFieldType (typeCode fi)) of Just s -> private s Nothing -> case typeName fi of Just s -> qualName s Nothing -> imp $ "No Name for Field!\n" ++ show fi -oneofFuncs :: OneofInfo -> [Decl]+oneofFuncs :: OneofInfo -> [Decl ()] oneofFuncs oi = map mkfuns (F.toList (oneofFields oi)) where mkfuns f = defun (fst (oneofGet f)) [patvar "x"] $- Case (lvar "x")- [ Alt src (snd (oneofPat f))- (UnGuardedRhs (preludecon "Just" $$ snd (oneofRec f))) noWhere- , Alt src PWildCard- (UnGuardedRhs (preludecon "Nothing")) noWhere+ Case () (lvar "x")+ [ Alt () (snd (oneofPat f))+ (UnGuardedRhs () (preludecon "Just" $$ snd (oneofRec f))) noWhere+ , Alt () (PWildCard ())+ (UnGuardedRhs () (preludecon "Nothing")) noWhere ] @@ -391,33 +367,34 @@ (to make all messages an instance of Default and Mergeable), we make the first case as default like enum. -} -instanceDefaultOneof :: OneofInfo -> Decl+instanceDefaultOneof :: OneofInfo -> Decl () instanceDefaultOneof oi- = InstDecl src Nothing [] [] (private "Default") [TyCon (unqualName (oneofName oi))]+ = InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (oneofName oi))]) . Just $ [ inst "defaultValue" [] firstValue ]- where firstValue :: Exp+ where firstValue :: Exp () firstValue = case Seq.viewl (oneofFields oi) of EmptyL -> imp ("instanceDefaultOneof: empty in " ++ show oi) (n,_) :< _ -> case (baseIdent n) of- Ident str -> App (lcon str) (pvar "defaultValue")- Symbol _ -> imp ("instanceDefaultOneof: " ++ show n)+ Ident () str -> App () (lcon str) (pvar "defaultValue")+ Symbol () _ -> imp ("instanceDefaultOneof: " ++ show n) -instanceMergeableOneof :: OneofInfo -> Decl+instanceMergeableOneof :: OneofInfo -> Decl () instanceMergeableOneof oi- = InstDecl src Nothing [] [] (private "Mergeable") [TyCon (unqualName (oneofName oi))] []+ = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (oneofName oi))]) Nothing -------------------------------------------- -- EnumDescriptorProto module creation ---------------------------------------------enumModule :: EnumInfo -> Module+enumModule :: EnumInfo -> Module () enumModule ei = let protoName = enumName ei- in Module src (ModuleName (fqMod protoName)) (modulePragmas False) Nothing- (Just [EThingAll (unqualName protoName)])+ exportList =+ (Just (ExportSpecList () [EThingWith () (EWildcard () 0) (unqualName protoName) []]))+ in Module () (Just (ModuleHead () (ModuleName () (fqMod protoName)) Nothing exportList)) (modulePragmas False) (standardImports True False False) (enumDecls ei) -enumDecls :: EnumInfo -> [Decl]+enumDecls :: EnumInfo -> [Decl ()] enumDecls ei = map ($ ei) [ enumX , instanceMergeableEnum , instanceBounded@@ -431,25 +408,24 @@ , instanceTextTypeEnum ] -enumX :: EnumInfo -> Decl-enumX ei = DataDecl src DataType [] (baseIdent (enumName ei)) [] (map enumValueX (enumValues ei)) derivesEnum--- where enumValueX (_,name) = ConDecl src (HsIdent name) []- where enumValueX (_,name) = QualConDecl src [] [] (ConDecl (Ident name) [])+enumX :: EnumInfo -> Decl ()+enumX ei = DataDecl () (DataType ()) Nothing (DHead () (baseIdent (enumName ei))) (map enumValueX (enumValues ei)) (Just derivesEnum)+ where enumValueX (_,name) = QualConDecl () Nothing Nothing (ConDecl () (Ident () name) []) -instanceTextTypeEnum :: EnumInfo -> Decl+instanceTextTypeEnum :: EnumInfo -> Decl () instanceTextTypeEnum ei- = InstDecl src Nothing [] [] (private "TextType") [TyCon (unqualName (enumName ei))] [- inst "tellT" [] (pvar "tellShow")+ = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (enumName ei))]) . Just $+ [ inst "tellT" [] (pvar "tellShow") , inst "getT" [] (pvar "getRead") ] -instanceMergeableEnum :: EnumInfo -> Decl+instanceMergeableEnum :: EnumInfo -> Decl () instanceMergeableEnum ei- = InstDecl src Nothing [] [] (private "Mergeable") [TyCon (unqualName (enumName ei))] []+ = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () (unqualName (enumName ei))]) Nothing -instanceBounded :: EnumInfo -> Decl+instanceBounded :: EnumInfo -> Decl () instanceBounded ei- = InstDecl src Nothing [] [] (prelude "Bounded") [TyCon (unqualName (enumName ei))]+ = InstDecl () Nothing (mkSimpleIRule (prelude "Bounded") [TyCon () (unqualName (enumName ei))]) .Just $ [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 [] (lcon n)@@ -462,50 +438,50 @@ // This never returns NULL. -}-instanceDefaultEnum :: EnumInfo -> Decl+instanceDefaultEnum :: EnumInfo -> Decl () instanceDefaultEnum ei- = InstDecl src Nothing [] [] (private "Default") [TyCon (unqualName (enumName ei))]+ = InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () (unqualName (enumName ei))]) . Just $ [ inst "defaultValue" [] firstValue ]- where firstValue :: Exp+ where firstValue :: Exp () firstValue = case enumValues ei of (:) (_,n) _ -> lcon n [] -> error $ "Impossible? EnumDescriptorProto had empty sequence of EnumValueDescriptorProto.\n" ++ show ei -declToEnum :: EnumInfo -> [Decl]-declToEnum ei = [ TypeSig src [Ident "toMaybe'Enum"]- (TyFun (TyCon (prelude "Int"))- (typeApp "Maybe" (TyCon (unqualName (enumName ei)))))- , FunBind (map toEnum'one values ++ [final]) ]+declToEnum :: EnumInfo -> [Decl ()]+declToEnum ei = [ TypeSig () [Ident () "toMaybe'Enum"]+ (TyFun () (TyCon () (prelude "Int"))+ (typeApp "Maybe" (TyCon () (unqualName (enumName ei)))))+ , FunBind () (map toEnum'one values ++ [final]) ] where values = enumValues ei toEnum'one (v,n) = match "toMaybe'Enum" [litIntP (getEnumCode v)] (preludecon "Just" $$ lcon n)- final = match "toMaybe'Enum" [PWildCard] (preludecon "Nothing")+ final = match "toMaybe'Enum" [PWildCard ()] (preludecon "Nothing") -instanceEnum :: EnumInfo -> Decl+instanceEnum :: EnumInfo -> Decl () instanceEnum ei- = InstDecl src Nothing [] [] (prelude "Enum") [TyCon (unqualName (enumName ei))]- (map (InsDecl . FunBind) [fromEnum',toEnum',succ',pred'])+ = InstDecl () Nothing (mkSimpleIRule (prelude "Enum") [TyCon () (unqualName (enumName ei))]) . Just $+ (map (InsDecl () . FunBind ()) [fromEnum',toEnum',succ',pred']) where values = enumValues ei fromEnum' = map fromEnum'one values- fromEnum'one (v,n) = match "fromEnum" [PApp (local n) []] (litInt (getEnumCode v))+ fromEnum'one (v,n) = match "fromEnum" [PApp () (local n) []] (litInt (getEnumCode v)) toEnum' = [ match "toEnum" [] (compose mayErr (lvar "toMaybe'Enum")) ]- mayErr = pvar "fromMaybe" $$ (Paren (preludevar "error" $$ (litStr $+ mayErr = pvar "fromMaybe" $$ (Paren () (preludevar "error" $$ (litStr $ "hprotoc generated code: toEnum failure for type "++ fqMod (enumName ei)))) succ' = zipWith (equate "succ") values (tail values) ++- [ match "succ" [PWildCard] (preludevar "error" $$ (litStr $+ [ match "succ" [PWildCard ()] (preludevar "error" $$ (litStr $ "hprotoc generated code: succ failure for type "++ fqMod (enumName ei))) ] pred' = zipWith (equate "pred") (tail values) values ++- [ match "pred" [PWildCard] (preludevar "error" $$ (litStr $+ [ match "pred" [PWildCard ()] (preludevar "error" $$ (litStr $ "hprotoc generated code: pred failure for type "++ fqMod (enumName ei))) ]- equate f (_,n1) (_,n2) = match f [PApp (local n1) []] (lcon n2)+ equate f (_,n1) (_,n2) = match f [PApp () (local n1) []] (lcon n2) -- fromEnum TYPE_ENUM == 14 :: Int-instanceWireEnum :: EnumInfo -> Decl+instanceWireEnum :: EnumInfo -> Decl () instanceWireEnum ei- = InstDecl src Nothing [] [] (private "Wire") [TyCon (unqualName (enumName ei))]+ = InstDecl () Nothing (mkSimpleIRule (private "Wire") [TyCon () (unqualName (enumName ei))]) . Just $ [ withName "wireSize", withName "wirePut", withGet, withGetErr,withGetPacked,withGetPackedErr ] where withName foo = inst foo [patvar "ft'",patvar "enum"] rhs where rhs = pvar foo $$ lvar "ft'" $$- (Paren $ preludevar "fromEnum" $$ lvar "enum")+ (Paren () $ preludevar "fromEnum" $$ lvar "enum") withGet = inst "wireGet" [litIntP' 14] rhs where rhs = pvar "wireGetEnum" $$ lvar "toMaybe'Enum" withGetErr = inst "wireGet" [patvar "ft'"] rhs@@ -515,28 +491,28 @@ withGetPackedErr = inst "wireGetPacked" [patvar "ft'"] rhs where rhs = pvar "wireGetErr" $$ lvar "ft'" -instanceGPB :: ProtoName -> Decl+instanceGPB :: ProtoName -> Decl () instanceGPB protoName- = InstDecl src Nothing [] [] (private "GPB") [TyCon (unqualName protoName)] []+ = InstDecl () Nothing (mkSimpleIRule (private "GPB") [TyCon () (unqualName protoName)]) Nothing -instanceReflectEnum :: EnumInfo -> Decl+instanceReflectEnum :: EnumInfo -> Decl () instanceReflectEnum ei- = InstDecl src Nothing [] [] (private "ReflectEnum") [TyCon (unqualName (enumName ei))]+ = InstDecl () Nothing (mkSimpleIRule (private "ReflectEnum") [TyCon () (unqualName (enumName ei))]) . Just $ [ inst "reflectEnum" [] ascList- , inst "reflectEnumInfo" [ PWildCard ] ei' ]+ , inst "reflectEnumInfo" [ PWildCard () ] ei' ] where (ProtoName xxx a b c) = enumName ei- xxx'Exp = Paren $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx)))+ xxx'Exp = Paren () $ pvar "pack" $$ litStr (LC.unpack (utf8 (fiName xxx))) values = enumValues ei- ascList,ei',protoNameExp :: Exp- ascList = List (map one values)- where one (v,ns) = Tuple Boxed [litInt (getEnumCode v),litStr ns,lcon ns]- ei' = foldl' App (pcon "EnumInfo") [protoNameExp- ,List $ map litStr (enumFilePath ei)- ,List (map two values)]- where two (v,ns) = Tuple Boxed [litInt (getEnumCode v),litStr ns]- protoNameExp = Paren $ foldl' App (pvar "makePNF")+ ascList,ei',protoNameExp :: Exp ()+ ascList = List () (map one values)+ where one (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns,lcon ns]+ ei' = foldl' (App ()) (pcon "EnumInfo") [protoNameExp+ ,List () $ map litStr (enumFilePath ei)+ ,List () (map two values)]+ where two (v,ns) = Tuple () Boxed [litInt (getEnumCode v),litStr ns]+ protoNameExp = Paren () $ foldl' (App ()) (pvar "makePNF") [ xxx'Exp, mList a, mList b, litStr (mName c) ]- where mList = List . map (litStr . mName)+ where mList = List () . map (litStr . mName) hasExt :: DescriptorInfo -> Bool hasExt di = not (null (extRanges di))@@ -545,62 +521,45 @@ -- FileDescriptorProto module creation -------------------------------------------- -protoModule :: Result -> ProtoInfo -> ByteString -> Module+protoModule :: Result -> ProtoInfo -> ByteString -> Module () protoModule result pri fdpBS = 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+ m = ModuleName () (fqMod protoName)+ exportKeys = map (EVar () . unqualFName . fieldName) myKeys+ exportNames = map (EVar () . UnQual () . Ident ()) ["protoInfo","fileDescriptorProto"] imports = (protoImports ++) . mergeImports $ mapMaybe (importPN result m Normal) $ extendees ++ mapMaybe typeName myKeys- in Module src m (modulePragmas False) Nothing (Just (exportKeys++exportNames)) imports+ in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exportKeys++exportNames))))) (modulePragmas False) imports (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'"))-#if MIN_VERSION_haskell_src_exts(1, 17, 0)- (Just (False,[IVar (Ident "wireGet,getFromBS")]))-#else- (Just (False,[IVar NoNamespace (Ident "wireGet,getFromBS")]))-#endif+ [ ImportDecl () (ModuleName () "Text.DescriptorProtos.FileDescriptorProto") False False False Nothing Nothing+ (Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "FileDescriptorProto")]))+ , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Reflections") False False False Nothing Nothing+ (Just (ImportSpecList () False [IAbs () (NoNamespace ()) (Ident () "ProtoInfo")]))+ , ImportDecl () (ModuleName () "Text.ProtocolBuffers.WireMessage") True False False Nothing (Just (ModuleName () "P'"))+ (Just (ImportSpecList () False [IVar () (Ident () "wireGet,getFromBS")])) ] -embed'ProtoInfo :: ProtoInfo -> [Decl]+embed'ProtoInfo :: ProtoInfo -> [Decl ()] embed'ProtoInfo pri = [ myType, myValue ]- where myType = TypeSig src [ Ident "protoInfo" ] (TyCon (local "ProtoInfo"))- myValue = PatBind src (PApp (local "protoInfo") []) (UnGuardedRhs $+ where myType = TypeSig () [ Ident () "protoInfo" ] (TyCon () (local "ProtoInfo"))+ myValue = PatBind () (PApp () (local "protoInfo") []) (UnGuardedRhs () $ preludevar "read" $$ litStr (show pri)) noWhere -embed'fdpBS :: ByteString -> [Decl]+embed'fdpBS :: ByteString -> [Decl ()] embed'fdpBS bs = [ myType, myValue ]- where myType = TypeSig src [ Ident "fileDescriptorProto" ] (TyCon (local "FileDescriptorProto"))- myValue = PatBind src (PApp (local "fileDescriptorProto") []) (UnGuardedRhs $+ where myType = TypeSig () [ Ident () "fileDescriptorProto" ] (TyCon () (local "FileDescriptorProto"))+ myValue = PatBind () (PApp () (local "fileDescriptorProto") []) (UnGuardedRhs () $ pvar "getFromBS" $$- Paren (pvar "wireGet" $$ litInt' 11) $$- Paren (pvar "pack" $$ litStr (LC.unpack bs))) noWhere+ Paren () (pvar "wireGet" $$ litInt' 11) $$+ Paren () (pvar "pack" $$ litStr (LC.unpack bs))) noWhere -------------------------------------------- -- DescriptorProto module creation ---------------------------------------------descriptorModules :: Result -> DescriptorInfo -> [(FilePath,Module)]+descriptorModules :: Result -> DescriptorInfo -> [(FilePath,Module ())] descriptorModules result di = let mainPath = joinPath (descFilePath di) bootPath = joinPath (descFilePath di) ++ "-boot"@@ -615,7 +574,7 @@ ,(keyfilePath,descriptorKeyfileModule result di)] -- This build a hs-boot that declares the type of the data type only-descriptorBootModule :: DescriptorInfo -> Module+descriptorBootModule :: DescriptorInfo -> Module () descriptorBootModule di = let protoName = descName di un = unqualName protoName@@ -626,53 +585,41 @@ ] ++ if hasExt di then [private "ExtendMessage"] else [] ++ if storeUnknown di then [private "UnknownMessage"] else []- instMesAPI = InstDecl src Nothing [] [] (private "MessageAPI")- [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] []-#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+ 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)) [] Nothing+ 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 (dataDecl : instMesAPI : map mkInst classes) -- This builds on the output of descriptorBootModule and declares a hs-boot that -- declares the data type and the keys-descriptorKeyBootModule :: Result -> DescriptorInfo -> Module+descriptorKeyBootModule :: Result -> DescriptorInfo -> Module () descriptorKeyBootModule result di- = let Module p1 m@(ModuleName _self) p3 p4 (Just exports) imports decls = descriptorBootModule di+ = let Module () (Just (ModuleHead () m _ (Just (ExportSpecList () exports)))) pragmas 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+ exportKeys = map (EVar () . unqualFName . fieldName) myKeys importTypes = mergeImports . mapMaybe (importPN result m Source) . nubSort $ extendees ++ mapMaybe typeName myKeys declKeys = keysXType (descName di) (keys di)- in Module p1 m p3 p4 (Just (exports++exportKeys)) (imports++importTypes) (decls++declKeys)+ in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () (exports++exportKeys))))) pragmas (imports++importTypes) (decls++declKeys) -- This build the 'Key module that defines the keys only-descriptorKeyfileModule :: Result -> DescriptorInfo -> Module+descriptorKeyfileModule :: Result -> DescriptorInfo -> Module () descriptorKeyfileModule result di = let protoName'Key = (descName di) { baseName = MName . (++"'Key") . mName $ (baseName (descName di)) } (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+ mBase = ModuleName () (fqMod (descName di))+ m = ModuleName () (fqMod protoName'Key)+ exportKeys = map (EVar () . unqualFName . fieldName) myKeys importTypes = mergeImports . mapMaybe (importPN result mBase KeyFile) . nubSort $ extendees ++ mapMaybe typeName myKeys declKeys = keysXTypeVal protoName'Key (keys di)- in Module src m (modulePragmas $ makeLenses di) Nothing (Just exportKeys) (minimalImports++importTypes) declKeys+ in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () exportKeys)) )) (modulePragmas $ makeLenses di) (minimalImports++importTypes) declKeys -- This builds the normal module-descriptorNormalModule :: Result -> DescriptorInfo -> Module+descriptorNormalModule :: Result -> DescriptorInfo -> Module () descriptorNormalModule result di = let protoName = descName di un = unqualName protoName@@ -681,79 +628,67 @@ (extendees,myKeys) = unzip $ F.toList (keys di) 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+ m = ModuleName () (fqMod protoName)+ exportKeys :: [ExportSpec ()]+ exportKeys = map (EVar () . unqualFName . fieldName) myKeys imports = (standardImports False (hasExt di) (makeLenses di) ++) . mergeImports . concat $ [ mapMaybe (importPN result m Normal) $ extendees' ++ mapMaybe typeName (myKeys' ++ (F.toList (fields di))) , concat . mapMaybe (importO result m Normal) $ F.toList (descOneofs di) , mapMaybe (importPFN result m) (map fieldName (myKeys ++ F.toList (knownKeys di))) ]- lenses | makeLenses di = [SpliceDecl src (mkLenses $$ TypQuote (unqualName protoName))]+ lenses | makeLenses di = [SpliceDecl () (mkLenses $$ TypQuote () (unqualName protoName))] | otherwise = [] declKeys | sepKey = [] | otherwise = keysXTypeVal (descName di) (keys di)- in Module src m (modulePragmas $ makeLenses di) Nothing (Just (EThingAll un : exportLenses di ++ exportKeys)) imports+ in Module () (Just (ModuleHead () m Nothing (Just (ExportSpecList () ((EThingWith () (EWildcard () 0) un [] : exportLenses di ++ exportKeys)))))) (modulePragmas $ makeLenses di) imports (descriptorX di : lenses ++ declKeys ++ instancesDescriptor di) -mkLenses :: Exp-mkLenses = Var (Qual (ModuleName "Control.Lens.TH") (Ident "makeLenses"))+mkLenses :: Exp ()+mkLenses = Var () (Qual () (ModuleName () "Control.Lens.TH") (Ident () "makeLenses")) -exportLenses :: DescriptorInfo -> [ExportSpec]+exportLenses :: DescriptorInfo -> [ExportSpec ()] exportLenses di = if makeLenses di then-#if MIN_VERSION_haskell_src_exts(1, 17, 0)- map (EVar . unqualFName . stripPrefix) (lensFieldNames di)-#else- map (EVar NoNamespace . unqualFName . stripPrefix) (lensFieldNames di)-#endif+ map (EVar () . unqualFName . stripPrefix) (lensFieldNames di) else [] where stripPrefix pfn = pfn { baseNamePrefix' = "" } lensFieldNames di = map fieldName (F.toList (fields di)) ++ map oneofFName (F.toList (descOneofs di)) -minimalImports :: [ImportDecl]+minimalImports :: [ImportDecl ()] minimalImports =- [ ImportDecl src (ModuleName "Prelude") True False False Nothing (Just (ModuleName "Prelude'")) Nothing- , 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 "GHC.Generics") True False False Nothing (Just (ModuleName "Prelude'")) Nothing- , ImportDecl src (ModuleName "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName "P'")) Nothing ]+ [ ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing ] -standardImports :: Bool -> Bool -> Bool -> [ImportDecl]+standardImports :: Bool -> Bool -> Bool -> [ImportDecl ()] standardImports isEnumMod ext lenses =- [ ImportDecl src (ModuleName "Prelude") False False False Nothing Nothing (Just (False,ops))- , ImportDecl src (ModuleName "Prelude") True False False Nothing (Just (ModuleName "Prelude'")) Nothing- , ImportDecl src (ModuleName "Data.Typeable") True False False Nothing (Just (ModuleName "Prelude'")) Nothing- , ImportDecl src (ModuleName "GHC.Generics") 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+ [ ImportDecl () (ModuleName () "Prelude") False False False Nothing Nothing (Just (ImportSpecList () False ops))+ , ImportDecl () (ModuleName () "Prelude") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Data.Typeable") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "GHC.Generics") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Data.Data") True False False Nothing (Just (ModuleName () "Prelude'")) Nothing+ , ImportDecl () (ModuleName () "Text.ProtocolBuffers.Header") True False False Nothing (Just (ModuleName () "P'")) Nothing ] ++ lensTH 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+ ops | ext = map (IVar () . Symbol ()) $ base ++ ["==","<=","&&"]+ | otherwise = map (IVar () . Symbol ()) base base | isEnumMod = ["+","/","."] | otherwise = ["+","/"]- lensTH | lenses = [ImportDecl src (ModuleName "Control.Lens.TH") True False False Nothing Nothing Nothing]+ lensTH | lenses = [ImportDecl () (ModuleName () "Control.Lens.TH") True False False Nothing Nothing Nothing] | otherwise = [] -keysXType :: ProtoName -> Seq KeyInfo -> [Decl]+keysXType :: ProtoName -> Seq KeyInfo -> [Decl ()] keysXType self ks = map (makeKeyType self) . F.toList $ ks -keysXTypeVal :: ProtoName -> Seq KeyInfo -> [Decl]+keysXTypeVal :: ProtoName -> Seq KeyInfo -> [Decl ()] keysXTypeVal self ks = concatMap (\ ki -> [makeKeyType self ki,makeKeyVal self ki]) . F.toList $ ks -makeKeyType :: ProtoName -> KeyInfo -> Decl+makeKeyType :: ProtoName -> KeyInfo -> Decl () makeKeyType self (extendee,f) = keyType- where keyType = TypeSig src [ baseIdent' . fieldName $ f ] (foldl1 TyApp . map TyCon $+ where keyType = TypeSig () [ baseIdent' . fieldName $ f ] (foldl1 (TyApp ()) . map (TyCon ()) $ [ private "Key", private labeled , if extendee /= self then qualName extendee else unqualName extendee , typeQName ])@@ -761,7 +696,7 @@ | canRepeat f = "Seq" | otherwise = "Maybe" typeNumber = getFieldType . typeCode $ f- typeQName :: QName+ typeQName :: QName () typeQName = case useType typeNumber of Just s -> private s Nothing -> case typeName f of@@ -769,65 +704,65 @@ | otherwise -> unqualName s Nothing -> error $ "No Name for Field!\n" ++ show f -makeKeyVal :: ProtoName -> KeyInfo -> Decl+makeKeyVal :: ProtoName -> KeyInfo -> Decl () makeKeyVal _self (_extendee,f) = keyVal where typeNumber = getFieldType . typeCode $ f- keyVal = PatBind src (PApp (unqualFName . fieldName $ f) []) (UnGuardedRhs+ keyVal = PatBind () (PApp () (unqualFName . fieldName $ f) []) (UnGuardedRhs () (pcon "Key" $$ litInt (getFieldId (fieldNumber f)) $$ litInt typeNumber $$ maybe (preludecon "Nothing")- (Paren . (preludecon "Just" $$) . (defToSyntax (typeCode f)))+ (Paren () . (preludecon "Just" $$) . (defToSyntax (typeCode f))) (hsDefault f) )) noWhere -defToSyntax :: FieldType -> HsDefault -> Exp+defToSyntax :: FieldType -> HsDefault -> Exp () defToSyntax tc x = case x of HsDef'Bool b -> preludecon (show b)- HsDef'ByteString bs -> (if tc == 9 then (\ xx -> Paren (pcon "Utf8" $$ xx)) else id) $- (Paren $ pvar "pack" $$ litStr (LC.unpack bs))- HsDef'RealFloat (SRF'Rational r) | r < 0 -> Paren $ Lit (Frac r)- | otherwise -> Lit (Frac r)+ HsDef'ByteString bs -> (if tc == 9 then (\ xx -> Paren () (pcon "Utf8" $$ xx)) else id) $+ (Paren () $ pvar "pack" $$ litStr (LC.unpack bs))+ HsDef'RealFloat (SRF'Rational r) | r < 0 -> Paren () $ Lit () (Frac () r (show r))+ | otherwise -> Lit () (Frac () r (show r)) HsDef'RealFloat SRF'nan -> litInt' 0 /! litInt' 0 HsDef'RealFloat SRF'ninf -> litInt' 1 /! litInt' 0 HsDef'RealFloat SRF'inf -> litInt' (-1) /! litInt' 0 HsDef'Integer i -> litInt i- HsDef'Enum s -> Paren $ preludevar "read" $$ litStr s- where (/!) a b = Paren (mkOp "/" a b)+ HsDef'Enum s -> Paren () $ preludevar "read" $$ litStr s+ where (/!) a b = Paren () (mkOp "/" a b) -descriptorX :: DescriptorInfo -> Decl-descriptorX di = DataDecl src DataType [] name [] [QualConDecl src [] [] con] derives+descriptorX :: DescriptorInfo -> Decl ()+descriptorX di = DataDecl () (DataType ()) Nothing (DHead () name) [QualConDecl () Nothing Nothing con] (Just derives) where self = descName di name = baseIdent self- con = RecDecl name eFields- where eFields = F.foldr ((:) . fieldX) end (fields di)+ con = RecDecl () name eFields+ where eFields = map (\(ns, t) -> FieldDecl () ns t) $ F.foldr ((:) . fieldX) end (fields di) end = (if hasExt di then (extfield:) else id) . (if storeUnknown di then (unknownField:) else id) $ eOneof eOneof = F.foldr ((:) . fieldOneofX) [] (descOneofs di) - bangType = if lazyFields di then TyParen {- UnBangedTy -} else TyBang BangedTy . TyParen+ bangType = if lazyFields di then TyParen () {- UnBangedTy -} else TyBang () (BangedTy ()) (NoUnpackPragma ()) . TyParen () -- extfield :: ([Name],BangType)- extfield = ([fieldIdent di "ext'field"], bangType (TyCon (private "ExtField")))+ extfield = ([fieldIdent di "ext'field"], bangType (TyCon () (private "ExtField"))) -- unknownField :: ([Name],BangType)- unknownField = ([fieldIdent di "unknown'field"], bangType (TyCon (private "UnknownField")))+ unknownField = ([fieldIdent di "unknown'field"], bangType (TyCon () (private "UnknownField"))) -- fieldX :: FieldInfo -> ([Name],BangType)- fieldX fi = ([baseIdent' . fieldName $ fi], bangType (labeled (TyCon typed)))+ fieldX fi = ([baseIdent' . fieldName $ fi], bangType (labeled (TyCon () typed))) where labeled | canRepeat fi = typeApp "Seq" | isRequired fi = id | otherwise = typeApp "Maybe"- typed :: QName+ typed :: QName () typed = case useType (getFieldType (typeCode fi)) of Just s -> private s Nothing -> case typeName fi of Just s | self /= s -> qualName s | otherwise -> unqualName s Nothing -> error $ "No Name for Field!\n" ++ show fi- fieldOneofX :: OneofInfo -> ([Name],Type)- fieldOneofX oi = ([baseIdent' . oneofFName $ oi], typeApp "Maybe" (TyParen (TyCon typed)))+ fieldOneofX :: OneofInfo -> ([Name ()],Type ())+ fieldOneofX oi = ([baseIdent' . oneofFName $ oi], typeApp "Maybe" (TyParen () (TyCon () typed))) where typed = qualName (oneofName oi) -instancesDescriptor :: DescriptorInfo -> [Decl]+instancesDescriptor :: DescriptorInfo -> [Decl ()] instancesDescriptor di = map ($ di) $ (if hasExt di then (instanceExtendMessage:) else id) $ (if storeUnknown di then (instanceUnknownMessage:) else id) $@@ -841,160 +776,156 @@ , instanceTextMsg ] -instanceExtendMessage :: DescriptorInfo -> Decl+instanceExtendMessage :: DescriptorInfo -> Decl () instanceExtendMessage di- = InstDecl src Nothing [] [] (private "ExtendMessage") [TyCon (unqualName (descName di))]- [ inst "getExtField" [] (Var (localField di "ext'field"))+ = InstDecl () Nothing (mkSimpleIRule (private "ExtendMessage") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "getExtField" [] (Var () (localField di "ext'field")) , inst "putExtField" [patvar "e'f", patvar "msg"] putextfield- , inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren $ pvar "reflectDescriptorInfo" $$ lvar "msg"))+ , inst "validExtRanges" [patvar "msg"] (pvar "extRanges" $$ (Paren () $ pvar "reflectDescriptorInfo" $$ lvar "msg")) ]- where putextfield = RecUpdate (lvar "msg") [ FieldUpdate (localField di "ext'field") (lvar "e'f") ]+ where putextfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "ext'field") (lvar "e'f") ] -instanceUnknownMessage :: DescriptorInfo -> Decl+instanceUnknownMessage :: DescriptorInfo -> Decl () instanceUnknownMessage di- = InstDecl src Nothing [] [] (private "UnknownMessage") [TyCon (unqualName (descName di))]- [ inst "getUnknownField" [] (Var (localField di "unknown'field"))+ = InstDecl () Nothing (mkSimpleIRule (private "UnknownMessage") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "getUnknownField" [] (Var () (localField di "unknown'field")) , inst "putUnknownField" [patvar "u'f",patvar "msg"] putunknownfield ]- where putunknownfield = RecUpdate (lvar "msg") [ FieldUpdate (localField di "unknown'field") (lvar "u'f") ]+ where putunknownfield = RecUpdate () (lvar "msg") [ FieldUpdate () (localField di "unknown'field") (lvar "u'f") ] -instanceTextType :: DescriptorInfo -> Decl+instanceTextType :: DescriptorInfo -> Decl () instanceTextType di- = InstDecl src Nothing [] [] (private "TextType") [TyCon (unqualName (descName di))] [- inst "tellT" [] (pvar "tellSubMessage")+ = InstDecl () Nothing (mkSimpleIRule (private "TextType") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "tellT" [] (pvar "tellSubMessage") , inst "getT" [] (pvar "getSubMessage") ] -instanceTextMsg :: DescriptorInfo -> Decl+instanceTextMsg :: DescriptorInfo -> Decl () instanceTextMsg di- = InstDecl src Nothing [] [] (private "TextMsg") [TyCon (unqualName (descName di))] [- inst "textPut" [patvar msgVar] genPrint- , InsDecl $ FunBind [Match src (Ident "textGet") [] Nothing (UnGuardedRhs parser) bdecls]+ = InstDecl () Nothing (mkSimpleIRule (private "TextMsg") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "textPut" [patvar msgVar] genPrint+ , InsDecl () $ FunBind () [Match () (Ident () "textGet") [] (UnGuardedRhs () parser) bdecls] ] where-#if MIN_VERSION_haskell_src_exts(1, 17, 0)- bdecls = Just (BDecls (subparsers ++ subparsersO))-#else- bdecls = BDecls (subparsers ++ subparsersO)-#endif+ bdecls = Just (BDecls () (subparsers ++ subparsersO)) flds = F.toList (fields di) os = F.toList (descOneofs di) msgVar = distinctVar "msg" distinctVar var = if var `elem` reservedVars then distinctVar (var ++ "'") else var reservedVars = map toPrintName flds- genPrintFields = map (Qualifier . printField msgVar) flds- genPrintOneofs = map (Qualifier . printOneof msgVar) os+ genPrintFields = map (Qualifier () . printField msgVar) flds+ genPrintOneofs = map (Qualifier () . printOneof msgVar) os genPrint = if null flds && null os- then preludevar "return" $$ Hse.Tuple Boxed []- else Do $ genPrintFields ++ genPrintOneofs+ then preludevar "return" $$ Hse.Tuple () Boxed []+ else Do () $ genPrintFields ++ genPrintOneofs parser | null flds && null os = preludevar "return" $$ pvar "defaultValue"- | otherwise = Do [- Generator src (patvar "mods")+ | otherwise = Do () [+ Generator () (patvar "mods") $ pvar "sepEndBy"- $$ Paren (pvar "choice" $$ List (map (lvar . parserName) flds ++ map (lvar . parserNameO) os))+ $$ Paren () (pvar "choice" $$ List () (map (lvar . parserName) flds ++ map (lvar . parserNameO) os)) $$ pvar "spaces",- Qualifier $ (preludevar "return")- $$ Paren (preludevar "foldl"- $$ Lambda src [patvar "v", patvar "f"] (lvar "f" $$ lvar "v")+ Qualifier () $ (preludevar "return")+ $$ Paren () (preludevar "foldl"+ $$ Lambda () [patvar "v", patvar "f"] (lvar "f" $$ lvar "v") $$ pvar "defaultValue" $$ lvar "mods") ]- parserName f = let Ident fname = baseIdent' (fieldName f) in "parse'" ++ fname- parserNameO o = let Ident oname = baseIdent' (oneofFName o) in "parse'" ++ oname+ parserName f = let Ident () fname = baseIdent' (fieldName f) in "parse'" ++ fname+ parserNameO o = let Ident () oname = baseIdent' (oneofFName o) in "parse'" ++ oname subparsers = map (\f -> defun (parserName f) [] (getField f)) flds getField fi = let printname = toPrintName fi- Ident funcname = baseIdent' (fieldName fi)- update = if canRepeat fi then pvar "append" $$ Paren (lvar funcname $$ lvar "o") $$ lvar "v" else lvar "v"- in pvar "try" $$ Do [- Generator src (patvar "v") $ pvar "getT" $$ litStr printname,- Qualifier $ (preludevar "return")- $$ Paren (Lambda src [patvar "o"]- (RecUpdate (lvar "o") [ FieldUpdate (local funcname) update]))+ Ident () funcname = baseIdent' (fieldName fi)+ update = if canRepeat fi then pvar "append" $$ Paren () (lvar funcname $$ lvar "o") $$ lvar "v" else lvar "v"+ in pvar "try" $$ Do () [+ Generator () (patvar "v") $ pvar "getT" $$ litStr printname,+ Qualifier () $ (preludevar "return")+ $$ Paren () (Lambda () [patvar "o"]+ (RecUpdate () (lvar "o") [ FieldUpdate () (local funcname) update])) ] subparsersO = map funbind os- funbind o = FunBind [Match src (Ident (parserNameO o)) [] Nothing (UnGuardedRhs (getOneof)) whereParse]+ funbind o = FunBind () [Match () (Ident () (parserNameO o)) [] (UnGuardedRhs () (getOneof)) whereParse] where getOneof = pvar "try" $$- (pvar "choice" $$ List (map (Var . UnQual . Ident) parsefs))+ (pvar "choice" $$ List () (map (Var () . UnQual () . Ident ()) parsefs)) oflds = F.toList (oneofFields o) flds = map snd oflds parsefs = map parserName flds- whereParse = whereBinds $ BDecls (map decl oflds)+ whereParse = whereBinds $ BDecls () (map decl oflds) where decl (n,f) = defun (parserName f) [] (getOneofField (n,f)) getOneofField p@(n,f) =- let Ident oname = baseIdent' (oneofFName o)+ let Ident () oname = baseIdent' (oneofFName o) printname = toPrintName f- update = preludecon "Just" $$ Paren (oneofCon p $$ lvar "v")- in pvar "try" $$ Do [- Generator src (patvar "v") $ pvar "getT" $$ litStr printname,- Qualifier $ (preludevar "return")- $$ Paren (Lambda src [patvar "s"]- (RecUpdate (lvar "s") [ FieldUpdate (local oname) update]))+ update = preludecon "Just" $$ Paren () (oneofCon p $$ lvar "v")+ in pvar "try" $$ Do () [+ Generator () (patvar "v") $ pvar "getT" $$ litStr printname,+ Qualifier () $ (preludevar "return")+ $$ Paren () (Lambda () [patvar "s"]+ (RecUpdate () (lvar "s") [ FieldUpdate () (local oname) update])) ] -printField :: String -> FieldInfo -> Exp+printField :: String -> FieldInfo -> Exp () printField msgVar fi- = let Ident funcname = baseIdent' (fieldName fi)+ = let Ident () funcname = baseIdent' (fieldName fi) printname = toPrintName fi- in pvar "tellT" $$ litStr printname $$ Paren (lvar funcname $$ lvar msgVar)+ in pvar "tellT" $$ litStr printname $$ Paren () (lvar funcname $$ lvar msgVar) toPrintName :: FieldInfo -> String toPrintName fi = let IName uname = last $ splitFI $ protobufName' (fieldName fi) in uToString uname -printOneof :: String -> OneofInfo -> Exp+printOneof :: String -> OneofInfo -> Exp () printOneof msgVar oi- = Case (Paren (lvar funcname $$ lvar msgVar)) (map caseAlt flds ++ [caseAltNothing])- where Ident funcname = baseIdent' (oneofFName oi)+ = Case () (Paren () (lvar funcname $$ lvar msgVar)) (map caseAlt flds ++ [caseAltNothing])+ where Ident () funcname = baseIdent' (oneofFName oi) IName uname = last $ splitFI $ protobufName' (oneofFName oi) printname = uToString uname flds = F.toList (oneofFields oi)- caseAlt :: (ProtoName,FieldInfo) -> Alt- caseAlt f = Alt src patt (UnGuardedRhs rhs) noWhere- where patt = PApp (prelude "Just") [fst (oneofPat f)]+ caseAlt :: (ProtoName,FieldInfo) -> Alt ()+ caseAlt f = Alt () patt (UnGuardedRhs () rhs) noWhere+ where patt = PApp () (prelude "Just") [fst (oneofPat f)] (rstr,rvar) = oneofRec f rhs = pvar "tellT" $$ rstr $$ rvar -- litStr fname $$ (lvar fname)- caseAltNothing :: Alt- caseAltNothing = Alt src (PApp (prelude "Nothing") []) (UnGuardedRhs rhs) noWhere- where rhs = preludevar "return" $$ unit_con+ caseAltNothing :: Alt ()+ caseAltNothing = Alt () (PApp () (prelude "Nothing") []) (UnGuardedRhs () rhs) noWhere+ where rhs = preludevar "return" $$ unit_con () -instanceMergeable :: DescriptorInfo -> Decl+instanceMergeable :: DescriptorInfo -> Decl () instanceMergeable di- = InstDecl src Nothing [] [] (private "Mergeable") [TyCon un]+ = InstDecl () Nothing (mkSimpleIRule (private "Mergeable") [TyCon () un]) . Just $ [ -- inst "mergeEmpty" [] (foldl' App (Con un) (replicate len (pvar "mergeEmpty"))),- inst "mergeAppend" [PApp un patternVars1, PApp un patternVars2]- (foldl' App (Con un) (zipWith append vars1 vars2))+ inst "mergeAppend" [PApp () un patternVars1, PApp () un patternVars2]+ (foldl' (App ()) (Con () un) (zipWith append vars1 vars2)) ] where un = unqualName (descName di) len = (if hasExt di then succ else id) $ (if storeUnknown di then succ else id) $ Seq.length (fields di) + Seq.length (descOneofs di)- patternVars1,patternVars2 :: [Pat]+ patternVars1,patternVars2 :: [Pat ()] patternVars1 = take len inf where inf = map (\ n -> patvar ("x'" ++ show n)) [(1::Int)..] patternVars2 = take len inf where inf = map (\ n -> patvar ("y'" ++ show n)) [(1::Int)..]- vars1,vars2 :: [Exp]+ vars1,vars2 :: [Exp ()] vars1 = take len inf where inf = map (\ n -> lvar ("x'" ++ show n)) [(1::Int)..] vars2 = take len inf where inf = map (\ n -> lvar ("y'" ++ show n)) [(1::Int)..]- append x y = Paren $ pvar "mergeAppend" $$ x $$ y+ append x y = Paren () $ pvar "mergeAppend" $$ x $$ y -instanceDefault :: DescriptorInfo -> Decl+instanceDefault :: DescriptorInfo -> Decl () instanceDefault di- = InstDecl src Nothing [] [] (private "Default") [TyCon un]- [ inst "defaultValue" [] (foldl' App (Con un) deflistExt) ]+ = InstDecl () Nothing (mkSimpleIRule (private "Default") [TyCon () un]) . Just $+ [ inst "defaultValue" [] (foldl' (App ()) (Con () un) deflistExt) ] where un = unqualName (descName di) deflistExt = F.foldr ((:) . defX) end (fields di) end = (if hasExt di then (pvar "defaultValue":) else id) . (if storeUnknown di then (pvar "defaultValue":) else id) $ F.foldr ((:) . defOneof) [] (descOneofs di) - defX :: FieldInfo -> Exp+ defX :: FieldInfo -> Exp () defX fi | isRequired fi = dv1 | otherwise = dv2 where dv1 = case hsDefault fi of@@ -1002,19 +933,19 @@ Just hsdef -> defToSyntax (typeCode fi) hsdef dv2 = case hsDefault fi of Nothing -> pvar "defaultValue"- Just hsdef -> Paren $ preludecon "Just" $$ defToSyntax (typeCode fi) hsdef- defOneof :: OneofInfo -> Exp+ Just hsdef -> Paren () $ preludecon "Just" $$ defToSyntax (typeCode fi) hsdef+ defOneof :: OneofInfo -> Exp () defOneof oi= pvar "defaultValue" -instanceMessageAPI :: ProtoName -> Decl+instanceMessageAPI :: ProtoName -> Decl () instanceMessageAPI protoName- = InstDecl src Nothing [] [] (private "MessageAPI")- [TyVar (Ident "msg'"), TyFun (TyVar (Ident "msg'")) (TyCon un), (TyCon un)]- [ inst "getVal" [patvar "m'",patvar "f'"] (App (lvar "f'" ) (lvar "m'")) ]+ = InstDecl () Nothing (mkSimpleIRule (private "MessageAPI")+ [TyVar () (Ident () "msg'"), TyParen () (TyFun () (TyVar () (Ident () "msg'")) (TyCon () un)), (TyCon () un)]) . Just $+ [ inst "getVal" [patvar "m'",patvar "f'"] (App () (lvar "f'" ) (lvar "m'")) ] where un = unqualName protoName -instanceWireDescriptor :: DescriptorInfo -> Decl+instanceWireDescriptor :: DescriptorInfo -> Decl () instanceWireDescriptor di@(DescriptorInfo { descName = protoName , fields = fieldInfos , descOneofs = oneofInfos@@ -1025,7 +956,7 @@ len = (if extensible then succ else id) $ (if storeUnknown di then succ else id) $ Seq.length fieldInfos + Seq.length oneofInfos- mine = PApp me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [(1::Int)..]+ mine = PApp () me . take len . map (\ n -> patvar ("x'" ++ show n)) $ [(1::Int)..] vars = take len . map (\ n -> lvar ("x'" ++ show n)) $ [(1::Int)..] mExt | extensible = Just (vars !! Seq.length fieldInfos) | otherwise = Nothing@@ -1034,22 +965,18 @@ -- reusable 'cases' generator -- first case is for Group behavior, second case is for Message behavior, last is error handler- cases g m e = Case (lvar "ft'") [ Alt src (litIntP' 10) (UnGuardedRhs g) noWhere- , Alt src (litIntP' 11) (UnGuardedRhs m) noWhere- , Alt src PWildCard (UnGuardedRhs e) noWhere+ cases g m e = Case () (lvar "ft'") [ Alt () (litIntP' 10) (UnGuardedRhs () g) noWhere+ , Alt () (litIntP' 11) (UnGuardedRhs () m) noWhere+ , Alt () (PWildCard ()) (UnGuardedRhs () e) noWhere ] -- wireSize generation- sizeCases = UnGuardedRhs $ cases (lvar "calc'Size")+ 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)+ whereCalcSize = Just (BDecls () [defun "calc'Size" [] sizes])+ sizes | null sizesList = Lit () (Hse.Int () 0 "0")+ | otherwise = Paren () (foldl1' (+!) sizesList) where (+!) = mkOp "+" sizesList | Just v <- mUnknown = sizesListExt ++ [ pvar "wireSizeUnknownField" $$ v ] | otherwise = sizesListExt@@ -1062,36 +989,32 @@ else if isRequired fi then "wireSizeReq" else if canRepeat fi then "wireSizeRep" else "wireSizeOpt"- in [foldl' App (pvar f) [ litInt (wireTagLength fi)+ in [foldl' (App ()) (pvar f) [ litInt (wireTagLength fi) , litInt (getFieldType (typeCode fi)) , var]] toSize var (Right oi) = map (toSize' var) . F.toList . oneofFields $ oi where toSize' var r@(n,fi) = let f = "wireSizeOpt"- var' = mkOp "Prelude'.=<<" (Var (qualName (snd (oneofGet r)))) var- in foldl' App (pvar f) [ litInt (wireTagLength fi)+ var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var+ in foldl' (App ()) (pvar f) [ litInt (wireTagLength fi) , litInt (getFieldType (typeCode fi)) , var'] -- wirePut generation- putCases = UnGuardedRhs $ cases+ putCases = UnGuardedRhs () $ cases (lvar "put'Fields")- (Do [ Qualifier $ pvar "putSize" $$- (Paren $ foldl' App (pvar "wireSize") [ litInt' 10 , lvar "self'" ])- , Qualifier $ lvar "put'Fields" ])+ (Do () [ Qualifier () $ pvar "putSize" $$+ (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+ wherePutFields = Just (BDecls () [defun "put'Fields" [] (Do () putStmts)]) putStmts = putStmtsContent- where putStmtsContent | null putStmtsAll = [Qualifier $ preludevar "return" $$ Con (Special UnitCon)]+ where putStmtsContent | null putStmtsAll = [Qualifier () $ preludevar "return" $$ Con () (Special () (UnitCon ()))] | otherwise = putStmtsAll- putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ Qualifier $ pvar "wirePutUnknownField" $$ v ]+ putStmtsAll | Just v <- mUnknown = putStmtsListExt ++ [ Qualifier () $ pvar "wirePutUnknownField" $$ v ] | otherwise = putStmtsListExt- putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ Qualifier $ pvar "wirePutExtField" $$ v ]+ putStmtsListExt | Just v <- mExt = sortedPutStmtsList ++ [ Qualifier () $ pvar "wirePutExtField" $$ v ] | otherwise = sortedPutStmtsList sortedPutStmtsList = map snd -- remove number . sortBy (compare `on` fst) -- sort by number@@ -1104,18 +1027,18 @@ else if canRepeat fi then "wirePutRep" else "wirePutOpt" in [(fieldNumber fi,- Qualifier $- foldl' App (pvar f) [ litInt (getWireTag (wireTag 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"- var' = mkOp "Prelude'.=<<" (Var (qualName (snd (oneofGet r)))) var+ var' = mkOp "Prelude'.=<<" (Var () (qualName (snd (oneofGet r)))) var in (fieldNumber fi- ,Qualifier $- foldl' App (pvar f) [ litInt (getWireTag (wireTag fi))+ ,Qualifier () $+ foldl' (App ()) (pvar f) [ litInt (getWireTag (wireTag fi)) , litInt (getFieldType (typeCode fi)) , var'] )@@ -1123,18 +1046,14 @@ -- wireGet generation -- new for 1.5.7, rewriting this a great deal! getCases = let param = if storeUnknown di- then Paren (pvar "catch'Unknown" $$ lvar "update'Self")+ then Paren () (pvar "catch'Unknown" $$ lvar "update'Self") else lvar "update'Self"- in UnGuardedRhs $ cases (pvar "getBareMessageWith" $$ param)+ 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+ whereDecls = Just (BDecls () [whereUpdateSelf]) whereUpdateSelf = defun "update'Self" [patvar "wire'Tag", patvar "old'Self"]- (Case (lvar "wire'Tag") updateAlts)+ (Case () (lvar "wire'Tag") updateAlts) -- update cases are all normal fields then all known extensions then wildcard updateAlts = concatMap toUpdate (F.toList fieldInfos) ++ (do -- in list monad@@ -1142,23 +1061,19 @@ f <- F.toList (oneofFields o) toUpdateO o f) ++ (if extensible then concatMap toUpdateExt (F.toList fieldExts) else [])- ++ [Alt src PWildCard (UnGuardedRhs wildcardAlt) noWhere]+ ++ [Alt () (PWildCard ()) (UnGuardedRhs () wildcardAlt) noWhere] -- 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])- extBranch | extensible = If (isAllowedExt (lvar "field'Number"))+ where letPair = Let () (BDecls () [PatBind () (PTuple () Boxed [patvar "field'Number",patvar "wire'Type"])+ (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+ isAllowedExt x = preludevar "or" $$ List () ranges where (<=!) = mkOp "<="; (&&!) = mkOp "&&"; (==!) = mkOp "=="; (FieldId maxHi) = maxBound ranges = map (\ (FieldId lo,FieldId hi) -> if hi < maxHi@@ -1175,12 +1090,12 @@ where (getUnP,getP) | isPacked fi = (pvar "wireGetKeyToPacked",pvar "wireGetKey") | otherwise = (pvar "wireGetKey",pvar "wireGetKeyToUnPacked") toUpdateExtUnpacked wt1 =- Alt src (litIntP . getWireTag $ wt1)- (UnGuardedRhs $ getUnP $$ Var (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")+ Alt () (litIntP . getWireTag $ wt1)+ (UnGuardedRhs () $ getUnP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere toUpdateExtPacked wt2 =- Alt src (litIntP . getWireTag $ wt2)- (UnGuardedRhs $ getP $$ Var (mayQualName protoName (fieldName fi)) $$ lvar "old'Self")+ Alt () (litIntP . getWireTag $ wt2)+ (UnGuardedRhs () $ getP $$ Var () (mayQualName protoName (fieldName fi)) $$ lvar "old'Self") noWhere -- wireGet without extensions@@ -1190,30 +1105,30 @@ toUpdateUnpacked wt1 fi =- Alt src (litIntP . getWireTag $ wt1) (UnGuardedRhs $- preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $- RecUpdate (lvar "old'Self")- [FieldUpdate (unqualFName . fieldName $ fi)+ Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $+ preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $+ RecUpdate () (lvar "old'Self")+ [FieldUpdate () (unqualFName . fieldName $ fi) (labelUpdateUnpacked fi)])- $$ (Paren (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere- labelUpdateUnpacked fi | canRepeat fi = pvar "append" $$ Paren ((Var . unqualFName . fieldName $ fi)+ $$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ labelUpdateUnpacked fi | canRepeat fi = pvar "append" $$ Paren () ((Var () . unqualFName . fieldName $ fi) $$ lvar "old'Self") $$ lvar "new'Field" | isRequired fi = qMerge (lvar "new'Field") | otherwise = qMerge (preludecon "Just" $$ lvar "new'Field") where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =- pvar "mergeAppend" $$ Paren ( (Var . unqualFName . fieldName $ fi)+ pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . fieldName $ fi) $$ lvar "old'Self" )- $$ Paren x+ $$ Paren () x | otherwise = x toUpdatePacked wt2 fi =- Alt src (litIntP . getWireTag $ wt2) (UnGuardedRhs $- preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $- RecUpdate (lvar "old'Self")- [FieldUpdate (unqualFName . fieldName $ fi)+ Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $+ preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $+ RecUpdate () (lvar "old'Self")+ [FieldUpdate () (unqualFName . fieldName $ fi) (labelUpdatePacked fi)])- $$ (Paren (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere- labelUpdatePacked fi = pvar "mergeAppend" $$ Paren ((Var . unqualFName . fieldName $ fi)+ $$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ labelUpdatePacked fi = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . fieldName $ fi) $$ lvar "old'Self") $$ lvar "new'Field" @@ -1229,65 +1144,70 @@ | otherwise = [toUpdateUnpackedO oi (wireTag fi) f] toUpdateUnpackedO oi wt1 f@(_,fi) =- Alt src (litIntP . getWireTag $ wt1) (UnGuardedRhs $- preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $- RecUpdate (lvar "old'Self")- [FieldUpdate (unqualFName . oneofFName $ oi)+ Alt () (litIntP . getWireTag $ wt1) (UnGuardedRhs () $+ preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $+ RecUpdate () (lvar "old'Self")+ [FieldUpdate () (unqualFName . oneofFName $ oi) (labelUpdateUnpackedO oi f)])- $$ (Paren (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ $$ (Paren () (pvar "wireGet" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere labelUpdateUnpackedO oi f@(_,fi) = qMerge (preludecon "Just" $$ (oneofCon f $$ lvar "new'Field") ) where qMerge x | fromIntegral (getFieldType (typeCode fi)) `elem` [10,(11::Int)] =- pvar "mergeAppend" $$ Paren ( (Var . unqualFName . oneofFName $ oi)+ pvar "mergeAppend" $$ Paren () ( (Var () . unqualFName . oneofFName $ oi) $$ lvar "old'Self" )- $$ Paren x+ $$ Paren () x | otherwise = x toUpdatePackedO oi wt2 f@(_,fi) =- Alt src (litIntP . getWireTag $ wt2) (UnGuardedRhs $- preludevar "fmap" $$ (Paren $ Lambda src [PBangPat (patvar "new'Field")] $- RecUpdate (lvar "old'Self")- [FieldUpdate (unqualFName . oneofFName $ oi)+ Alt () (litIntP . getWireTag $ wt2) (UnGuardedRhs () $+ preludevar "fmap" $$ (Paren () $ Lambda () [PBangPat () (patvar "new'Field")] $+ RecUpdate () (lvar "old'Self")+ [FieldUpdate () (unqualFName . oneofFName $ oi) (labelUpdatePackedO oi f)])- $$ (Paren (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere- labelUpdatePackedO oi f@(_,fi) = pvar "mergeAppend" $$ Paren ((Var . unqualFName . oneofFName $ oi)+ $$ (Paren () (pvar "wireGetPacked" $$ (litInt . getFieldType . typeCode $ fi)))) noWhere+ labelUpdatePackedO oi f@(_,fi) = pvar "mergeAppend" $$ Paren () ((Var () . unqualFName . oneofFName $ oi) $$ lvar "old'Self")- $$ Paren (preludecon "Just" $$+ $$ Paren () (preludecon "Just" $$ (oneofCon f $$ lvar "new'Field")) ---- in InstDecl src Nothing [] [] (private "Wire") [TyCon me] . map InsDecl $- [ FunBind [Match src (Ident "wireSize") [patvar "ft'",PAsPat (Ident "self'") (PParen mine)] Nothing sizeCases whereCalcSize]- , FunBind [Match src (Ident "wirePut") [patvar "ft'",PAsPat (Ident "self'") (PParen mine)] Nothing putCases wherePutFields]- , FunBind [Match src (Ident "wireGet") [patvar "ft'"] Nothing getCases whereDecls]+ 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 () "wireGet") [patvar "ft'"] getCases whereDecls] ] -instanceReflectDescriptor :: DescriptorInfo -> Decl+instanceReflectDescriptor :: DescriptorInfo -> Decl () instanceReflectDescriptor di- = InstDecl src Nothing [] [] (private "ReflectDescriptor") [TyCon (unqualName (descName di))]- [ inst "getMessageInfo" [PWildCard] gmi- , inst "reflectDescriptorInfo" [ PWildCard ] rdi ]+ = InstDecl () Nothing (mkSimpleIRule (private "ReflectDescriptor") [TyCon () (unqualName (descName di))]) . Just $+ [ inst "getMessageInfo" [PWildCard ()] gmi+ , inst "reflectDescriptorInfo" [PWildCard ()] rdi ] where -- massive shortcut through show and read- rdi :: Exp+ rdi :: Exp () rdi = preludevar "read" $$ litStr (show di)- gmi,reqId,allId :: Exp- gmi = pcon "GetMessageInfo" $$ Paren reqId $$ Paren allId+ gmi,reqId,allId :: Exp ()+ gmi = pcon "GetMessageInfo" $$ Paren () reqId $$ Paren () allId reqId = pvar "fromDistinctAscList" $$- List (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di), isRequired fi])+ List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di), isRequired fi]) allId = pvar "fromDistinctAscList" $$- List (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di)] +++ List () (map litInt . sort . concat $ [ allowedList fi | fi <- F.toList (fields di)] ++ [ allowedList fi | fi <- F.toList (knownKeys di)]) allowedList fi | Just (wt1,wt2) <- packedTag fi = [getWireTag wt1,getWireTag wt2] | otherwise = [getWireTag (wireTag fi)] ------------------------------------------------------------------ -derives,derivesEnum :: [Deriving]-derives = map (\ x -> (prelude x,[])) ["Show","Eq","Ord","Typeable","Data","Generic"]-derivesEnum = map (\ x -> (prelude x,[])) ["Read","Show","Eq","Ord","Typeable","Data","Generic"]+mkSimpleIRule :: QName () -> [Type ()] -> InstRule ()+mkSimpleIRule con args =+ let instHead = foldl' (IHApp ()) (IHCon () con) args+ in IRule () Nothing Nothing instHead +mkDeriving :: [QName ()] -> Deriving ()+mkDeriving xs = Deriving () (map (\x -> mkSimpleIRule x []) xs)++derives,derivesEnum :: Deriving ()+derives = mkDeriving $ map prelude ["Show","Eq","Ord","Typeable","Data","Generic"]+derivesEnum = mkDeriving $ map prelude ["Read","Show","Eq","Ord","Typeable","Data","Generic"]+ -- All of these type names are also exported by Text.ProtocolBuffers.Header via Text.ProtocolBuffers.Basic useType :: Int -> Maybe String useType 1 = Just "Double"@@ -1309,5 +1229,3 @@ useType 17 = Just "Int32" useType 18 = Just "Int64" useType x = imp $ "useType: Unknown type code (expected 1 to 18) of "++show x--
hprotoc.cabal view
@@ -1,5 +1,5 @@ name: hprotoc-version: 2.4.4+version: 2.4.5 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.4.4,- protocol-buffers-descriptor == 2.4.4+ build-depends: protocol-buffers == 2.4.5,+ protocol-buffers-descriptor == 2.4.5 Main-Is: Text/ProtocolBuffers/ProtoCompile.hs Hs-Source-Dirs: ., protoc-gen-haskell@@ -35,7 +35,7 @@ containers, directory >= 1.0.0.1, filepath >= 1.1.0.0,- haskell-src-exts >= 1.16.0 && < 1.18,+ haskell-src-exts >= 1.18, mtl, parsec, utf8-string@@ -69,8 +69,8 @@ TypeSynonymInstances Library- build-depends: protocol-buffers == 2.4.4,- protocol-buffers-descriptor == 2.4.4+ build-depends: protocol-buffers == 2.4.5,+ protocol-buffers-descriptor == 2.4.5 Hs-Source-Dirs: ., protoc-gen-haskell build-tools: alex