[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsEmbTy, EmbTyPat
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Wed Dec 6 17:32:01 UTC 2023
Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
03b000f7 by Vladislav Zavialov at 2023-12-06T20:31:02+03:00
EPA: use EpToken in HsEmbTy, EmbTyPat
- - - - -
21 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Pmc/Desugar.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Pat.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -374,7 +374,7 @@ type instance XStatic GhcTc = (NameSet, Type)
-- Free variables and type of expression, this is stored for convenience as wiring in
-- StaticPtr is a bit tricky (see #20150)
-type instance XEmbTy GhcPs = NoExtField
+type instance XEmbTy GhcPs = EpToken "type"
type instance XEmbTy GhcRn = NoExtField
type instance XEmbTy GhcTc = DataConCantHappen
-- A free-standing HsEmbTy is an error.
@@ -720,7 +720,7 @@ ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
-ppr_expr (HsEmbTy _ _ ty)
+ppr_expr (HsEmbTy _ ty)
= hsep [text "type", ppr ty]
ppr_expr (XExpr x) = case ghcPass @p of
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -158,7 +158,7 @@ type instance XSigPat GhcPs = EpAnn [AddEpAnn]
type instance XSigPat GhcRn = NoExtField
type instance XSigPat GhcTc = Type
-type instance XEmbTyPat GhcPs = NoExtField
+type instance XEmbTyPat GhcPs = EpToken "type"
type instance XEmbTyPat GhcRn = NoExtField
type instance XEmbTyPat GhcTc = Type
@@ -390,7 +390,7 @@ pprPat (ConPat { pat_con = con
, cpt_dicts = dicts
, cpt_binds = binds
} = ext
-pprPat (EmbTyPat _ toktype tp) = ppr toktype <+> ppr tp
+pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp
pprPat (XPat ext) = case ghcPass @p of
GhcRn -> case ext of
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -63,7 +63,7 @@ hsPatType (ConPat { pat_con = lcon
hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
-hsPatType (EmbTyPat ty _ _) = typeKind ty
+hsPatType (EmbTyPat ty _) = typeKind ty
hsPatType (XPat ext) =
case ext of
CoPat _ _ ty -> ty
@@ -142,7 +142,7 @@ hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext
hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
-hsExprType (HsEmbTy x _ _) = dataConCantHappen x
+hsExprType (HsEmbTy x _) = dataConCantHappen x
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1248,7 +1248,7 @@ collect_pat flag pat bndrs = case pat of
CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig
XPat ext -> collectXXPat @p flag ext bndrs
SplicePat ext _ -> collectXSplicePat @p flag ext bndrs
- EmbTyPat _ _ tp -> case flag of
+ EmbTyPat _ tp -> case flag of
CollNoDictBinders -> bndrs
CollWithDictBinders -> bndrs
CollVarTyVarBinders -> collectTyPatBndrs tp ++ bndrs
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -415,7 +415,7 @@ dsExpr (ExplicitSum types alt arity expr)
dsExpr (HsPragE _ prag expr) =
ds_prag_expr prag expr
-dsExpr (HsEmbTy x _ _) = dataConCantHappen x
+dsExpr (HsEmbTy x _) = dataConCantHappen x
dsExpr (HsCase ctxt discrim matches)
= do { core_discrim <- dsLExpr discrim
=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -123,7 +123,7 @@ desugarPat x pat = case pat of
AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p
SigPat _ p _ty -> desugarLPat x p
- EmbTyPat _ _ _ -> pure []
+ EmbTyPat _ _ -> pure []
XPat ext -> case ext of
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1664,7 +1664,7 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
e1 <- repLE e
repGetField e1 f
repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
-repE (HsEmbTy _ _ t) = do
+repE (HsEmbTy _ t) = do
t1 <- repLTy (hswc_body t)
rep2 typeEName [unC t1]
repE (XExpr (HsExpanded orig_expr ds_expr))
@@ -2124,8 +2124,8 @@ repP p@(NPat _ (L _ l) (Just _) _)
repP (SigPat _ p t) = do { p' <- repLP p
; t' <- repLTy (hsPatSigType t)
; repPsig p' t' }
-repP (EmbTyPat _ _ t) = do { t' <- repLTy (hstp_body t)
- ; repPtype t' }
+repP (EmbTyPat _ t) = do { t' <- repLTy (hstp_body t)
+ ; repPtype t' }
repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n
repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p)
repP other = notHandled (ThExoticPattern other)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1028,7 +1028,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
sig
HieRn -> pure []
]
- EmbTyPat _ _ tp ->
+ EmbTyPat _ tp ->
[ toHie $ TS (ResolvedScopes [scope, pscope]) tp
]
XPat e ->
@@ -1264,7 +1264,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HsStatic _ expr ->
[ toHie expr
]
- HsEmbTy _ _ ty ->
+ HsEmbTy _ ty ->
[ toHie $ TS (ResolvedScopes []) ty
]
HsTypedBracket xbracket b -> case hiePass @p of
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2736,7 +2736,7 @@ exp :: { ECP }
-- Embed types into expressions and patterns for required type arguments
| 'type' atype
{% do { requireExplicitNamespaces (getLoc $1)
- ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (hsTok $1) $2 } }
+ ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (epTok $1) $2 } }
infixexp :: { ECP }
: exp10 { $1 }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1647,7 +1647,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
mkSumOrTuplePV
:: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)
-- | Disambiguate "type t" (embedded type)
- mkHsEmbTyPV :: SrcSpan -> LHsToken "type" GhcPs -> LHsType GhcPs -> PV (LocatedA b)
+ mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)
-- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
rejectPragmaPV :: LocatedA b -> PV ()
@@ -1865,7 +1865,7 @@ instance DisambECP (HsExpr GhcPs) where
mkSumOrTuplePV = mkSumOrTupleExpr
mkHsEmbTyPV l toktype ty =
return $ L (noAnnSrcSpan l) $
- HsEmbTy noExtField toktype (mkHsWildCardBndrs ty)
+ HsEmbTy toktype (mkHsWildCardBndrs ty)
rejectPragmaPV (L _ (OpApp _ _ _ e)) =
-- assuming left-associative parsing of operators
rejectPragmaPV e
@@ -1954,7 +1954,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkSumOrTuplePV = mkSumOrTuplePat
mkHsEmbTyPV l toktype ty =
return $ L (noAnnSrcSpan l) $
- PatBuilderPat (EmbTyPat noExtField toktype (mkHsTyPat noAnn ty))
+ PatBuilderPat (EmbTyPat toktype (mkHsTyPat noAnn ty))
rejectPragmaPV _ = return ()
-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -560,9 +560,9 @@ rnExpr (ArithSeq _ _ seq)
else
return (ArithSeq noExtField Nothing new_seq, fvs) }
-rnExpr (HsEmbTy _ toktype ty)
+rnExpr (HsEmbTy _ ty)
= do { (ty', fvs) <- rnHsWcType HsTypeCtx ty
- ; return (HsEmbTy noExtField toktype ty', fvs) }
+ ; return (HsEmbTy noExtField ty', fvs) }
{-
************************************************************************
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -635,9 +635,9 @@ rnPatAndThen mk (SplicePat _ splice)
(rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed
}
-rnPatAndThen _ (EmbTyPat _ toktype tp)
+rnPatAndThen _ (EmbTyPat _ tp)
= do { tp' <- rnHsTyPat HsTypePatCtx tp
- ; return (EmbTyPat noExtField toktype tp') }
+ ; return (EmbTyPat noExtField tp') }
--------------------
rnConPatAndThen :: NameMaker
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -750,8 +750,8 @@ looks_like_type_arg EValArg{ eva_arg = ValArg (L _ e) } =
-- type arguments without the `type` qualifier, so `f True` could
-- instantiate `forall (b :: Bool) -> t`.
case stripParensHsExpr e of
- HsEmbTy _ _ _ -> True
- _ -> False
+ HsEmbTy _ _ -> True
+ _ -> False
looks_like_type_arg _ = False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
@@ -817,7 +817,7 @@ tcVDQ conc_tvs (tvb, inner_ty) arg
expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)
expr_to_type earg =
case stripParensLHsExpr earg of
- L _ (HsEmbTy _ _ hs_ty) ->
+ L _ (HsEmbTy _ hs_ty) ->
-- The entire type argument is guarded with the `type` herald,
-- e.g. `vfun (type (Maybe Int))`. This special case supports
-- named wildcards. See Note [Wildcards in the T2T translation]
@@ -829,7 +829,7 @@ expr_to_type earg =
HsWC [] <$> go e
where
go :: LHsExpr GhcRn -> TcM (LHsType GhcRn)
- go (L _ (HsEmbTy _ _ t)) =
+ go (L _ (HsEmbTy _ t)) =
-- HsEmbTy means there is an explicit `type` herald, e.g. vfun :: forall a -> blah
-- and the call vfun (type Int)
-- or vfun (Int -> type Int)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -468,7 +468,7 @@ tcExpr (HsStatic fvs expr) res_ty
(L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))
}
-tcExpr (HsEmbTy _ _ _) _ = failWith TcRnIllegalTypeExpr
+tcExpr (HsEmbTy _ _) _ = failWith TcRnIllegalTypeExpr
{-
************************************************************************
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -389,13 +389,13 @@ tc_tt_pat (ExpFunPatTy pat_ty) penv pat thing_inside = tc_pat pat_ty penv pat th
tc_tt_pat (ExpForAllPatTy tv) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside
tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc)
-tc_forall_pat _ (EmbTyPat _ toktype tp, tv) thing_inside
+tc_forall_pat _ (EmbTyPat _ tp, tv) thing_inside
= do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat tp (varType tv)
; _ <- unifyType Nothing arg_ty (mkTyVarTy tv)
; result <- tcExtendNameTyVarEnv sig_wcs $
tcExtendNameTyVarEnv sig_ibs $
thing_inside
- ; return (EmbTyPat arg_ty toktype tp, result) }
+ ; return (EmbTyPat arg_ty tp, result) }
tc_forall_pat _ (pat, _) _ = failWith $ TcRnIllformedTypePattern pat
tc_pat :: Scaled ExpSigmaTypeFRR
@@ -737,7 +737,7 @@ AST is used for the subtraction operation.
SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
- EmbTyPat _ _ _ -> failWith TcRnIllegalTypePattern
+ EmbTyPat _ _ -> failWith TcRnIllegalTypePattern
XPat (HsPatExpanded lpat rpat) -> do
{ (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -1050,7 +1050,7 @@ tcPatToExpr args pat = go pat
| otherwise = return $ HsOverLit noAnn n
go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat
go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice"
- go1 (EmbTyPat _ toktype tp) = return $ HsEmbTy noExtField toktype (hstp_to_hswc tp)
+ go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp)
where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn
hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty })
= HsWC { hswc_ext = wcs, hswc_body = hs_ty }
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1059,7 +1059,7 @@ zonkExpr (HsStatic (fvs, ty) expr)
= do new_ty <- zonkTcTypeToTypeX ty
HsStatic (fvs, new_ty) <$> zonkLExpr expr
-zonkExpr (HsEmbTy x _ _) = dataConCantHappen x
+zonkExpr (HsEmbTy x _) = dataConCantHappen x
zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr)))
= runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn ->
@@ -1570,9 +1570,9 @@ zonk_pat (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
; n' <- zonkIdBndrX n
; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-zonk_pat (EmbTyPat ty toktype tp)
+zonk_pat (EmbTyPat ty tp)
= do { ty' <- noBinders $ zonkTcTypeToTypeX ty
- ; return (EmbTyPat ty' toktype tp) }
+ ; return (EmbTyPat ty' tp) }
zonk_pat (XPat ext) = case ext of
{ ExpansionPat orig pat->
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1165,7 +1165,7 @@ cvtl e = wrapLA (cvt e)
cvt (TypedBracketE e) = do { e' <- cvtl e
; return $ HsTypedBracket noAnn e' }
cvt (TypeE t) = do { t' <- cvtType t
- ; return $ HsEmbTy noExtField noHsTok (mkHsWildCardBndrs t') }
+ ; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') }
{- | #16895 Ensure an infix expression's operator is a variable/constructor.
Consider this example:
@@ -1483,7 +1483,7 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat noAnn e' p'}
cvtp (TypeP t) = do { t' <- cvtType t
- ; return $ EmbTyPat noExtField noHsTok (mkHsTyPat noAnn t') }
+ ; return $ EmbTyPat noAnn (mkHsTyPat noAnn t') }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
cvtPatFld (s,p)
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -25,7 +25,6 @@ import Language.Haskell.Syntax.Basic
import Language.Haskell.Syntax.Decls
import Language.Haskell.Syntax.Pat
import Language.Haskell.Syntax.Lit
-import Language.Haskell.Syntax.Concrete
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
import Language.Haskell.Syntax.Binds
@@ -578,7 +577,6 @@ data HsExpr p
-- Embed the syntax of types into expressions.
-- Used with RequiredTypeArguments, e.g. fn (type (Int -> Bool))
| HsEmbTy (XEmbTy p)
- !(LHsToken "type" p)
(LHsWcType (NoGhcTc p))
| XExpr !(XXExpr p)
=====================================
compiler/Language/Haskell/Syntax/Pat.hs
=====================================
@@ -36,7 +36,6 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntyp
-- friends:
import Language.Haskell.Syntax.Basic
import Language.Haskell.Syntax.Lit
-import Language.Haskell.Syntax.Concrete
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
@@ -219,7 +218,6 @@ data Pat p
-- Embed the syntax of types into patterns.
-- Used with RequiredTypeArguments, e.g. fn (type t) = rhs
| EmbTyPat (XEmbTyPat p)
- !(LHsToken "type" p)
(HsTyPat (NoGhcTc p))
-- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3210,6 +3210,12 @@ instance ExactPrint (HsExpr GhcPs) where
prag' <- markAnnotated prag
e' <- markAnnotated e
return (HsPragE a prag' e')
+
+ exact (HsEmbTy toktype t) = do
+ toktype' <- markEpToken toktype
+ t' <- markAnnotated t
+ return (HsEmbTy toktype' t')
+
exact x = error $ "exact HsExpr for:" ++ showAst x
-- ---------------------------------------------------------------------
@@ -4773,7 +4779,7 @@ instance ExactPrint (Pat GhcPs) where
getAnnotationEntry (NPat an _ _ _) = fromAnn an
getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an
getAnnotationEntry (SigPat an _ _) = fromAnn an
- getAnnotationEntry (EmbTyPat _ _ _) = NoEntryVal
+ getAnnotationEntry (EmbTyPat _ _) = NoEntryVal
setAnnotationAnchor a@(WildPat _) _ _ _s = a
setAnnotationAnchor a@(VarPat _ _) _ _ _s = a
@@ -4791,7 +4797,7 @@ instance ExactPrint (Pat GhcPs) where
setAnnotationAnchor (NPat an a b c) anc ts cs = (NPat (setAnchorEpa an anc ts cs) a b c)
setAnnotationAnchor (NPlusKPat an a b c d e) anc ts cs = (NPlusKPat (setAnchorEpa an anc ts cs) a b c d e)
setAnnotationAnchor (SigPat an a b) anc ts cs = (SigPat (setAnchorEpa an anc ts cs) a b)
- setAnnotationAnchor a@(EmbTyPat _ _ _) _ _ _s = a
+ setAnnotationAnchor a@(EmbTyPat _ _) _ _ _s = a
exact (WildPat w) = do
anchor' <- getAnchorU
@@ -4879,10 +4885,10 @@ instance ExactPrint (Pat GhcPs) where
sig' <- markAnnotated sig
return (SigPat an0 pat' sig')
- exact (EmbTyPat x toktype tp) = do
- toktype' <- markToken toktype
+ exact (EmbTyPat toktype tp) = do
+ toktype' <- markEpToken toktype
tp' <- markAnnotated tp
- return (EmbTyPat x toktype' tp')
+ return (EmbTyPat toktype' tp')
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03b000f7b0003da7acdee4f741e278bedfdbe7a4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03b000f7b0003da7acdee4f741e278bedfdbe7a4
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/20231206/19071ba6/attachment-0001.html>
More information about the ghc-commits
mailing list