Fix #14875 by introducing PprPrec, and using it

Trying to determine when to insert parentheses during TH
conversion is a bit of a mess. There is an assortment of functions
that try to detect this, such as:

* `hsExprNeedsParens`
* `isCompoundHsType`
* `hsPatNeedsParens`
* `isCompoundPat`
* etc.

To make things worse, each of them have slightly different semantics.
Plus, they don't work well in the presence of explicit type
signatures, as #14875 demonstrates.

All of these problems can be alleviated with the use of an explicit
precedence argument (much like what `showsPrec` currently does). To
accomplish this, I introduce a new `PprPrec` data type, and define
standard predences for things like function application, infix
operators, function arrows, and explicit type signatures (that last
one is new). I then added `PprPrec` arguments to the various
`-NeedsParens` functions, and use them to make smarter decisions
about when things need to be parenthesized.

A nice side effect is that functions like `isCompoundHsType` are
now completely unneeded, since they're simply aliases for
`hsTypeNeedsParens appPrec`. As a result, I did a bit of refactoring
to remove these sorts of functions. I also did a pass over various
utility functions in GHC for constructing AST forms and used more
appropriate precedences where convenient.

Along the way, I also ripped out the existing `TyPrec`
data type (which was tailor-made for pretty-printing `Type`s) and
replaced it with `PprPrec` for consistency.

Test Plan: make test TEST=T14875

Reviewers: alanz, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14875

Differential Revision: https://phabricator.haskell.org/D4688

