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.)

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{}]}