summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsheaf <sam.derbyshire@gmail.com>2022-04-01 12:02:46 +0200
committerMatthew Pickering <matthewtpickering@gmail.com>2022-04-01 11:17:56 +0100
commitd85c7dcb7c457efc23b20ac8f4e4ae88bae5b050 (patch)
tree6a052785be9dd3b67e42637102de21f0630f6ddf
parent950f58e7bf584ec6970327ac7c7ae3f3fdbc9882 (diff)
downloadhaskell-d85c7dcb7c457efc23b20ac8f4e4ae88bae5b050.tar.gz
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
-rw-r--r--compiler/GHC/Core/Ppr.hs15
-rw-r--r--compiler/GHC/Hs/Type.hs28
-rw-r--r--compiler/GHC/Hs/Utils.hs13
-rw-r--r--compiler/GHC/HsToCore/Quote.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs2
-rw-r--r--compiler/GHC/Parser.y23
-rw-r--r--compiler/GHC/Parser/PostProcess.hs14
-rw-r--r--compiler/GHC/Rename/Env.hs4
-rw-r--r--compiler/GHC/Rename/HsType.hs80
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs6
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs21
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs13
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs4
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs2
-rw-r--r--compiler/GHC/ThToHs.hs24
-rw-r--r--compiler/GHC/Types/Hint.hs40
-rw-r--r--compiler/GHC/Types/Hint/Ppr.hs19
-rw-r--r--compiler/Language/Haskell/Syntax/Type.hs2
-rw-r--r--docs/users_guide/9.4.1-notes.rst4
-rw-r--r--docs/users_guide/using-warnings.rst7
-rw-r--r--ghc/GHCi/UI.hs10
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr3
-rw-r--r--testsuite/tests/rename/should_compile/T19984.hs34
-rw-r--r--testsuite/tests/rename/should_compile/T19984.stderr20
-rw-r--r--testsuite/tests/rename/should_compile/T9778.hs8
-rw-r--r--testsuite/tests/rename/should_compile/T9778.stderr10
-rw-r--r--testsuite/tests/rename/should_compile/all.T1
-rw-r--r--utils/check-exact/ExactPrint.hs5
m---------utils/haddock0
32 files changed, 295 insertions, 132 deletions
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index 43579082a9..b319abec08 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -23,13 +23,15 @@ module GHC.Core.Ppr (
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
pprCoreBinder, pprCoreBinders,
- pprRule, pprRules, pprOptCo
+ pprRule, pprRules, pprOptCo,
+ pprOcc, pprOccWithTick
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Stats (exprStats)
+import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Literal( pprLiteral )
import GHC.Types.Name( pprInfixName, pprPrefixName )
import GHC.Types.Var
@@ -382,6 +384,17 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
pprPrefixOcc b = ppr b
bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
+pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc
+pprOcc Infix = pprInfixOcc
+pprOcc Prefix = pprPrefixOcc
+
+pprOccWithTick :: OutputableBndr a => LexicalFixity -> PromotionFlag -> a -> SDoc
+pprOccWithTick fixity prom op
+ | isPromoted prom
+ = quote (pprOcc fixity op)
+ | otherwise
+ = pprOcc fixity op
+
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
| isTyVar binder = pprKindedTyVarBndr binder
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 40dc281a74..208d7777f7 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -97,6 +97,7 @@ import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension
import GHC.Parser.Annotation
+import GHC.Types.Fixity ( LexicalFixity(..) )
import GHC.Types.Id ( Id )
import GHC.Types.SourceText
import GHC.Types.Name( Name, NamedThing(getName) )
@@ -104,6 +105,7 @@ import GHC.Types.Name.Reader ( RdrName )
import GHC.Types.Var ( VarBndr )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
+import GHC.Core.Ppr ( pprOccWithTick)
import GHC.Core.Type
import GHC.Hs.Doc
import GHC.Types.Basic
@@ -291,7 +293,7 @@ type instance XFunTy (GhcPass _) = EpAnnCO
type instance XListTy (GhcPass _) = EpAnn AnnParen
type instance XTupleTy (GhcPass _) = EpAnn AnnParen
type instance XSumTy (GhcPass _) = EpAnn AnnParen
-type instance XOpTy (GhcPass _) = NoExtField
+type instance XOpTy (GhcPass _) = EpAnn [AddEpAnn]
type instance XParTy (GhcPass _) = EpAnn AnnParen
type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn]
type instance XStarTy (GhcPass _) = NoExtField
@@ -448,9 +450,10 @@ mkAnonWildCardTy :: HsType GhcPs
mkAnonWildCardTy = HsWildCardTy noExtField
mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
- => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))
+ => PromotionFlag
+ -> LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))
-> LHsType (GhcPass p) -> HsType (GhcPass p)
-mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2
+mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2
mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy t1 t2
@@ -513,7 +516,7 @@ hsTyGetAppHead_maybe = go
go (L _ (HsTyVar _ _ ln)) = Just ln
go (L _ (HsAppTy _ l _)) = go l
go (L _ (HsAppKindTy _ t _)) = go t
- go (L _ (HsOpTy _ _ ln _)) = Just ln
+ go (L _ (HsOpTy _ _ _ ln _)) = Just ln
go (L _ (HsParTy _ t)) = go t
go (L _ (HsKindSig _ t _)) = go t
go _ = Nothing
@@ -1040,12 +1043,10 @@ ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })
ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })
= sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]
-ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
-ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
-ppr_mono_ty (HsTyVar _ prom (L _ name))
- | isPromoted prom = quote (pprPrefixOcc name)
- | otherwise = pprPrefixOcc name
-ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
+ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
+ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
+ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name
+ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `Solo x`, not `(x)`
@@ -1083,10 +1084,9 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty)
= hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]
ppr_mono_ty (HsAppKindTy _ ty k)
= ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k
-ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)
+ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)
= sep [ ppr_mono_lty ty1
- , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]
-
+ , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ]
ppr_mono_ty (HsParTy _ ty)
= parens (ppr_mono_lty ty)
-- Put the parens in where the user did
@@ -1187,7 +1187,7 @@ lhsTypeHasLeadingPromotionQuote ty
go (HsListTy{}) = False
go (HsTupleTy{}) = False
go (HsSumTy{}) = False
- go (HsOpTy _ t1 _ _) = goL t1
+ go (HsOpTy _ _ t1 _ _) = goL t1
go (HsKindSig _ t _) = goL t
go (HsIParamTy{}) = False
go (HsSpliceTy{}) = False
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 51306d627c..ef5ad6e494 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -603,24 +603,25 @@ nlList exprs = noLocA (ExplicitList noAnn exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IsSrcSpanAnn p a
- => IdP (GhcPass p) -> LHsType (GhcPass p)
+ => PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))
-nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x))
+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))
nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLocA (HsParTy noAnn t)
nlHsTyConApp :: IsSrcSpanAnn p a
- => LexicalFixity -> IdP (GhcPass p)
+ => PromotionFlag
+ -> LexicalFixity -> IdP (GhcPass p)
-> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
-nlHsTyConApp fixity tycon tys
+nlHsTyConApp prom fixity tycon tys
| Infix <- fixity
, HsValArg ty1 : HsValArg ty2 : rest <- tys
- = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest
+ = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest
| otherwise
- = foldl' mk_app (nlHsTyVar tycon) tys
+ = foldl' mk_app (nlHsTyVar prom tycon) tys
where
mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)
mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 22fc242e87..dfa634b399 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1394,7 +1394,7 @@ repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
tcon <- repUnboxedSumTyCon (length tys)
repTapps tcon tys1
-repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)
`nlHsAppTy` ty2)
repTy (HsParTy _ t) = repLTy t
repTy (HsStarTy _ _) = repTStar
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index db93777a7d..19f198e2c3 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1768,7 +1768,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where
HsSumTy _ tys ->
[ toHie tys
]
- HsOpTy _ a op b ->
+ HsOpTy _ _prom a op b ->
[ toHie a
, toHie $ C Use op
, toHie b
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index af6bb3d51a..55052f0df6 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2168,14 +2168,15 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
: ftype %shift { $1 }
| ftype tyop infixtype { $1 >>= \ $1 ->
$3 >>= \ $3 ->
- do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)
- ; mkHsOpTyPV $1 $2 $3 } }
+ do { let (op, prom) = $2
+ ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)
+ ; mkHsOpTyPV prom $1 op $3 } }
| unpackedness infixtype { $2 >>= \ $2 ->
mkUnpackednessPV $1 $2 }
ftype :: { forall b. DisambTD b => PV (LocatedA b) }
: atype { mkHsAppTyHeadPV $1 }
- | tyop { failOpFewArgs $1 }
+ | tyop { failOpFewArgs (fst $1) }
| ftype tyarg { $1 >>= \ $1 ->
mkHsAppTyPV $1 $2 }
| ftype PREFIX_AT atype { $1 >>= \ $1 ->
@@ -2185,13 +2186,15 @@ tyarg :: { LHsType GhcPs }
: atype { $1 }
| unpackedness atype {% addUnpackednessP $1 $2 }
-tyop :: { LocatedN RdrName }
- : qtyconop { $1 }
- | tyvarop { $1 }
- | SIMPLEQUOTE qconop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
- (NameAnnQuote (glAA $1) (gl $2) []) }
- | SIMPLEQUOTE varop {% amsrn (sLL $1 (reLoc $>) (unLoc $2))
- (NameAnnQuote (glAA $1) (gl $2) []) }
+tyop :: { (LocatedN RdrName, PromotionFlag) }
+ : qtyconop { ($1, NotPromoted) }
+ | tyvarop { ($1, NotPromoted) }
+ | SIMPLEQUOTE qconop {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glAA $1) (gl $2) [])
+ ; return (op, IsPromoted) } }
+ | SIMPLEQUOTE varop {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ (NameAnnQuote (glAA $1) (gl $2) [])
+ ; return (op, IsPromoted) } }
atype :: { LHsType GhcPs }
: ntgtycon {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) } -- Not including unit tuples
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0457618e86..568f5df5e6 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -984,7 +984,7 @@ checkTyClHdr is_cls ty
go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
| isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps)
- go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+ go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)
go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
where
@@ -1928,7 +1928,7 @@ class DisambTD b where
-- | Disambiguate @f \@t@ (visible kind application)
mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @f \# x@ (infix operator)
- mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
+ mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)
-- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)
mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)
@@ -1936,7 +1936,7 @@ instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki)
- mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)
+ mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
mkUnpackednessPV = addUnpackednessP
dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
@@ -1975,7 +1975,7 @@ instance DisambTD DataConBuilder where
addFatalError $ mkPlainErrorMsgEnvelope l_at $
(PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
- mkHsOpTyPV lhs tc rhs = do
+ mkHsOpTyPV _ lhs tc rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
data_con <- eitherToP $ tyConToDataCon tc
return $ L l (InfixDataConBuilder lhs data_con rhs)
@@ -3048,10 +3048,10 @@ mkSumOrTuplePat l Boxed a@Sum{} _ =
addFatalError $
mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a
-mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
-mkLHsOpTy x op y =
+mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
+mkLHsOpTy prom x op y =
let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
- in L loc (mkHsOpTy x op y)
+ in L loc (mkHsOpTy prom x op y)
mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 2440976b31..e5c1c17f3c 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1078,9 +1078,7 @@ lookup_demoted rdr_name
then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
Nothing -> unboundNameX looking_for rdr_name star_is_type_hints
- Just demoted_name ->
- do { addDiagnostic $ TcRnUntickedPromotedConstructor demoted_name
- ; return demoted_name } }
+ Just demoted_name -> return demoted_name }
else do { -- We need to check if a data constructor of this name is
-- in scope to give good error messages. However, we do
-- not want to give an additional error if the data
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index ae22cfa0cb..bbcd5244af 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -61,6 +61,7 @@ import GHC.Tc.Errors.Ppr ( pprScopeError
import GHC.Tc.Utils.Monad
import GHC.Types.Name.Reader
import GHC.Builtin.Names
+import GHC.Types.Hint ( UntickedPromotedThing(..) )
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
@@ -70,7 +71,7 @@ import GHC.Types.Error
import GHC.Utils.Misc
import GHC.Types.Fixity ( compareFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..) )
-import GHC.Types.Basic ( TypeOrKind(..) )
+import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
@@ -626,15 +627,21 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
-- Any type variable at the kind level is illegal without the use
-- of PolyKinds (see #14710)
; name <- rnTyVar env rdr_name
+ ; when (isDataConName name && not (isPromoted ip)) $
+ -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
+ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
; return (HsTyVar noAnn ip (L loc name), unitFV name) }
-rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
+rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
= setSrcSpan (getLocA l_op) $
do { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
+ ; let op_name = unLoc l_op'
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
- ; res_ty <- mkHsOpTyRn l_op' fix ty1' ty2'
+ ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'
+ ; when (isDataConName op_name && not (isPromoted prom)) $
+ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
rnHsTyKi env (HsParTy _ ty)
@@ -758,6 +765,8 @@ rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+ ; unless (isPromoted ip) $
+ addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
; return (HsExplicitListTy noExtField ip tys', fvs) }
rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
@@ -1314,33 +1323,34 @@ precedence and does not require rearrangement.
-}
---------------
--- Building (ty1 `op1` (ty21 `op2` ty22))
-mkHsOpTyRn :: LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
+-- Building (ty1 `op1` (ty2a `op2` ty2b))
+mkHsOpTyRn :: PromotionFlag
+ -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
-mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22))
+mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))
= do { fix2 <- lookupTyFixityRn op2
- ; mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 }
+ ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }
-mkHsOpTyRn op1 _ ty1 ty2 -- Default case, no rearrangment
- = return (HsOpTy noExtField ty1 op1 ty2)
+mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangment
+ = return (HsOpTy noAnn prom1 ty1 op1 ty2)
---------------
-mk_hs_op_ty :: LocatedN Name -> Fixity -> LHsType GhcRn
- -> LocatedN Name -> Fixity -> LHsType GhcRn
+mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
+ -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-> LHsType GhcRn -> SrcSpanAnnA
-> RnM (HsType GhcRn)
-mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2
+mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2
| nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1)
(NormalOp (unLoc op2),fix2)
- ; return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) }
- | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22)))
- | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
- new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21
- ; return (noLocA new_ty `op2ty` ty22) }
+ ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }
+ | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))
+ | otherwise = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)
+ new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a
+ ; return (noLocA new_ty `op2ty` ty2b) }
where
- lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs
- lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs
+ lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs
+ lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs
(nofix_error, associate_right) = compareFixity fix1 fix2
@@ -1352,17 +1362,17 @@ mkOpAppRn :: NegationHandling
-- be a NegApp)
-> RnM (HsExpr GhcRn)
--- (e11 `op1` e12) `op2` e2
-mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
+-- (e1a `op1` e1b) `op2` e2
+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (OpApp fix2 e1 op2 e2)
| associate_right = do
- new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2
- return (OpApp fix1 e11 op1 (L loc' new_e))
+ new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2
+ return (OpApp fix1 e1a op1 (L loc' new_e))
where
- loc'= combineLocsA e12 e2
+ loc'= combineLocsA e1b e2
(nofix_error, associate_right) = compareFixity fix1 fix2
---------------------------
@@ -1447,20 +1457,20 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
-> LHsCmdTop GhcRn -- Right operand (not an infix)
-> RnM (HsCmd GhcRn)
--- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc
+-- (e1a `op1` e1b) `op2` e2
+mkOpFormRn e1@(L loc
(HsCmdTop _
(L _ (HsCmdArrForm x op1 f (Just fix1)
- [a11,a12]))))
- op2 fix2 a2
+ [e1a,e1b]))))
+ op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
+ return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])
| associate_right
- = do new_c <- mkOpFormRn a12 op2 fix2 a2
+ = do new_c <- mkOpFormRn e1a op2 fix2 e2
return (HsCmdArrForm noExtField op1 f (Just fix1)
- [a11, L loc (HsCmdTop [] (L (l2l loc) new_c))])
+ [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])
-- TODO: locs are wrong
where
(nofix_error, associate_right) = compareFixity fix1 fix2
@@ -1474,7 +1484,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-> RnM (Pat GhcRn)
-mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2
+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2
= do { fix1 <- lookupFixityRn (unLoc op1)
; let (nofix_error, associate_right) = compareFixity fix1 fix2
@@ -1489,11 +1499,11 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2
}
else if associate_right then do
- { new_p <- mkConOpPatRn op2 fix2 p12 p2
+ { new_p <- mkConOpPatRn op2 fix2 p1b p2
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = op1
- , pat_args = InfixCon p11 (L loc new_p)
+ , pat_args = InfixCon p1a (L loc new_p)
}
}
-- XXX loc right?
@@ -1946,7 +1956,7 @@ extract_lty (L _ ty) acc
extract_lty ty2 $
extract_hs_arrow w acc
HsIParamTy _ _ ty -> extract_lty ty acc
- HsOpTy _ ty1 tv ty2 -> extract_tv tv $
+ HsOpTy _ _ ty1 tv ty2 -> extract_tv tv $
extract_lty ty1 $
extract_lty ty2 acc
HsParTy _ ty -> extract_lty ty acc
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" $
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index d1ab002532..7644109ae0 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1661,7 +1661,7 @@ cvtTypeKind ty_str ty
UInfixT t1 s t2
-> do { s' <- tconNameN s
; t2' <- cvtType t2
- ; t <- cvtOpAppT t1 s' t2'
+ ; t <- cvtOpAppT NotPromoted t1 s' t2'
; mk_apps (unLoc t) tys'
} -- Note [Converting UInfix]
@@ -1677,7 +1677,7 @@ cvtTypeKind ty_str ty
PromotedUInfixT t1 s t2
-> do { s' <- cNameN s
; t2' <- cvtType t2
- ; t <- cvtOpAppT t1 s' t2'
+ ; t <- cvtOpAppT IsPromoted t1 s' t2'
; mk_apps (unLoc t) tys'
} -- Note [Converting UInfix]
@@ -1725,7 +1725,7 @@ cvtTypeKind ty_str ty
let px = parenthesizeHsType opPrec x'
py = parenthesizeHsType opPrec y'
in do { eq_tc <- returnLA eqTyCon_RDR
- ; returnLA (HsOpTy noExtField px eq_tc py) }
+ ; returnLA (HsOpTy noAnn NotPromoted px eq_tc py) }
-- The long-term goal is to remove the above case entirely and
-- subsume it under the case for InfixT. See #15815, comment:6,
-- for more details.
@@ -1835,18 +1835,18 @@ provided @y@ is.
See the @cvtOpApp@ documentation for how this function works.
-}
-cvtOpAppT :: TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
-cvtOpAppT (UInfixT x op2 y) op1 z
+cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT prom (UInfixT x op2 y) op1 z
= do { op2' <- tconNameN op2
- ; l <- cvtOpAppT y op1 z
- ; cvtOpAppT x op2' l }
-cvtOpAppT (PromotedUInfixT x op2 y) op1 z
+ ; l <- cvtOpAppT prom y op1 z
+ ; cvtOpAppT NotPromoted x op2' l }
+cvtOpAppT prom (PromotedUInfixT x op2 y) op1 z
= do { op2' <- cNameN op2
- ; l <- cvtOpAppT y op1 z
- ; cvtOpAppT x op2' l }
-cvtOpAppT x op y
+ ; l <- cvtOpAppT prom y op1 z
+ ; cvtOpAppT IsPromoted x op2' l }
+cvtOpAppT prom x op y
= do { x' <- cvtType x
- ; returnLA (mkHsOpTy x' op y) }
+ ; returnLA (mkHsOpTy prom x' op y) }
cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
cvtKind = cvtTypeKind "kind"
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 6304b1d7fd..a3b40dbf2f 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -9,6 +9,8 @@ module GHC.Types.Hint (
, HowInScope(..)
, SimilarName(..)
, StarIsType(..)
+ , UntickedPromotedThing(..)
+ , pprUntickedConstructor, isBareSymbol
, suggestExtension
, suggestExtensionWithInfo
, suggestExtensions
@@ -29,7 +31,8 @@ import Data.Typeable
import GHC.Unit.Module (ModuleName, Module)
import GHC.Hs.Extension (GhcTc)
import GHC.Core.Coercion
-import GHC.Types.Name (Name, NameSpace, OccName (occNameFS))
+import GHC.Types.Fixity (LexicalFixity(..))
+import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.Basic (Activation, RuleName)
@@ -342,12 +345,12 @@ data GhcHint
-}
| SuggestDumpSlices
- {-| Suggests adding a tick to refer to a data constructor
- at the type level.
+ {-| Suggests adding a tick to refer to something which has been
+ promoted to the type level, e.g. a data constructor.
- Test case: T9778.
+ Test cases: T9778, T19984.
-}
- | SuggestAddTick Name
+ | SuggestAddTick UntickedPromotedThing
{-| Something is split off from its corresponding declaration.
For example, a datatype is given a role declaration
@@ -422,6 +425,33 @@ data SimilarName
= SimilarName Name
| SimilarRdrName RdrName HowInScope
+-- | Something is promoted to the type-level without a promotion tick.
+data UntickedPromotedThing
+ = UntickedConstructor LexicalFixity Name
+ | UntickedExplicitList
+
+pprUntickedConstructor :: LexicalFixity -> Name -> SDoc
+pprUntickedConstructor fixity nm =
+ case fixity of
+ Prefix -> pprPrefixVar is_op ppr_nm -- e.g. (:) and '(:)
+ Infix -> pprInfixVar is_op ppr_nm -- e.g. `Con` and '`Con`
+ where
+ ppr_nm = ppr nm
+ is_op = isSymOcc (nameOccName nm)
+
+-- | Whether a constructor name is printed out as a bare symbol, e.g. @:@.
+--
+-- True for symbolic names in infix position.
+--
+-- Used for pretty-printing.
+isBareSymbol :: LexicalFixity -> Name -> Bool
+isBareSymbol fixity nm
+ | isSymOcc (nameOccName nm)
+ , Infix <- fixity
+ = True
+ | otherwise
+ = False
+
--------------------------------------------------------------------------------
-- | Whether '*' is a synonym for 'Data.Kind.Type'.
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 5ed31571b0..ee1060f0ff 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -152,11 +152,24 @@ instance Outputable GhcHint where
-> vcat [ text "If you bound a unique Template Haskell name (NameU)"
, text "perhaps via newName,"
, text "then -ddump-splices might be useful." ]
- SuggestAddTick name
+ SuggestAddTick (UntickedConstructor fixity name)
-> hsep [ text "Use"
- , quotes (char '\'' <> ppr name)
+ , char '\'' <> con
, text "instead of"
- , quotes (ppr name) <> dot ]
+ , con <> mb_dot ]
+ where
+ con = pprUntickedConstructor fixity name
+ mb_dot
+ | isBareSymbol fixity name
+ -- A final dot can be confusing for a symbol without parens, e.g.
+ --
+ -- * Use ': instead of :.
+ = empty
+ | otherwise
+ = dot
+
+ SuggestAddTick UntickedExplicitList
+ -> text "Add a promotion tick, e.g." <+> text "'[x,y,z]" <> dot
SuggestMoveToDeclarationSite what rdr_name
-> text "Move the" <+> what <+> text "to the declaration site of"
<+> quotes (ppr rdr_name) <> dot
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index e7c35f93c1..0c84e9faa6 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -791,6 +791,8 @@ data HsType pass
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
| HsOpTy (XOpTy pass)
+ PromotionFlag -- Whether explicitly promoted,
+ -- for the pretty printer
(LHsType pass) (LIdP pass) (LHsType pass)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index a77b6b451b..2576a21cea 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -383,3 +383,7 @@ Compiler
- GHC no longer carries ``Derived`` constraints. Accordingly, several functions
in the plugin architecture that previously passed or received three sets of
constraints (givens, deriveds, and wanteds) now work with two such sets.
+
+- A new argument has been added to the ``HsOpTy`` constructor of the ``HsType``
+ datatype, to track the presence of a promotion tick. Plugins which manipulate
+ the Haskell AST will need to take this change into account.
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 9eaf63ed80..13c04f7d98 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -1652,6 +1652,13 @@ of ``-W(no-)*``.
Will raise two warnings because ``Zero`` and ``Succ`` are not
written as ``'Zero`` and ``'Succ``.
+ This also applies to list literals since 9.4. For example: ::
+
+ type L = [Int, Char, Bool]
+
+ will raise a warning, because ``[Int, Char, Bool]`` is a promoted list
+ which lacks a tick.
+
.. ghc-flag:: -Wunused-binds
:shortdesc: warn about bindings that are unused. Alias for
:ghc-flag:`-Wunused-top-binds`, :ghc-flag:`-Wunused-local-binds` and
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 68519f5ce7..fa04121821 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1783,9 +1783,9 @@ defineMacro overwrite s = do
expr <- GHC.parseExpr definition
-- > ghciStepIO . definition :: String -> IO String
let stringTy :: LHsType GhcPs
- stringTy = nlHsTyVar stringTyCon_RDR
+ stringTy = nlHsTyVar NotPromoted stringTyCon_RDR
ioM :: LHsType GhcPs -- AZ
- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+ ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
`mkHsApp` (nlHsPar expr)
tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
@@ -1853,9 +1853,9 @@ cmdCmd str = handleSourceError printErrAndMaybeExit $ do
getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)
getGhciStepIO = do
ghciTyConName <- GHC.getGHCiMonad
- let stringTy = nlHsTyVar stringTyCon_RDR
- ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
- ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+ let stringTy = nlHsTyVar NotPromoted stringTyCon_RDR
+ ghciM = nlHsTyVar NotPromoted (getRdrName ghciTyConName) `nlHsAppTy` stringTy
+ ioM = nlHsTyVar NotPromoted (getRdrName ioTyConName) `nlHsAppTy` stringTy
body = nlHsVar (getRdrName ghciStepIoMName)
tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $
nlHsFunTy ghciM ioM
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 60230b3b63..38e55e1021 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -227,7 +227,8 @@
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:11:11-16 })
(HsOpTy
- (NoExtField)
+ (EpAnnNotUsed)
+ (NotPromoted)
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:11:11 })
(HsTyVar
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 77061c1f84..cfaa1b102e 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -206,7 +206,8 @@
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:13:11-16 })
(HsOpTy
- (NoExtField)
+ (EpAnnNotUsed)
+ (NotPromoted)
(L
(SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:13:11 })
(HsTyVar
diff --git a/testsuite/tests/rename/should_compile/T19984.hs b/testsuite/tests/rename/should_compile/T19984.hs
new file mode 100644
index 0000000000..355fcdda64
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T19984.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T19984 where
+
+data D a = (:-) a a
+
+-- promoted datacons missing promotion tick
+-- (should give warnings with -fwarn-unticked-promoted-constructors)
+type A1 = Int : '[]
+type B1 = [Int, Bool]
+type C1 = (:) Int '[]
+type E1 = Int :- Bool
+type F1 = (:-) Int Bool
+
+-- promoted datacons with promotion ticks
+-- (no warnings)
+type A2 = Int ': '[]
+type B2 = '[Int, Bool]
+type C2 = '(:) Int '[]
+type E2 = Int ':- Bool
+type F2 = '(:-) Int Bool
+
+-- non-promoted datacons
+-- (no warnings)
+data G = GA | GB
+a3, b3, c3 :: [G]
+a3 = GA : []
+b3 = [GA, GB]
+c3 = (:) GA []
+
+e3, f3 :: D G
+e3 = GA :- GB
+f3 = (:-) GA GB
diff --git a/testsuite/tests/rename/should_compile/T19984.stderr b/testsuite/tests/rename/should_compile/T19984.stderr
new file mode 100644
index 0000000000..1f814797be
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T19984.stderr
@@ -0,0 +1,20 @@
+
+T19984.hs:10:15: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: :
+ Suggested fix: Use ': instead of :
+
+T19984.hs:11:11: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted list.
+ Suggested fix: Add a promotion tick, e.g. '[x,y,z].
+
+T19984.hs:12:11: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: (:).
+ Suggested fix: Use '(:) instead of (:).
+
+T19984.hs:13:15: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: :-
+ Suggested fix: Use ':- instead of :-
+
+T19984.hs:14:11: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: (:-).
+ Suggested fix: Use '(:-) instead of (:-).
diff --git a/testsuite/tests/rename/should_compile/T9778.hs b/testsuite/tests/rename/should_compile/T9778.hs
index 5b32f6763f..1ced4fbab5 100644
--- a/testsuite/tests/rename/should_compile/T9778.hs
+++ b/testsuite/tests/rename/should_compile/T9778.hs
@@ -1,8 +1,16 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+
module T9778 where
+import Data.Kind
+
data T = A | B
data G a where
C :: G A
+
+data D = MkD Type Type
+
+type S = Int `MkD` Bool
diff --git a/testsuite/tests/rename/should_compile/T9778.stderr b/testsuite/tests/rename/should_compile/T9778.stderr
index 99b93c104c..24a9c3c958 100644
--- a/testsuite/tests/rename/should_compile/T9778.stderr
+++ b/testsuite/tests/rename/should_compile/T9778.stderr
@@ -1,4 +1,8 @@
-T9778.hs:8:10: warning: [-Wunticked-promoted-constructors]
- Unticked promoted constructor: ‘A’.
- Suggested fix: Use ‘'A’ instead of ‘A’.
+T9778.hs:12:10: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: A.
+ Suggested fix: Use 'A instead of A.
+
+T9778.hs:16:14: warning: [-Wunticked-promoted-constructors]
+ Unticked promoted constructor: `MkD`.
+ Suggested fix: Use '`MkD` instead of `MkD`.
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 563eb3604f..e81bc0e4c8 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -187,3 +187,4 @@ test('T20609c', normal, compile, [''])
test('T20609d', normal, compile, [''])
test('T18862', normal, compile, [''])
test('unused_haddock', normal, compile, ['-haddock -Wall'])
+test('T19984', normal, compile, ['-fwarn-unticked-promoted-constructors'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 67aa1f280d..3d493cfd22 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -2876,7 +2876,7 @@ instance ExactPrint (HsType GhcPs) where
getAnnotationEntry (HsListTy an _) = fromAnn an
getAnnotationEntry (HsTupleTy an _ _) = fromAnn an
getAnnotationEntry (HsSumTy an _) = fromAnn an
- getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal
+ getAnnotationEntry (HsOpTy an _ _ _ _) = fromAnn an
getAnnotationEntry (HsParTy an _) = fromAnn an
getAnnotationEntry (HsIParamTy an _ _) = fromAnn an
getAnnotationEntry (HsStarTy _ _) = NoEntryVal
@@ -2926,7 +2926,8 @@ instance ExactPrint (HsType GhcPs) where
markOpeningParen an
markAnnotated tys
markClosingParen an
- exact (HsOpTy _an t1 lo t2) = do
+ exact (HsOpTy an promoted t1 lo t2) = do
+ when (isPromoted promoted) $ markEpAnn an AnnSimpleQuote
markAnnotated t1
markAnnotated lo
markAnnotated t2
diff --git a/utils/haddock b/utils/haddock
-Subproject 559e41505e81d93939e9afa6aa9793b0a428924
+Subproject 58237d76c96325f25627bfd7cdad5b93364d29a