18 files changed, 417 insertions, 357 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index dfb7ab426b..6dfa37e52c 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -52,7 +52,7 @@ module BasicTypes(
 
         Boxity(..), isBoxed,
 
-        TyPrec(..), maybeParen,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
 
         TupleSort(..), tupleSortBoxity, boxityTupleSort,
         tupleParens,
@@ -692,40 +692,25 @@ pprSafeOverlap False = empty
 {-
 ************************************************************************
 *                                                                      *
-                Type precedence
+                Precedence
 *                                                                      *
 ************************************************************************
 -}
 
-data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
-  = TopPrec         -- No parens
-  | FunPrec         -- Function args; no parens for tycon apps
-  | TyOpPrec        -- Infix operator
-  | TyConPrec       -- Tycon args; no parens for atomic
+-- | A general-purpose pretty-printing precedence type.
+newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
+-- See Note [Precedence in types]
 
-instance Eq TyPrec where
-  (==) a b = case compare a b of
-               EQ -> True
-               _  -> False
+topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec
+topPrec = PprPrec 0 -- No parens
+sigPrec = PprPrec 1 -- Explicit type signatures
+funPrec = PprPrec 2 -- Function args; no parens for constructor apps
+                    -- See [Type operator precedence] for why both
+                    -- funPrec and opPrec exist.
+opPrec  = PprPrec 2 -- Infix operator
+appPrec = PprPrec 3 -- Constructor args; no parens for atomic
 
-instance Ord TyPrec where
-  compare TopPrec TopPrec  = EQ
-  compare TopPrec _        = LT
-
-  compare FunPrec TopPrec   = GT
-  compare FunPrec FunPrec   = EQ
-  compare FunPrec TyOpPrec  = EQ   -- See Note [Type operator precedence]
-  compare FunPrec TyConPrec = LT
-
-  compare TyOpPrec TopPrec   = GT
-  compare TyOpPrec FunPrec   = EQ  -- See Note [Type operator precedence]
-  compare TyOpPrec TyOpPrec  = EQ
-  compare TyOpPrec TyConPrec = LT
-
-  compare TyConPrec TyConPrec = EQ
-  compare TyConPrec _         = GT
-
-maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc
+maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
 maybeParen ctxt_prec inner_prec pretty
   | ctxt_prec < inner_prec = pretty
   | otherwise              = parens pretty
@@ -733,12 +718,12 @@ maybeParen ctxt_prec inner_prec pretty
 {- Note [Precedence in types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Many pretty-printing functions have type
-    ppr_ty :: TyPrec -> Type -> SDoc
+    ppr_ty :: PprPrec -> Type -> SDoc
 
-The TyPrec gives the binding strength of the context.  For example, in
+The PprPrec gives the binding strength of the context.  For example, in
    T ty1 ty2
 we will pretty-print 'ty1' and 'ty2' with the call
-  (ppr_ty TyConPrec ty)
+  (ppr_ty appPrec ty)
 to indicate that the context is that of an argument of a TyConApp.
 
 We use this consistently for Type and HsType.
@@ -751,16 +736,16 @@ pretty printer follows the following precedence order:
    TyConPrec         Type constructor application
    TyOpPrec/FunPrec  Operator application and function arrow
 
-We have FunPrec and TyOpPrec to represent the precedence of function
+We have funPrec and opPrec to represent the precedence of function
 arrow and type operators respectively, but currently we implement
-FunPred == TyOpPrec, so that we don't distinguish the two. Reason:
+funPrec == opPrec, so that we don't distinguish the two. Reason:
 it's hard to parse a type like
     a ~ b => c * d -> e - f
 
-By treating TyOpPrec = FunPrec we end up with more parens
+By treating opPrec = funPrec we end up with more parens
     (a ~ b) => (c * d) -> (e - f)
 
-But the two are different constructors of TyPrec so we could make
+But the two are different constructors of PprPrec so we could make
 (->) bind more or less tightly if we wanted.
 -}
 
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index f683cc8c59..9063d1f773 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -779,7 +779,7 @@ cvtClause :: HsMatchContext RdrName
           -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
 cvtClause ctxt (Clause ps body wheres)
   = do  { ps' <- cvtPats ps
-        ; pps <- mapM wrap_conpat ps'
+        ; let pps = map (parenthesizePat appPrec) ps'
         ; g'  <- cvtGuard body
         ; ds' <- cvtLocalDecs (text "a where clause") wheres
         ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
@@ -795,8 +795,10 @@ cvtl e = wrapL (cvt e)
     cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
     cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
     cvt (LitE l)
-      | overloadedLit l = go cvtOverLit (HsOverLit noExt) isCompoundHsOverLit
-      | otherwise       = go cvtLit     (HsLit     noExt) isCompoundHsLit
+      | overloadedLit l = go cvtOverLit (HsOverLit noExt)
+                             (hsOverLitNeedsParens appPrec)
+      | otherwise       = go cvtLit (HsLit noExt)
+                             (hsLitNeedsParens appPrec)
       where
         go :: (Lit -> CvtM (l GhcPs))
            -> (l GhcPs -> HsExpr GhcPs)
@@ -821,7 +823,7 @@ cvtl e = wrapL (cvt e)
                                -- oddities that can result from zero-argument
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
-                            ; let pats = map parenthesizeCompoundPat ps'
+                            ; let pats = map (parenthesizePat appPrec) ps'
                             ; return $ HsLam noExt (mkMatchGroup FromSource
                                              [mkSimpleMatch LambdaExpr
                                              pats e'])}
@@ -869,9 +871,10 @@ cvtl e = wrapL (cvt e)
 
     -- Infix expressions
     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
+                                          ; let px = parenthesizeHsExpr opPrec x'
+                                                py = parenthesizeHsExpr opPrec y'
                                           ; wrapParL (HsPar noExt) $
-                                            OpApp noExt (mkLHsPar x') s'
-                                                        (mkLHsPar y') }
+                                            OpApp noExt px s' py }
                                             -- Parenthesise both arguments and result,
                                             -- to ensure this operator application does
                                             -- does not get re-associated
@@ -897,7 +900,8 @@ cvtl e = wrapL (cvt e)
 
     cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
-                              ; return $ ExprWithTySig (mkLHsSigWcType t') e' }
+                              ; let pe = parenthesizeHsExpr sigPrec e'
+                              ; return $ ExprWithTySig (mkLHsSigWcType t') pe }
     cvt (RecConE c flds) = do { c' <- cNameL c
                               ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
                               ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
@@ -1041,9 +1045,9 @@ cvtMatch :: HsMatchContext RdrName
          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
 cvtMatch ctxt (TH.Match p body decs)
   = do  { p' <- cvtPat p
-        ; lp <- case ctxt of
-            CaseAlt -> return p'
-            _       -> wrap_conpat p'
+        ; let lp = case p' of
+                     L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
+                     _              -> p'
         ; g' <- cvtGuard body
         ; decs' <- cvtLocalDecs (text "a where clause") decs
         ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
@@ -1144,11 +1148,13 @@ cvtp (UnboxedSumP p alt arity)
                             ; unboxedSumChecks alt arity
                             ; return $ SumPat noExt p' alt arity }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
-                            ; pps <- mapM wrap_conpat ps'
+                            ; let pps = map (parenthesizePat appPrec) ps'
                             ; return $ ConPatIn s' (PrefixCon pps) }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
                             ; wrapParL (ParPat noExt) $
-                              ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
+                              ConPatIn s' $
+                              InfixCon (parenthesizePat opPrec p1')
+                                       (parenthesizePat opPrec p2') }
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
 cvtp (ParensP p)       = do { p' <- cvtPat p;
@@ -1179,12 +1185,6 @@ cvtPatFld (s,p)
                                      , hsRecFieldArg = p'
                                      , hsRecPun      = False}) }
 
-wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs)
-wrap_conpat p@(L _ (ConPatIn _ (InfixCon{})))   = returnL $ ParPat noExt p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
-wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _)))  = returnL $ ParPat noExt p
-wrap_conpat p                                   = return p
-
 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
 The produced tree of infix patterns will be left-biased, provided @x@ is.
 
@@ -1393,9 +1393,9 @@ mk_apps head_ty (ty:tys) =
      ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
   where
     -- See Note [Adding parens for splices]
-    add_parens t
-      | isCompoundHsType t = returnL (HsParTy noExt t)
-      | otherwise          = return t
+    add_parens lt@(L _ t)
+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
+      | otherwise                   = return lt
 
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
 wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index df26b45e10..10f09da558 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1186,10 +1186,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
         -- This complexity is to distinguish between
         --    deriving Show
         --    deriving (Show)
-        pp_dct [a@(HsIB { hsib_body = ty })]
-          | isCompoundHsType ty = parens (ppr a)
-          | otherwise           = ppr a
-        pp_dct _   = parens (interpp'SP dct)
+        pp_dct [HsIB { hsib_body = ty }]
+                 = ppr (parenthesizeHsType appPrec ty)
+        pp_dct _ = parens (interpp'SP dct)
   ppr (XHsDerivingClause x) = ppr x
 
 data NewOrData
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index c328cff9eb..19cb70d6f3 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1005,8 +1005,8 @@ ppr_expr (OpApp _ e1 op e2)
     should_print_infix (HsWrap _ _ e)  = should_print_infix e
     should_print_infix _               = Nothing
 
-    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
-    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens
+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear
 
     pp_prefixly
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
@@ -1014,7 +1014,7 @@ ppr_expr (OpApp _ e1 op e2)
     pp_infixly pp_op
       = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
 
-ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr e
+ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
 
 ppr_expr (SectionL _ expr op)
   = case unLoc op of
@@ -1024,7 +1024,7 @@ ppr_expr (SectionL _ expr op)
                        -> pp_infixly (unboundVarOcc h)
       _                -> pp_prefixly
   where
-    pp_expr = pprDebugParendExpr expr
+    pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, text "x_ )"])
@@ -1040,7 +1040,7 @@ ppr_expr (SectionR _ op expr)
                        -> pp_infixly (unboundVarOcc h)
       _                -> pp_prefixly
   where
-    pp_expr = pprDebugParendExpr expr
+    pp_expr = pprDebugParendExpr opPrec expr
 
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
                        4 (pp_expr <> rparen)
@@ -1229,50 +1229,88 @@ can see the structure of the parse tree.
 -}
 
 pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
-                   => LHsExpr (GhcPass p) -> SDoc
-pprDebugParendExpr expr
+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprDebugParendExpr p expr
   = getPprStyle (\sty ->
-    if debugStyle sty then pprParendLExpr expr
+    if debugStyle sty then pprParendLExpr p expr
                       else pprLExpr      expr)
 
-pprParendLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
-pprParendLExpr (L _ e) = pprParendExpr e
+pprParendLExpr :: (OutputableBndrId (GhcPass p))
+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc
+pprParendLExpr p (L _ e) = pprParendExpr p e
 
-pprParendExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
-pprParendExpr expr
-  | hsExprNeedsParens expr = parens (pprExpr expr)
-  | otherwise              = pprExpr expr
+pprParendExpr :: (OutputableBndrId (GhcPass p))
+              => PprPrec -> HsExpr (GhcPass p) -> SDoc
+pprParendExpr p expr
+  | hsExprNeedsParens p expr = parens (pprExpr expr)
+  | otherwise                = pprExpr expr
         -- Using pprLExpr makes sure that we go 'deeper'
         -- I think that is usually (always?) right
 
-hsExprNeedsParens :: HsExpr id -> Bool
--- True of expressions for which '(e)' and 'e'
--- mean the same thing
-hsExprNeedsParens (ArithSeq {})       = False
-hsExprNeedsParens (PArrSeq {})        = False
-hsExprNeedsParens (HsLit {})          = False
-hsExprNeedsParens (HsOverLit {})      = False
-hsExprNeedsParens (HsVar {})          = False
-hsExprNeedsParens (HsUnboundVar {})   = False
-hsExprNeedsParens (HsConLikeOut {})   = False
-hsExprNeedsParens (HsIPVar {})        = False
-hsExprNeedsParens (HsOverLabel {})    = False
-hsExprNeedsParens (ExplicitTuple {})  = False
-hsExprNeedsParens (ExplicitList {})   = False
-hsExprNeedsParens (ExplicitPArr {})   = False
-hsExprNeedsParens (HsPar {})          = False
-hsExprNeedsParens (HsBracket {})      = False
-hsExprNeedsParens (HsRnBracketOut {}) = False
-hsExprNeedsParens (HsTcBracketOut {}) = False
-hsExprNeedsParens (HsDo _ sc _)
-       | isListCompExpr sc            = False
-hsExprNeedsParens (HsRecFld{})        = False
-hsExprNeedsParens (RecordCon{})       = False
-hsExprNeedsParens (HsSpliceE{})       = False
-hsExprNeedsParens (RecordUpd{})       = False
-hsExprNeedsParens (HsWrap _ _ e)      = hsExprNeedsParens e
-hsExprNeedsParens _ = True
-
+-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
+-- parentheses under precedence @p@.
+hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
+hsExprNeedsParens p = go
+  where
+    go (HsVar{})                      = False
+    go (HsUnboundVar{})               = False
+    go (HsConLikeOut{})               = False
+    go (HsIPVar{})                    = False
+    go (HsOverLabel{})                = False
+    go (HsLit _ l)                    = hsLitNeedsParens p l
+    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol
+    go (HsPar{})                      = False
+    go (HsCoreAnn _ _ _ (L _ e))      = go e
+    go (HsApp{})                      = p >= appPrec
+    go (HsAppType {})                 = p >= appPrec
+    go (OpApp{})                      = p >= opPrec
+    go (NegApp{})                     = p > topPrec
+    go (SectionL{})                   = True
+    go (SectionR{})                   = True
+    go (ExplicitTuple{})              = False
+    go (ExplicitSum{})                = False
+    go (HsLam{})                      = p > topPrec
+    go (HsLamCase{})                  = p > topPrec
+    go (HsCase{})                     = p > topPrec
+    go (HsIf{})                       = p > topPrec
+    go (HsMultiIf{})                  = p > topPrec
+    go (HsLet{})                      = p > topPrec
+    go (HsDo _ sc _)
+      | isListCompExpr sc             = False
+      | otherwise                     = p > topPrec
+    go (ExplicitList{})               = False
+    go (ExplicitPArr{})               = False
+    go (RecordUpd{})                  = False
+    go (ExprWithTySig{})              = p > topPrec
+    go (ArithSeq{})                   = False
+    go (PArrSeq{})                    = False
+    go (EWildPat{})                   = False
+    go (ELazyPat{})                   = False
+    go (EAsPat{})                     = False
+    go (EViewPat{})                   = True
+    go (HsSCC{})                      = p >= appPrec
+    go (HsWrap _ _ e)                 = go e
+    go (HsSpliceE{})                  = False
+    go (HsBracket{})                  = False
+    go (HsRnBracketOut{})             = False
+    go (HsTcBracketOut{})             = False
+    go (HsProc{})                     = p > topPrec
+    go (HsStatic{})                   = p >= appPrec
+    go (HsTick _ _ (L _ e))           = go e
+    go (HsBinTick _ _ _ (L _ e))      = go e
+    go (HsTickPragma _ _ _ _ (L _ e)) = go e
+    go (HsArrApp{})                   = True
+    go (HsArrForm{})                  = True
+    go (RecordCon{})                  = False
+    go (HsRecFld{})                   = False
+    go (XExpr{})                      = True
+
+-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
+parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+parenthesizeHsExpr p le@(L loc e)
+  | hsExprNeedsParens p e = L loc (HsPar NoExt le)
+  | otherwise             = le
 
 isAtomicHsExpr :: HsExpr id -> Bool
 -- True of a single token
@@ -1744,7 +1782,7 @@ pprPatBind pat (grhss)
 pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
          => Match (GhcPass idR) body -> SDoc
 pprMatch match
-  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
         , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
   where
     ctxt = m_ctxt match
@@ -1765,7 +1803,9 @@ pprMatch match
                 | otherwise -> (parens pp_infix, pats2)
                         -- (x &&& y) z = e
                 where
-                  pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
+                  pp_infix = pprParendLPat opPrec pat1
+                         <+> pprInfixOcc fun
+                         <+> pprParendLPat opPrec pat2
 
             LambdaExpr -> (char '\\', m_pats match)
 
diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs
index 9a184b7afa..d1411bd750 100644
--- a/compiler/hsSyn/HsLit.hs
+++ b/compiler/hsSyn/HsLit.hs
@@ -23,7 +23,7 @@ import GhcPrelude
 import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
 import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
                     negateFractionalLit,SourceText(..),pprWithSourceText )
-import Type       ( Type )
+import Type
 import Outputable
 import FastString
 import HsExtension
@@ -282,30 +282,33 @@ pmPprHsLit (HsFloatPrim _ f)  = ppr f
 pmPprHsLit (HsDoublePrim _ d) = ppr d
 pmPprHsLit (XLit x)           = ppr x
 
--- | Returns 'True' for compound literals that will need parentheses.
-isCompoundHsLit :: HsLit x -> Bool
-isCompoundHsLit (HsChar {})        = False
-isCompoundHsLit (HsCharPrim {})    = False
-isCompoundHsLit (HsString {})      = False
-isCompoundHsLit (HsStringPrim {})  = False
-isCompoundHsLit (HsInt _ x)        = il_neg x
-isCompoundHsLit (HsIntPrim _ x)    = x < 0
-isCompoundHsLit (HsWordPrim _ x)   = x < 0
-isCompoundHsLit (HsInt64Prim _ x)  = x < 0
-isCompoundHsLit (HsWord64Prim _ x) = x < 0
-isCompoundHsLit (HsInteger _ x _)  = x < 0
-isCompoundHsLit (HsRat _ x _)      = fl_neg x
-isCompoundHsLit (HsFloatPrim _ x)  = fl_neg x
-isCompoundHsLit (HsDoublePrim _ x) = fl_neg x
-isCompoundHsLit (XLit _)           = False
-
--- | Returns 'True' for compound overloaded literals that will need
--- parentheses when used in an argument position.
-isCompoundHsOverLit :: HsOverLit x -> Bool
-isCompoundHsOverLit (OverLit { ol_val = olv }) = compound_ol_val olv
+-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
+-- to be parenthesized under precedence @p@.
+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
+hsLitNeedsParens p = go
   where
-    compound_ol_val :: OverLitVal -> Bool
-    compound_ol_val (HsIntegral x)   = il_neg x
-    compound_ol_val (HsFractional x) = fl_neg x
-    compound_ol_val (HsIsString {})  = False
-isCompoundHsOverLit (XOverLit { }) = False
+    go (HsChar {})        = False
+    go (HsCharPrim {})    = False
+    go (HsString {})      = False
+    go (HsStringPrim {})  = False
+    go (HsInt _ x)        = p > topPrec && il_neg x
+    go (HsIntPrim _ x)    = p > topPrec && x < 0
+    go (HsWordPrim {})    = False
+    go (HsInt64Prim _ x)  = p > topPrec && x < 0
+    go (HsWord64Prim {})  = False
+    go (HsInteger _ x _)  = p > topPrec && x < 0
+    go (HsRat _ x _)      = p > topPrec && fl_neg x
+    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x
+    go (HsDoublePrim _ x) = p > topPrec && fl_neg x
+    go (XLit _)           = False
+
+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal
+-- @ol@ needs to be parenthesized under precedence @p@.
+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool
+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv
+  where
+    go :: OverLitVal -> Bool
+    go (HsIntegral x)   = p > topPrec && il_neg x
+    go (HsFractional x) = p > topPrec && fl_neg x
+    go (HsIsString {})  = False
+hsOverLitNeedsParens _ (XOverLit { }) = False
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index d589882de3..6c092d34a7 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -31,8 +31,7 @@ module HsPat (
 
         looksLazyPatBind,
         isBangedLPat,
-        hsPatNeedsParens,
-        isCompoundPat, parenthesizeCompoundPat,
+        patNeedsParens, parenthesizePat,
         isIrrefutableHsPat,
 
         collectEvVarsPats,
@@ -497,18 +496,20 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
     else
         pprPrefixOcc var
 
-pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc
-pprParendLPat (L _ p) = pprParendPat p
+pprParendLPat :: (OutputableBndrId (GhcPass p))
+              => PprPrec -> LPat (GhcPass p) -> SDoc
+pprParendLPat p (L _ pat) = pprParendPat p pat
 
-pprParendPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
-pprParendPat p = sdocWithDynFlags $ \ dflags ->
-                 if need_parens dflags p
-                 then parens (pprPat p)
-                 else  pprPat p
+pprParendPat :: (OutputableBndrId (GhcPass p))
+             => PprPrec -> Pat (GhcPass p) -> SDoc
+pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
+                     if need_parens dflags pat
+                     then parens (pprPat pat)
+                     else  pprPat pat
   where
-    need_parens dflags p
-      | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags
-      | otherwise     = hsPatNeedsParens p
+    need_parens dflags pat
+      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
+      | otherwise       = patNeedsParens p pat
       -- 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
@@ -517,10 +518,10 @@ pprParendPat p = sdocWithDynFlags $ \ dflags ->
 pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
 pprPat (VarPat _ (L _ var))     = pprPatBndr var
 pprPat (WildPat _)              = char '_'
-pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat pat
-pprPat (BangPat _ pat)          = char '!' <> pprParendLPat pat
+pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
+pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat
 pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',
-                                        pprParendLPat pat]
+                                        pprParendLPat appPrec pat]
 pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat _ pat)           = parens (ppr pat)
 pprPat (LitPat _ s)             = ppr s
@@ -528,10 +529,10 @@ 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 co (\parens
-                                                   -> if parens
-                                                        then pprParendPat pat
-                                                        else pprPat pat)
+pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens
+                                            -> if parens
+                                                 then pprParendPat appPrec pat
+                                                 else pprPat pat
 pprPat (SigPat ty pat)          = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat _ pats)         = brackets (interpp'SP pats)
 pprPat (PArrPat _ pats)         = paBrackets (interpp'SP pats)
@@ -561,8 +562,9 @@ pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
 
 pprConArgs :: (OutputableBndrId (GhcPass p))
            => HsConPatDetails (GhcPass p) -> SDoc
-pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
-pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
+pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats)
+pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
+                                  , pprParendLPat appPrec p2 ]
 pprConArgs (RecCon rpats)   = ppr rpats
 
 instance (Outputable arg)
@@ -735,86 +737,47 @@ case in foo to be unreachable, as GHC would mistakenly believe that Nothing'
 is the only thing that could possibly be matched!
 -}
 
