diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2018-01-18 11:06:42 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-01-18 11:06:43 -0500 |
commit | 575c009d9e4b25384ef984c09b2c54f909693e93 (patch) | |
tree | 210feb761638b515f8abf8fe3e3726550b346cbf /compiler/hsSyn | |
parent | 2a78cf773cb447ac91c4a23d7e921e091e499134 (diff) | |
download | haskell-575c009d9e4b25384ef984c09b2c54f909693e93.tar.gz |
Fix #14681 and #14682 with precision-aimed parentheses
It turns out that `Convert` was recklessly leaving off
parentheses in two places:
* Negative numeric literals
* Patterns in lambda position
This patch fixes it by adding three new functions, `isCompoundHsLit`,
`isCompoundHsOverLit`, and `isCompoundPat`, and using them in the
right places in `Convert`. While I was in town, I also sprinkled
`isCompoundPat` among some `Pat`-constructing functions in `HsUtils`
to help avoid the likelihood of this problem happening in other
places. One of these places is in `TcGenDeriv`, and sprinkling
`isCompountPat` there fixes #14682
Test Plan: make test TEST="T14681 T14682"
Reviewers: alanz, goldfire, bgamari
Reviewed By: bgamari
Subscribers: rwbarton, thomie, carter
GHC Trac Issues: #14681, #14682
Differential Revision: https://phabricator.haskell.org/D4323
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r-- | compiler/hsSyn/Convert.hs | 17 | ||||
-rw-r--r-- | compiler/hsSyn/HsLit.hs | 26 | ||||
-rw-r--r-- | compiler/hsSyn/HsPat.hs | 55 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.hs | 5 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.hs | 9 |
5 files changed, 104 insertions, 8 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index e8c7f0de01..e137b1e836 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -773,8 +773,17 @@ cvtl e = wrapL (cvt e) cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } cvt (LitE l) - | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } - | otherwise = do { l' <- cvtLit l; return $ HsLit l' } + | overloadedLit l = go cvtOverLit HsOverLit isCompoundHsOverLit + | otherwise = go cvtLit HsLit isCompoundHsLit + where + go :: (Lit -> CvtM (l GhcPs)) + -> (l GhcPs -> HsExpr GhcPs) + -> (l GhcPs -> Bool) + -> CvtM (HsExpr GhcPs) + go cvt_lit mk_expr is_compound_lit = do + l' <- cvt_lit l + let e' = mk_expr l' + return $ if is_compound_lit l' then HsPar (noLoc e') else e' cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y @@ -788,8 +797,10 @@ 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' ; return $ HsLam (mkMatchGroup FromSource - [mkSimpleMatch LambdaExpr ps' e'])} + [mkSimpleMatch LambdaExpr + pats e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms ; return $ HsLamCase (mkMatchGroup FromSource ms') } diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 7f0864eccc..d46ef9b448 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -254,3 +254,29 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d + +-- | 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 + +-- | 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 + 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 diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e05d8bbf68..e25ff7bbcc 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -31,6 +31,7 @@ module HsPat ( looksLazyPatBind, isBangedLPat, hsPatNeedsParens, + isCompoundPat, parenthesizeCompoundPat, isIrrefutableHsPat, collectEvVarsPats, @@ -659,6 +660,8 @@ 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 @@ -681,11 +684,63 @@ hsPatNeedsParens (PArrPat {}) = False hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False +-- | 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 (SigPatIn {}) = True +isCompoundPat (SigPatOut {}) = 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 + +-- | 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 p -> LPat p +parenthesizeCompoundPat lp@(L loc p) + | isCompoundPat p = L loc (ParPat lp) + | otherwise = lp + {- % Collect all EvVars from all constructor patterns -} diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 602140b065..6503670130 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -1351,7 +1351,8 @@ ppr_tylit (HsNumTy _ i) = integer i ppr_tylit (HsStrTy _ s) = text (show s) --- | Return True for compound types that will need parens. +-- | 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 @@ -1361,7 +1362,7 @@ isCompoundHsType (L _ HsOpTy{} ) = True isCompoundHsType _ = False -- | @'parenthesizeCompoundHsType' ty@ checks if @'isCompoundHsType' ty@ is --- true, and if so, surrounds it with an 'HsParTy'. Otherwise, it simply +-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply -- returns @ty@. parenthesizeCompoundHsType :: LHsType pass -> LHsType pass parenthesizeCompoundHsType ty@(L loc _) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 6db21331a0..2937c1a657 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -190,7 +190,8 @@ mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where matches = mkMatchGroup Generated - [mkSimpleMatch LambdaExpr pats body] + [mkSimpleMatch LambdaExpr pats' body] + pats' = map parenthesizeCompoundPat pats mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars @@ -430,10 +431,12 @@ nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs -nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) +nlConPat con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map parenthesizeCompoundPat pats))) nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn -nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) +nlConPatName con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map parenthesizeCompoundPat pats))) nlNullaryConPat :: IdP id -> LPat id nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) |