[Git][ghc/ghc][wip/expansions-appdo] add flavour into OrigStmt to guide better error messages about qualified do.
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Mar 25 14:37:38 UTC 2024
Apoorv Ingle pushed to branch wip/expansions-appdo at Glasgow Haskell Compiler / GHC
Commits:
0047f94e by Apoorv Ingle at 2024-03-25T09:37:28-05:00
add flavour into OrigStmt to guide better error messages about qualified do.
- - - - -
8 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Types/Origin.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -476,7 +476,7 @@ type instance XXExpr GhcTc = XXExprGhcTc
-- | The different source constructs that we use to instantiate the "original" field
-- in an `XXExprGhcRn original expansion`
data HsThingRn = OrigExpr (HsExpr GhcRn)
- | OrigStmt (ExprLStmt GhcRn)
+ | OrigStmt (ExprLStmt GhcRn) HsDoFlavour
| OrigPat (LPat GhcRn)
isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool
@@ -522,9 +522,10 @@ mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)
-- expanded expression
mkExpandedStmt
:: ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)
+mkExpandedStmt oStmt flav eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt flav) eExpr)
mkExpandedPatRn
:: LPat GhcRn -- ^ source pattern
@@ -538,17 +539,19 @@ mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)
mkExpandedStmtAt
:: SrcSpanAnnA -- ^ Location for the expansion expression
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn'
-mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr
+mkExpandedStmtAt loc oStmt flav eExpr = L loc $ mkExpandedStmt oStmt flav eExpr
-- | Wrap the expanded version of the expression with a pop.
mkExpandedStmtPopAt
:: SrcSpanAnnA -- ^ Location for the expansion statement
-> ExprLStmt GhcRn -- ^ source statement
+ -> HsDoFlavour
-> HsExpr GhcRn -- ^ expanded expression
-> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr
+mkExpandedStmtPopAt loc oStmt flav eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt flav eExpr
data XXExprGhcTc
@@ -593,9 +596,10 @@ mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)
-- expanded typechecked expression.
mkExpandedStmtTc
:: ExprLStmt GhcRn -- ^ source do statement
+ -> HsDoFlavour
-> HsExpr GhcTc -- ^ expanded typechecked expression
-> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn'
-mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)
+mkExpandedStmtTc oStmt flav eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt flav) eExpr)
{- *********************************************************************
* *
@@ -836,7 +840,7 @@ instance Outputable HsThingRn where
ppr thing
= case thing of
OrigExpr x -> ppr_builder "<OrigExpr>:" x
- OrigStmt x -> ppr_builder "<OrigStmt>:" x
+ OrigStmt x _ -> ppr_builder "<OrigStmt>:" x
OrigPat x -> ppr_builder "<OrigPat>:" x
where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -315,7 +315,7 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
ExpandedThingTc o e
- | OrigStmt (L loc _) <- o
+ | OrigStmt (L loc _) _ <- o
-> putSrcSpanDsA loc $ dsExpr e
| otherwise -> dsExpr e
WrapExpr {} -> dsHsWrapped e
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -611,7 +611,7 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts))
_ -> Nothing
addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e
+addTickHsExpanded o@(OrigStmt (L pos LastStmt{}) _) e
-- LastStmt always gets a tick for breakpoint and hpc coverage
= do d <- getDensity
case d of
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -806,18 +806,18 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
| XExpr{} <- arg, in_generated_code
-> thing_inside -- AppDo case for <*>'s second argument, the ctxt will be set by addHeadCtxt
- VAExpansion (OrigStmt (L _ stmt@(BindStmt {}))) _ loc
+ VAExpansion (OrigStmt (L _ stmt@(BindStmt {})) flav) _ loc
| isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
-> setSrcSpan loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
| otherwise -- This arg is the first argument to generated (>>=)
-> setSrcSpanA arg_loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
- VAExpansion (OrigStmt (L loc stmt)) _ _
+ VAExpansion (OrigStmt (L loc stmt) flav) _ _
-> setSrcSpanA loc $
- addStmtCtxt stmt $
+ addStmtCtxt stmt flav $
thing_inside
_ -> setSrcSpanA arg_loc $
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -80,7 +80,7 @@ expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
pprPanic "expand_do_stmts: ParStmt" $ ppr stmt
-- handeled by `GHC.Tc.Gen.Match.tcLcStmt`
-expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
+expand_do_stmts flav [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below
-- last statement of a list comprehension, needs to explicitly return it
-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt`
@@ -89,8 +89,8 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
= do traceTc "expand_do_stmts last" (ppr ret_expr)
appDo <- xoptM LangExt.ApplicativeDo
if appDo
- then return $ mkExpandedStmtAt loc stmt body
- else return $ mkExpandedStmtPopAt loc stmt body
+ then return $ mkExpandedStmtAt loc stmt flav body
+ else return $ mkExpandedStmtPopAt loc stmt flav body
| SyntaxExprRn ret <- ret_expr
--
@@ -99,7 +99,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))]
-- to make T18324 work
= do traceTc "expand_do_stmts last" (ppr ret_expr)
let expansion = genHsApp ret (L body_loc body)
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt flav expansion
expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below
@@ -108,7 +108,7 @@ expand_do_stmts doFlavour (stmt@(L loc (LetStmt _ bs)) : lstmts) =
-- let x = e ; stmts ~~> let x = e in stmts'
do expand_stmts <- expand_do_stmts doFlavour lstmts
let expansion = genHsLet bs expand_stmts
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
| SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn
@@ -124,7 +124,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts)
let expansion = genHsExpApps bind_op -- (>>=)
[ e
, failable_expr ]
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
| otherwise
= pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt)
@@ -139,7 +139,7 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _))
let expansion = genHsExpApps then_op -- (>>)
[ e
, expand_stmts_expr ]
- return $ mkExpandedStmtPopAt loc stmt expansion
+ return $ mkExpandedStmtPopAt loc stmt doFlavour expansion
expand_do_stmts doFlavour
((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts
@@ -226,7 +226,8 @@ expand_do_stmts doFlavour ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
, app_arg_pattern = pat
, arg_expr = (L rhs_loc rhs)
}) =
- return ((pat, mb_fail_op), mkExpandedStmtAt rhs_loc (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs))) rhs)
+ return ((pat, mb_fail_op)
+ , mkExpandedStmtAt rhs_loc (L rhs_loc (BindStmt xbsn pat (L rhs_loc rhs))) doFlavour rhs)
do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
; return ((pat, Nothing)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -711,26 +711,26 @@ tcXExpr (PopErrCtxt (L loc e)) res_ty
tcExpr e res_ty
tcXExpr xe@(ExpandedThingRn o e') res_ty
- | OrigStmt ls@(L loc s at LetStmt{}) <- o
+ | OrigStmt ls@(L loc s at LetStmt{}) flav <- o
, HsLet x binds e <- e'
= do { (binds', wrapper, e') <- setSrcSpanA loc $
- addStmtCtxt s $
+ addStmtCtxt s flav $
tcLocalBinds binds $
tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
-- a duplicate error context
- ; return $ mkExpandedStmtTc ls (HsLet x binds' (mkLHsWrap wrapper e'))
+ ; return $ mkExpandedStmtTc ls flav (HsLet x binds' (mkLHsWrap wrapper e'))
}
- | OrigStmt ls@(L loc s at LastStmt{}) <- o
+ | OrigStmt ls@(L loc s at LastStmt{}) flav <- o
= setSrcSpanA loc $
- addStmtCtxt s $
- mkExpandedStmtTc ls <$> tcExpr e' res_ty
+ addStmtCtxt s flav $
+ mkExpandedStmtTc ls flav <$> tcExpr e' res_ty
-- It is important that we call tcExpr (and not tcApp) here as
-- `e` is the last statement's body expression
-- and not a HsApp of a generated (>>) or (>>=)
-- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3
- | OrigStmt ls@(L loc _) <- o
+ | OrigStmt ls@(L loc _) flav <- o
= setSrcSpanA loc $
- mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty
+ mkExpandedStmtTc ls flav <$> tcApp (XExpr xe) res_ty
tcXExpr xe res_ty = tcApp (XExpr xe) res_ty
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -325,7 +325,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
= go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt))
(EWrap (EExpand o) : args)
- | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated
+ | OrigStmt (L _ stmt) _ <- o -- so that we set `(>>)` as generated
, BodyStmt{} <- stmt -- and get the right unused bind warnings
= go e (VAExpansion o generatedSrcSpan generatedSrcSpan)
-- See Part 3. in Note [Expanding HsDo with XXExprGhcRn]
@@ -896,10 +896,10 @@ tcInferAppHead_maybe fun
_ -> return Nothing
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside =
+addHeadCtxt (VAExpansion (OrigStmt (L loc stmt) flav) _ _) thing_inside =
do traceTc "addHeadCtxt stmt" (ppr stmt)
setSrcSpanA loc $
- addStmtCtxt stmt
+ addStmtCtxt stmt flav $
thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
@@ -1628,9 +1628,9 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt stmt thing_inside
- = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
+addStmtCtxt :: ExprStmt GhcRn -> HsDoFlavour -> TcRn a -> TcRn a
+addStmtCtxt stmt flav thing_inside
+ = do let err_doc = pprStmtInCtxt (HsDoStmt flav) stmt
addErrCtxt err_doc thing_inside
where
pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
@@ -1643,7 +1643,7 @@ addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt e thing_inside
= case e of
HsUnboundVar {} -> thing_inside
- XExpr (ExpandedThingRn (OrigStmt stmt) _) -> addStmtCtxt (unLoc stmt) thing_inside
+ XExpr (ExpandedThingRn (OrigStmt stmt flav) _) -> addStmtCtxt (unLoc stmt) flav thing_inside
_ -> addErrCtxt (exprCtxt e) thing_inside
-- The HsUnboundVar special case addresses situations like
-- f x = _
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -751,7 +751,7 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression"
exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a
- | OrigStmt _ <- thing = DoOrigin
+ | OrigStmt _ _ <- thing = DoOrigin
| OrigPat p <- thing = DoPatOrigin p
exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0047f94e045a074de02ea1fe61552492d5618153
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0047f94e045a074de02ea1fe61552492d5618153
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/20240325/ec56a847/attachment-0001.html>
More information about the ghc-commits
mailing list