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

12 files changed, 334 insertions, 10 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 []))
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index d9166e5e00..b2d45fda6d 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -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 ]
 
diff --git a/testsuite/tests/deriving/should_compile/T14682.hs b/testsuite/tests/deriving/should_compile/T14682.hs
new file mode 100644
index 0000000000..8f8161f00f
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T14682.hs
@@ -0,0 +1,10 @@
+{-# 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)
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
new file mode 100644
index 0000000000..6ff285fbef
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -0,0 +1,194 @@
+
+==================== 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)
+
+
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 8752bbdb73..3360c81850 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -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'])
diff --git a/testsuite/tests/th/T14681.hs b/testsuite/tests/th/T14681.hs
new file mode 100644
index 0000000000..341a1a66b1
--- /dev/null
+++ b/testsuite/tests/th/T14681.hs
@@ -0,0 +1,9 @@
+{-# 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)))) |])
diff --git a/testsuite/tests/th/T14681.stderr b/testsuite/tests/th/T14681.stderr
new file mode 100644
index 0000000000..debb18dee5
--- /dev/null
+++ b/testsuite/tests/th/T14681.stderr
@@ -0,0 +1,11 @@
+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)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2e7ffa3368..41567162e8 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -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'])