Commit 33e3b3eb authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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

(cherry picked from commit 575c009d)
parent 4eccca7e
......@@ -775,8 +775,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
......@@ -790,8 +799,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')
}
......
......@@ -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
......@@ -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
-}
......
......@@ -1368,7 +1368,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
......@@ -1378,7 +1379,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 _)
......
......@@ -191,7 +191,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
......@@ -431,10 +432,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 []))
......
......@@ -1849,7 +1849,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches
where
matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
matches = [mkMatch (mkPrefixFunRhs (L loc fun))
(map parenthesizeCompoundPat p) e
(noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs]
......@@ -1869,7 +1870,8 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
mkFunBindEC arity loc fun catch_all pats_and_exprs
= mkRdrFunBindEC arity catch_all (L loc fun) matches
where
matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) p e
matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
(map parenthesizeCompoundPat p) e
(noLoc emptyLocalBinds)
| (p,e) <- pats_and_exprs ]
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
module T14682 where
import Data.Data
import Data.Ix
import Language.Haskell.TH.Syntax
data Foo = Foo Int Int
deriving (Show, Lift, Data, Eq, Ord, Ix)
==================== Derived instances ====================
Derived class instances:
instance GHC.Show.Show T14682.Foo where
GHC.Show.showsPrec a (T14682.Foo b1 b2)
= GHC.Show.showParen
(a GHC.Classes.>= 11)
((GHC.Base..)
(GHC.Show.showString "Foo ")
((GHC.Base..)
(GHC.Show.showsPrec 11 b1)
((GHC.Base..) GHC.Show.showSpace (GHC.Show.showsPrec 11 b2))))
instance Language.Haskell.TH.Syntax.Lift T14682.Foo where
Language.Haskell.TH.Syntax.lift (T14682.Foo a1 a2)
= Language.Haskell.TH.Lib.Internal.appE
(Language.Haskell.TH.Lib.Internal.appE
(Language.Haskell.TH.Lib.Internal.conE
(Language.Haskell.TH.Syntax.mkNameG_d "main" "T14682" "Foo"))
(Language.Haskell.TH.Syntax.lift a1))
(Language.Haskell.TH.Syntax.lift a2)
instance Data.Data.Data T14682.Foo where
Data.Data.gfoldl k z (T14682.Foo a1 a2)
= ((z T14682.Foo `k` a1) `k` a2)
Data.Data.gunfold k z _ = k (k (z T14682.Foo))
Data.Data.toConstr (T14682.Foo _ _) = T14682.$cFoo
Data.Data.dataTypeOf _ = T14682.$tFoo
instance GHC.Classes.Eq T14682.Foo where
(GHC.Classes.==) (T14682.Foo a1 a2) (T14682.Foo b1 b2)
= (((a1 GHC.Classes.== b1))
GHC.Classes.&& ((a2 GHC.Classes.== b2)))
instance GHC.Classes.Ord T14682.Foo where
GHC.Classes.compare a b
= case a of {
T14682.Foo a1 a2
-> case b of {
T14682.Foo b1 b2
-> case (GHC.Classes.compare a1 b1) of
GHC.Types.LT -> GHC.Types.LT
GHC.Types.EQ -> (a2 `GHC.Classes.compare` b2)
GHC.Types.GT -> GHC.Types.GT } }
(GHC.Classes.<) a b
= case a of {
T14682.Foo a1 a2
-> case b of {
T14682.Foo b1 b2
-> case (GHC.Classes.compare a1 b1) of
GHC.Types.LT -> GHC.Types.True
GHC.Types.EQ -> (a2 GHC.Classes.< b2)
GHC.Types.GT -> GHC.Types.False } }
(GHC.Classes.<=) a b = GHC.Classes.not ((GHC.Classes.<) b a)
(GHC.Classes.>) a b = (GHC.Classes.<) b a
(GHC.Classes.>=) a b = GHC.Classes.not ((GHC.Classes.<) a b)
instance GHC.Arr.Ix T14682.Foo where
GHC.Arr.range (T14682.Foo a1 a2, T14682.Foo b1 b2)
= [T14682.Foo c1 c2 |
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
= (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
= (GHC.Arr.inRange (a1, b1) c1
GHC.Classes.&& GHC.Arr.inRange (a2, b2) c2)
T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX ::
T14682.Foo -> GHC.Prim.Int#
T14682.$con2tag_B4iUvrAY4wB3YczpMJQUOX (T14682.Foo _ _) = 0#
T14682.$tFoo :: Data.Data.DataType
T14682.$cFoo :: Data.Data.Constr
T14682.$tFoo = Data.Data.mkDataType "Foo" [T14682.$cFoo]
T14682.$cFoo
= Data.Data.mkConstr T14682.$tFoo "Foo" [] Data.Data.Prefix
Derived type family instances:
==================== Filling in method body ====================
GHC.Show.Show [T14682.Foo]
GHC.Show.show = GHC.Show.$dmshow @(T14682.Foo)
==================== Filling in method body ====================
GHC.Show.Show [T14682.Foo]
GHC.Show.showList = GHC.Show.$dmshowList @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.dataCast1 = Data.Data.$dmdataCast1 @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.dataCast2 = Data.Data.$dmdataCast2 @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapT = Data.Data.$dmgmapT @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapQl = Data.Data.$dmgmapQl @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapQr = Data.Data.$dmgmapQr @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapQ = Data.Data.$dmgmapQ @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapQi = Data.Data.$dmgmapQi @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapM = Data.Data.$dmgmapM @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapMp = Data.Data.$dmgmapMp @(T14682.Foo)
==================== Filling in method body ====================
Data.Data.Data [T14682.Foo]
Data.Data.gmapMo = Data.Data.$dmgmapMo @(T14682.Foo)
==================== Filling in method body ====================
GHC.Classes.Eq [T14682.Foo]
GHC.Classes./= = GHC.Classes.$dm/= @(T14682.Foo)
==================== Filling in method body ====================
GHC.Classes.Ord [T14682.Foo]
GHC.Classes.max = GHC.Classes.$dmmax @(T14682.Foo)
==================== Filling in method body ====================
GHC.Classes.Ord [T14682.Foo]
GHC.Classes.min = GHC.Classes.$dmmin @(T14682.Foo)
==================== Filling in method body ====================
GHC.Arr.Ix [T14682.Foo]
GHC.Arr.index = GHC.Arr.$dmindex @(T14682.Foo)
==================== Filling in method body ====================
GHC.Arr.Ix [T14682.Foo]
GHC.Arr.rangeSize = GHC.Arr.$dmrangeSize @(T14682.Foo)
==================== Filling in method body ====================
GHC.Arr.Ix [T14682.Foo]
GHC.Arr.unsafeRangeSize = GHC.Arr.$dmunsafeRangeSize @(T14682.Foo)
......@@ -100,3 +100,4 @@ test('T14339', normal, compile, [''])
test('T14331', normal, compile, [''])
test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques'])
test('T14579', normal, compile, [''])
test('T14682', normal, compile, ['-ddump-deriv -dsuppress-uniques'])
{-# LANGUAGE TemplateHaskell #-}
module T14681 where
import Data.Functor.Identity
import Language.Haskell.TH
$([d| f = \(Identity x) -> x |])
$([d| g = $(pure $ VarE '(+) `AppE` LitE (IntegerL (-1))
`AppE` (LitE (IntegerL (-1)))) |])
T14681.hs:7:3-31: Splicing declarations
[d| f = \ (Identity x) -> x |] ======> f = \ (Identity x) -> x
T14681.hs:(8,3)-(9,62): Splicing declarations
[d| g = $(pure
$ VarE '(+) `AppE` LitE (IntegerL (- 1))
`AppE` (LitE (IntegerL (- 1)))) |]
pending(rn) [<splice, pure
$ VarE '(+) `AppE` LitE (IntegerL (- 1))
`AppE` (LitE (IntegerL (- 1)))>]
======>
g = ((+) (-1)) (-1)
......@@ -398,3 +398,4 @@ test('T13968', normal, compile_fail, ['-v0'])
test('T14204', normal, compile_fail, ['-v0'])
test('T14060', normal, compile_and_run, ['-v0'])
test('T14646', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14681', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment