Fix #15843 by extending Template Haskell AST for tuples to support sections

13 files changed, 201 insertions, 40 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 303c7a08d3..25f5ec0ab1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1332,12 +1332,20 @@ repE e@(HsDo _ ctxt (dL->L _ sts))
   = notHandled "monad comprehension and [: :]" (ppr e)
 
 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
-repE e@(ExplicitTuple _ es boxed)
-  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
-  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
-                       ; repTup xs }
-  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
-                       ; repUnboxedTup xs }
+repE (ExplicitTuple _ es boxity) =
+  let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
+      tupArgToCoreExp a
+        | L _ (Present _ e) <- dL a = do { e' <- repLE e
+                                         ; coreJust expQTyConName e' }
+        | otherwise = coreNothing expQTyConName
+
+  in do { args <- mapM tupArgToCoreExp es
+        ; expQTy <- lookupType expQTyConName
+        ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy]
+              listArg = coreList' maybeExpQTy args
+        ; if isBoxed boxity
+          then repTup listArg
+          else repUnboxedTup listArg }
 
 repE (ExplicitSum _ alt arity e)
  = do { e1 <- repLE e
@@ -2077,10 +2085,10 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
 
-repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
 repTup (MkC es) = rep2 tupEName [es]
 
-repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ)
 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 
 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index b4be2f0000..12f22e8dd3 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -891,17 +891,11 @@ cvtl e = wrapL (cvt e)
                             ; return $ HsLamCase noExt
                                                    (mkMatchGroup FromSource ms')
                             }
-    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
+    cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
                                  -- Note [Dropping constructors]
                                  -- Singleton tuples treated like nothing (just parens)
-    cvt (TupE es)      = do { es' <- mapM cvtl es
-                            ; return $ ExplicitTuple noExt
-                                             (map (noLoc . (Present noExt)) es')
-                                                                         Boxed }
-    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
-                                   ; return $ ExplicitTuple noExt
-                                           (map (noLoc . (Present noExt)) es')
-                                                                       Unboxed }
+    cvt (TupE es)        = cvt_tup es Boxed
+    cvt (UnboxedTupE es) = cvt_tup es Unboxed
     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                        ; unboxedSumChecks alt arity
                                        ; return $ ExplicitSum noExt
@@ -1013,6 +1007,15 @@ cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x
 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 
+cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
+cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg
+                             cvtl_maybe (Just e) = fmap (Present noExt) (cvtl e)
+                       ; es' <- mapM cvtl_maybe es
+                       ; return $ ExplicitTuple
+                                    noExt
+                                    (map noLoc es')
+                                    boxity }
+
 {- Note [Operator assocation]
 We must be quite careful about adding parens:
   * Infix (UInfix ...) op arg      Needs parens round the first arg
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 0a9e11b936..86311762a3 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -151,6 +151,9 @@ import Language.Haskell.TH.Lib.Internal hiding
   , derivClause
   , standaloneDerivWithStrategyD
 
+  , tupE
+  , unboxedTupE
+
   , Role
   , InjectivityAnn
   )
@@ -319,3 +322,12 @@ mkBytes
    -> Word             -- ^ Number of bytes
    -> Bytes
 mkBytes = Bytes
+
+-------------------------------------------------------------------------------
+-- * Tuple expressions
+
+tupE :: [ExpQ] -> ExpQ
+tupE es = do { es1 <- sequence es; return (TupE $ map Just es1)}
+
+unboxedTupE :: [ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE $ map Just es1)}
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 9b9c016c88..5ec59b3737 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -286,11 +286,11 @@ lam1E p e = lamE [p] e
 lamCaseE :: [MatchQ] -> ExpQ
 lamCaseE ms = sequence ms >>= return . LamCaseE
 
-tupE :: [ExpQ] -> ExpQ
-tupE es = do { es1 <- sequence es; return (TupE es1)}
+tupE :: [Maybe ExpQ] -> ExpQ
+tupE es = do { es1 <- traverse sequence es; return (TupE es1)}
 
