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) ...@@ -775,8 +775,17 @@ cvtl e = wrapL (cvt e)
cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
cvt (LitE l) cvt (LitE l)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | overloadedLit l = go cvtOverLit HsOverLit isCompoundHsOverLit
| otherwise = do { l' <- cvtLit l; return $ HsLit l' } | 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 cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp (mkLHsPar x') (mkLHsPar y')} ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
...@@ -790,8 +799,10 @@ cvtl e = wrapL (cvt e) ...@@ -790,8 +799,10 @@ 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'
; return $ HsLam (mkMatchGroup FromSource ; return $ HsLam (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr ps' e'])} [mkSimpleMatch LambdaExpr
pats e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
; return $ HsLamCase (mkMatchGroup FromSource ms') ; return $ HsLamCase (mkMatchGroup FromSource ms')
} }
......
...@@ -254,3 +254,29 @@ pmPprHsLit (HsInteger _ i _) = integer i ...@@ -254,3 +254,29 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d 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 ( ...@@ -31,6 +31,7 @@ module HsPat (
looksLazyPatBind, looksLazyPatBind,
isBangedLPat, isBangedLPat,
hsPatNeedsParens, hsPatNeedsParens,
isCompoundPat, parenthesizeCompoundPat,
isIrrefutableHsPat, isIrrefutableHsPat,
collectEvVarsPats, collectEvVarsPats,
...@@ -659,6 +660,8 @@ case in foo to be unreachable, as GHC would mistakenly believe that Nothing' ...@@ -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! 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 :: Pat a -> Bool
hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (SplicePat {}) = False hsPatNeedsParens (SplicePat {}) = False
...@@ -681,11 +684,63 @@ hsPatNeedsParens (PArrPat {}) = False ...@@ -681,11 +684,63 @@ hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False hsPatNeedsParens (NPat {}) = False
-- | Returns 'True' if a constructor pattern must be parenthesized in order
-- to parse.
conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon {}) = False conPatNeedsParens (PrefixCon {}) = False
conPatNeedsParens (InfixCon {}) = True conPatNeedsParens (InfixCon {}) = True
conPatNeedsParens (RecCon {}) = False 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 % Collect all EvVars from all constructor patterns
-} -}
......
...@@ -1368,7 +1368,8 @@ ppr_tylit (HsNumTy _ i) = integer i ...@@ -1368,7 +1368,8 @@ ppr_tylit (HsNumTy _ i) = integer i
ppr_tylit (HsStrTy _ s) = text (show s) 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 :: LHsType pass -> Bool
isCompoundHsType (L _ HsAppTy{} ) = True isCompoundHsType (L _ HsAppTy{} ) = True
isCompoundHsType (L _ HsAppsTy{}) = True isCompoundHsType (L _ HsAppsTy{}) = True
...@@ -1378,7 +1379,7 @@ isCompoundHsType (L _ HsOpTy{} ) = True ...@@ -1378,7 +1379,7 @@ isCompoundHsType (L _ HsOpTy{} ) = True
isCompoundHsType _ = False isCompoundHsType _ = False
-- | @'parenthesizeCompoundHsType' ty@ checks if @'isCompoundHsType' ty@ is -- | @'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@. -- returns @ty@.
parenthesizeCompoundHsType :: LHsType pass -> LHsType pass parenthesizeCompoundHsType :: LHsType pass -> LHsType pass
parenthesizeCompoundHsType ty@(L loc _) parenthesizeCompoundHsType ty@(L loc _)
......
...@@ -191,7 +191,8 @@ mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs ...@@ -191,7 +191,8 @@ mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where where
matches = mkMatchGroup Generated matches = mkMatchGroup Generated
[mkSimpleMatch LambdaExpr pats body] [mkSimpleMatch LambdaExpr pats' body]
pats' = map parenthesizeCompoundPat pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
...@@ -431,10 +432,12 @@ nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id ...@@ -431,10 +432,12 @@ nlInfixConPat :: IdP id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs 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 :: 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 :: IdP id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
......
...@@ -1849,7 +1849,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName ...@@ -1849,7 +1849,8 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
mkFunBindSE arity loc fun pats_and_exprs mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches = mkRdrFunBindSE arity (L loc fun) matches
where where
matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e matches = [mkMatch (mkPrefixFunRhs (L loc fun))
(map parenthesizeCompoundPat p) e
(noLoc emptyLocalBinds) (noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs] | (p,e) <-pats_and_exprs]
...@@ -1869,7 +1870,8 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName ...@@ -1869,7 +1870,8 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
mkFunBindEC arity loc fun catch_all pats_and_exprs mkFunBindEC arity loc fun catch_all pats_and_exprs
= mkRdrFunBindEC arity catch_all (L loc fun) matches = mkRdrFunBindEC arity catch_all (L loc fun) matches
where where
matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) p e matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
(map parenthesizeCompoundPat p) e
(noLoc emptyLocalBinds) (noLoc emptyLocalBinds)
| (p,e) <- pats_and_exprs ] | (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, ['']) ...@@ -100,3 +100,4 @@ test('T14339', normal, compile, [''])
test('T14331', normal, compile, ['']) test('T14331', normal, compile, [''])
test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques']) test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques'])
test('T14579', normal, compile, ['']) 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']) ...@@ -398,3 +398,4 @@ test('T13968', normal, compile_fail, ['-v0'])
test('T14204', normal, compile_fail, ['-v0']) test('T14204', normal, compile_fail, ['-v0'])
test('T14060', normal, compile_and_run, ['-v0']) test('T14060', normal, compile_and_run, ['-v0'])
test('T14646', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) 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