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

10 files changed, 192 insertions, 111 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"
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.
diff --git a/testsuite/tests/th/T20773.script b/testsuite/tests/th/T20773.script
new file mode 100644
index 0000000000..9b71d0926e
--- /dev/null
+++ b/testsuite/tests/th/T20773.script
@@ -0,0 +1,17 @@
+:seti -XDataKinds -XTemplateHaskell
+import Language.Haskell.TH
+import Data.Proxy
+
+data (:::) = forall k k' . k ::: k'; infixr 5 :::
+
+intT = ConT ''Int
+stringT = ConT ''String
+boolT = ConT ''Bool
+
+:t Proxy @($(pure $ UInfixT intT '(:::) stringT))
+
+promUInf x y = PromotedUInfixT x (mkName ":::") y
+:t Proxy @($(pure $ (intT `promUInf` stringT) `promUInf` boolT))
+
+promInf x y = PromotedInfixT x (mkName ":::") y
+:t Proxy @($(pure $ (intT `promInf` stringT) `promInf` boolT))
diff --git a/testsuite/tests/th/T20773.stdout b/testsuite/tests/th/T20773.stdout
new file mode 100644
index 0000000000..ea8c61726d
--- /dev/null
+++ b/testsuite/tests/th/T20773.stdout
@@ -0,0 +1,6 @@
+Proxy @($(pure $ UInfixT intT '(:::) stringT))
+  :: Proxy (Int '::: String)
+Proxy @($(pure $ (intT `promUInf` stringT) `promUInf` boolT))
+  :: Proxy (Int '::: (String '::: Bool))
+Proxy @($(pure $ (intT `promInf` stringT) `promInf` boolT))
+  :: Proxy ((Int '::: String) '::: Bool)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 439e88cd9a..cfd40a40df 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -538,3 +538,4 @@ test('T17820c', normal, compile_fail, [''])
 test('T17820d', normal, compile_fail, [''])
 test('T17820e', normal, compile_fail, [''])
 test('T20590', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T20773', only_ways(['ghci']), ghci_script, ['T20773.script'])