Keep track of promotion ticks in HsOpTywip/no-c-stubswip/matt-merge-batch

This patch adds a PromotionFlag field to HsOpTy, which is used
in pretty-printing and when determining whether to emit warnings
with -fwarn-unticked-promoted-constructors.

This allows us to correctly report tick-related warnings for things
like:

  type A = Int : '[]
  type B = [Int, Bool]

Updates haddock submodule

Fixes #19984

7 files changed, 34 insertions, 22 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5bacc4fb30..dc4fa5d46b 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -590,7 +590,7 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
   where
     ascribeBool e = noLocA $ ExprWithTySig noAnn e
                            $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType
-                           $ nlHsTyVar boolTyCon_RDR
+                           $ nlHsTyVar NotPromoted boolTyCon_RDR
 
 nlConWildPat :: DataCon -> LPat GhcPs
 -- The pattern (K {})
@@ -2233,9 +2233,9 @@ genAuxBindSpecSig loc spec = case spec of
   DerivMaxTag _ _
     -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
   DerivDataDataType _ _ _
-    -> mk_sig (nlHsTyVar dataType_RDR)
+    -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
   DerivDataConstr _ _ _
-    -> mk_sig (nlHsTyVar constr_RDR)
+    -> mk_sig (nlHsTyVar NotPromoted constr_RDR)
   where
     mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
 
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index de8d893f80..cab71a1deb 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -50,6 +50,7 @@ import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType
 import GHC.Types.Error
 import GHC.Types.FieldLabel (flIsOverloaded)
+import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol)
 import GHC.Types.Hint.Ppr () -- Outputable GhcHint
 import GHC.Types.Basic
 import GHC.Types.Id
@@ -691,9 +692,17 @@ instance Diagnostic TcRnMessage where
     TcRnNotInScope err name imp_errs _
       -> mkSimpleDecorated $
            pprScopeError name err $$ vcat (map ppr imp_errs)
-    TcRnUntickedPromotedConstructor name
-      -> mkSimpleDecorated $
-         text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot
+    TcRnUntickedPromotedThing thing
+      -> mkSimpleDecorated $
+         text "Unticked promoted" <+> what
+           where
+             what :: SDoc
+             what = case thing of
+               UntickedExplicitList -> text "list" <> dot
+               UntickedConstructor fixity nm ->
+                 let con      = pprUntickedConstructor fixity nm
+                     bare_sym = isBareSymbol fixity nm
+                 in text "constructor:" <+> con <> if bare_sym then empty else dot
     TcRnIllegalBuiltinSyntax what rdr_name
       -> mkSimpleDecorated $
            hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name]
@@ -1032,7 +1041,7 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnNotInScope {}
       -> ErrorWithoutFlag
-    TcRnUntickedPromotedConstructor {}
+    TcRnUntickedPromotedThing {}
       -> WarningWithFlag Opt_WarnUntickedPromotedConstructors
     TcRnIllegalBuiltinSyntax {}
       -> ErrorWithoutFlag
@@ -1291,8 +1300,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnNotInScope err _ _ hints
       -> scopeErrorHints err ++ hints
-    TcRnUntickedPromotedConstructor name
-      -> [SuggestAddTick name]
+    TcRnUntickedPromotedThing thing
+      -> [SuggestAddTick thing]
     TcRnIllegalBuiltinSyntax {}
       -> noHints
     TcRnWarnDefaulting {}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 78be225cf9..9a9a64130f 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -73,6 +73,7 @@ import GHC.Tc.Types.Origin (CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol),
 import GHC.Tc.Types.Rank (Rank)
 import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
 import GHC.Types.Error
+import GHC.Types.Hint (UntickedPromotedThing(..))
 import GHC.Types.FieldLabel (FieldLabelString)
 import GHC.Types.ForeignCall (CLabelString)
 import GHC.Types.Name (Name, OccName, getSrcLoc)
@@ -1631,18 +1632,20 @@ data TcRnMessage where
                  -> [GhcHint]        -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor
                  -> TcRnMessage
 
-  {-| TcRnUntickedPromotedConstructor is a warning (controlled with -Wunticked-promoted-constructors)
+  {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)
       that is triggered by an unticked occurrence of a promoted data constructor.
 
-      Example:
+      Examples:
 
         data A = MkA
         type family F (a :: A) where { F MkA = Bool }
 
-      Test case: T9778.
+        type B = [ Int, Bool ]
+
+      Test cases: T9778, T19984.
   -}
-  TcRnUntickedPromotedConstructor :: Name
-                                  -> TcRnMessage
+  TcRnUntickedPromotedThing :: UntickedPromotedThing
+                            -> TcRnMessage
 
   {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears
       in an unexpected location, e.g. as a data constructor or in a fixity declaration.
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index de16c657fd..b3d6a69977 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1165,7 +1165,7 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
 tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind
   = tc_fun_type mode mult ty1 ty2 exp_kind
 
-tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
+tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind
   | op `hasKey` funTyConKey
   = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind
 
@@ -1508,7 +1508,7 @@ splitHsAppTys hs_ty
     is_app :: HsType GhcRn -> Bool
     is_app (HsAppKindTy {})        = True
     is_app (HsAppTy {})            = True
-    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)
+    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey)
       -- I'm not sure why this funTyConKey test is necessary
       -- Can it even happen?  Perhaps for   t1 `(->)` t2
       -- but then maybe it's ok to treat that like a normal
@@ -1524,8 +1524,8 @@ splitHsAppTys hs_ty
     go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)
     go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
     go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)
-    go (L _  (HsOpTy _ l op@(L sp _) r)) as
-      = ( L (na2la sp) (HsTyVar noAnn NotPromoted op)
+    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as
+      = ( L (na2la sp) (HsTyVar noAnn prom op)
         , HsValArg l : HsValArg r : as )
     go f as = (f, as)
 
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index ed1833c1e7..971a47bb99 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -301,7 +301,7 @@ no_anon_wc_ty lty = go lty
       HsListTy _ ty                  -> go ty
       HsTupleTy _ _ tys              -> gos tys
       HsSumTy _ tys                  -> gos tys
-      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2
+      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2
       HsParTy _ ty                   -> go ty
       HsIParamTy _ _ ty              -> go ty
       HsKindSig _ ty kind            -> go ty && go kind
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index d9bb0dba17..9a19461b13 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2516,8 +2516,8 @@ getGhciStepIO :: TcM (LHsExpr GhcRn)
 getGhciStepIO = do
     ghciTy <- getGHCiMonad
     a_tv <- newName (mkTyVarOccFS (fsLit "a"))
-    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
-        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+    let ghciM   = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)
+        ioM     = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)
 
         step_ty :: LHsSigType GhcRn
         step_ty = noLocA $ HsSig
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 36a58d760a..24802a65ea 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -924,7 +924,7 @@ tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
                   -- Check that the result kind of the TyCon applied to its args
                   -- is compatible with the explicit signature (or Type, if there
                   -- is none)
-                  ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats
+                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats
                   ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
 
                   ; traceTc "tcDataFamInstHeader" $