Commit d0846243 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.)
parent 12515187
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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))
{-
************************************************************************
......
......@@ -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"]
-------------------
......
......@@ -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{}]}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment