Add PromotedInfixT/PromotedUInfixT to TH

Previously, it was not possible to refer to a data constructor using
InfixT with a dynamically bound name (i.e. a name with NameFlavour
`NameS` or `NameQ`) if a type constructor of the same
name exists.

This commit adds promoted counterparts to InfixT and UInfixT,
analogously to how PromotedT is the promoted counterpart to ConT.

Closes #20773

2 files changed, 65 insertions, 40 deletions

diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 13cd3e71c9..af46ba75c0 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1401,33 +1401,35 @@ lookupThInstName th_type = do
     -- > inst_cls_name (Monad Maybe) == Monad
     -- > inst_cls_name C = C
     inst_cls_name :: TH.Type -> TcM TH.Name
-    inst_cls_name (TH.AppT t _)           = inst_cls_name t
-    inst_cls_name (TH.SigT n _)           = inst_cls_name n
-    inst_cls_name (TH.VarT n)             = pure n
-    inst_cls_name (TH.ConT n)             = pure n
-    inst_cls_name (TH.PromotedT n)        = pure n
-    inst_cls_name (TH.InfixT _ n _)       = pure n
-    inst_cls_name (TH.UInfixT _ n _)      = pure n
-    inst_cls_name (TH.ParensT t)          = inst_cls_name t
-
-    inst_cls_name (TH.ForallT _ _ _)      = inst_cls_name_err
-    inst_cls_name (TH.ForallVisT _ _)     = inst_cls_name_err
-    inst_cls_name (TH.AppKindT _ _)       = inst_cls_name_err
-    inst_cls_name (TH.TupleT _)           = inst_cls_name_err
-    inst_cls_name (TH.UnboxedTupleT _)    = inst_cls_name_err
-    inst_cls_name (TH.UnboxedSumT _)      = inst_cls_name_err
-    inst_cls_name TH.ArrowT               = inst_cls_name_err
-    inst_cls_name TH.MulArrowT            = inst_cls_name_err
-    inst_cls_name TH.EqualityT            = inst_cls_name_err
-    inst_cls_name TH.ListT                = inst_cls_name_err
-    inst_cls_name (TH.PromotedTupleT _)   = inst_cls_name_err
-    inst_cls_name TH.PromotedNilT         = inst_cls_name_err
-    inst_cls_name TH.PromotedConsT        = inst_cls_name_err
-    inst_cls_name TH.StarT                = inst_cls_name_err
-    inst_cls_name TH.ConstraintT          = inst_cls_name_err
-    inst_cls_name (TH.LitT _)             = inst_cls_name_err
-    inst_cls_name TH.WildCardT            = inst_cls_name_err
-    inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err
+    inst_cls_name (TH.AppT t _)              = inst_cls_name t
+    inst_cls_name (TH.SigT n _)              = inst_cls_name n
+    inst_cls_name (TH.VarT n)                = pure n
+    inst_cls_name (TH.ConT n)                = pure n
+    inst_cls_name (TH.PromotedT n)           = pure n
+    inst_cls_name (TH.InfixT _ n _)          = pure n
+    inst_cls_name (TH.UInfixT _ n _)         = pure n
+    inst_cls_name (TH.PromotedInfixT _ n _)  = pure n
+    inst_cls_name (TH.PromotedUInfixT _ n _) = pure n
+    inst_cls_name (TH.ParensT t)             = inst_cls_name t
+
+    inst_cls_name (TH.ForallT _ _ _)         = inst_cls_name_err
+    inst_cls_name (TH.ForallVisT _ _)        = inst_cls_name_err
+    inst_cls_name (TH.AppKindT _ _)          = inst_cls_name_err
+    inst_cls_name (TH.TupleT _)              = inst_cls_name_err
+    inst_cls_name (TH.UnboxedTupleT _)       = inst_cls_name_err
+    inst_cls_name (TH.UnboxedSumT _)         = inst_cls_name_err
+    inst_cls_name TH.ArrowT                  = inst_cls_name_err
+    inst_cls_name TH.MulArrowT               = inst_cls_name_err
+    inst_cls_name TH.EqualityT               = inst_cls_name_err
+    inst_cls_name TH.ListT                   = inst_cls_name_err
+    inst_cls_name (TH.PromotedTupleT _)      = inst_cls_name_err
+    inst_cls_name TH.PromotedNilT            = inst_cls_name_err
+    inst_cls_name TH.PromotedConsT           = inst_cls_name_err
+    inst_cls_name TH.StarT                   = inst_cls_name_err
+    inst_cls_name TH.ConstraintT             = inst_cls_name_err
+    inst_cls_name (TH.LitT _)                = inst_cls_name_err
+    inst_cls_name TH.WildCardT               = inst_cls_name_err
+    inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err
 
     inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
       text "Couldn't work out what instance"
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 891eb0af0e..1020b5af3f 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1119,15 +1119,17 @@ We must be quite careful about adding parens:
 
 Note [Converting UInfix]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
-the trees to reflect the fixities of the underlying operators:
+When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,
+we want to readjust the trees to reflect the fixities of the underlying
+operators:
 
   UInfixE x * (UInfixE y + z) ---> (x * y) + z
 
 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
-@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be completely
-right-biased for types and left-biased for everything else. So we left-bias the
-trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
+@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be
+completely right-biased for types and left-biased for everything else. So we
+left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of
+@UInfixT@ and @PromotedUnfixT@.
 
 Sample input:
 
@@ -1603,8 +1605,25 @@ cvtTypeKind ty_str ty
                    }
 
            UInfixT t1 s t2
-             -> do { t2' <- cvtType t2
-                   ; t <- cvtOpAppT t1 s t2'
+             -> do { s' <- tconNameN s
+                   ; t2' <- cvtType t2
+                   ; t <- cvtOpAppT t1 s' t2'
+                   ; mk_apps (unLoc t) tys'
+                   } -- Note [Converting UInfix]
+
+           PromotedInfixT t1 s t2
+             -> do { s'  <- cName s
+                   ; t1' <- cvtType t1
+                   ; t2' <- cvtType t2
+                   ; mk_apps
+                      (HsTyVar noAnn IsPromoted (noLocA s'))
+                      ([HsValArg t1', HsValArg t2'] ++ tys')
+                   }
+
+           PromotedUInfixT t1 s t2
+             -> do { s' <- cNameN s
+                   ; t2' <- cvtType t2
+                   ; t <- cvtOpAppT t1 s' t2'
                    ; mk_apps (unLoc t) tys'
                    } -- Note [Converting UInfix]
 
@@ -1769,14 +1788,18 @@ provided @y@ is.
 
 See the @cvtOpApp@ documentation for how this function works.
 -}
-cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT :: TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
 cvtOpAppT (UInfixT x op2 y) op1 z
-  = do { l <- cvtOpAppT y op1 z
-       ; cvtOpAppT x op2 l }
+  = do { op2' <- tconNameN op2
+       ; l <- cvtOpAppT y op1 z
+       ; cvtOpAppT x op2' l }
+cvtOpAppT (PromotedUInfixT x op2 y) op1 z
+  = do { op2' <- cNameN op2
+       ; l <- cvtOpAppT y op1 z
+       ; cvtOpAppT x op2' l }
 cvtOpAppT x op y
-  = do { op' <- tconNameN op
-       ; x' <- cvtType x
-       ; returnLA (mkHsOpTy x' op' y) }
+  = do { x' <- cvtType x
+       ; returnLA (mkHsOpTy x' op y) }
 
 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
 cvtKind = cvtTypeKind "kind"