Template Haskell: make unary tuples legal (#16881)

9 files changed, 71 insertions, 48 deletions

diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index f49d6ff0b2..8c3e6a5f1e 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1368,12 +1368,7 @@ cvtTypeKind ty_str ty
            TupleT n
             | Just normals <- m_normals
             , normals `lengthIs` n         -- Saturated
-               -> if n==1 then return (head normals) -- Singleton tuples treated
-                                                     -- like nothing (ie just parens)
-                          else returnL (HsTupleTy noExtField
-                                        HsBoxedOrConstraintTuple normals)
-            | n == 1
-               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
+            -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)
             | otherwise
             -> mk_apps
                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty
                  -- Promoted data constructor; hence cName
 
            PromotedTupleT n
-              | n == 1
-              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
               | Just normals <- m_normals
               , normals `lengthIs` n   -- Saturated
               -> returnL (HsExplicitTupleTy noExtField normals)
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index 77c1469639..3251b326d5 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -171,6 +171,10 @@ Template Haskell
   :extension:`DeriveLift` has been simplified to take advantage of expression
   quotations.
 
+- Explicit boxed 1-tuples from `HsSyn` are now treated as actual 1-tuples,
+  without flattening. In most of the cases these will be obtained using
+  Template Haskell since it is uncommon to deal with 1-tuples in the source.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 59cc5dceef..81cd588ec8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1534,20 +1534,8 @@ tupleDataName :: Int -> Name
 -- | Tuple type constructor
 tupleTypeName :: Int -> Name
 
-tupleDataName 0 = mk_tup_name 0 DataName
-tupleDataName 1 = error "tupleDataName 1"
-tupleDataName n = mk_tup_name (n-1) DataName
-
-tupleTypeName 0 = mk_tup_name 0 TcClsName
-tupleTypeName 1 = error "tupleTypeName 1"
-tupleTypeName n = mk_tup_name (n-1) TcClsName
-
-mk_tup_name :: Int -> NameSpace -> Name
-mk_tup_name n_commas space
-  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
-  where
-    occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
-    tup_mod = mkModName "GHC.Tuple"
+tupleDataName n = mk_tup_name n DataName  True
+tupleTypeName n = mk_tup_name n TcClsName True
 
 -- Unboxed tuple data and type constructors
 -- | Unboxed tuple data constructor
@@ -1555,15 +1543,18 @@ unboxedTupleDataName :: Int -> Name
 -- | Unboxed tuple type constructor
 unboxedTupleTypeName :: Int -> Name
 
-unboxedTupleDataName n = mk_unboxed_tup_name n DataName
-unboxedTupleTypeName n = mk_unboxed_tup_name n TcClsName
+unboxedTupleDataName n = mk_tup_name n DataName  False
+unboxedTupleTypeName n = mk_tup_name n TcClsName False
 
-mk_unboxed_tup_name :: Int -> NameSpace -> Name
-mk_unboxed_tup_name n space
+mk_tup_name :: Int -> NameSpace -> Bool -> Name
+mk_tup_name n space boxed
   = Name (mkOccName tup_occ) (NameG space (mkPkgName "ghc-prim") tup_mod)
   where
-    tup_occ | n == 1    = "Unit#" -- See Note [One-tuples] in TysWiredIn
-            | otherwise = "(#" ++ replicate n_commas ',' ++ "#)"
+    withParens thing
+      | boxed     = "("  ++ thing ++ ")"
+      | otherwise = "(#" ++ thing ++ "#)"
+    tup_occ | n == 1    = if boxed then "Unit" else "Unit#"
+            | otherwise = withParens (replicate n_commas ',')
     n_commas = n - 1
     tup_mod  = mkModName "GHC.Tuple"
 
diff --git a/testsuite/tests/th/TH_1tuple.stderr b/testsuite/tests/th/TH_1tuple.stderr
index 5e9d6c799d..bc7f25ad81 100644
--- a/testsuite/tests/th/TH_1tuple.stderr
+++ b/testsuite/tests/th/TH_1tuple.stderr
@@ -1,5 +1,7 @@
 
-TH_1tuple.hs:11:7:
-    Illegal 1-tuple type constructor
-    When splicing a TH expression: 1 :: ()
-    In the untyped splice: $(sigE [| 1 |] (tupleT 1))
+TH_1tuple.hs:11:7: error:
+    • Expecting one more argument to ‘Unit’
+      Expected a type, but ‘Unit’ has kind ‘* -> *’
+    • In an expression type signature: Unit
+      In the expression: (1 :: Unit)
+      In an equation for ‘y’: y = (1 :: Unit)
diff --git a/testsuite/tests/th/TH_Promoted1Tuple.stderr b/testsuite/tests/th/TH_Promoted1Tuple.stderr
index bcda8189e0..a996623c30 100644
--- a/testsuite/tests/th/TH_Promoted1Tuple.stderr
+++ b/testsuite/tests/th/TH_Promoted1Tuple.stderr
@@ -1,4 +1,3 @@
 