--- | Returns 'True' if a pattern must be parenthesized in order to parse
--- (e.g., the @(x :: Int)@ in @f (x :: Int) = x@).
-hsPatNeedsParens :: Pat a -> Bool
-hsPatNeedsParens (NPlusKPat {})      = True
-hsPatNeedsParens (SplicePat {})      = False
-hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
-hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
-hsPatNeedsParens (SigPat {})         = True
-hsPatNeedsParens (ViewPat {})        = True
-hsPatNeedsParens (CoPat _ _ p _)     = hsPatNeedsParens p
-hsPatNeedsParens (WildPat {})        = False
-hsPatNeedsParens (VarPat {})         = False
-hsPatNeedsParens (LazyPat {})        = False
-hsPatNeedsParens (BangPat {})        = False
-hsPatNeedsParens (ParPat {})         = False
-hsPatNeedsParens (AsPat {})          = False
-hsPatNeedsParens (TuplePat {})       = False
-hsPatNeedsParens (SumPat {})         = False
-hsPatNeedsParens (ListPat {})        = False
-hsPatNeedsParens (PArrPat {})        = False
-hsPatNeedsParens (LitPat {})         = False
-hsPatNeedsParens (NPat {})           = False
-hsPatNeedsParens (XPat {})           = True -- conservative default
-
--- | Returns 'True' if a constructor pattern must be parenthesized in order
--- to parse.
-conPatNeedsParens :: HsConDetails a b -> Bool
-conPatNeedsParens (PrefixCon {}) = False
-conPatNeedsParens (InfixCon {})  = True
-conPatNeedsParens (RecCon {})    = False
-
--- | Returns 'True' for compound patterns that need parentheses when used in
--- an argument position.
---
--- Note that this is different from 'hsPatNeedsParens', which only says if
--- a pattern needs to be parenthesized to parse in /any/ position, whereas
--- 'isCompountPat' says if a pattern needs to be parenthesized in an /argument/
--- position. In other words, @'hsPatNeedsParens' x@ implies
--- @'isCompoundPat' x@, but not necessarily the other way around.
-isCompoundPat :: Pat a -> Bool
-isCompoundPat (NPlusKPat {})       = True
-isCompoundPat (SplicePat {})       = False
-isCompoundPat (ConPatIn _ ds)      = isCompoundConPat ds
-isCompoundPat p@(ConPatOut {})     = isCompoundConPat (pat_args p)
-isCompoundPat (SigPat {})          = True
-isCompoundPat (ViewPat {})         = True
-isCompoundPat (CoPat _ _ p _)      = isCompoundPat p
-isCompoundPat (WildPat {})         = False
-isCompoundPat (VarPat {})          = False
-isCompoundPat (LazyPat {})         = False
-isCompoundPat (BangPat {})         = False
-isCompoundPat (ParPat {})          = False
-isCompoundPat (AsPat {})           = False
-isCompoundPat (TuplePat {})        = False
-isCompoundPat (SumPat {})          = False
-isCompoundPat (ListPat {})         = False
-isCompoundPat (PArrPat {})         = False
-isCompoundPat (LitPat _ p)         = isCompoundHsLit p
-isCompoundPat (NPat _ (L _ p) _ _) = isCompoundHsOverLit p
-isCompoundPat (XPat {})            = False -- Assumption
-
--- | Returns 'True' for compound constructor patterns that need parentheses
--- when used in an argument position.
---
--- Note that this is different from 'conPatNeedsParens', which only says if
--- a constructor pattern needs to be parenthesized to parse in /any/ position,
--- whereas 'isCompountConPat' says if a pattern needs to be parenthesized in an
--- /argument/ position. In other words, @'conPatNeedsParens' x@ implies
--- @'isCompoundConPat' x@, but not necessarily the other way around.
-isCompoundConPat :: HsConDetails a b -> Bool
-isCompoundConPat (PrefixCon args) = not (null args)
-isCompoundConPat (InfixCon {})    = True
-isCompoundConPat (RecCon {})      = False
-
--- | @'parenthesizeCompoundPat' p@ checks if @'isCompoundPat' p@ is true, and
--- if so, surrounds @p@ with a 'ParPat'. Otherwise, it simply returns @p@.
-parenthesizeCompoundPat :: LPat (GhcPass p) -> LPat (GhcPass p)
-parenthesizeCompoundPat lp@(L loc p)
-  | isCompoundPat p = L loc (ParPat NoExt lp)
-  | otherwise       = lp
+-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
+-- parentheses under precedence @p@.
+patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens p = go
+  where
+    go (NPlusKPat {})         = p > opPrec
+    go (SplicePat {})         = False
+    go (ConPatIn _ ds)        = conPatNeedsParens p ds
+    go cp@(ConPatOut {})      = conPatNeedsParens p (pat_args cp)
+    go (SigPat {})            = p > topPrec
+    go (ViewPat {})           = True
+    go (CoPat _ _ p _)        = go p
+    go (WildPat {})           = False
+    go (VarPat {})            = False
+    go (LazyPat {})           = False
+    go (BangPat {})           = False
+    go (ParPat {})            = False
+    go (AsPat {})             = False
+    go (TuplePat {})          = False
+    go (SumPat {})            = False
+    go (ListPat {})           = False
+    go (PArrPat {})           = False
+    go (LitPat _ l)           = hsLitNeedsParens p l
+    go (NPat _ (L _ ol) _ _)  = hsOverLitNeedsParens p ol
+    go (XPat {})              = True -- conservative default
+
+-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
+-- needs parentheses under precedence @p@.
+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
+conPatNeedsParens p = go
+  where
+    go (PrefixCon args) = p >= appPrec && not (null args)
+    go (InfixCon {})    = p >= opPrec
+    go (RecCon {})      = False
+
+-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
+-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
+parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
+parenthesizePat p lpat@(L loc pat)
+  | patNeedsParens p pat = L loc (ParPat NoExt lpat)
+  | otherwise            = lpat
 
 {-
 % Collect all EvVars from all constructor patterns
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index e0a8e0b6a0..af64c2c69f 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -66,7 +66,7 @@ module HsTypes (
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
-        isCompoundHsType, parenthesizeCompoundHsType
+        hsTypeNeedsParens, parenthesizeHsType
     ) where
 
 import GhcPrelude
@@ -1044,7 +1044,7 @@ mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2
 
 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
 mkHsAppTy t1 t2
-  = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeCompoundHsType t2))
+  = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2))
 
 mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
            -> LHsType (GhcPass p)
