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, 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 - - diff --git a/hprotoc.cabal b/hprotoc.cabal --- a/hprotoc.cabal +++ b/hprotoc.cabal @@ -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