-TH_Promoted1Tuple.hs:7:3:
-    Illegal promoted 1-tuple type
-    When splicing a TH declaration: type F = '(GHC.Types.Int)
+TH_Promoted1Tuple.hs:7:3: error:
+    Illegal type: ‘'(Int)’ Perhaps you intended to use DataKinds
diff --git a/testsuite/tests/th/TH_tuple1.hs b/testsuite/tests/th/TH_tuple1.hs
index 3e9b330fb0..f2d1baf3a4 100644
--- a/testsuite/tests/th/TH_tuple1.hs
+++ b/testsuite/tests/th/TH_tuple1.hs
@@ -1,15 +1,9 @@
-{-# LANGUAGE TemplateHaskell #-}
-
--- Test the use of tupleDataName, tupleTypeName
-
-module ShouldCompile where
+module Main where
 
 import Language.Haskell.TH
+import TH_tuple1a
 
-foo = $( sigE (appsE [conE (tupleDataName 2),
-                     litE (integerL 1),
-                     litE (integerL 2)])
-              (appT (appT (conT (tupleTypeName 2))
-                          (conT ''Integer))
-                    (conT ''Integer))
-        )
+main :: IO ()
+main = do
+ let pprQ = \a -> print a >> (putStrLn $ pprint a)
+ mapM_ (\q -> runQ q >>= pprQ) [tp2, tp1, tp2u, tp1u]
diff --git a/testsuite/tests/th/TH_tuple1.stdout b/testsuite/tests/th/TH_tuple1.stdout
new file mode 100644
index 0000000000..7e35530f6c
--- /dev/null
+++ b/testsuite/tests/th/TH_tuple1.stdout
@@ -0,0 +1,10 @@
+SigE (AppE (AppE (ConE GHC.Tuple.(,)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Tuple.(,)) (ConT GHC.Integer.Type.Integer)) (ConT GHC.Integer.Type.Integer))
+GHC.Tuple.(,) 1 2 :: GHC.Tuple.(,) GHC.Integer.Type.Integer
+                                   GHC.Integer.Type.Integer
+SigE (AppE (ConE GHC.Tuple.Unit) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Unit) (ConT GHC.Integer.Type.Integer))
+GHC.Tuple.Unit 1 :: GHC.Tuple.Unit GHC.Integer.Type.Integer
+SigE (AppE (AppE (ConE GHC.Tuple.(#,#)) (LitE (IntegerL 1))) (LitE (IntegerL 2))) (AppT (AppT (ConT GHC.Tuple.(#,#)) (ConT GHC.Integer.Type.Integer)) (ConT GHC.Integer.Type.Integer))
+GHC.Tuple.(#,#) 1 2 :: GHC.Tuple.(#,#) GHC.Integer.Type.Integer
+                                       GHC.Integer.Type.Integer
+SigE (AppE (ConE GHC.Tuple.Unit#) (LitE (IntegerL 1))) (AppT (ConT GHC.Tuple.Unit#) (ConT GHC.Integer.Type.Integer))
+GHC.Tuple.Unit# 1 :: GHC.Tuple.Unit# GHC.Integer.Type.Integer
diff --git a/testsuite/tests/th/TH_tuple1a.hs b/testsuite/tests/th/TH_tuple1a.hs
new file mode 100644
index 0000000000..2b4bb5014b
--- /dev/null
+++ b/testsuite/tests/th/TH_tuple1a.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- Test the use of tupleDataName, tupleTypeName
+module TH_tuple1a where
+
+import Language.Haskell.TH
+
+tp2 = sigE (appsE [conE (tupleDataName 2),
+                  litE (integerL 1),
+                  litE (integerL 2)])
+           (appT (appT (conT (tupleTypeName 2))
+                       (conT ''Integer))
+                       (conT ''Integer))
+
+tp1 = sigE (appsE [conE (tupleDataName 1),
+                  litE (integerL 1)])
+           (appT (conT (tupleTypeName 1))
+                 (conT ''Integer))
+
+tp2u = sigE (appsE [conE (unboxedTupleDataName 2),
+                   litE (integerL 1),
+                   litE (integerL 2)])
+            (appT (appT (conT (unboxedTupleTypeName 2))
+                        (conT ''Integer))
+                  (conT ''Integer))
+
+tp1u = sigE (appsE [conE (unboxedTupleDataName 1),
+                   litE (integerL 1)])
+            (appT (conT (unboxedTupleTypeName 1))
+                  (conT ''Integer))
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 590b060b0b..cbd40f6edd 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -102,7 +102,8 @@ test('TH_spliceE3', normal, compile, ['-v0'])
 test('TH_spliceE4', normal, compile_and_run, [''])
 
 test('TH_class1', normal, compile, ['-v0'])
-test('TH_tuple1', normal, compile, ['-v0'])
+test('TH_tuple1', [], multimod_compile_and_run,
+    ['TH_tuple1', '-v0 ' + config.ghc_th_way_flags])
 test('TH_genEx', [], multimod_compile,
      ['TH_genEx', '-v0 ' + config.ghc_th_way_flags])