@@ -1520,20 +1520,40 @@ ppr_tylit (HsNumTy _ i) = integer i
 ppr_tylit (HsStrTy _ s) = text (show s)
 
 
--- | Return 'True' for compound types that will need parentheses when used in
--- an argument position.
-isCompoundHsType :: LHsType pass -> Bool
-isCompoundHsType (L _ HsAppTy{} ) = True
-isCompoundHsType (L _ HsAppsTy{}) = True
-isCompoundHsType (L _ HsEqTy{}  ) = True
-isCompoundHsType (L _ HsFunTy{} ) = True
-isCompoundHsType (L _ HsOpTy{}  ) = True
-isCompoundHsType _                = False
-
--- | @'parenthesizeCompoundHsType' ty@ checks if @'isCompoundHsType' ty@ is
+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
+-- under precedence @p@.
+hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool
+hsTypeNeedsParens p = go
+  where
+    go (HsForAllTy{})        = False
+    go (HsQualTy{})          = False
+    go (HsBangTy{})          = p > topPrec
+    go (HsRecTy{})           = False
+    go (HsTyVar{})           = False
+    go (HsFunTy{})           = p >= funPrec
+    go (HsTupleTy{})         = False
+    go (HsSumTy{})           = False
+    go (HsKindSig{})         = False
+    go (HsListTy{})          = False
+    go (HsPArrTy{})          = False
+    go (HsIParamTy{})        = p > topPrec
+    go (HsSpliceTy{})        = False
+    go (HsExplicitListTy{})  = False
+    go (HsExplicitTupleTy{}) = False
+    go (HsTyLit{})           = False
+    go (HsWildCardTy{})      = False
+    go (HsEqTy{})            = p >= opPrec
+    go (HsAppsTy _ args)     = p >= appPrec && not (null args)
+    go (HsAppTy{})           = p >= appPrec
+    go (HsOpTy{})            = p >= opPrec
+    go (HsParTy{})           = False
+    go (HsDocTy _ (L _ t) _) = go t
+    go (XHsType{})           = False
+
+-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
 -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
 -- returns @ty@.
