[Git][ghc/ghc][wip/T18462] Restrict XBangTy and XRectTy to GhcPs phase
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Fri Jan 10 16:47:17 UTC 2025
Sjoerd Visscher pushed to branch wip/T18462 at Glasgow Haskell Compiler / GHC
Commits:
9103745e by Sjoerd Visscher at 2025-01-10T17:46:55+01:00
Restrict XBangTy and XRectTy to GhcPs phase
- - - - -
25 changed files:
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/Language/Haskell/Syntax/Type.hs
- testsuite/tests/rename/should_fail/T22478b.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -530,6 +530,8 @@ deriving instance Data (HsType GhcPs)
deriving instance Data (HsType GhcRn)
deriving instance Data (HsType GhcTc)
+deriving instance Data (HsTypeGhcPsExt GhcPs)
+
-- deriving instance (DataIdLR p p) => Data (HsTyLit p)
deriving instance Data (HsTyLit GhcPs)
deriving instance Data (HsTyLit GhcRn)
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -32,6 +32,7 @@ module GHC.Hs.Type (
pprHsArrow,
HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,
+ HsTypeGhcPsExt(..),
HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,
HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),
HsBndrKind(..),
@@ -55,7 +56,6 @@ module GHC.Hs.Type (
LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..),
- getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
@@ -108,7 +108,6 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..)
import Language.Haskell.Syntax.Extension
import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)
, HsSrcBang(..), HsImplBang(..)
- , mkHsSrcBang
)
import GHC.Hs.Extension
import GHC.Parser.Annotation
@@ -136,25 +135,6 @@ import Data.Data (Data)
import qualified Data.Semigroup as S
import GHC.Data.Bag
-{-
-************************************************************************
-* *
-\subsection{Bang annotations}
-* *
-************************************************************************
--}
-
-getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)
-getBangType (L _ (HsBangTy _ _ lty)) = lty
-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
- addCLocA lty lds (HsDocTy x lty lds)
-getBangType lty = lty
-
-getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang
-getBangStrictness (L _ (HsBangTy (_, s) b _)) = HsSrcBang s b
-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy (_, s) b _)) _)) = HsSrcBang s b
-getBangStrictness _ = (mkHsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
-
{-
************************************************************************
* *
@@ -504,7 +484,9 @@ type instance XWildCardTy GhcPs = EpToken "_"
type instance XWildCardTy GhcRn = NoExtField
type instance XWildCardTy GhcTc = NoExtField
-type instance XXType (GhcPass _) = HsCoreTy
+type instance XXType GhcPs = HsTypeGhcPsExt GhcPs
+type instance XXType GhcRn = HsCoreTy
+type instance XXType GhcTc = DataConCantHappen
-- An escape hatch for tunnelling a Core 'Type' through 'HsType'.
-- For more details on how this works, see:
@@ -519,6 +501,15 @@ type instance XStrTy (GhcPass _) = SourceText
type instance XCharTy (GhcPass _) = SourceText
type instance XXTyLit (GhcPass _) = DataConCantHappen
+data HsTypeGhcPsExt pass
+ = HsCoreTy HsCoreTy
+
+ | HsBangTy (XBangTy pass) -- Contains the SourceText in GHC passes.
+ HsBang (LHsType pass) -- Bang-style type annotations
+
+ | HsRecTy (XRecTy pass)
+ [LConDeclField pass] -- Only in data type declarations
+
data EpLinearArrow
= EpPct1 !(EpToken "%1") !(TokRarrow)
| EpLolly !(EpToken "⊸")
@@ -1311,7 +1302,7 @@ hsPlainTypeField = mkConFieldSpec (HsLinearAnn noAnn)
mkConFieldSpec :: HsMultAnnOn on (LHsType GhcPs) GhcPs -> LHsType GhcPs -> HsConFieldSpec on GhcPs
mkConFieldSpec mult (L l (HsDocTy x ty lds)) = case mkConFieldSpec mult ty of
CFS ann unp str mult' t -> CFS ann unp str mult' (L l (HsDocTy x t lds))
-mkConFieldSpec mult (L _ (HsBangTy ann (HsBang unp str) t)) = CFS ann unp str mult t
+mkConFieldSpec mult (L _ (XHsType (HsBangTy ann (HsBang unp str) t))) = CFS ann unp str mult t
mkConFieldSpec mult t = CFS noAnn NoSrcUnpack NoSrcStrict mult t
instance Outputable (XRecGhc (IdGhcP p)) =>
@@ -1410,8 +1401,6 @@ 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)) = pprOccWithTick Prefix prom name
ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys)
@@ -1468,7 +1457,12 @@ ppr_mono_ty (HsParTy _ ty)
ppr_mono_ty (HsDocTy _ ty doc)
= pprWithDoc doc $ ppr_mono_lty ty
-ppr_mono_ty (XHsType t) = ppr t
+ppr_mono_ty (XHsType t) = case ghcPass @p of
+ GhcPs -> case t of
+ HsCoreTy ty -> ppr ty
+ HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty
+ HsRecTy _ flds -> pprConDeclFields flds
+ GhcRn -> ppr t
--------------------------
ppr_fun_ty :: (OutputableBndrId p)
@@ -1487,13 +1481,11 @@ quote_tuple NotPromoted doc = doc
--------------------------
-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses
-- under precedence @p at .
-hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool
+hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens p = go_hs_ty
where
go_hs_ty (HsForAllTy{}) = p >= funPrec
go_hs_ty (HsQualTy{}) = p >= funPrec
- go_hs_ty (HsBangTy{}) = p > topPrec
- go_hs_ty (HsRecTy{}) = False
go_hs_ty (HsTyVar{}) = False
go_hs_ty (HsFunTy{}) = p >= funPrec
-- Special-case unary boxed tuple applications so that they are
@@ -1524,7 +1516,12 @@ hsTypeNeedsParens p = go_hs_ty
go_hs_ty (HsOpTy{}) = p >= opPrec
go_hs_ty (HsParTy{}) = False
go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t
- go_hs_ty (XHsType ty) = go_core_ty ty
+ go_hs_ty (XHsType t) = case ghcPass @p of
+ GhcPs -> case t of
+ HsCoreTy ty -> go_core_ty ty
+ HsBangTy{} -> p > topPrec
+ HsRecTy{} -> False
+ GhcRn -> go_core_ty t
go_core_ty (TyVarTy{}) = False
go_core_ty (AppTy{}) = p >= appPrec
@@ -1556,8 +1553,6 @@ lhsTypeHasLeadingPromotionQuote ty
go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})
| (L _ (c:_)) <- ctxt = goL c
| otherwise = goL body
- go (HsBangTy{}) = False
- go (HsRecTy{}) = False
go (HsTyVar _ p _) = isPromoted p
go (HsFunTy _ _ arg _) = goL arg
go (HsListTy{}) = False
@@ -1581,7 +1576,7 @@ lhsTypeHasLeadingPromotionQuote ty
-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
-- returns @ty at .
-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType p lty@(L loc ty)
| hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)
| otherwise = lty
@@ -1590,8 +1585,7 @@ parenthesizeHsType p lty@(L loc ty)
-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@
-- with an 'HsParTy' to form a parenthesized @ctxt at . Otherwise, it simply
-- returns @ctxt@ unchanged.
-parenthesizeHsContext :: PprPrec
- -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
+parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
parenthesizeHsContext p lctxt@(L loc ctxt) =
case ctxt of
[c] -> L loc [parenthesizeHsType p c]
=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -444,7 +444,6 @@ con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)
con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
where
f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
- f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
f _ _ = Nothing
isValD :: HsDecl a -> Bool
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1943,12 +1943,6 @@ instance ToHie (LocatedA (HsType GhcRn)) where
[ toHie a
, toHie doc
]
- HsBangTy _ _ ty ->
- [ toHie ty
- ]
- HsRecTy _ fields ->
- [ toHie fields
- ]
HsExplicitListTy _ _ tys ->
[ toHie tys
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2324,7 +2324,7 @@ atype :: { LHsType GhcPs }
| PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcLazy $2)) }
| PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy (glR $1) SrcStrict $2)) }
- | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)
+ | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ XHsType $ HsRecTy (AnnList (listAsAnchorM $2) (ListBraces (epTok $1) (epTok $3)) [] noAnn []) $2)
; checkRecordSyntax decls }}
-- Constructor sigs only
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -805,7 +805,7 @@ mkGadtDecl loc names dcol ty = do
(args, res_ty, (ops, cps), csa) <-
case body_ty of
- L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do
+ L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do
arr <- case hsArr of
HsUnrestrictedArrow arr -> return arr
_ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $
@@ -1537,8 +1537,8 @@ instance Outputable (ArgPatBuilder GhcPs) where
ppr (ArgPatBuilderArgPat p) = ppr p
mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
-mkBangTy tok_loc strictness =
- HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness)
+mkBangTy tok_loc strictness lty =
+ XHsType (HsBangTy ((noAnn, noAnn, tok_loc), NoSourceText) (HsBang NoSrcUnpack strictness) lty)
-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.
data UnpackednessPragma =
@@ -1555,11 +1555,11 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do
-- such as ~T or !T, then add the pragma to the existing HsBangTy.
--
-- Otherwise, wrap the type in a new HsBangTy constructor.
- addUnpackedness (o,c) (L _ (HsBangTy ((_,_,tl), NoSourceText) bang t))
+ addUnpackedness (o,c) (L _ (XHsType (HsBangTy ((_,_,tl), NoSourceText) bang t)))
| HsBang NoSrcUnpack strictness <- bang
- = HsBangTy ((o,c,tl), prag) (HsBang unpk strictness) t
+ = XHsType (HsBangTy ((o,c,tl), prag) (HsBang unpk strictness) t)
addUnpackedness (o,c) t
- = HsBangTy ((o,c,noAnn), prag) (HsBang unpk NoSrcStrict) t
+ = XHsType (HsBangTy ((o,c,noAnn), prag) (HsBang unpk NoSrcStrict) t)
---------------------------------------------------------------------------
-- | Check for monad comprehensions
@@ -2333,7 +2333,7 @@ dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
- | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
+ | [L (EpAnn anc _ cs) (XHsType (HsRecTy an fields))] <- toList flds
= RecCon (L (EpAnn anc an cs) fields)
-- Normal prefix constructor, e.g. data T = MkT A B C
@@ -2369,7 +2369,7 @@ instance DisambTD DataConBuilder where
return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l = combineLocsA lhs rhs
- check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
+ check_no_ops (XHsType (HsBangTy _ _ t)) = check_no_ops (unLoc t)
check_no_ops (HsOpTy{}) =
addError $ mkPlainErrorMsgEnvelope (locA l) $
(PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -571,31 +571,6 @@ rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
; return (HsParTy noAnn ty', fvs) }
-rnHsTyKi env (HsBangTy x b ty)
- = do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsBangTy x b ty', fvs) }
-
-rnHsTyKi env ty@(HsRecTy _ flds)
- = do { let ctxt = rtke_ctxt env
- ; fls <- get_fields ctxt
- ; (flds', fvs) <- rnConDeclFields ctxt fls flds
- ; return (HsRecTy noExtField flds', fvs) }
- where
- get_fields ctxt@(ConDeclCtx names)
- = do res <- concatMapM (lookupConstructorFields . unLoc) names
- if equalLength res names
- -- Lookup can fail when the record syntax is incorrect, e.g.
- -- data D = D Int { fld :: Bool }. See T7943.
- then return res
- else err ctxt
- get_fields ctxt = err ctxt
-
- err ctxt =
- do { addErr $
- TcRnWithHsDocContext ctxt $
- TcRnIllegalRecordSyntax (Left ty)
- ; return [] }
-
rnHsTyKi env (HsFunTy u mult ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
@@ -666,7 +641,7 @@ rnHsTyKi env (HsDocTy x ty haddock_doc)
; return (HsDocTy x ty' haddock_doc', fvs) }
-- See Note [Renaming HsCoreTys]
-rnHsTyKi env (XHsType ty)
+rnHsTyKi env (XHsType (HsCoreTy ty))
= do mapM_ (check_in_scope . nameRdrName) fvs_list
return (XHsType ty, fvs)
where
@@ -681,6 +656,23 @@ rnHsTyKi env (XHsType ty)
TcRnWithHsDocContext (rtke_ctxt env) $
TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] []
+rnHsTyKi env ty@(XHsType (HsBangTy _ bang (L _ inner))) = do
+ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
+ -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
+ -- bangs are invalid, so fail. (#7210, #14761)
+ addErr $
+ TcRnWithHsDocContext (rtke_ctxt env) $
+ TcRnUnexpectedAnnotation ty bang
+ rnHsTyKi env inner
+
+rnHsTyKi env ty@(XHsType (HsRecTy {})) = do
+ -- Record types (which only show up temporarily in constructor
+ -- signatures) should have been removed by now
+ addErr $
+ TcRnWithHsDocContext (rtke_ctxt env) $
+ TcRnIllegalRecordSyntax ty
+ return (HsWildCardTy noExtField, emptyFVs) -- trick to avoid `failWithTc`
+
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
= do { checkDataKinds env ty
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
@@ -2066,10 +2058,6 @@ extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty (L _ ty) acc
= case ty of
HsTyVar _ _ ltv -> extract_tv ltv acc
- HsBangTy _ _ ty -> extract_lty ty acc
- HsRecTy _ flds -> foldr (extract_scaled_lty
- . cd_fld_spec . unLoc) acc
- flds
HsAppTy _ ty1 ty2 -> extract_lty ty1 $
extract_lty ty2 acc
HsAppKindTy _ ty k -> extract_lty ty $
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1383,21 +1383,6 @@ rn_ty_pat (HsSpliceTy _ splice) = do
| hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)
| otherwise = lhs_ty
-rn_ty_pat (HsBangTy an bang_src lty) = do
- ctxt <- askDocContext
- lty'@(L _ ty') <- rn_lty_pat lty
- liftRn $ addErr $
- TcRnWithHsDocContext ctxt $
- TcRnUnexpectedAnnotation ty' bang_src
- pure (HsBangTy an bang_src lty')
-
-rn_ty_pat ty at HsRecTy{} = do
- ctxt <- askDocContext
- liftRn $ addErr $
- TcRnWithHsDocContext ctxt $
- TcRnIllegalRecordSyntax (Left ty)
- pure (HsWildCardTy noExtField) -- trick to avoid `failWithTc`
-
rn_ty_pat ty@(XHsType{}) = do
ctxt <- askDocContext
liftRnFV $ rnHsType ctxt ty
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -2127,7 +2127,7 @@ nlHsAppType e s = noLocA (HsAppType noAnn e hs_ty)
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
-nlHsCoreTy = noLocA . XHsType
+nlHsCoreTy = noLocA . XHsType . HsCoreTy
mkCoerceClassMethEqn :: Class -- the class being derived
-> [TyVar] -- the tvs in the instance head (this includes
@@ -2244,10 +2244,10 @@ genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivTag2Con tycon _
-> mk_sig $ L (noAnnSrcSpan loc) $
- XHsType $ mkSpecForAllTys (tyConTyVars tycon) $
+ XHsType $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkVisFunTyMany` mkParentType tycon
DerivMaxTag _ _
- -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
+ -> mk_sig (L (noAnnSrcSpan loc) (XHsType (HsCoreTy intTy)))
DerivDataDataType _ _ _
-> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
DerivDataConstr _ _ _
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1005,9 +1005,9 @@ instance Diagnostic TcRnMessage where
HsBang _ _ -> "strictness"
in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
text err <+> text "annotation cannot appear nested inside a type"
- TcRnIllegalRecordSyntax either_ty_ty
+ TcRnIllegalRecordSyntax ty
-> mkSimpleDecorated $
- text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty
+ text "Record syntax is illegal here:" <+> ppr ty
TcRnInvalidVisibleKindArgument arg ty
-> mkSimpleDecorated $
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2261,7 +2261,7 @@ data TcRnMessage where
typecheck/should_fail/T7210
rename/should_fail/T22478b
-}
- TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsBang -> TcRnMessage
+ TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsBang -> TcRnMessage
{-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax.
@@ -2272,7 +2272,7 @@ data TcRnMessage where
rename/should_fail/T9077
rename/should_fail/T22478b
-}
- TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage
+ TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage
{-| TcRnInvalidVisibleKindArgument is an error for a kind application on a
target type that cannot accept it.
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1098,15 +1098,6 @@ tcHsType :: TcTyMode -> HsType GhcRn -> ExpKind -> TcM TcType
tcHsType mode (HsParTy _ ty) exp_kind = tcLHsType mode ty exp_kind
tcHsType mode (HsDocTy _ ty _) exp_kind = tcLHsType mode ty exp_kind
-tcHsType _ ty@(HsBangTy _ bang _) _
- -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
- -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
- -- bangs are invalid, so fail. (#7210, #14761)
- = failWith $ TcRnUnexpectedAnnotation ty bang
-tcHsType _ ty@(HsRecTy {}) _
- -- Record types (which only show up temporarily in constructor
- -- signatures) should have been removed by now
- = failWithTc $ TcRnIllegalRecordSyntax (Right ty)
-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.
-- Here we get rid of it and add the finalizers to the global environment
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -282,8 +282,6 @@ no_anon_wc_ty lty = go lty
HsIParamTy _ _ ty -> go ty
HsKindSig _ ty kind -> go ty && go kind
HsDocTy _ ty _ -> go ty
- HsBangTy _ _ ty -> go ty
- HsRecTy _ flds -> gos $ concatMap (hsConFieldSpecToHsTypes . cd_fld_spec . unLoc) flds
HsExplicitListTy _ _ tys -> gos tys
HsExplicitTupleTy _ _ tys -> gos tys
HsForAllTy { hst_tele = tele
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -1802,7 +1802,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
kcConArgTys :: NewOrData -> TcKind -> [HsConFieldSpec on GhcRn] -> TcM ()
kcConArgTys new_or_data res_kind arg_tys = do
{ let exp_kind = getArgExpKind new_or_data res_kind
- ; forM_ arg_tys (\(CFS _ _ _ mult ty) -> do _ <- tcCheckLHsTypeInContext (getBangType ty) exp_kind
+ ; forM_ arg_tys (\(CFS _ _ _ mult ty) -> do _ <- tcCheckLHsTypeInContext ty exp_kind
tcMult mult)
-- See Note [Implementation of UnliftedNewtypes], STEP 2
}
@@ -3927,7 +3927,7 @@ tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatype
-> HsConFieldSpec on GhcRn -> TcM (Scaled TcType, HsSrcBang)
tcConArg exp_kind (CFS (_, src) unp str w bty)
= do { traceTc "tcConArg 1" (ppr bty)
- ; arg_ty <- tcCheckLHsTypeInContext (getBangType bty) exp_kind
+ ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind
; w' <- tcDataConMult w
; traceTc "tcConArg 2" (ppr bty)
; return (Scaled w' arg_ty, HsSrcBang src (HsBang unp str)) }
=====================================
compiler/Language/Haskell/Syntax/Type.hs
=====================================
@@ -909,12 +909,6 @@ data HsType pass
| HsDocTy (XDocTy pass)
(LHsType pass) (LHsDoc pass) -- A documented type
- | HsBangTy (XBangTy pass) -- Contains the SourceText in GHC passes.
- HsBang (LHsType pass) -- Bang-style type annotations
-
- | HsRecTy (XRecTy pass)
- [LConDeclField pass] -- Only in data type declarations
-
| HsExplicitListTy -- A promoted explicit list
(XExplicitListTy pass)
PromotionFlag -- whether explicitly promoted, for pretty printer
=====================================
testsuite/tests/rename/should_fail/T22478b.stderr
=====================================
@@ -5,7 +5,7 @@ T22478b.hs:16:14: error: [GHC-10498]
• In an equation for ‘fOutOfOrder’
T22478b.hs:18:10: error: [GHC-18932]
- • Unexpected strictness annotation: Int
+ • Unexpected strictness annotation: !Int
strictness annotation cannot appear nested inside a type
• In a type argument in a pattern
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4041,22 +4041,6 @@ instance ExactPrint (HsType GhcPs) where
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
return (HsDocTy an ty' doc)
- exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do
- (o',c') <-
- case mt of
- NoSourceText -> return (o,c)
- SourceText src -> do
- debugM $ "HsBangTy: src=" ++ showAst src
- o' <- printStringAtAA o (unpackFS src)
- c' <- markEpToken c
- return (o',c')
- tk' <-
- case str of
- SrcLazy -> printStringAtAA tk "~"
- SrcStrict -> printStringAtAA tk "!"
- NoSrcStrict -> return tk
- ty' <- markAnnotated ty
- return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty')
exact (HsExplicitListTy (sq,o,c) prom tys) = do
sq' <- if (isPromoted prom)
then markEpToken sq
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -98,7 +98,6 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
- drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -597,7 +597,7 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
, decltt (ppLContextNoArrow lctxt unicode) <+> nl
)
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) =
+ do_args n leader (HsFunTy _ _w (L _ (XHsType (HsRecTy _ fields))) r) =
[ (decltt ldr, latex <+> nl)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let latex = ppSideBySideField subdocs unicode field
@@ -1320,7 +1320,6 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u =
HsLinearAnn _ -> lollipop u
HsUnannotated _ _ -> arrow u
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
-ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
@@ -1329,8 +1328,9 @@ ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+>
ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v
-ppr_mono_ty (HsRecTy{}) _ = text "{..}"
-ppr_mono_ty (XHsType{}) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType (HsBangTy _ b ty)) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty (XHsType HsRecTy{}) _ = text "{..}"
+ppr_mono_ty (XHsType HsCoreTy{}) _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -335,7 +335,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
| otherwise =
(leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
- do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) =
+ do_args n leader (HsFunTy _ _w (L _ (XHsType (HsRecTy _ fields))) r) =
[ (ldr <+> html, mdoc, subs)
| (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)
, let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field
@@ -1808,8 +1808,6 @@ ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts =
-- UnicodeSyntax alternatives
ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty (HsBangTy _ b ty) u q _ =
- ppBang b +++ ppLParendType u q HideEmptyContexts ty
ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
| isPromoted prom = promoQuote (ppDocName q Prefix True name)
| otherwise = ppDocName q Prefix True name
@@ -1835,11 +1833,13 @@ ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyConte
ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v
-ppr_mono_ty (HsRecTy{}) _ _ _ = toHtml "{..}"
+ppr_mono_ty (XHsType (HsBangTy _ b ty)) u q _ =
+ ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty (XHsType (HsRecTy{})) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty (XHsType{}) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType HsCoreTy{}) _ _ _ = error "ppr_mono_ty HsCoreTy"
ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
ppr_mono_ty (HsExplicitTupleTy _ IsPromoted tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -196,14 +196,14 @@ hsConFieldSpecToFunTy (hsConFieldSpecGeneralize -> cfs) tgt =
noLocA (HsFunTy noAnn (cfs_multiplicity cfs) (hsConFieldSpecToHsTypeNoMult cfs) tgt)
hsConFieldSpecToHsTypeNoMult
- :: (XRec pass (HsType pass) ~ GenLocated e (HsType pass), HasAnnotation e, NoAnn (XBangTy pass))
+ :: (XRec pass (HsType pass) ~ GenLocated e (HsType pass), HasAnnotation e, NoAnn (XBangTy pass), XXType pass ~ HsTypeGhcPsExt pass)
=> HsConFieldSpec on pass -> LHsType pass
hsConFieldSpecToHsTypeNoMult (CFS _ unp str _ t) = case t of
L l (HsDocTy x ty doc) -> L l (HsDocTy x (mkBang unp str ty) doc)
_ -> mkBang unp str t
where
mkBang NoSrcUnpack NoSrcStrict ty = ty
- mkBang u s ty = noLocA (HsBangTy noAnn (HsBang u s) ty)
+ mkBang u s ty = noLocA (XHsType (HsBangTy noAnn (HsBang u s) ty))
getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
-- The full type of a GADT data constructor We really only get this in
@@ -234,7 +234,7 @@ getGADTConType
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT _ flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
+ RecConGADT _ flds -> mkFunTy (noLocA (XHsType (HsRecTy noAnn (unLoc flds)))) res_ty
PrefixConGADT _ pos_args -> foldr hsConFieldSpecToFunTy res_ty pos_args
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
@@ -426,11 +426,9 @@ reparenTypePrec = go
where
-- Shorter name for 'reparenType'
go :: Precedence -> HsType a -> HsType a
- go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
- go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x p tys) = HsExplicitTupleTy x p (map reparenLType tys)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -962,12 +962,12 @@ extractPatternSyn nm t tvs cons =
let args =
case con of
ConDeclH98{con_args = con_args'} -> case con_args' of
- PrefixCon _ args' -> map hsConFieldSpecToHsTypeNoMult args'
- RecCon (L _ fields) -> hsConFieldSpecToHsTypeNoMult . cd_fld_spec . unLoc <$> fields
- InfixCon arg1 arg2 -> map hsConFieldSpecToHsTypeNoMult [arg1, arg2]
+ PrefixCon _ args' -> map cfs_type args'
+ RecCon (L _ fields) -> cfs_type . cd_fld_spec . unLoc <$> fields
+ InfixCon arg1 arg2 -> map cfs_type [arg1, arg2]
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
- PrefixConGADT _ args' -> map hsConFieldSpecToHsTypeNoMult args'
- RecConGADT _ (L _ fields) -> hsConFieldSpecToHsTypeNoMult . cd_fld_spec . unLoc <$> fields
+ PrefixConGADT _ args' -> map cfs_type args'
+ RecConGADT _ (L _ fields) -> cfs_type . cd_fld_spec . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -362,7 +362,6 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy{hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype'})
HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n
- HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype
HsStarTy _ isUni -> return (HsStarTy noAnn isUni)
HsAppTy _ a b -> do
a' <- renameLType a
@@ -403,8 +402,7 @@ renameType t = case t of
doc' <- renameLDocHsSyn doc
return (HsDocTy noAnn ty' doc')
HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x))
- HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a
- XHsType a -> pure (XHsType a)
+ XHsType a -> pure (XHsType (HsCoreTy a))
HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `'MkSolo x`, not `'(x)`
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs
=====================================
@@ -111,8 +111,6 @@ renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
-renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
-renameType t@(HsRecTy _ _) = pure t
renameType t@(XHsType _) = pure t
renameType (HsExplicitListTy x ip ltys) =
HsExplicitListTy x ip <$> renameLTypes ltys
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -866,7 +866,7 @@ type instance XExplicitListTy DocNameI = EpAnn NoEpAnns
type instance XExplicitTupleTy DocNameI = EpAnn NoEpAnns
type instance XTyLit DocNameI = EpAnn NoEpAnns
type instance XWildCardTy DocNameI = EpAnn NoEpAnns
-type instance XXType DocNameI = HsCoreTy
+type instance XXType DocNameI = HsTypeGhcPsExt DocNameI
type instance XNumTy DocNameI = NoExtField
type instance XStrTy DocNameI = NoExtField
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9103745e24a3b7534a996b78b6a2ebf938c4b06d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9103745e24a3b7534a996b78b6a2ebf938c4b06d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250110/08f036db/attachment-0001.html>
More information about the ghc-commits
mailing list