From 21e1a00c0ccf3072ccc04cd1acfc541c141189d2 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sun, 13 May 2018 18:36:23 -0400
Subject: [PATCH] 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
---
compiler/basicTypes/BasicTypes.hs | 57 +++---
compiler/hsSyn/Convert.hs | 42 ++---
compiler/hsSyn/HsDecls.hs | 7 +-
compiler/hsSyn/HsExpr.hs | 128 +++++++++-----
compiler/hsSyn/HsLit.hs | 57 +++---
compiler/hsSyn/HsPat.hs | 165 +++++++-----------
compiler/hsSyn/HsTypes.hs | 54 ++++--
compiler/hsSyn/HsUtils.hs | 28 +--
compiler/iface/IfaceSyn.hs | 2 +-
compiler/iface/IfaceType.hs | 126 ++++++-------
compiler/typecheck/TcGenDeriv.hs | 7 +-
compiler/types/TyCoRep.hs | 37 ++--
compiler/types/Type.hs | 2 +-
.../Language/Haskell/TH/Ppr.hs | 19 +-
.../deriving/should_compile/T14682.stderr | 4 +-
testsuite/tests/th/T14875.hs | 14 ++
testsuite/tests/th/T14875.stderr | 24 +++
testsuite/tests/th/all.T | 1 +
18 files changed, 417 insertions(+), 357 deletions(-)
create mode 100644 testsuite/tests/th/T14875.hs
create mode 100644 testsuite/tests/th/T14875.stderr
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index dfb7ab426b41..6dfa37e52c0d 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 f683cc8c5992..9063d1f773c2 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 df26b45e105a..10f09da55894 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 c328cff9ebbc..19cb70d6f31e 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 9a184b7afa88..d1411bd75016 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 d589882de376..6c092d34a771 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 e0a8e0b6a0f2..af64c2c69f7f 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 fc918e30bb26..e23b0960b0e3 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 9afd2b819144..778e8d637d70 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 f6493f0a245c..81d070a4936d 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 05c6276cb508..b94452059dea 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 ec4607a2fb0b..2a90a1606680 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 766b3d138055..1e0ce99c46e8 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 278b45edf2c3..46f4dc044484 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 6ff285fbef96..ed44b3c2b12f 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 000000000000..e601d36da804
--- /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 000000000000..09374f243d66
--- /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 2b6e5176978a..4169d7e202bb 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, [''])
--
GitLab