-parenthesizeCompoundHsType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-parenthesizeCompoundHsType ty@(L loc _)
-  | isCompoundHsType ty = L loc (HsParTy NoExt ty)
-  | otherwise           = ty
+parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+parenthesizeHsType p lty@(L loc ty)
+  | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty)
+  | otherwise              = lty
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index fc918e30bb..e23b0960b0 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -191,7 +191,7 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches))
   where
     matches = mkMatchGroup Generated
                            [mkSimpleMatch LambdaExpr pats' body]
-    pats' = map parenthesizeCompoundPat pats
+    pats' = map (parenthesizePat appPrec) pats
 
 mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
@@ -214,14 +214,14 @@ nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
 
 --------- Adding parens ---------
 mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
--- Wrap in parens if hsExprNeedsParens says it needs them
+-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
 -- So   'f x'  becomes '(f x)', but '3' stays as '3'
-mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le)
-                      | otherwise           = le
+mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExt le)
+                      | otherwise                   = le
 
 mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
-mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp)
-                      | otherwise          = lp
+mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExt lp)
+                      | otherwise                = lp
 
 nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
 nlParPat p = noLoc (ParPat noExt p)
@@ -439,16 +439,18 @@ nlConVarPat con vars = nlConPat con (map nlVarPat vars)
 nlConVarPatName :: Name -> [Name] -> LPat GhcRn
 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
 
-nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
+nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
+nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
+                              (InfixCon (parenthesizePat opPrec l)
+                                        (parenthesizePat opPrec r)))
 
 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
 nlConPat con pats =
-  noLoc (ConPatIn (noLoc con) (PrefixCon (map parenthesizeCompoundPat pats)))
+  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
 
 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
 nlConPatName con pats =
-  noLoc (ConPatIn (noLoc con) (PrefixCon (map parenthesizeCompoundPat pats)))
+  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
 
 nlNullaryConPat :: IdP id -> LPat id
 nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
@@ -496,7 +498,7 @@ nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)
 nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
 nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)
 
-nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeCompoundHsType t))
+nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
 nlHsTyVar x   = noLoc (HsTyVar noExt NotPromoted (noLoc x))
 nlHsFunTy a b = noLoc (HsFunTy noExt a b)
 nlHsParTy t   = noLoc (HsParTy noExt t)
@@ -855,8 +857,8 @@ mkMatch ctxt pats expr lbinds
                  , m_pats  = map paren pats
                  , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
   where
-    paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp)
-                     | otherwise          = lp
+    paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExt lp)
+                     | otherwise                = lp
 
 {-
 ************************************************************************
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 9afd2b8191..778e8d637d 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -953,7 +953,7 @@ pprIfaceTyConParent IfNoParent
 pprIfaceTyConParent (IfDataInstance _ tc tys)
   = sdocWithDynFlags $ \dflags ->
     let ftys = stripInvisArgs dflags tys
-    in pprIfaceTypeApp TopPrec tc ftys
+    in pprIfaceTypeApp topPrec tc ftys
 
 pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name
                  -> [IfaceTyConBinder]   -- of the tycon, for invisible-suppression
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index f6493f0a24..81d070a493 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -516,15 +516,15 @@ if_print_coercions yes no
     then yes
     else no
 
-pprIfaceInfixApp :: TyPrec -> SDoc -> SDoc -> SDoc -> SDoc
+pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc
 pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2
-  = maybeParen ctxt_prec TyOpPrec $
+  = maybeParen ctxt_prec opPrec $
     sep [pp_ty1, pp_tc <+> pp_ty2]
 
-pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
+pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc
 pprIfacePrefixApp ctxt_prec pp_fun pp_tys
   | null pp_tys = pp_fun
-  | otherwise   = maybeParen ctxt_prec TyConPrec $
+  | otherwise   = maybeParen ctxt_prec appPrec $
                   hang pp_fun 2 (sep pp_tys)
 
 -- ----------------------------- Printing binders ------------------------------------
@@ -589,13 +589,13 @@ instance Outputable IfaceType where
   ppr ty = pprIfaceType ty
 
 pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc
-pprIfaceType       = pprPrecIfaceType TopPrec
-pprParendIfaceType = pprPrecIfaceType TyConPrec
+pprIfaceType       = pprPrecIfaceType topPrec
+pprParendIfaceType = pprPrecIfaceType appPrec
 
-pprPrecIfaceType :: TyPrec -> IfaceType -> SDoc
+pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
 pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty
 
-ppr_ty :: TyPrec -> IfaceType -> SDoc
+ppr_ty :: PprPrec -> IfaceType -> SDoc
 ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reson for IfaceFreeTyVar!
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [TcTyVars in IfaceType]
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
@@ -604,11 +604,11 @@ ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n
         -- Function types
 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
-    maybeParen ctxt_prec FunPrec $
-    sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
+    maybeParen ctxt_prec funPrec $
+    sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)]
   where
     ppr_fun_tail (IfaceFunTy ty1 ty2)
-      = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
+      = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2
     ppr_fun_tail other_ty
       = [arrow <+> pprIfaceType other_ty]
 
