From d0846243747213218cba856d5c322016bd3e6d9e Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 12 Feb 2016 13:42:55 +0000 Subject: Improve pretty-printing of HsWrappers Reduces un-neede parens. Also -fprint-typechecker-elaboration now makes type applications and casts in expressions also appear. (Previously those were confusingly controlled by -fprint-explicit-coercions.) --- compiler/hsSyn/HsExpr.hs | 40 +++++++++++++---------- compiler/hsSyn/HsPat.hs | 22 ++++++++----- compiler/typecheck/TcEvidence.hs | 40 ++++++++++++----------- compiler/typecheck/TcExpr.hs | 6 ++-- compiler/typecheck/TcSplice.hs | 2 +- testsuite/tests/roles/should_compile/T8958.stderr | 10 +++--- 6 files changed, 64 insertions(+), 56 deletions(-) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index cfc373eeed..dd850c44bd 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -122,8 +122,8 @@ instance OutputableBndr id => Outputable (SyntaxExpr id) where = sdocWithDynFlags $ \ dflags -> getPprStyle $ \s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags - then ppr expr <> braces (pprWithCommas (pprHsWrapper (text "<>")) arg_wraps) - <> braces (pprHsWrapper (text "<>") res_wrap) + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) else ppr expr type CmdSyntaxTable id = [(Name, HsExpr id)] @@ -691,7 +691,7 @@ ppr_expr (HsCoreAnn _ (StringLiteral _ s) e) ppr_expr (HsApp e1 e2) = let (fun, args) = collect_args e1 [e2] in - hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args)) + hang (ppr_lexpr fun) 2 (sep (map pprParendLExpr args)) where collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -803,15 +803,18 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info) ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' -ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e -ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e +ppr_expr (ELazyPat e) = char '~' <> pprParendLExpr e +ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendLExpr e ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e ppr_expr (HsSCC _ (StringLiteral _ lbl) expr) = sep [ text "{-# SCC" <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), - pprParendExpr expr ] + pprParendLExpr expr ] + +ppr_expr (HsWrap co_fn e) + = pprHsWrapper co_fn (\parens -> if parens then pprParendExpr e + else pprExpr e) -ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn ppr_expr (HsType (HsWC { hswc_body = ty })) = char '@' <> pprParendHsType (unLoc ty) ppr_expr (HsTypeOut (HsWC { hswc_body = ty })) @@ -828,7 +831,7 @@ ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] ppr_expr (HsStatic e) - = hsep [text "static", pprParendExpr e] + = hsep [text "static", pprParendLExpr e] ppr_expr (HsTick tickish exp) = pprTicks (ppr exp) $ @@ -874,7 +877,7 @@ HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens. However, some code is internally generated, and in some places parens are absolutely required; so for these places we use -pprParendExpr (but don't print double parens of course). +pprParendLExpr (but don't print double parens of course). For operator applications we don't add parens, because the operator fixities should do the job, except in debug mode (-dppr-debug) so we @@ -884,13 +887,16 @@ can see the structure of the parse tree. pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> - if debugStyle sty then pprParendExpr expr + if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprParendLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprParendLExpr (L _ e) = pprParendExpr e + +pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc pprParendExpr expr - | hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr) - | otherwise = pprLExpr expr + | hsExprNeedsParens expr = parens (pprExpr expr) + | otherwise = pprExpr expr -- Using pprLExpr makes sure that we go 'deeper' -- I think that is usually (always?) right @@ -1082,7 +1088,7 @@ ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) = let (fun, args) = collect_args c [e] in - hang (ppr_lcmd fun) 2 (sep (map pprParendExpr args)) + hang (ppr_lcmd fun) 2 (sep (map pprParendLExpr args)) where collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -1111,8 +1117,8 @@ ppr_cmd (HsCmdLet (L _ binds) cmd) ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts -ppr_cmd (HsCmdWrap w cmd) = pprHsWrapper (ppr_cmd cmd) w - +ppr_cmd (HsCmdWrap w cmd) + = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) @@ -1925,7 +1931,7 @@ ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc ppr_splice herald n e = herald <> ifPprDebug (brackets (ppr n)) <> eDoc where - -- We use pprLExpr to match pprParendExpr: + -- We use pprLExpr to match pprParendLExpr: -- Using pprLExpr makes sure that we go 'deeper' -- I think that is usually (always?) right pp_as_was = pprLExpr e diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e1ccd63203..5b7f6d4971 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -57,6 +57,7 @@ import Outputable import Type import SrcLoc import Bag -- collect ev vars from pats +import DynFlags( gopt, GeneralFlag(..) ) import Maybes -- libraries: import Data.Data hiding (TyCon,Fixity) @@ -378,17 +379,18 @@ pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p pprParendPat :: (OutputableBndr name) => Pat name -> SDoc -pprParendPat p = getPprStyle $ \ sty -> - if need_parens sty p +pprParendPat p = sdocWithDynFlags $ \ dflags -> + if need_parens dflags p then parens (pprPat p) else pprPat p where - need_parens sty p - | CoPat {} <- p -- In debug style we print the cast - , debugStyle sty = True -- (see pprHsWrapper) so parens are needed - | otherwise = hsPatNeedsParens p - -- But otherwise the CoPat is discarded, so it - -- is the pattern inside that matters. Sigh. + need_parens dflags p + | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags + | otherwise = hsPatNeedsParens p + -- For a CoPat we need parens if we are going to show it, which + -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) + -- But otherwise the CoPat is discarded, so it + -- is the pattern inside that matters. Sigh. pprPat :: (OutputableBndr name) => Pat name -> SDoc pprPat (VarPat (L _ var)) = pprPatBndr var @@ -403,7 +405,9 @@ pprPat (NPat l Nothing _ _) = ppr l pprPat (NPat l (Just _) _ _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k] pprPat (SplicePat splice) = pprSplice splice -pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co +pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens + then pprParendPat pat + else pprPat pat) pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat pats _ _) = brackets (interpp'SP pats) diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index f58b73cf7f..30ce159aed 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -48,7 +48,7 @@ import Type import TyCon import Class( Class ) import PrelNames -import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) +import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) import VarEnv import VarSet import Name @@ -716,16 +716,18 @@ evVarsOfTypeable ev = -} instance Outputable HsWrapper where - ppr co_fn = pprHsWrapper (text "<>") co_fn - -pprHsWrapper :: SDoc -> HsWrapper -> SDoc --- In debug mode, print the wrapper --- otherwise just print what's inside -pprHsWrapper doc wrap + ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) + +pprHsWrapper ::HsWrapper -> (Bool -> SDoc) -> SDoc +-- With -fprint-typechecker-elaboration, print the wrapper +-- otherwise just print what's inside +-- The pp_thing_inside function takes Bool to say whether +-- it's in a position that needs parens for a non-atomic thing +pprHsWrapper wrap pp_thing_inside = sdocWithDynFlags $ \ dflags -> - getPprStyle (\ s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags - then (help (add_parens doc) wrap False) - else doc ) + if gopt Opt_PrintTypecheckerElaboration dflags + then help pp_thing_inside wrap False + else pp_thing_inside False where help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc -- True <=> appears in function application position @@ -736,18 +738,18 @@ pprHsWrapper doc wrap help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" <+> pprParendCo co)] - help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] - help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] pp_bndr v = pprBndr LambdaBind v <> dot - add_parens, no_parens :: SDoc -> Bool -> SDoc - add_parens d True = parens d - add_parens d False = d - no_parens d _ = d +add_parens, no_parens :: SDoc -> Bool -> SDoc +add_parens d True = parens d +add_parens d False = d +no_parens d _ = d instance Outputable TcEvBinds where ppr (TcEvBinds v) = ppr v diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 1911b063b1..970d2465a6 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1682,9 +1682,7 @@ tcSeq loc fun_name args res_ty too_many_args = failWith $ hang (text "Too many type arguments to seq:") - 2 (sep (map pprParendExpr args)) - - + 2 (sep (map pprParendLExpr args)) tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId]) -- tagToEnum# :: forall a. Int# -> a @@ -1744,7 +1742,7 @@ tcTagToEnum loc fun_name args res_ty too_many_args = failWith $ hang (text "Too many type arguments to tagToEnum#:") - 2 (sep (map pprParendExpr args)) + 2 (sep (map pprParendLExpr args)) {- ************************************************************************ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 924837c2d4..921da07d2d 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -513,7 +513,7 @@ spliceCtxtDoc splice spliceResultDoc :: LHsExpr Name -> SDoc spliceResultDoc expr = sep [ text "In the result of the splice:" - , nest 2 (char '$' <> pprParendExpr expr) + , nest 2 (char '$' <> pprParendLExpr expr) , text "To see what the splice expanded to, use -ddump-splices"] ------------------- diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 4434b1ee74..91b58a1ba6 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -62,19 +62,17 @@ T8958.$trModule (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T8958"#) AbsBinds [a] [] {Exports: [T8958.$fRepresentationala <= $dRepresentational - <> - <>] + wrap: <>] Exported types: T8958.$fRepresentationala :: forall a. Representational a [LclIdX[DFunId], Str=DmdType] - Binds: $dRepresentational = T8958.C:Representational + Binds: $dRepresentational = T8958.C:Representational @ a Evidence: [EvBinds{}]} AbsBinds [a] [] {Exports: [T8958.$fNominala <= $dNominal - <> - <>] + wrap: <>] Exported types: T8958.$fNominala :: forall a. Nominal a [LclIdX[DFunId], Str=DmdType] - Binds: $dNominal = T8958.C:Nominal + Binds: $dNominal = T8958.C:Nominal @ a Evidence: [EvBinds{}]} -- cgit v1.2.1