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

5 files changed, 103 insertions, 71 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 7dcf328574..42fa6cd501 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -56,9 +56,9 @@ module Language.Haskell.TH.Lib (
     bindS, letS, noBindS, parS, recS,
 
     -- *** Types
-        forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT,
-        mulArrowT,
-        uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,
+        forallT, forallVisT, varT, conT, appT, appKindT, arrowT, mulArrowT,
+        infixT, uInfixT, promotedInfixT, promotedUInfixT,
+        parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,
         sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,
         promotedConsT, implicitParamT,
     -- **** Type literals
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 379a2ad07d..95ccf39447 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -698,6 +698,16 @@ uInfixT t1 n t2 = do t1' <- t1
                      t2' <- t2
                      pure (UInfixT t1' n t2')
 
+promotedInfixT :: Quote m => m Type -> Name -> m Type -> m Type
+promotedInfixT t1 n t2 = do t1' <- t1
+                            t2' <- t2
+                            pure (PromotedInfixT t1' n t2')
+
+promotedUInfixT :: Quote m => m Type -> Name -> m Type -> m Type
+promotedUInfixT t1 n t2 = do t1' <- t1
+                             t2' <- t2
+                             pure (PromotedUInfixT t1' n t2')
+
 parensT :: Quote m => m Type -> m Type
 parensT t = do t' <- t
                pure (ParensT t')
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 7f34bdc6d6..02f38852ac 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+{-# LANGUAGE LambdaCase #-}
 -- | contains a prettyprinter for the
 -- Template Haskell datatypes
 
@@ -760,44 +761,52 @@ pprStrictType = pprBangType
 
 ------------------------------
 pprParendType :: Type -> Doc
-pprParendType (VarT v)            = pprName' Applied v
+pprParendType (VarT v)               = pprName' Applied v
 -- `Applied` is used here instead of `ppr` because of infix names (#13887)
-pprParendType (ConT c)            = pprName' Applied c
-pprParendType (TupleT 0)          = text "()"
-pprParendType (TupleT 1)          = pprParendType (ConT (tupleTypeName 1))
-pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
-pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
-pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
-pprParendType ArrowT              = parens (text "->")
-pprParendType MulArrowT           = text "FUN"
-pprParendType ListT               = text "[]"
-pprParendType (LitT l)            = pprTyLit l
-pprParendType (PromotedT c)       = text "'" <> pprName' Applied c
-pprParendType (PromotedTupleT 0)  = text "'()"
-pprParendType (PromotedTupleT 1)  = pprParendType (PromotedT (tupleDataName 1))
-pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
-pprParendType PromotedNilT        = text "'[]"
-pprParendType PromotedConsT       = text "'(:)"
-pprParendType StarT               = char '*'
-pprParendType ConstraintT         = text "Constraint"
-pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)
-pprParendType WildCardT           = char '_'
-pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)
-pprParendType t@(UInfixT {})      = parens (pprUInfixT t)
-pprParendType (ParensT t)         = ppr t
+pprParendType (ConT c)               = pprName' Applied c
+pprParendType (TupleT 0)             = text "()"
+pprParendType (TupleT 1)             = pprParendType (ConT (tupleTypeName 1))
+pprParendType (TupleT n)             = parens (hcat (replicate (n-1) comma))
+pprParendType (UnboxedTupleT n)      = hashParens $ hcat $ replicate (n-1) comma
+pprParendType (UnboxedSumT arity)    = hashParens $ hcat $ replicate (arity-1) bar
+pprParendType ArrowT                 = parens (text "->")
+pprParendType MulArrowT              = text "FUN"
+pprParendType ListT                  = text "[]"
+pprParendType (LitT l)               = pprTyLit l
+pprParendType (PromotedT c)          = text "'" <> pprName' Applied c
+pprParendType (PromotedTupleT 0)     = text "'()"
+pprParendType (PromotedTupleT 1)     = pprParendType (PromotedT (tupleDataName 1))
+pprParendType (PromotedTupleT n)     = quoteParens (hcat (replicate (n-1) comma))
+pprParendType PromotedNilT           = text "'[]"
+pprParendType PromotedConsT          = text "'(:)"
+pprParendType StarT                  = char '*'
+pprParendType ConstraintT            = text "Constraint"
+pprParendType (SigT ty k)            = parens (ppr ty <+> text "::" <+> ppr k)
+pprParendType WildCardT              = char '_'
+pprParendType t@(InfixT {})          = parens (pprInfixT t)
+pprParendType t@(UInfixT {})         = parens (pprInfixT t)
+pprParendType t@(PromotedInfixT {})  = parens (pprInfixT t)
+pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t)
+pprParendType (ParensT t)            = ppr t
 pprParendType tuple | (TupleT n, args) <- split tuple
                     , length args == n
                     = parens (commaSep args)
-pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t
-pprParendType EqualityT           = text "(~)"
-pprParendType t@(ForallT {})      = parens (ppr t)
-pprParendType t@(ForallVisT {})   = parens (ppr t)
-pprParendType t@(AppT {})         = parens (ppr t)
-pprParendType t@(AppKindT {})     = parens (ppr t)
-
-pprUInfixT :: Type -> Doc
-pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
-pprUInfixT t               = ppr t
+pprParendType (ImplicitParamT n t)   = text ('?':n) <+> text "::" <+> ppr t
+pprParendType EqualityT              = text "(~)"
+pprParendType t@(ForallT {})         = parens (ppr t)
+pprParendType t@(ForallVisT {})      = parens (ppr t)
+pprParendType t@(AppT {})            = parens (ppr t)
+pprParendType t@(AppKindT {})        = parens (ppr t)
+
+pprInfixT :: Type -> Doc
+pprInfixT = \case
+  (InfixT x n y)          -> with x n y ""  ppr
+  (UInfixT x n y)         -> with x n y ""  pprInfixT
+  (PromotedInfixT x n y)  -> with x n y "'" ppr
+  (PromotedUInfixT x n y) -> with x n y "'" pprInfixT
+  t                       -> ppr t
+  where
+    with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y
 
 instance Ppr Type where
     ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index e99a20c04b..6991d77227 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1986,9 +1986,10 @@ But how should we parse @a + b * c@? If we don't know the fixities of
 @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a
 + b) * c@.
 