-unboxedTupE :: [ExpQ] -> ExpQ
-unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
+unboxedTupE :: [Maybe ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- traverse sequence es; return (UnboxedTupE es1)}
 
 unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
 unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 84fc740426..6eaadd648e 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -150,8 +150,8 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat ap
                                            <+> text "->" <+> ppr e
 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                        $ text "\\case" $$ nest nestDepth (ppr ms)
-pprExp _ (TupE es) = parens (commaSep es)
-pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
+pprExp _ (TupE es) = parens (commaSepWith (pprMaybeExp noPrec) es)
+pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es)
 pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
 -- Nesting in Cond is to avoid potential problems in do statements
 pprExp i (CondE guard true false)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index dfcdfd5f17..2d79d5a28f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -846,35 +846,38 @@ instance Lift () where
 instance (Lift a, Lift b) => Lift (a, b) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b)
-    = liftM TupE $ sequence [lift a, lift b]
+    = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b]
 
 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c)
-    = liftM TupE $ sequence [lift a, lift b, lift c]
+    = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
 
 instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d)
-    = liftM TupE $ sequence [lift a, lift b, lift c, lift d]
+    = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c, lift d]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
       => Lift (a, b, c, d, e) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e)
-    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
+    = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b
+                                              , lift c, lift d, lift e ]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
       => Lift (a, b, c, d, e, f) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f)
-    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
+    = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
+                                              , lift d, lift e, lift f ]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
       => Lift (a, b, c, d, e, f, g) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f, g)
