[Git][ghc/ghc][wip/expand-do] handle a special in desugaring when a do block has only one statment, the ds...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Jun 23 17:13:01 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
2b3e0526 by Apoorv Ingle at 2023-06-23T12:12:46-05:00
handle a special in desugaring when a do block has only one statment, the ds location should be set to that of the last statement
- - - - -
7 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1145,7 +1145,6 @@ instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
= ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
(ppr orig)
- -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
{-
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -264,7 +264,10 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
- ExpansionExpr (HsExpanded _ b) -> dsExpr b
+ ExpansionExpr (HsExpanded orig b) ->
+ case isSingleDoStmt orig of
+ Just loc -> putSrcSpanDsA loc $ dsExpr b
+ Nothing -> dsExpr b
WrapExpr {} -> dsHsWrapped e
ConLikeTc con tvs tys -> dsConLike con tvs tys
-- Hpc Support
@@ -284,6 +287,9 @@ dsExpr e@(XExpr ext_expr_tc)
do { assert (exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
+ where
+ isSingleDoStmt (HsDo _ _ (L _ [L loc _])) = Just loc
+ isSingleDoStmt _ = Nothing
-- Strip ticks due to #21701, need to be invariant about warnings we produce whether
-- this is enabled or not.
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -775,8 +775,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
; let matches
= if any (is_pat_syn_match origin) matches'
then filter (non_gen_wc origin) matches'
- -- filter out the wild pattern fail alternatives that
- -- generate spurious overlapping warnings
+ -- filter out the wild pattern fail alternatives
+ -- They generate spurious overlapping warnings
+ -- Due to pattern synonyms treated as refutable patterns
else matches'
; new_vars <- case matches of
[] -> newSysLocalsDs arg_tys
@@ -849,7 +850,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
is_pat_syn_match _ _ = False
-- generated match pattern that is not a wildcard
non_gen_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
- non_gen_wc (Generated _) (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
+ non_gen_wc origin (L _ (Match _ _ ([L _ (WildPat _)]) _))
+ | isDoExpansionGenerated origin = False
+ | otherwise = True
non_gen_wc _ _ = True
{- Note [Long-distance information in matchWrapper]
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -160,7 +160,7 @@ pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do
tracePm "pmcMatches {" $
hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
2
- (vcat (map ppr matches) $$ (text "missing:" <+> ppr missing))
+ ((ppr matches) $$ (text "missing:" <+> ppr missing))
case NE.nonEmpty matches of
Nothing -> do
-- This must be an -XEmptyCase. See Note [Checking EmptyCase]
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -367,7 +367,7 @@ tcApp rn_expr exp_res_ty
= do traceTc "tcApp" (vcat [text "insideExpansion", ppr rn_fun, ppr fun_ctxt])
addHeadCtxt fun_ctxt thing_inside
| otherwise
- = do traceTc "tcApp" (vcat [text "no expansion", ppr rn_fun])
+ = do traceTc "tcApp" (vcat [text "no expansion", ppr rn_fun, ppr fun_ctxt])
addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
thing_inside
@@ -729,14 +729,8 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
<+> ppr (is_then_fun (appCtxtExpr ctxt))
<+> ppr (is_bind_fun (appCtxtExpr ctxt)) ])
; case ctxt of
- -- VACall _ _ _ | not in_src_ctxt -- the context we are in is generated
- -- , not rebindableOn
- -- -> do traceTc "addArgCtxt 1" empty
- -- thing_inside -- do not do anything in case of expanded (>>)
- -- -- TODO: this behaviour is not quite right
- -- -- user written (>>)/(>>=) are infix and then 'expanded' to be prefix
VACall fun arg_no _ | not in_generated_code && not (is_then_fun fun || is_bind_fun fun)
- -> do traceTc "addArgCtxt 2" empty
+ -> do traceTc "addArgCtxt 2a" empty
setSrcSpanA arg_loc $
addErrCtxt (funAppCtxt fun arg arg_no) $
thing_inside
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -300,6 +300,7 @@ splitHsApps e = go e (top_ctxt 0 e) []
top_ctxt n (HsAppType _ fun _ _) = top_lctxt (n+1) fun
top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
top_ctxt n (XExpr (ExpandedExpr (HsExpanded orig _))) = VACall orig n noSrcSpan
+ top_ctxt n other_fun@(XExpr (ExpandedStmt _)) = VACall other_fun n generatedSrcSpan
top_ctxt n other_fun = VACall other_fun n noSrcSpan
top_lctxt n (L _ fun) = top_ctxt n fun
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -832,10 +832,9 @@ unifyExpectedType :: HsExpr GhcRn
-> ExpRhoType -- Expected
-> TcM TcCoercionN
unifyExpectedType rn_expr act_ty exp_ty
- = do traceTc "unifyExpectedType" (ppr rn_expr)
- case exp_ty of
- Infer inf_res -> fillInferResult act_ty inf_res
- Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty
+ = case exp_ty of
+ Infer inf_res -> fillInferResult act_ty inf_res
+ Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty
------------------------
tcSubTypePat :: CtOrigin -> UserTypeCtxt
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b3e05262d892fa27bdd47aecf19b40c39af7579
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b3e05262d892fa27bdd47aecf19b40c39af7579
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/20230623/0d47840c/attachment-0001.html>
More information about the ghc-commits
mailing list