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(
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.
-}
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......@@ -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
......
......@@ -66,7 +66,7 @@ module HsTypes (
-- Printing
pprHsType,