@@ -618,8 +618,8 @@ ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
       ppr_app_ty_no_casts
   where
     ppr_app_ty =
-        maybeParen ctxt_prec TyConPrec
-        $ ppr_ty FunPrec ty1 <+> ppr_ty TyConPrec ty2
+        maybeParen ctxt_prec appPrec
+        $ ppr_ty funPrec ty1 <+> ppr_ty appPrec ty2
 
     -- Strip any casts from the head of the application
     ppr_app_ty_no_casts =
@@ -639,7 +639,7 @@ ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
 
 ppr_ty ctxt_prec (IfaceCastTy ty co)
   = if_print_coercions
-      (parens (ppr_ty TopPrec ty <+> text "|>" <+> ppr co))
+      (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co))
       (ppr_ty ctxt_prec ty)
 
 ppr_ty ctxt_prec (IfaceCoercionTy co)
@@ -648,7 +648,7 @@ ppr_ty ctxt_prec (IfaceCoercionTy co)
       (text "<>")
 
 ppr_ty ctxt_prec ty
-  = maybeParen ctxt_prec FunPrec (pprIfaceSigmaType ShowForAllMust ty)
+  = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty)
 
 {-
 Note [Defaulting RuntimeRep variables]
@@ -767,10 +767,10 @@ instance Outputable IfaceTcArgs where
   ppr tca = pprIfaceTcArgs tca
 
 pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
-pprIfaceTcArgs  = ppr_tc_args TopPrec
-pprParendIfaceTcArgs = ppr_tc_args TyConPrec
+pprIfaceTcArgs  = ppr_tc_args topPrec
+pprParendIfaceTcArgs = ppr_tc_args appPrec
 
-ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
+ppr_tc_args :: PprPrec -> IfaceTcArgs -> SDoc
 ppr_tc_args ctx_prec args
  = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
    in case args of
@@ -904,7 +904,7 @@ criteria are met:
 -------------------
 
 -- See equivalent function in TyCoRep.hs
-pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
+pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 -- Given a type-level list (t1 ': t2), see if we can print
 -- it in list notation [t1, ...].
 -- Precondition: Opt_PrintExplicitKinds is off
@@ -912,10 +912,10 @@ pprIfaceTyList ctxt_prec ty1 ty2
   = case gather ty2 of
       (arg_tys, Nothing)
         -> char '\'' <> brackets (fsep (punctuate comma
-                        (map (ppr_ty TopPrec) (ty1:arg_tys))))
+                        (map (ppr_ty topPrec) (ty1:arg_tys))))
       (arg_tys, Just tl)
-        -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
-           2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
+        -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
+           2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
   where
     gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
      -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
@@ -929,22 +929,22 @@ pprIfaceTyList ctxt_prec ty1 ty2
       = ([], Nothing)
     gather ty = ([], Just ty)
 
-pprIfaceTypeApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
 pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
 
-pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
+pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceTcArgs -> SDoc
 pprTyTcApp ctxt_prec tc tys =
     sdocWithDynFlags $ \dflags ->
     getPprStyle $ \style ->
     pprTyTcApp' ctxt_prec tc tys dflags style
 
-pprTyTcApp' :: TyPrec -> IfaceTyCon -> IfaceTcArgs
+pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceTcArgs
             -> DynFlags -> PprStyle -> SDoc
 pprTyTcApp' ctxt_prec tc tys dflags style
   | ifaceTyConName tc `hasKey` ipClassKey
   , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
-  = maybeParen ctxt_prec FunPrec
-    $ char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty
+  = maybeParen ctxt_prec funPrec
+    $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty
 
   | IfaceTupleTyCon arity sort <- ifaceTyConSort info
   , not (debugStyle style)
@@ -988,7 +988,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style
 --
 -- See Note [Equality predicates in IfaceType]
 -- and Note [The equality types story] in TysPrim
-ppr_equality :: TyPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
+ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc
 ppr_equality ctxt_prec tc args
   | hetero_eq_tc
   , [k1, k2, t1, t2] <- args
@@ -1029,27 +1029,27 @@ ppr_equality ctxt_prec tc args
       | otherwise
       = if tc_name `hasKey` eqReprPrimTyConKey
         then pprIfacePrefixApp ctxt_prec (text "Coercible")
-                               [pp TyConPrec ty1, pp TyConPrec ty2]
+                               [pp appPrec ty1, pp appPrec ty2]
         else pprIfaceInfixApp ctxt_prec (char '~')
-                 (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+                 (pp opPrec ty1) (pp opPrec ty2)
       where
         ppr_infix_eq eq_op
            = pprIfaceInfixApp ctxt_prec eq_op
-                 (parens (pp TopPrec ty1 <+> dcolon <+> pp TyOpPrec ki1))
-                 (parens (pp TopPrec ty2 <+> dcolon <+> pp TyOpPrec ki2))
+                 (parens (pp topPrec ty1 <+> dcolon <+> pp opPrec ki1))
+                 (parens (pp topPrec ty2 <+> dcolon <+> pp opPrec ki2))
 
         print_kinds = gopt Opt_PrintExplicitKinds dflags
         print_eqs   = gopt Opt_PrintEqualityRelations dflags ||
                       dumpStyle style || debugStyle style
 
 
-pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
+pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
 pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
 
-ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
+ppr_iface_tc_app :: (PprPrec -> a -> SDoc) -> PprPrec -> IfaceTyCon -> [a] -> SDoc
 ppr_iface_tc_app pp _ tc [ty]
-  | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty)
-  | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
+  | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty)
+  | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp topPrec ty)
 
 ppr_iface_tc_app pp ctxt_prec tc tys
   |  tc `ifaceTyConHasKey` starKindTyConKey
@@ -1058,15 +1058,15 @@ ppr_iface_tc_app pp ctxt_prec tc tys
   = kindStar   -- Handle unicode; do not wrap * in parens
 
   | not (isSymOcc (nameOccName (ifaceTyConName tc)))
-  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
+  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
 
   | [ty1,ty2] <- tys  -- Infix, two arguments;
                       -- we know nothing of precedence though
   = pprIfaceInfixApp ctxt_prec (ppr tc)
-                     (pp TyOpPrec ty1) (pp TyOpPrec ty2)
+                     (pp opPrec ty1) (pp opPrec ty2)
 
   | otherwise
-  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
+  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
 
 pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
 pprSum _arity is_promoted args
@@ -1075,11 +1075,11 @@ pprSum _arity is_promoted args
     let tys   = tcArgsIfaceTypes args
         args' = drop (length tys `div` 2) tys
     in pprPromotionQuoteI is_promoted