-    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+    = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
+                                              , lift d, lift e, lift f, lift g ]
 
 -- | @since 2.16.0.0
 instance Lift (# #) where
@@ -885,48 +888,53 @@ instance Lift (# #) where
 instance (Lift a) => Lift (# a #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a #)
-    = liftM UnboxedTupE $ sequence [lift a]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b) => Lift (# a, b #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c)
       => Lift (# a, b, c #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b, c #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c, Lift d)
       => Lift (# a, b, c, d #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b, c, d #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
+                                                     , lift c, lift d ]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
       => Lift (# a, b, c, d, e #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b, c, d, e #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
+                                                     , lift c, lift d, lift e ]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
       => Lift (# a, b, c, d, e, f #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b, c, d, e, f #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
+                                                     , lift d, lift e, lift f ]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
       => Lift (# a, b, c, d, e, f, g #) where
   liftTyped x = unsafeTExpCoerce (lift x)
   lift (# a, b, c, d, e, f, g #)
-    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+    = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
+                                                     , lift d, lift e, lift f
+                                                     , lift g ]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b) => Lift (# a | b #) where
@@ -1901,8 +1909,28 @@ data Exp
                                        -- See "Language.Haskell.TH.Syntax#infix"
   | LamE [Pat] Exp                     -- ^ @{ \\ p1 p2 -> e }@
   | LamCaseE [Match]                   -- ^ @{ \\case m1; m2 }@
-  | TupE [Exp]                         -- ^ @{ (e1,e2) }  @
-  | UnboxedTupE [Exp]                  -- ^ @{ (\# e1,e2 \#) }  @
+  | TupE [Maybe Exp]                   -- ^ @{ (e1,e2) }  @
+                                       --
+                                       -- The 'Maybe' is necessary for handling
+                                       -- tuple sections.
+                                       --
+                                       -- > (1,)
+                                       --
+                                       -- translates to
+                                       --
+                                       -- > TupE [Just (LitE (IntegerL 1)),Nothing]
+
+  | UnboxedTupE [Maybe Exp]            -- ^ @{ (\# e1,e2 \#) }  @
+                                       --
+                                       -- The 'Maybe' is necessary for handling
+                                       -- tuple sections.
+                                       --
+                                       -- > (# 'c', #)
+                                       --
+                                       -- translates to
+                                       --
+                                       -- > UnboxedTupE [Just (LitE (CharL 'c')),Nothing]
+
   | UnboxedSumE Exp SumAlt SumArity    -- ^ @{ (\#|e|\#) }@
   | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@
   | MultiIfE [(Guard, Exp)]            -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 0958f0c163..a25292e29b 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -2,6 +2,11 @@
 
 ## 2.16.0.0 *TBA*
 
+  * Add support for tuple sections. (#15843) The type signatures of `TupE` and
+    `UnboxedTupE` have changed from `[Exp] -> Exp` to `[Maybe Exp] -> Exp`.
+    The type signatures of `tupE` and `unboxedTupE` remain the same for
+    backwards compatibility.
+
   * Introduce a `liftTyped` method to the `Lift` class and set the default
     implementations of `lift` in terms of `liftTyped`.
 
diff --git a/testsuite/tests/th/T15843.hs b/testsuite/tests/th/T15843.hs
new file mode 100644
index 0000000000..9f807a8cb6
--- /dev/null
+++ b/testsuite/tests/th/T15843.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UnboxedTuples #-}
+module Main where
+
+import Language.Haskell.TH
+
+import T15843a
+
+ppr_and_show a = print a >> (putStrLn $ pprint a)
+
+main :: IO ()
+main = do
+  mapM_ (\q -> runQ q >>= ppr_and_show)
+        [first_of_2, second_of_2, empty_2, full_2, third_of_3]
+
+  mapM_ (\q -> runQ (fmap unType q) >>= ppr_and_show)
+        [first_of_2_T, second_of_2_T]
+
+  runQ (fmap unType empty_2_T) >>= ppr_and_show
+  runQ (fmap unType full_2_T) >>= ppr_and_show
+  runQ (fmap unType third_of_3_T) >>= ppr_and_show
+
+  print $ "(909,) applied to 'c' should be (909, 'c') ===> "
+            ++ (show $ (909, 'c') == ($first_of_2 'c'))
+
+  print $ "(,909) applied to False should be (False, 909) ===> "
+            ++ (show $ (False, 909) == ($second_of_2 False))
+
+  print $ "(,,909) applied to 606 and True should be (606, True, 909) ===> "
+            ++ (show $ (606, True, 909) == ($third_of_3 606 True))
+
+  mapM_ (\q -> runQ q >>= ppr_and_show)
+        [unb0, unb1, unb2, unb3, unb4]
diff --git a/testsuite/tests/th/T15843.stdout b/testsuite/tests/th/T15843.stdout
new file mode 100644
index 0000000000..b7fede7e46
--- /dev/null
+++ b/testsuite/tests/th/T15843.stdout
@@ -0,0 +1,33 @@
+TupE [Just (LitE (IntegerL 909)),Nothing]
+(909,)
+TupE [Nothing,Just (LitE (IntegerL 909))]
+(, 909)
+ConE GHC.Tuple.(,)
+GHC.Tuple.(,)
+TupE [Just (LitE (IntegerL 909)),Just (LitE (IntegerL 606))]
+(909, 606)
+TupE [Nothing,Nothing,Just (LitE (IntegerL 909))]
+(, , 909)
+TupE [Just (LitE (IntegerL 909)),Nothing]
+(909,)
+TupE [Nothing,Just (LitE (IntegerL 909))]
+(, 909)
+ConE GHC.Tuple.(,)
+GHC.Tuple.(,)
+TupE [Just (LitE (IntegerL 909)),Just (LitE (IntegerL 606))]
+(909, 606)
+TupE [Nothing,Nothing,Just (LitE (IntegerL 909))]
+(, , 909)
+"(909,) applied to 'c' should be (909, 'c') ===> True"
+"(,909) applied to False should be (False, 909) ===> True"
+"(,,909) applied to 606 and True should be (606, True, 909) ===> True"
+ConE GHC.Prim.(#,#)
+GHC.Prim.(#,#)
+UnboxedTupE [Just (LitE (CharL 'c')),Just (ConE GHC.Types.False)]
+(# 'c', GHC.Types.False #)
+UnboxedTupE [Just (LitE (CharL 'c')),Nothing]
+(# 'c', #)
+UnboxedTupE [Nothing,Just (ConE GHC.Types.False)]
+(# , GHC.Types.False #)
+AppE (UnboxedTupE [Nothing,Just (ConE GHC.Types.False)]) (LitE (CharL 'c'))
+(# , GHC.Types.False #) 'c'
diff --git a/testsuite/tests/th/T15843a.hs b/testsuite/tests/th/T15843a.hs
new file mode 100644
index 0000000000..2f413fd2c1
--- /dev/null
+++ b/testsuite/tests/th/T15843a.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T15843a where
+
+import Language.Haskell.TH
+
+first_of_2 = [| (909,) |]
+
+second_of_2 = [| (,909) |]
+
+empty_2 = [| (,) |]
+
+full_2 = [| (909,606) |]
+
+third_of_3 = [| (,,909) |]
+
+first_of_2_T = [|| (909,) ||]
+
+second_of_2_T = [|| (,909) ||]
+
+empty_2_T = [|| (,) ||]
+
+full_2_T = [|| (909,606) ||]
+
+third_of_3_T = [|| (,,909) ||]
+
+unb0 = [| (# , #) |]
+
+unb1 = [| (# 'c', False #) |]
+
+unb2  = [| (# 'c', #) |]
+
+unb3 = [| (# ,False #) |]
+
+unb4 = [| (# ,False #) 'c' |]
diff --git a/testsuite/tests/th/T3899a.hs b/testsuite/tests/th/T3899a.hs
index 73ed534786..a63c17b0d3 100644
--- a/testsuite/tests/th/T3899a.hs
+++ b/testsuite/tests/th/T3899a.hs
@@ -12,4 +12,4 @@ nestedTuple n = do
      xs <- replicateM n (newName "x")
      return $ LamE [foldr (\v prev -> ParensP (ConP 'Cons [VarP v,prev]))
                        (ConP 'Nil []) xs]
-                   (TupE $ map VarE xs)
+                   (TupE $ map (Just . VarE) xs)
diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr
index 45cb29cdef..5b1f2b386e 100644
--- a/testsuite/tests/th/TH_repUnboxedTuples.stderr
+++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr
@@ -1,4 +1,4 @@
-CaseE (UnboxedTupE [LitE (CharL 'b'),ConE GHC.Types.False]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True []]) (NormalB (UnboxedTupE [LitE (StringL "One"),LitE (IntegerL 1)])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False []]) (NormalB (UnboxedTupE [LitE (StringL "Two"),LitE (IntegerL 2)])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [LitE (StringL "Three"),LitE (IntegerL 3)])) []]
+CaseE (UnboxedTupE [Just (LitE (CharL 'b')),Just (ConE GHC.Types.False)]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True []]) (NormalB (UnboxedTupE [Just (LitE (StringL "One")),Just (LitE (IntegerL 1))])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False []]) (NormalB (UnboxedTupE [Just (LitE (StringL "Two")),Just (LitE (IntegerL 2))])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [Just (LitE (StringL "Three")),Just (LitE (IntegerL 3))])) []]
 case (# 'b', GHC.Types.False #) of
     (# 'a', GHC.Types.True #) -> (# "One", 1 #)
     (# 'b', GHC.Types.False #) -> (# "Two", 2 #)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 73b4cf48c3..def7a843c8 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -461,6 +461,9 @@ test('T15783', normal, multimod_compile,
 test('T15792', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T15815', normal, multimod_compile,
     ['T15815B', '-v0 ' + config.ghc_th_way_flags])
+test('T15843', [], multimod_compile_and_run,
+     ['T15843.hs',
+      '-v0 ' + config.ghc_th_way_flags])
 test('T15845', normal, compile, ['-v0 -dsuppress-uniques'])
 test('T15437', expect_broken(15437), multimod_compile,
      ['T15437', '-v0 ' + config.ghc_th_way_flags])