[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: New location for HsLet tokens
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Tue Dec 5 18:21:07 UTC 2023
Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
7007b26c by Alan Zimmerman at 2023-12-05T18:20:43+00:00
EPA: New location for HsLet tokens
First example rework of using a tuple in the extension field for GhcPs
for token locations, and keeping the EpAnn field in the surrounding
XRec.
Addresses #23447
- - - - -
20 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/perf/compiler/hard_hole_fits.hs
- testsuite/tests/perf/compiler/hard_hole_fits.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -75,6 +75,7 @@ import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
import Data.List.NonEmpty (NonEmpty)
+import Language.Haskell.Syntax.Concrete (LHsToken)
{- *********************************************************************
* *
@@ -289,7 +290,7 @@ type instance XMultiIf GhcPs = EpAnn [AddEpAnn]
type instance XMultiIf GhcRn = NoExtField
type instance XMultiIf GhcTc = Type
-type instance XLet GhcPs = EpAnnCO
+type instance XLet GhcPs = (LHsToken "let" GhcPs, LHsToken "in" GhcPs)
type instance XLet GhcRn = NoExtField
type instance XLet GhcTc = NoExtField
@@ -644,11 +645,11 @@ ppr_expr (HsMultiIf _ alts)
ppr_alt (L _ (XGRHS x)) = ppr x
-- special case: let ... in let ...
-ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _)))
+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))
= sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),
ppr_lexpr expr]
-ppr_expr (HsLet _ _ binds _ expr)
+ppr_expr (HsLet _ binds expr)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr expr)]
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -118,7 +118,7 @@ hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
hsExprType (HsIf _ _ t _) = lhsExprType t
hsExprType (HsMultiIf ty _) = ty
-hsExprType (HsLet _ _ _ _ body) = lhsExprType body
+hsExprType (HsLet _ _ body) = lhsExprType body
hsExprType (HsDo ty _ _) = ty
hsExprType (ExplicitList ty _) = mkListTy ty
hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -424,7 +424,7 @@ dsExpr (HsCase ctxt discrim matches)
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
-dsExpr (HsLet _ _ binds _ body) = do
+dsExpr (HsLet _ binds body) = do
body' <- dsLExpr body
dsLocalBinds binds body'
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1569,10 +1569,10 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
-repE (HsLet _ _ bs _ e) = do { (ss,ds) <- repBinds bs
- ; e2 <- addBinds ss (repLE e)
- ; z <- repLetE ds e2
- ; wrapGenSyms ss z }
+repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs
+ ; e2 <- addBinds ss (repLE e)
+ ; z <- repLetE ds e2
+ ; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
repE e@(HsDo _ ctxt (L _ sts))
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -528,11 +528,11 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x tkLet binds tkIn e) =
+addTickHsExpr (HsLet x binds e) =
bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
e' <- addTickLHsExprLetBody e
- return (HsLet x tkLet binds' tkIn e')
+ return (HsLet x binds' e')
addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo srcloc cxt (L l stmts')) }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -739,7 +739,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
HsPar _ _ e _ -> computeLType e
ExplicitTuple{} -> Nothing
HsIf _ _ t f -> computeLType t <|> computeLType f
- HsLet _ _ _ _ body -> computeLType body
+ HsLet _ _ body -> computeLType body
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
@@ -1217,7 +1217,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HsMultiIf _ grhss ->
[ toHie grhss
]
- HsLet _ _ binds _ expr ->
+ HsLet _ binds expr ->
[ toHie $ RS (mkScope expr) binds
, toHie expr
]
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -105,6 +105,7 @@ import GHC.Hs.DocString
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
+import Language.Haskell.Syntax.Concrete (HsToken(..))
{-
Note [exact print annotations]
@@ -1342,6 +1343,9 @@ instance NoAnn AnnPragma where
instance NoAnn AnnParen where
noAnn = AnnParen AnnParens noAnn noAnn
+instance NoAnn (GenLocated TokenLocation (HsToken s)) where
+ noAnn = L NoTokenLoc HsTok
+
-- ---------------------------------------------------------------------
instance (Outputable a) => Outputable (EpAnn a) where
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1792,7 +1792,7 @@ instance DisambECP (HsExpr GhcPs) where
return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)
mkHsLetPV l tkLet bs tkIn c = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c)
type InfixOp (HsExpr GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -425,10 +425,10 @@ rnExpr (HsCase _ expr matches)
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-rnExpr (HsLet _ tkLet binds tkIn expr)
+rnExpr (HsLet _ binds expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
{ (expr',fvExpr) <- rnLExpr expr
- ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }
+ ; return (HsLet noExtField binds' expr', fvExpr) }
rnExpr (HsDo _ do_or_lc (L l stmts))
= do { ((stmts1, _), fvs1) <-
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -347,10 +347,10 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty
************************************************************************
-}
-tcExpr (HsLet x tkLet binds tkIn expr) res_ty
+tcExpr (HsLet x binds expr) res_ty
= do { (binds', expr') <- tcLocalBinds binds $
tcMonoExpr expr res_ty
- ; return (HsLet x tkLet binds' tkIn expr') }
+ ; return (HsLet x binds' expr') }
tcExpr (HsCase x scrut matches) res_ty
= do { -- We used to typecheck the case alternatives first.
@@ -1303,7 +1303,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
-- STEP 2 (b): desugar to HsCase, as per note [Record Updates]
; let ds_expr :: HsExpr GhcRn
- ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
+ ds_expr = HsLet noExtField let_binds (L gen case_expr)
case_expr :: HsExpr GhcRn
case_expr = HsCase RecUpd record_expr
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -726,7 +726,7 @@ exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
exprCtOrigin (HsIf {}) = IfThenElseOrigin
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
-exprCtOrigin (HsLet _ _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
exprCtOrigin (HsDo {}) = DoOrigin
exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = RecordUpdOrigin
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1011,10 +1011,10 @@ zonkExpr (HsMultiIf ty alts)
do { expr' <- zonkLExpr expr
; return $ GRHS x guard' expr' }
-zonkExpr (HsLet x tkLet binds tkIn expr)
+zonkExpr (HsLet x binds expr)
= runZonkBndrT (zonkLocalBinds binds) $ \ new_binds ->
do { new_expr <- zonkLExpr expr
- ; return (HsLet x tkLet new_binds tkIn new_expr) }
+ ; return (HsLet x new_binds new_expr) }
zonkExpr (HsDo ty do_or_lc (L l stmts))
= do new_stmts <- don'tBind $ zonkStmts zonkLExpr stmts
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1079,7 +1079,7 @@ cvtl e = wrapLA (cvt e)
| otherwise = do { alts' <- mapM cvtpair alts
; return $ HsMultiIf noAnn alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds
- ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}
+ ; e' <- cvtl e; return $ HsLet noAnn ds' e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
; th_origin <- getOrigin
; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -429,9 +429,7 @@ data HsExpr p
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
| HsLet (XLet p)
- !(LHsToken "let" p)
(HsLocalBinds p)
- !(LHsToken "in" p)
(LHsExpr p)
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1951,15 +1951,15 @@
(EpaComments
[]))
(HsLet
- (EpAnn
- (EpaSpan { DumpSemis.hs:34:10-35 })
- (NoEpAnns)
- (EpaComments
- []))
- (L
- (TokenLoc
- (EpaSpan { DumpSemis.hs:34:10-12 }))
- (HsTok))
+ ((,)
+ (L
+ (TokenLoc
+ (EpaSpan { DumpSemis.hs:34:10-12 }))
+ (HsTok))
+ (L
+ (TokenLoc
+ (EpaSpan { DumpSemis.hs:34:32-33 }))
+ (HsTok)))
(HsValBinds
(EpAnn
(EpaSpan { DumpSemis.hs:34:13-31 })
@@ -2186,10 +2186,6 @@
(EmptyLocalBinds
(NoExtField)))))]))))]}
[]))
- (L
- (TokenLoc
- (EpaSpan { DumpSemis.hs:34:32-33 }))
- (HsTok))
(L
(EpAnn
(EpaSpan { DumpSemis.hs:34:35 })
=====================================
testsuite/tests/perf/compiler/hard_hole_fits.hs
=====================================
@@ -30,7 +30,7 @@ testMe (ExplicitSum xes n i gl) = _
testMe (HsCase xc gl mg) = _
testMe (HsIf xi m_se gl gl' ) = _
testMe (HsMultiIf xmi gls) = _
-testMe (HsLet xl tkLet gl tkIn gl') = _
+testMe (HsLet xl gl gl') = _
testMe (HsDo xd hsc gl) = _
testMe (ExplicitList xel m_se) = _
testMe (RecordCon xrc gl hrf) = _
=====================================
testsuite/tests/perf/compiler/hard_hole_fits.stderr
=====================================
@@ -383,17 +383,12 @@ hard_hole_fits.hs:32:30: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
(imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20
(and originally defined in ‘GHC.Enum’))
-hard_hole_fits.hs:33:39: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
+hard_hole_fits.hs:33:28: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)]
• Found hole: _ :: Int
- • In an equation for ‘testMe’:
- testMe (HsLet xl tkLet gl tkIn gl') = _
+ • In an equation for ‘testMe’: testMe (HsLet xl gl gl') = _
• Relevant bindings include
- gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:33:32)
- tkIn :: Language.Haskell.Syntax.Concrete.LHsToken "in" GhcPs
- (bound at hard_hole_fits.hs:33:27)
+ gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:33:21)
gl :: Language.Haskell.Syntax.Binds.HsLocalBinds GhcPs
- (bound at hard_hole_fits.hs:33:24)
- tkLet :: Language.Haskell.Syntax.Concrete.LHsToken "let" GhcPs
(bound at hard_hole_fits.hs:33:18)
xl :: Language.Haskell.Syntax.Extension.XLet GhcPs
(bound at hard_hole_fits.hs:33:15)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2861,7 +2861,7 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsCase an _ _) = fromAnn an
getAnnotationEntry (HsIf an _ _ _) = fromAnn an
getAnnotationEntry (HsMultiIf an _) = fromAnn an
- getAnnotationEntry (HsLet an _ _ _ _) = fromAnn an
+ getAnnotationEntry (HsLet _ _ _) = NoEntryVal
getAnnotationEntry (HsDo an _ _) = fromAnn an
getAnnotationEntry (ExplicitList an _) = fromAnn an
getAnnotationEntry (RecordCon an _ _) = fromAnn an
@@ -2899,7 +2899,7 @@ instance ExactPrint (HsExpr GhcPs) where
setAnnotationAnchor (HsCase an a b) anc ts cs = (HsCase (setAnchorEpa an anc ts cs) a b)
setAnnotationAnchor (HsIf an a b c) anc ts cs = (HsIf (setAnchorEpa an anc ts cs) a b c)
setAnnotationAnchor (HsMultiIf an a) anc ts cs = (HsMultiIf (setAnchorEpa an anc ts cs) a)
- setAnnotationAnchor (HsLet an a b c d) anc ts cs = (HsLet (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor a@(HsLet{}) _ _ _s = a
setAnnotationAnchor (HsDo an a b) anc ts cs = (HsDo (setAnchorEpa an anc ts cs) a b)
setAnnotationAnchor (ExplicitList an a) anc ts cs = (ExplicitList (setAnchorEpa an anc ts cs) a)
setAnnotationAnchor (RecordCon an a b) anc ts cs = (RecordCon (setAnchorEpa an anc ts cs) a b)
@@ -3055,7 +3055,7 @@ instance ExactPrint (HsExpr GhcPs) where
an2 <- markEpAnnL an1 lidl AnnCloseC -- optional
return (HsMultiIf an2 mg')
- exact (HsLet an tkLet binds tkIn e) = do
+ exact (HsLet (tkLet, tkIn) binds e) = do
setLayoutBoth $ do -- Make sure the 'in' gets indented too
tkLet' <- markToken tkLet
debugM $ "HSlet:binds coming"
@@ -3064,7 +3064,7 @@ instance ExactPrint (HsExpr GhcPs) where
tkIn' <- markToken tkIn
debugM $ "HSlet:expr coming"
e' <- markAnnotated e
- return (HsLet an tkLet' binds' tkIn' e')
+ return (HsLet (tkLet',tkIn') binds' e')
exact (HsDo an do_or_list_comp stmts) = do
debugM $ "HsDo"
=====================================
utils/check-exact/Main.hs
=====================================
@@ -444,7 +444,7 @@ changeLetIn1 _libdir parsed
= return (everywhere (mkT replace) parsed)
where
replace :: HsExpr GhcPs -> HsExpr GhcPs
- replace (HsLet an tkLet localDecls _ expr)
+ replace (HsLet (tkLet, _) localDecls expr)
=
let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls
[l2,_l1] = map wrapDecl $ bagToList bagDecls
@@ -453,8 +453,8 @@ changeLetIn1 _libdir parsed
a = EpAnn (EpaDelta (SameLine 1) []) noAnn emptyComments
expr' = L a e
tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok
- in (HsLet an tkLet
- (HsValBinds x (ValBinds xv bagDecls' sigs)) tkIn' expr')
+ in (HsLet (tkLet, tkIn')
+ (HsValBinds x (ValBinds xv bagDecls' sigs)) expr')
replace x = x
@@ -802,13 +802,13 @@ rmDecl5 _libdir lp = do
doRmDecl = do
let
go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)
- go (HsLet a tkLet lb tkIn expr) = do
+ go (HsLet (tkLet, tkIn) lb expr) = do
let decs = hsDeclsLocalBinds lb
let hdecs : _ = decs
let dec = last decs
_ <- transferEntryDP hdecs dec
lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
- return (HsLet a tkLet lb' tkIn expr)
+ return (HsLet (tkLet, tkIn) lb' expr)
go x = return x
everywhereM (mkM go) lp
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -875,10 +875,10 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (HsExpr GhcPs)) where
- hsDecls (L _ (HsLet _ _ decls _ _ex)) = return $ hsDeclsLocalBinds decls
- hsDecls _ = return []
+ hsDecls (L _ (HsLet _ decls _ex)) = return $ hsDeclsLocalBinds decls
+ hsDecls _ = return []
- replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls
+ replaceDecls (L ll (HsLet (tkLet, tkIn) binds ex)) newDecls
= do
logTr "replaceDecls HsLet"
let lastAnc = realSrcSpan $ spanHsLocaLBinds binds
@@ -901,7 +901,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
, newDecls'')
(_,_) -> (tkLet, tkIn, ex, newDecls)
binds' <- replaceDeclsValbinds WithoutWhere binds newDecls'
- return (L ll (HsLet x tkLet' binds' tkIn' ex'))
+ return (L ll (HsLet (tkLet', tkIn') binds' ex'))
-- TODO: does this make sense? Especially as no hsDecls for HsPar
replaceDecls (L l (HsPar x lpar e rpar)) newDecls
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7007b26c5c1b3b37eeb92a15a538383a197902ba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7007b26c5c1b3b37eeb92a15a538383a197902ba
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/20231205/c700604c/attachment-0001.html>
More information about the ghc-commits
mailing list