-       <> sumParens (pprWithBars (ppr_ty TopPrec) args')
+       <> sumParens (pprWithBars (ppr_ty topPrec) args')
 
-pprTuple :: TyPrec -> TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
+pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceTcArgs -> SDoc
 pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil
-  = maybeParen ctxt_prec TyConPrec $
+  = maybeParen ctxt_prec appPrec $
     text "() :: Constraint"
 
 -- All promoted constructors have kind arguments
@@ -1105,27 +1105,27 @@ pprIfaceTyLit (IfaceNumTyLit n) = integer n
 pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
 
 pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
-pprIfaceCoercion = ppr_co TopPrec
-pprParendIfaceCoercion = ppr_co TyConPrec
+pprIfaceCoercion = ppr_co topPrec
+pprParendIfaceCoercion = ppr_co appPrec
 
-ppr_co :: TyPrec -> IfaceCoercion -> SDoc
+ppr_co :: PprPrec -> IfaceCoercion -> SDoc
 ppr_co _         (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
 ppr_co ctxt_prec (IfaceFunCo r co1 co2)
-  = maybeParen ctxt_prec FunPrec $
-    sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
+  = maybeParen ctxt_prec funPrec $
+    sep (ppr_co funPrec co1 : ppr_fun_tail co2)
   where
     ppr_fun_tail (IfaceFunCo r co1 co2)
-      = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
+      = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2
     ppr_fun_tail other_co
       = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
 
 ppr_co _         (IfaceTyConAppCo r tc cos)
-  = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
+  = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
 ppr_co ctxt_prec (IfaceAppCo co1 co2)
-  = maybeParen ctxt_prec TyConPrec $
-    ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
+  = maybeParen ctxt_prec appPrec $
+    ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
 ppr_co ctxt_prec co@(IfaceForAllCo {})
-  = maybeParen ctxt_prec FunPrec $
+  = maybeParen ctxt_prec funPrec $
     pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
   where
     (tvs, inner_co) = split_co co
@@ -1140,7 +1140,7 @@ ppr_co _ (IfaceCoVarCo covar)   = ppr covar
 ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar)
 
 ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
-  = maybeParen ctxt_prec TyConPrec $
+  = maybeParen ctxt_prec appPrec $
     text "UnsafeCo" <+> ppr r <+>
     pprParendIfaceType ty1 <+> pprParendIfaceType ty2
 
@@ -1150,20 +1150,20 @@ ppr_co _ (IfaceUnivCo prov role ty1 ty2)
           , dcolon <+>  ppr ty1 <> comma <+> ppr ty2 ])
 
 ppr_co ctxt_prec (IfaceInstCo co ty)
-  = maybeParen ctxt_prec TyConPrec $
+  = maybeParen ctxt_prec appPrec $
     text "Inst" <+> pprParendIfaceCoercion co
                         <+> pprParendIfaceCoercion ty
 
 ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
-  = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
+  = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos)
 
 ppr_co ctxt_prec (IfaceAxiomInstCo n i cos)
   = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos
 ppr_co ctxt_prec (IfaceSymCo co)
   = ppr_special_co ctxt_prec (text "Sym") [co]
 ppr_co ctxt_prec (IfaceTransCo co1 co2)
-  = maybeParen ctxt_prec TyOpPrec $
-    ppr_co TyOpPrec co1 <+> semi <+> ppr_co TyOpPrec co2
+  = maybeParen ctxt_prec opPrec $
+    ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2
 ppr_co ctxt_prec (IfaceNthCo d co)
   = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co]
 ppr_co ctxt_prec (IfaceLRCo lr co)
@@ -1175,9 +1175,9 @@ ppr_co ctxt_prec (IfaceCoherenceCo co1 co2)
 ppr_co ctxt_prec (IfaceKindCo co)
   = ppr_special_co ctxt_prec (text "Kind") [co]
 
-ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
+ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc
 ppr_special_co ctxt_prec doc cos
-  = maybeParen ctxt_prec TyConPrec
+  = maybeParen ctxt_prec appPrec
                (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
 
 ppr_role :: Role -> SDoc
@@ -1293,7 +1293,7 @@ instance Binary IfaceTcArgs where
 --
 -- In the event that we are printing a singleton context (e.g. @Eq a@) we can
 -- omit parentheses. However, we must take care to set the precedence correctly
--- to TyOpPrec, since something like @a :~: b@ must be parenthesized (see
+-- to opPrec, since something like @a :~: b@ must be parenthesized (see
 -- #9658).
 --
 -- When printing a larger context we use 'fsep' instead of 'sep' so that
@@ -1322,16 +1322,16 @@ instance Binary IfaceTcArgs where
 
 -- | Prints "(C a, D b) =>", including the arrow.
 -- Used when we want to print a context in a type, so we
--- use FunPrec to decide whether to parenthesise a singleton
+-- use 'funPrec' to decide whether to parenthesise a singleton
 -- predicate; e.g.   Num a => a -> a
 pprIfaceContextArr :: [IfacePredType] -> SDoc
 pprIfaceContextArr []     = empty
-pprIfaceContextArr [pred] = ppr_ty FunPrec pred <+> darrow
+pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow
 pprIfaceContextArr preds  = ppr_parend_preds preds <+> darrow
 
 -- | Prints a context or @()@ if empty
 -- You give it the context precedence
-pprIfaceContext :: TyPrec -> [IfacePredType] -> SDoc
+pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc
 pprIfaceContext _    []     = text "()"
 pprIfaceContext prec [pred] = ppr_ty prec pred
 pprIfaceContext _    preds  = ppr_parend_preds preds
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 05c6276cb5..b94452059d 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1709,7 +1709,8 @@ nlHsAppType e s = noLoc (HsAppType hs_ty e)
     hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
 
 nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlExprWithTySig e s = noLoc (ExprWithTySig hs_ty e)
+nlExprWithTySig e s = noLoc $ ExprWithTySig hs_ty
+                            $ parenthesizeHsExpr sigPrec e
   where
     hs_ty = mkLHsSigWcType (typeToLHsType s)
 
@@ -1855,7 +1856,7 @@ mkFunBindSE arity loc fun pats_and_exprs
   = mkRdrFunBindSE arity (L loc fun) matches
   where
     matches = [mkMatch (mkPrefixFunRhs (L loc fun))
-                               (map parenthesizeCompoundPat p) e
+                               (map (parenthesizePat appPrec) p) e
                                (noLoc emptyLocalBinds)
               | (p,e) <-pats_and_exprs]
 
@@ -1876,7 +1877,7 @@ mkFunBindEC arity loc fun catch_all pats_and_exprs
   = mkRdrFunBindEC arity catch_all (L loc fun) matches
   where
     matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
-                                (map parenthesizeCompoundPat p) e
+                                (map (parenthesizePat appPrec) p) e
                                 (noLoc emptyLocalBinds)
               | (p,e) <- pats_and_exprs ]
 
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index ec4607a2fb..2a90a16066 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -62,7 +62,7 @@ module TyCoRep (
         pprTyVar, pprTyVars,
         pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprTyLit,
-        TyPrec(..), maybeParen,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
         pprDataCons, ppSuggestExplicitKinds,
 
         pprCo, pprParendCo,
@@ -166,7 +166,8 @@ import CoAxiom
 import FV
 
 -- others
-import BasicTypes ( LeftOrRight(..), TyPrec(..), maybeParen, pickLR )
+import BasicTypes ( LeftOrRight(..), PprPrec(..), topPrec, sigPrec, opPrec
+                  , funPrec, appPrec, maybeParen, pickLR )
 import PrelNames
 import Outputable
 import DynFlags
@@ -2614,10 +2615,10 @@ See Note [Precedence in types] in BasicTypes.
 ------------------
 
 pprType, pprParendType :: Type -> SDoc
-pprType       = pprPrecType TopPrec
-pprParendType = pprPrecType TyConPrec
+pprType       = pprPrecType topPrec
+pprParendType = pprPrecType appPrec
 
-pprPrecType :: TyPrec -> Type -> SDoc
+pprPrecType :: PprPrec -> Type -> SDoc
 pprPrecType prec ty
   = getPprStyle $ \sty ->
     if debugStyle sty           -- Use pprDebugType when in
@@ -2678,10 +2679,10 @@ pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
 
 ------------
 pprTheta :: ThetaType -> SDoc
-pprTheta = pprIfaceContext TopPrec . map tidyToIfaceType
+pprTheta = pprIfaceContext topPrec . map tidyToIfaceType
 
 pprParendTheta :: ThetaType -> SDoc
-pprParendTheta = pprIfaceContext TyConPrec . map tidyToIfaceType
+pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType
 
 pprThetaArrowTy :: ThetaType -> SDoc
 pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType
@@ -2741,9 +2742,9 @@ debugPprType :: Type -> SDoc
 -- be useful for debugging.  E.g. with -dppr-debug it prints the
 -- kind on type-variable /occurrences/ which the normal route
 -- fundamentally cannot do.
-debugPprType ty = debug_ppr_ty TopPrec ty
+debugPprType ty = debug_ppr_ty topPrec ty
 
-debug_ppr_ty :: TyPrec -> Type -> SDoc
+debug_ppr_ty :: PprPrec -> Type -> SDoc
 debug_ppr_ty _ (LitTy l)
   = ppr l
 
@@ -2751,21 +2752,21 @@ debug_ppr_ty _ (TyVarTy tv)
   = ppr tv  -- With -dppr-debug we get (tv :: kind)
 
 debug_ppr_ty prec (FunTy arg res)
-  = maybeParen prec FunPrec $
-    sep [debug_ppr_ty FunPrec arg, arrow <+> debug_ppr_ty prec res]
+  = maybeParen prec funPrec $
+    sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res]
 
 debug_ppr_ty prec (TyConApp tc tys)
   | null tys  = ppr tc
-  | otherwise = maybeParen prec TyConPrec $
-                hang (ppr tc) 2 (sep (map (debug_ppr_ty TyConPrec) tys))
+  | otherwise = maybeParen prec appPrec $
+                hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))
 
 debug_ppr_ty prec (AppTy t1 t2)
   = hang (debug_ppr_ty prec t1)
