summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authornineonine <mail4chemik@gmail.com>2019-06-23 22:44:37 -0700
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-07-02 16:18:44 -0400
commitcef80c0b9edca3d21b5c762f51dfbab4c5857d8a (patch)
tree4812abbe6695af023ed25587b0800649ba0254fe
parent0bed9647c5e6edbfcfed2d7dbd8d25fd8fd2b195 (diff)
downloadhaskell-cef80c0b9edca3d21b5c762f51dfbab4c5857d8a.tar.gz
Fix #15843 by extending Template Haskell AST for tuples to support sections
-rw-r--r--compiler/deSugar/DsMeta.hs24
-rw-r--r--compiler/hsSyn/Convert.hs21
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs12
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs8
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs4
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs58
-rw-r--r--libraries/template-haskell/changelog.md5
-rw-r--r--testsuite/tests/th/T15843.hs33
-rw-r--r--testsuite/tests/th/T15843.stdout33
-rw-r--r--testsuite/tests/th/T15843a.hs36
-rw-r--r--testsuite/tests/th/T3899a.hs2
-rw-r--r--testsuite/tests/th/TH_repUnboxedTuples.stderr2
-rw-r--r--testsuite/tests/th/all.T3
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])