summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs25
-rw-r--r--compiler/GHC/Hs/Extension.hs81
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
View Lorry Controller Status