Mark promoted InfixT names as IsPromoted (#17394)wip/T17394

We applied a similar fix for `ConT` in #15572 but forgot to apply the
fix to `InfixT` as well. This patch fixes #17394 by doing just that.

4 files changed, 32 insertions, 8 deletions

diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 8c3e6a5f1e..29f7b1e139 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1421,13 +1421,7 @@ cvtTypeKind ty_str ty
            VarT nm -> do { nm' <- tNameL nm
                          ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; -- ConT can contain both data constructor (i.e.,
-                           -- promoted) names and other (i.e, unpromoted)
-                           -- names, as opposed to PromotedT, which can only
-                           -- contain data constructor names. See #15572.
-                           let prom = if isRdrDataCon nm'
-                                      then IsPromoted
-                                      else NotPromoted
+                         ; let prom = name_promotedness nm'
                          ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}
 
            ForallT tvs cxt ty
@@ -1464,8 +1458,9 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
+                   ; let prom = name_promotedness s'
                    ; mk_apps
-                      (HsTyVar noExtField NotPromoted (noLoc s'))
+                      (HsTyVar noExtField prom (noLoc s'))
                       ([HsValArg t1', HsValArg t2'] ++ tys')
                    }
 
@@ -1540,6 +1535,16 @@ cvtTypeKind ty_str ty
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
 
+-- ConT/InfixT can contain both data constructor (i.e., promoted) names and
+-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
+-- contain data constructor names. See #15572/#17394. We use this function to
+-- determine whether to mark a name as promoted/unpromoted when dealing with
+-- ConT/InfixT.
+name_promotedness :: RdrName -> Hs.PromotionFlag
+name_promotedness nm
+  | isRdrDataCon nm = IsPromoted
+  | otherwise       = NotPromoted
+
 -- | Constructs an application of a type to arguments passed in a list.
 mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
 mk_apps head_ty type_args = do
diff --git a/testsuite/tests/th/T17394.hs b/testsuite/tests/th/T17394.hs
new file mode 100644
index 0000000000..f81f4f91e5
--- /dev/null
+++ b/testsuite/tests/th/T17394.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices #-}
+module T17394 where
+
+import GHC.Generics
+import Language.Haskell.TH
+
+type T1 = $(infixT (promotedT 'Nothing) '(:*:) (promotedT 'Nothing))
+type T2 = $(infixT (conT     ''Maybe)  ''(:*:) (conT     ''Maybe))
diff --git a/testsuite/tests/th/T17394.stderr b/testsuite/tests/th/T17394.stderr
new file mode 100644
index 0000000000..c4ad33a671
--- /dev/null
+++ b/testsuite/tests/th/T17394.stderr
@@ -0,0 +1,8 @@
+T17394.hs:10:13-65: Splicing type
+    infixT (conT ''Maybe) ''(:*:) (conT ''Maybe)
+  ======>
+    (:*:) Maybe Maybe
+T17394.hs:9:13-67: Splicing type
+    infixT (promotedT 'Nothing) '(:*:) (promotedT 'Nothing)
+  ======>
+    '(:*:) 'Nothing 'Nothing
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 545c4e62aa..636bd537b0 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -487,3 +487,4 @@ test('T16976z', normal, compile_fail, [''])
 test('T16980', normal, compile, [''])
 test('T16980a', normal, compile_fail, [''])
 test('T17296', normal, compile, ['-v0'])
+test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])