-       2 (debug_ppr_ty TyConPrec t2)
+       2 (debug_ppr_ty appPrec t2)
 
 debug_ppr_ty prec (CastTy ty co)
-  = maybeParen prec TopPrec $
-    hang (debug_ppr_ty TopPrec ty)
+  = maybeParen prec topPrec $
+    hang (debug_ppr_ty topPrec ty)
        2 (text "|>" <+> ppr co)
 
 debug_ppr_ty _ (CoercionTy co)
@@ -2773,7 +2774,7 @@ debug_ppr_ty _ (CoercionTy co)
 
 debug_ppr_ty prec ty@(ForAllTy {})
   | (tvs, body) <- split ty
-  = maybeParen prec FunPrec $
+  = maybeParen prec funPrec $
     hang (text "forall" <+> fsep (map ppr tvs) <> dot)
          -- The (map ppr tvs) will print kind-annotated
          -- tvs, because we are (usually) in debug-style
@@ -2841,7 +2842,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
 
 pprTypeApp :: TyCon -> [Type] -> SDoc
 pprTypeApp tc tys
-  = pprIfaceTypeApp TopPrec (toIfaceTyCon tc)
+  = pprIfaceTypeApp topPrec (toIfaceTyCon tc)
                             (toIfaceTcArgs tc tys)
     -- TODO: toIfaceTcArgs seems rather wasteful here
 
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 766b3d1380..1e0ce99c46 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -187,7 +187,7 @@ module Type (
         pprSigmaType, ppSuggestExplicitKinds,
         pprTheta, pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprSourceTyCon,
-        TyPrec(..), maybeParen,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
         pprTyVar, pprTyVars,
         pprWithTYPE,
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 278b45edf2..46f4dc0444 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -20,10 +20,11 @@ nestDepth :: Int
 nestDepth = 4
 
 type Precedence = Int
-appPrec, unopPrec, opPrec, noPrec :: Precedence
-appPrec  = 3    -- Argument of a function application
-opPrec   = 2    -- Argument of an infix operator
-unopPrec = 1    -- Argument of an unresolved infix operator
+appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence
+appPrec  = 4    -- Argument of a function application
+opPrec   = 3    -- Argument of an infix operator
+unopPrec = 2    -- Argument of an unresolved infix operator
+sigPrec  = 1    -- Argument of an explicit type signature
 noPrec   = 0    -- Others
 
 parensIf :: Bool -> Doc -> Doc
@@ -194,7 +195,8 @@ pprExp _ (CompE ss) =
         ss' = init ss
 pprExp _ (ArithSeqE d) = ppr d
 pprExp _ (ListE es) = brackets (commaSep es)
-pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
+pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
+                                          <+> dcolon <+> ppr t
 pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
 pprExp i (StaticE e) = parensIf (i >= appPrec) $
@@ -219,9 +221,14 @@ instance Ppr Stmt where
 
 ------------------------------
 instance Ppr Match where
-    ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
+    ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs
                         $$ where_clause ds
 
+pprMatchPat :: Pat -> Doc
+-- Everything except pattern signatures bind more tightly than (->)
+pprMatchPat p@(SigP {}) = parens (ppr p)
+pprMatchPat p           = ppr p
+
 ------------------------------
 pprGuarded :: Doc -> (Guard, Exp) -> Doc
 pprGuarded eqDoc (guard, expr) = case guard of
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 6ff285fbef..ed44b3c2b1 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -61,14 +61,14 @@ Derived class instances:
            c1 <- GHC.Arr.range (a1, b1), c2 <- GHC.Arr.range (a2, b2)]
     GHC.Arr.unsafeIndex
       (T14682.Foo a1 a2, T14682.Foo b1 b2)
-      T14682.Foo c1 c2
+      (T14682.Foo c1 c2)
       = (GHC.Arr.unsafeIndex (a2, b2) c2
            GHC.Num.+
              (GHC.Arr.unsafeRangeSize (a2, b2)
                 GHC.Num.* GHC.Arr.unsafeIndex (a1, b1) c1))
     GHC.Arr.inRange
       (T14682.Foo a1 a2, T14682.Foo b1 b2)
-      T14682.Foo c1 c2
+      (T14682.Foo c1 c2)
       = (GHC.Arr.inRange (a1, b1) c1
            GHC.Classes.&& GHC.Arr.inRange (a2, b2) c2)
   
diff --git a/testsuite/tests/th/T14875.hs b/testsuite/tests/th/T14875.hs
new file mode 100644
index 0000000000..e601d36da8
--- /dev/null
+++ b/testsuite/tests/th/T14875.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T14875 where
+
+$([d| f :: Bool -> Bool
+      f x = case x of
+              (True :: Bool) -> True
+              (False :: Bool) -> False
+
+      g :: Bool -> Bool
+      g x = (case x of
+               True -> True
+               False -> False) :: Bool
+    |])
diff --git a/testsuite/tests/th/T14875.stderr b/testsuite/tests/th/T14875.stderr
new file mode 100644
index 0000000000..09374f243d
--- /dev/null
+++ b/testsuite/tests/th/T14875.stderr
@@ -0,0 +1,24 @@
+T14875.hs:(5,3)-(14,6): Splicing declarations
+    [d| f :: Bool -> Bool
+        f x
+          = case x of
+              (True :: Bool) -> True
+              (False :: Bool) -> False
+        g :: Bool -> Bool
+        g x
+          = (case x of
+               True -> True
+               False -> False) ::
+              Bool |]
+  ======>
+    f :: Bool -> Bool
+    f x
+      = case x of
+          (True :: Bool) -> True
+          (False :: Bool) -> False
+    g :: Bool -> Bool
+    g x
+      = (case x of
+           True -> True
+           False -> False) ::
+          Bool
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2b6e517697..4169d7e202 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -407,6 +407,7 @@ test('T14869', normal, compile,
 test('T14888', normal, compile,
     ['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
 test('T14298', normal, compile_and_run, ['-v0'])
+test('T14875', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14885a', normal, compile, [''])
 test('T14885b', normal, compile, [''])
 test('T14885c', normal, compile, [''])