[Git][ghc/ghc][wip/expand-do] adjusting the generated spans for proper error messages
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue Jun 6 16:27:47 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
39ac8d8f by Apoorv Ingle at 2023-06-06T11:27:36-05:00
adjusting the generated spans for proper error messages
- - - - -
5 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.Hs.Utils(
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
- mkHsDictLet, mkHsLams, mkHsLamDoExp,
+ mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
mkHsCmdIf, mkConLikeTc,
@@ -275,16 +275,6 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
(noLocA [mkSimpleMatch LambdaExpr pats' body])
pats' = map (parenthesizePat appPrec) pats
-mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
- => [LPat (GhcPass p)]
- -> LHsExpr (GhcPass p)
- -> LHsExpr (GhcPass p)
-mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
- where
- matches = mkMatchGroup (Generated DoExpansion)
- (noLocA [mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
- pats' = map (parenthesizePat appPrec) pats
-
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
<.> mkWpEvLams dicts) expr
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -328,6 +328,8 @@ tcApp rn_expr exp_res_ty
vcat [ text "rn_fun:" <+> ppr rn_fun
, text "rn_args:" <+> ppr rn_args
, text "fun_ctxt:" <+> ppr fun_ctxt <+> ppr (appCtxtLoc fun_ctxt)
+ <+> ppr (isGeneratedSrcSpan (appCtxtLoc fun_ctxt))
+ <+> ppr (insideExpansion fun_ctxt)
]
; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
@@ -349,7 +351,7 @@ tcApp rn_expr exp_res_ty
-- the source program; it was added by the renamer. See
-- Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
; let perhaps_add_res_ty_ctxt thing_inside
- | insideExpansion fun_ctxt
+ | insideExpansion fun_ctxt || isGeneratedSrcSpan (appCtxtLoc fun_ctxt)
= thing_inside
| otherwise
= addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -222,8 +222,6 @@ tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
}
-
-
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
-- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -250,8 +250,8 @@ insideExpansion (VAExpansion {}) = True
insideExpansion (VACall {}) = False
instance Outputable AppCtxt where
- ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
- ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
+ ppr (VAExpansion e l) = text "VAExpansion" <+> ppr e <+> ppr l
+ ppr (VACall f n l) = text "VACall" <+> int n <+> ppr f <+> ppr l
type family XPass p where
XPass 'TcpRn = 'Renamed
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -78,7 +78,7 @@ import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.SrcLoc
-import GHC.Types.Basic (Origin (..), GenReason (..))
+import GHC.Types.Basic (Origin (..), GenReason (..), appPrec)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
@@ -1225,8 +1225,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ body _ ret_expr))]
-- ------------------------------------------------
-- return e ~~> return e
-- to make T18324 work
- = return $ L loc (mkExpandedStmt stmt
- ((L loc (HsApp noAnn (L loc ret) body))))
+ = return $ wrapGenSpan (mkExpandedStmt stmt (L loc $ genHsApp ret body))
expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bnds)) : lstmts) =
@@ -1249,12 +1248,13 @@ expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
-- pat <- e ; stmts ~~> (>>=) e f
do expand_stmts <- expand_do_stmts do_or_lc lstmts
expr <- mk_failable_lexpr_tcm pat expand_stmts fail_op
- return $ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
- [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
- , expr
- ])
-
+ return $ (foldl genHsApp' (wrapGenSpan bind_op) -- (>>=)
+ [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e))
+ , expr
+ ])
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
+ where genHsApp' :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+ genHsApp' fun arg = wrapGenSpan (HsApp noAnn fun arg)
expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- See Note [BodyStmt]
@@ -1262,9 +1262,12 @@ expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn f) _)) : lstmt
-- ----------------------------------------------
-- e ; stmts ~~> (>>) e stmts'
do expand_stmts <- expand_do_stmts do_or_lc lstmts
- return $ (mkHsApps (wrapGenSpan f) -- (>>)
- [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
- , expand_stmts ]) -- stmts'
+ return $ (foldl genHsApp' (wrapGenSpan f) -- (>>)
+ [ L loc (mkPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)) -- e
+ , expand_stmts ]) -- stmts'
+ where
+ genHsApp' :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+ genHsApp' fun arg = wrapGenSpan (HsApp noAnn fun arg)
expand_do_stmts do_or_lc
((L do_loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -1405,6 +1408,32 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
+
+mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+ => [LPat (GhcPass p)]
+ -> LHsExpr (GhcPass p)
+ -> LHsExpr (GhcPass p)
+mkHsLamDoExp pats body = mkHsPar (wrapGenSpan $ HsLam noExtField matches)
+ where
+ matches = mkMatchGroup (Generated DoExpansion)
+ (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
+ pats' = map (parenthesizePat appPrec) pats
+
+
+
+genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcSpanAnnA,
+ Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
+ ~ SrcAnn NoEpAnns)
+ => HsMatchContext (GhcPass p)
+ -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
+ -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+genSimpleMatch ctxt pats rhs
+ = wrapGenSpan $
+ Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats
+ , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn }
+
+
{- Note [Expanding HsDo with HsExpansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We expand do blocks before typechecking it rather than after type checking it using the
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39ac8d8f65452b619447c66770c5dc6f46a28219
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39ac8d8f65452b619447c66770c5dc6f46a28219
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/20230606/dbfd5578/attachment-0001.html>
More information about the ghc-commits
mailing list