From 0cd0cece24b23d74c677ab04942f615852520734 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Wed, 30 Sep 2020 22:27:56 +0300 Subject: Minor TTG clean-up: comments, unused families, bottom 1. Fix and update section headers in GHC/Hs/Extension.hs 2. Delete the unused 'XCoreAnn' and 'XTickPragma' families 3. Avoid calls to 'panic' in 'pprStmt' --- compiler/GHC/Hs/Expr.hs | 25 +++++--------- compiler/GHC/Hs/Extension.hs | 81 ++++++++++++++++++++++++-------------------- 2 files changed, 54 insertions(+), 52 deletions(-) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 11a102f91b..648b075f71 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -847,7 +847,6 @@ data HsPragE p | XHsPragE !(XXPragE p) type instance XSCC (GhcPass _) = NoExtField -type instance XCoreAnn (GhcPass _) = NoExtField type instance XXPragE (GhcPass _) = NoExtCon -- | Located Haskell Tuple Argument @@ -2403,7 +2402,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _) Just False -> text "return" Nothing -> empty) <+> ppr expr -pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr] +pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _) = ppr expr pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) @@ -2439,11 +2438,8 @@ pprStmt (ApplicativeStmt _ args mb_join) flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne _ pat expr isBody) - | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] - | otherwise = - [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))] + | isBody = [ppr expr] -- See Note [Applicative BodyStmt] + | otherwise = [pprBindStmt pat expr] flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = concatMap flattenStmt stmts @@ -2457,6 +2453,8 @@ pprStmt (ApplicativeStmt _ args mb_join) pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, applicativeArg) = ppr applicativeArg +pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc +pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] instance (OutputableBndrId idL) => Outputable (ApplicativeArg (GhcPass idL)) where @@ -2464,18 +2462,13 @@ instance (OutputableBndrId idL) pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc pprArg (ApplicativeArgOne _ pat expr isBody) - | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) - | otherwise = - ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL)) + | isBody = ppr expr -- See Note [Applicative BodyStmt] + | otherwise = pprBindStmt pat expr pprArg (ApplicativeArgMany _ stmts return pat ctxt) = ppr pat <+> text "<-" <+> - ppr (HsDo (panic "pprStmt") ctxt (noLoc - (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])) - :: HsExpr (GhcPass idL)) + pprDo ctxt (stmts ++ + [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]) pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 119997cdb1..13c2f157e5 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -331,11 +331,11 @@ type family XHsIPBinds x x' type family XEmptyLocalBinds x x' type family XXHsLocalBindsLR x x' --- ValBindsLR type families +-- HsValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' --- HsBindsLR type families +-- HsBindLR type families type family XFunBind x x' type family XPatBind x x' type family XVarBind x x' @@ -469,7 +469,7 @@ type family XCClsInstDecl x type family XXClsInstDecl x -- ------------------------------------- --- ClsInstDecl type families +-- InstDecl type families type family XClsInstD x type family XDataFamInstD x type family XTyFamInstD x @@ -490,7 +490,7 @@ type family XCDefaultDecl x type family XXDefaultDecl x -- ------------------------------------- --- DefaultDecl type families +-- ForeignDecl type families type family XForeignImport x type family XForeignExport x type family XXForeignDecl x @@ -517,7 +517,7 @@ type family XWarnings x type family XXWarnDecls x -- ------------------------------------- --- AnnDecl type families +-- WarnDecl type families type family XWarning x type family XXWarnDecl x @@ -574,32 +574,34 @@ type family XBinTick x type family XPragE x type family XXExpr x +-- ------------------------------------- +-- HsPragE type families type family XSCC x -type family XCoreAnn x -type family XTickPragma x type family XXPragE x --- --------------------------------------------------------------------- + +-- ------------------------------------- +-- AmbiguousFieldOcc type families type family XUnambiguous x type family XAmbiguous x type family XXAmbiguousFieldOcc x --- ---------------------------------------------------------------------- - +-- ------------------------------------- +-- HsTupArg type families type family XPresent x type family XMissing x type family XXTupArg x --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- HsSplice type families type family XTypedSplice x type family XUntypedSplice x type family XQuasiQuote x type family XSpliced x type family XXSplice x --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- HsBracket type families type family XExpBr x type family XPatBr x type family XDecBrL x @@ -609,33 +611,33 @@ type family XVarBr x type family XTExpBr x type family XXBracket x --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- HsCmdTop type families type family XCmdTop x type family XXCmdTop x -- ------------------------------------- - +-- MatchGroup type families type family XMG x b type family XXMatchGroup x b -- ------------------------------------- - +-- Match type families type family XCMatch x b type family XXMatch x b -- ------------------------------------- - +-- GRHSs type families type family XCGRHSs x b type family XXGRHSs x b -- ------------------------------------- - +-- GRHS type families type family XCGRHS x b type family XXGRHS x b -- ------------------------------------- - +-- StmtLR type families type family XLastStmt x x' b type family XBindStmt x x' b type family XApplicativeStmt x x' b @@ -646,8 +648,8 @@ type family XTransStmt x x' b type family XRecStmt x x' b type family XXStmtLR x x' b --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- HsCmd type families type family XCmdArrApp x type family XCmdArrForm x type family XCmdApp x @@ -661,13 +663,13 @@ type family XCmdDo x type family XCmdWrap x type family XXCmd x --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- ParStmtBlock type families type family XParStmtBlock x x' type family XXParStmtBlock x x' --- --------------------------------------------------------------------- - +-- ------------------------------------- +-- ApplicativeArg type families type family XApplicativeArgOne x type family XApplicativeArgMany x type family XXApplicativeArg x @@ -697,6 +699,8 @@ type family XHsFloatPrim x type family XHsDoublePrim x type family XXLit x +-- ------------------------------------- +-- HsOverLit type families type family XOverLit x type family XXOverLit x @@ -725,26 +729,29 @@ type family XXPat x -- ===================================================================== -- Type families for the HsTypes type families + +-- ------------------------------------- +-- LHsQTyVars type families type family XHsQTvs x type family XXLHsQTyVars x -- ------------------------------------- - +-- HsImplicitBndrs type families type family XHsIB x b type family XXHsImplicitBndrs x b -- ------------------------------------- - +-- HsWildCardBndrs type families type family XHsWC x b type family XXHsWildCardBndrs x b -- ------------------------------------- - +-- HsPatSigType type families type family XHsPS x type family XXHsPatSigType x -- ------------------------------------- - +-- HsType type families type family XForAllTy x type family XQualTy x type family XTyVar x @@ -770,35 +777,37 @@ type family XWildCardTy x type family XXType x -- --------------------------------------------------------------------- - +-- HsForAllTelescope type families type family XHsForAllVis x type family XHsForAllInvis x type family XXHsForAllTelescope x -- --------------------------------------------------------------------- - +-- HsTyVarBndr type families type family XUserTyVar x type family XKindedTyVar x type family XXTyVarBndr x -- --------------------------------------------------------------------- - +-- ConDeclField type families type family XConDeclField x type family XXConDeclField x -- --------------------------------------------------------------------- - +-- FieldOcc type families type family XCFieldOcc x type family XXFieldOcc x -- ===================================================================== -- Type families for the HsImpExp type families +-- ------------------------------------- +-- ImportDecl type families type family XCImportDecl x type family XXImportDecl x -- ------------------------------------- - +-- IE type families type family XIEVar x type family XIEThingAbs x type family XIEThingAll x -- cgit v1.2.1