-In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for
-\"unresolved infix expression/pattern/type\", respectively. When the compiler
-is given a splice containing a tree of @UInfixE@ applications such as
+In cases like this, use 'UInfixE', 'UInfixP', 'UInfixT', or 'PromotedUInfixT',
+which stand for \"unresolved infix expression/pattern/type/promoted
+constructor\", respectively. When the compiler is given a splice containing a
+tree of @UInfixE@ applications such as
 
 > UInfixE
 >   (UInfixE e1 op1 e2)
@@ -2003,7 +2004,8 @@ reassociate the tree as necessary.
 
     > (a + b * c) + d * e
 
-  * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated.
+  * 'InfixE', 'InfixP', 'InfixT', and 'PromotedInfixT' expressions are never
+    reassociated.
 
   * The 'UInfixE' constructor doesn't support sections. Sections
     such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer
@@ -2030,8 +2032,8 @@ reassociate the tree as necessary.
     > [p| a : b : c |] :: Q Pat
     > [t| T + T |] :: Q Type
 
-    will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE',
-    'ParensP', or 'ParensT' constructors.
+    will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'PromotedUInfixT',
+    'InfixT', 'PromotedInfixT, 'ParensE', 'ParensP', or 'ParensT' constructors.
 
 -}
 
@@ -2624,35 +2626,39 @@ data PatSynArgs
   deriving( Show, Eq, Ord, Data, Generic )
 
 data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@
