diff options
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 |