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

5 files changed, 66 insertions, 21 deletions

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`.