-          | ForallVisT [TyVarBndr ()] Type  -- ^ @forall \<vars\> -> \<type\>@
-          | AppT Type Type                -- ^ @T a b@
-          | AppKindT Type Kind            -- ^ @T \@k t@
-          | SigT Type Kind                -- ^ @t :: k@
-          | VarT Name                     -- ^ @a@
-          | ConT Name                     -- ^ @T@
-          | PromotedT Name                -- ^ @'T@
-          | InfixT Type Name Type         -- ^ @T + T@
-          | UInfixT Type Name Type        -- ^ @T + T@
-                                          --
-                                          -- See "Language.Haskell.TH.Syntax#infix"
-          | ParensT Type                  -- ^ @(T)@
+          | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@
+          | AppT Type Type                 -- ^ @T a b@
+          | AppKindT Type Kind             -- ^ @T \@k t@
+          | SigT Type Kind                 -- ^ @t :: k@
+          | VarT Name                      -- ^ @a@
+          | ConT Name                      -- ^ @T@
+          | PromotedT Name                 -- ^ @'T@
+          | InfixT Type Name Type          -- ^ @T + T@
+          | UInfixT Type Name Type         -- ^ @T + T@
+                                           --
+                                           -- See "Language.Haskell.TH.Syntax#infix"
+          | PromotedInfixT Type Name Type  -- ^ @T :+: T@
+          | PromotedUInfixT Type Name Type -- ^ @T :+: T@
+                                           --
+                                           -- See "Language.Haskell.TH.Syntax#infix"
+          | ParensT Type                   -- ^ @(T)@
 
           -- See Note [Representing concrete syntax in types]
-          | TupleT Int                    -- ^ @(,), (,,), etc.@
-          | UnboxedTupleT Int             -- ^ @(\#,\#), (\#,,\#), etc.@
-          | UnboxedSumT SumArity          -- ^ @(\#|\#), (\#||\#), etc.@
-          | ArrowT                        -- ^ @->@
-          | MulArrowT                     -- ^ @FUN@
-          | EqualityT                     -- ^ @~@
-          | ListT                         -- ^ @[]@
-          | PromotedTupleT Int            -- ^ @'(), '(,), '(,,), etc.@
-          | PromotedNilT                  -- ^ @'[]@
-          | PromotedConsT                 -- ^ @(':)@
-          | StarT                         -- ^ @*@
-          | ConstraintT                   -- ^ @Constraint@
-          | LitT TyLit                    -- ^ @0,1,2, etc.@
-          | WildCardT                     -- ^ @_@
-          | ImplicitParamT String Type    -- ^ @?x :: t@
+          | TupleT Int                     -- ^ @(,), (,,), etc.@
+          | UnboxedTupleT Int              -- ^ @(\#,\#), (\#,,\#), etc.@
+          | UnboxedSumT SumArity           -- ^ @(\#|\#), (\#||\#), etc.@
+          | ArrowT                         -- ^ @->@
+          | MulArrowT                      -- ^ @FUN@
+          | EqualityT                      -- ^ @~@
+          | ListT                          -- ^ @[]@
+          | PromotedTupleT Int             -- ^ @'(), '(,), '(,,), etc.@
+          | PromotedNilT                   -- ^ @'[]@
+          | PromotedConsT                  -- ^ @(':)@
+          | StarT                          -- ^ @*@
+          | ConstraintT                    -- ^ @Constraint@
+          | LitT TyLit                     -- ^ @0,1,2, etc.@
+          | WildCardT                      -- ^ @_@
+          | ImplicitParamT String Type     -- ^ @?x :: t@
       deriving( Show, Eq, Ord, Data, Generic )
 
 data Specificity = SpecifiedSpec          -- ^ @a@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index f30c9df660..3965279f15 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -3,10 +3,17 @@
 ## 2.19.0.0
 
   * Add `DefaultD` constructor to support Haskell `default` declarations.
-  * Add support for Overloaded Record Dot. 
+
+  * Add support for Overloaded Record Dot.
     Introduces `getFieldE :: Quote m => m Exp -> String -> m Exp` and
     `projectionE :: Quote m => [String] -> m Exp`.
 
+  * Add `PromotedInfixT` and `PromotedUInfixT`, which are analogs to `InfixT`
+    and `UInfixT` that ensure that if a dynamically bound name (i.e. a name
+    with `NameFlavour` `NameS` or `NameQ`; the flavours produced by `mkName`)
+    is used as operator, it will be bound to a promoted data constructor rather
+    than a type constructor, if both are in scope.
+
 ## 2.18.0.0
   * The types of `ConP` and `conP` have been changed to allow for an additional list
     of type applications preceding the argument patterns.