Commit 21e1a00c authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent bf6cad8b
...@@ -52,7 +52,7 @@ module BasicTypes( ...@@ -52,7 +52,7 @@ module BasicTypes(
Boxity(..), isBoxed, Boxity(..), isBoxed,
TyPrec(..), maybeParen, PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
TupleSort(..), tupleSortBoxity, boxityTupleSort, TupleSort(..), tupleSortBoxity, boxityTupleSort,
tupleParens, tupleParens,
...@@ -692,40 +692,25 @@ pprSafeOverlap False = empty ...@@ -692,40 +692,25 @@ pprSafeOverlap False = empty
{- {-
************************************************************************ ************************************************************************
* * * *
Type precedence Precedence
* * * *
************************************************************************ ************************************************************************
-} -}
data TyPrec -- See Note [Precedence in types] in TyCoRep.hs -- | A general-purpose pretty-printing precedence type.
= TopPrec -- No parens newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
| FunPrec -- Function args; no parens for tycon apps -- See Note [Precedence in types]
| TyOpPrec -- Infix operator
| TyConPrec -- Tycon args; no parens for atomic
instance Eq TyPrec where topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec
(==) a b = case compare a b of topPrec = PprPrec 0 -- No parens
EQ -> True sigPrec = PprPrec 1 -- Explicit type signatures
_ -> False 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 maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
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 ctxt_prec inner_prec pretty maybeParen ctxt_prec inner_prec pretty
| ctxt_prec < inner_prec = pretty | ctxt_prec < inner_prec = pretty
| otherwise = parens pretty | otherwise = parens pretty
...@@ -733,12 +718,12 @@ maybeParen ctxt_prec inner_prec pretty ...@@ -733,12 +718,12 @@ maybeParen ctxt_prec inner_prec pretty
{- Note [Precedence in types] {- Note [Precedence in types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Many pretty-printing functions have type 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 T ty1 ty2
we will pretty-print 'ty1' and 'ty2' with the call 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. to indicate that the context is that of an argument of a TyConApp.
We use this consistently for Type and HsType. We use this consistently for Type and HsType.
...@@ -751,16 +736,16 @@ pretty printer follows the following precedence order: ...@@ -751,16 +736,16 @@ pretty printer follows the following precedence order:
TyConPrec Type constructor application TyConPrec Type constructor application
TyOpPrec/FunPrec Operator application and function arrow 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 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 it's hard to parse a type like
a ~ b => c * d -> e - f 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) (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. (->) bind more or less tightly if we wanted.
-} -}
......
...@@ -779,7 +779,7 @@ cvtClause :: HsMatchContext RdrName ...@@ -779,7 +779,7 @@ cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres) cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps = do { ps' <- cvtPats ps
; pps <- mapM wrap_conpat ps' ; let pps = map (parenthesizePat appPrec) ps'
; g' <- cvtGuard body ; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres ; ds' <- cvtLocalDecs (text "a where clause") wheres
; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) } ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
...@@ -795,8 +795,10 @@ cvtl e = wrapL (cvt e) ...@@ -795,8 +795,10 @@ cvtl e = wrapL (cvt e)
cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } 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 (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
cvt (LitE l) cvt (LitE l)
| overloadedLit l = go cvtOverLit (HsOverLit noExt) isCompoundHsOverLit | overloadedLit l = go cvtOverLit (HsOverLit noExt)
| otherwise = go cvtLit (HsLit noExt) isCompoundHsLit (hsOverLitNeedsParens appPrec)
| otherwise = go cvtLit (HsLit noExt)
(hsLitNeedsParens appPrec)
where where
go :: (Lit -> CvtM (l GhcPs)) go :: (Lit -> CvtM (l GhcPs))
-> (l GhcPs -> HsExpr GhcPs) -> (l GhcPs -> HsExpr GhcPs)
...@@ -821,7 +823,7 @@ cvtl e = wrapL (cvt e) ...@@ -821,7 +823,7 @@ cvtl e = wrapL (cvt e)
-- oddities that can result from zero-argument -- oddities that can result from zero-argument
-- lambda expressions. See #13856. -- lambda expressions. See #13856.
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e 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 ; return $ HsLam noExt (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr [mkSimpleMatch LambdaExpr
pats e'])} pats e'])}
...@@ -869,9 +871,10 @@ cvtl e = wrapL (cvt e) ...@@ -869,9 +871,10 @@ cvtl e = wrapL (cvt e)
-- Infix expressions -- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y 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) $ ; wrapParL (HsPar noExt) $
OpApp noExt (mkLHsPar x') s' OpApp noExt px s' py }
(mkLHsPar y') }
-- Parenthesise both arguments and result, -- Parenthesise both arguments and result,
-- to ensure this operator application does -- to ensure this operator application does
-- does not get re-associated -- does not get re-associated
...@@ -897,7 +900,8 @@ cvtl e = wrapL (cvt e) ...@@ -897,7 +900,8 @@ cvtl e = wrapL (cvt e)
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' } cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t 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 cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
...@@ -1041,9 +1045,9 @@ cvtMatch :: HsMatchContext RdrName ...@@ -1041,9 +1045,9 @@ cvtMatch :: HsMatchContext RdrName
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt (TH.Match p body decs) cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p = do { p' <- cvtPat p
; lp <- case ctxt of ; let lp = case p' of
CaseAlt -> return p' L loc SigPat{} -> L loc (ParPat NoExt p') -- #14875
_ -> wrap_conpat p' _ -> p'
; g' <- cvtGuard body ; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs ; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) } ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
...@@ -1144,11 +1148,13 @@ cvtp (UnboxedSumP p alt arity) ...@@ -1144,11 +1148,13 @@ cvtp (UnboxedSumP p alt arity)
; unboxedSumChecks alt arity ; unboxedSumChecks alt arity
; return $ SumPat noExt p' alt arity } ; return $ SumPat noExt p' alt arity }
cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps 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) } ; return $ ConPatIn s' (PrefixCon pps) }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
; wrapParL (ParPat noExt) $ ; wrapParL (ParPat noExt) $
ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } ConPatIn s' $
InfixCon (parenthesizePat opPrec p1')
(parenthesizePat opPrec p2') }
-- See Note [Operator association] -- See Note [Operator association]
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p) = do { p' <- cvtPat p; cvtp (ParensP p) = do { p' <- cvtPat p;
...@@ -1179,12 +1185,6 @@ cvtPatFld (s,p) ...@@ -1179,12 +1185,6 @@ cvtPatFld (s,p)
, hsRecFieldArg = p' , hsRecFieldArg = p'
, hsRecPun = False}) } , 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@. {- | @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. The produced tree of infix patterns will be left-biased, provided @x@ is.
...@@ -1393,9 +1393,9 @@ mk_apps head_ty (ty:tys) = ...@@ -1393,9 +1393,9 @@ mk_apps head_ty (ty:tys) =
; mk_apps (HsAppTy noExt head_ty' p_ty) tys } ; mk_apps (HsAppTy noExt head_ty' p_ty) tys }
where where
-- See Note [Adding parens for splices] -- See Note [Adding parens for splices]
add_parens t add_parens lt@(L _ t)
| isCompoundHsType t = returnL (HsParTy noExt t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
| otherwise = return t | otherwise = return lt
wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs)
wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t) wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t)
......
...@@ -1186,10 +1186,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ...@@ -1186,10 +1186,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p)
-- This complexity is to distinguish between -- This complexity is to distinguish between
-- deriving Show -- deriving Show
-- deriving (Show) -- deriving (Show)
pp_dct [a@(HsIB { hsib_body = ty })] pp_dct [HsIB { hsib_body = ty }]
| isCompoundHsType ty = parens (ppr a) = ppr (parenthesizeHsType appPrec ty)
| otherwise = ppr a pp_dct _ = parens (interpp'SP dct)
pp_dct _ = parens (interpp'SP dct)
ppr (XHsDerivingClause x) = ppr x ppr (XHsDerivingClause x) = ppr x
data NewOrData data NewOrData
......
...@@ -1005,8 +1005,8 @@ ppr_expr (OpApp _ e1 op e2) ...@@ -1005,8 +1005,8 @@ ppr_expr (OpApp _ e1 op e2)
should_print_infix (HsWrap _ _ e) = should_print_infix e should_print_infix (HsWrap _ _ e) = should_print_infix e
should_print_infix _ = Nothing should_print_infix _ = Nothing
pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens
pp_e2 = pprDebugParendExpr e2 -- to make precedence clear pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear
pp_prefixly pp_prefixly
= hang (ppr op) 2 (sep [pp_e1, pp_e2]) = hang (ppr op) 2 (sep [pp_e1, pp_e2])
...@@ -1014,7 +1014,7 @@ ppr_expr (OpApp _ e1 op e2) ...@@ -1014,7 +1014,7 @@ ppr_expr (OpApp _ e1 op e2)
pp_infixly pp_op pp_infixly pp_op
= hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) = 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) ppr_expr (SectionL _ expr op)
= case unLoc op of = case unLoc op of
...@@ -1024,7 +1024,7 @@ ppr_expr (SectionL _ expr op) ...@@ -1024,7 +1024,7 @@ ppr_expr (SectionL _ expr op)
-> pp_infixly (unboundVarOcc h) -> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly _ -> pp_prefixly
where where
pp_expr = pprDebugParendExpr expr pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"]) 4 (hsep [pp_expr, text "x_ )"])
...@@ -1040,7 +1040,7 @@ ppr_expr (SectionR _ op expr) ...@@ -1040,7 +1040,7 @@ ppr_expr (SectionR _ op expr)
-> pp_infixly (unboundVarOcc h) -> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly _ -> pp_prefixly
where where
pp_expr = pprDebugParendExpr expr pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen) 4 (pp_expr <> rparen)
...@@ -1229,50 +1229,88 @@ can see the structure of the parse tree. ...@@ -1229,50 +1229,88 @@ can see the structure of the parse tree.
-} -}
pprDebugParendExpr :: (OutputableBndrId (GhcPass p)) pprDebugParendExpr :: (OutputableBndrId (GhcPass p))
=> LHsExpr (GhcPass p) -> SDoc => PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprDebugParendExpr expr pprDebugParendExpr p expr
= getPprStyle (\sty -> = getPprStyle (\sty ->
if debugStyle sty then pprParendLExpr expr if debugStyle sty then pprParendLExpr p expr
else pprLExpr expr) else pprLExpr expr)
pprParendLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc pprParendLExpr :: (OutputableBndrId (GhcPass p))
pprParendLExpr (L _ e) = pprParendExpr e => PprPrec -> LHsExpr (GhcPass p) -> SDoc
pprParendLExpr p (L _ e) = pprParendExpr p e
pprParendExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc pprParendExpr :: (OutputableBndrId (GhcPass p))
pprParendExpr expr => PprPrec -> HsExpr (GhcPass p) -> SDoc
| hsExprNeedsParens expr = parens (pprExpr expr) pprParendExpr p expr
| otherwise = pprExpr expr | hsExprNeedsParens p expr = parens (pprExpr expr)
| otherwise = pprExpr expr
-- Using pprLExpr makes sure that we go 'deeper' -- Using pprLExpr makes sure that we go 'deeper'
-- I think that is usually (always?) right -- I think that is usually (always?) right
hsExprNeedsParens :: HsExpr id -> Bool -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
-- True of expressions for which '(e)' and 'e' -- parentheses under precedence @p@.
-- mean the same thing hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
hsExprNeedsParens (ArithSeq {}) = False hsExprNeedsParens p = go
hsExprNeedsParens (PArrSeq {}) = False where
hsExprNeedsParens (HsLit {}) = False go (HsVar{}) = False
hsExprNeedsParens (HsOverLit {}) = False go (HsUnboundVar{}) = False
hsExprNeedsParens (HsVar {}) = False go (HsConLikeOut{}) = False
hsExprNeedsParens (HsUnboundVar {}) = False go (HsIPVar{}) = False
hsExprNeedsParens (HsConLikeOut {}) = False go (HsOverLabel{}) = False
hsExprNeedsParens (HsIPVar {}) = False go (HsLit _ l) = hsLitNeedsParens p l
hsExprNeedsParens (HsOverLabel {}) = False go (HsOverLit _ ol) = hsOverLitNeedsParens p ol
hsExprNeedsParens (ExplicitTuple {}) = False go (HsPar{}) = False
hsExprNeedsParens (ExplicitList {}) = False go (HsCoreAnn _ _ _ (L _ e)) = go e
hsExprNeedsParens (ExplicitPArr {}) = False go (HsApp{}) = p >= appPrec
hsExprNeedsParens (HsPar {}) = False go (HsAppType {}) = p >= appPrec
hsExprNeedsParens (HsBracket {}) = False go (OpApp{}) = p >= opPrec
hsExprNeedsParens (HsRnBracketOut {}) = False go (NegApp{}) = p > topPrec
hsExprNeedsParens (HsTcBracketOut {}) = False go (SectionL{}) = True
hsExprNeedsParens (HsDo _ sc _) go (SectionR{}) = True
| isListCompExpr sc = False go (ExplicitTuple{}) = False
hsExprNeedsParens (HsRecFld{}) = False go (ExplicitSum{}) = False
hsExprNeedsParens (RecordCon{}) = False go (HsLam{}) = p > topPrec
hsExprNeedsParens (HsSpliceE{}) = False go (HsLamCase{}) = p > topPrec
hsExprNeedsParens (RecordUpd{}) = False go (HsCase{}) = p > topPrec
hsExprNeedsParens (HsWrap _ _ e) = hsExprNeedsParens e go (HsIf{}) = p > topPrec
hsExprNeedsParens _ = True 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 isAtomicHsExpr :: HsExpr id -> Bool
-- True of a single token -- True of a single token
...@@ -1744,7 +1782,7 @@ pprPatBind pat (grhss) ...@@ -1744,7 +1782,7 @@ pprPatBind pat (grhss)
pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body) pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body)
=> Match (GhcPass idR) body -> SDoc => Match (GhcPass idR) body -> SDoc
pprMatch match 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)) ] , nest 2 (pprGRHSs ctxt (m_grhss match)) ]
where where
ctxt = m_ctxt match ctxt = m_ctxt match
...@@ -1765,7 +1803,9 @@ pprMatch match ...@@ -1765,7 +1803,9 @@ pprMatch match
| otherwise -> (parens pp_infix, pats2) | otherwise -> (parens pp_infix, pats2)
-- (x &&& y) z = e -- (x &&& y) z = e
where where
pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2 pp_infix = pprParendLPat opPrec pat1
<+> pprInfixOcc fun
<+> pprParendLPat opPrec pat2
LambdaExpr -> (char '\\', m_pats match) LambdaExpr -> (char '\\', m_pats match)
......
...@@ -23,7 +23,7 @@ import GhcPrelude ...@@ -23,7 +23,7 @@ import GhcPrelude
import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,
negateFractionalLit,SourceText(..),pprWithSourceText ) negateFractionalLit,SourceText(..),pprWithSourceText )
import Type ( Type ) import Type
import Outputable import Outputable
import FastString import FastString
import HsExtension import HsExtension
...@@ -282,30 +282,33 @@ pmPprHsLit (HsFloatPrim _ f) = ppr f ...@@ -282,30 +282,33 @@ pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d pmPprHsLit (HsDoublePrim _ d) = ppr d
pmPprHsLit (XLit x) = ppr x pmPprHsLit (XLit x) = ppr x
-- | Returns 'True' for compound literals that will need parentheses. -- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
isCompoundHsLit :: HsLit x -> Bool -- to be parenthesized under precedence @p@.
isCompoundHsLit (HsChar {}) = False hsLitNeedsParens :: PprPrec -> HsLit x -> Bool
isCompoundHsLit (HsCharPrim {}) = False hsLitNeedsParens p = go
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
where where
compound_ol_val :: OverLitVal -> Bool go (HsChar {}) = False
compound_ol_val (HsIntegral x) = il_neg x go (HsCharPrim {}) = False
compound_ol_val (HsFractional x) = fl_neg x go (HsString {}) = False
compound_ol_val (HsIsString {}) = False go (HsStringPrim {}) = False
isCompoundHsOverLit (XOverLit { }) = 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
...@@ -31,8 +31,7 @@ module HsPat ( ...@@ -31,8 +31,7 @@ module HsPat (
looksLazyPatBind, looksLazyPatBind,
isBangedLPat, isBangedLPat,
hsPatNeedsParens, patNeedsParens, parenthesizePat,
isCompoundPat, parenthesizeCompoundPat,
isIrrefutableHsPat, isIrrefutableHsPat,
collectEvVarsPats, collectEvVarsPats,
...@@ -497,18 +496,20 @@ pprPatBndr var -- Print with type info if -dppr-debug is on ...@@ -497,18 +496,20 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else else
pprPrefixOcc var pprPrefixOcc var
pprParendLPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> SDoc pprParendLPat :: (OutputableBndrId (GhcPass p))
pprParendLPat (L _ p) = pprParendPat p => PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p (L _ pat) = pprParendPat p pat