[Git][ghc/ghc][wip/expand-do] more error context changes
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Tue May 30 18:25:39 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
a7c93859 by Apoorv Ingle at 2023-05-30T13:25:19-05:00
more error context changes
- - - - -
6 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/ghc-api/T18522-dbg-ppr.hs
- − testsuite/tests/rebindable/pattern-fails
- − testsuite/tests/typecheck/should_run/Typeable1
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -282,7 +282,7 @@ mkHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
mkHsLamDoExp pats body = mkHsPar (noLocA $ HsLam noExtField matches)
where
matches = mkMatchGroup (Generated DoExpansion)
- (noLocA [mkSimpleMatch LambdaExpr pats' body])
+ (noLocA [mkSimpleMatch (StmtCtxt (HsDoStmt (DoExpr Nothing))) pats' body])
pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -418,9 +418,10 @@ tcExpr (HsMultiIf _ alts) res_ty
tcExpr (XExpr (ExpandedStmt (HsExpanded stmt expr))) res_ty
= do { traceTc "tcDoStmts" (vcat [ text "stmt:" <+> ppr stmt
, text "expr:" <+> ppr expr
- , text "res_ty" <+> ppr res_ty ])
+ , text "res_ty" <+> ppr res_ty
+ ])
; addErrCtxt (pprStmtInCtxt @Renamed @Renamed @Renamed (HsDoStmt (DoExpr Nothing)) (unLoc stmt)) $
- tcExpr (unLoc expr) res_ty
+ tcApp (unLoc expr) res_ty
}
tcExpr hsDo@(HsDo _ doFlav@(DoExpr{}) (L _ stmts)) res_ty
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -267,6 +267,7 @@ tcMatch ctxt pat_tys rhs_ty match
add_match_ctxt match thing_inside
= case mc_what ctxt of
LambdaExpr -> thing_inside
+ StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
-------------
@@ -1249,11 +1250,11 @@ 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) -- (>>=)
- [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
- , expr
- ]
+ expr <- mk_failable_lexpr_tcm pat (noLocA $ mkExpandedStmt stmt expand_stmts) fail_op
+ return $ (mkHsApps (wrapGenSpan bind_op) -- (>>=)
+ [ genPopSrcSpanExpr $ L loc (mkExpandedStmt stmt e)
+ , genPopSrcSpanExpr expr
+ ])
| otherwise = pprPanic "expand do: shouldn't happen" (text "stmt" <+> ppr stmt)
@@ -1339,10 +1340,14 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
}
where
do_arg :: ApplicativeArg GhcRn -> TcM ((LPat GhcRn, FailOperator GhcRn), LHsExpr GhcRn)
- do_arg (ApplicativeArgOne mb_fail_op pat expr _) =
- return ((pat, mb_fail_op), expr)
- do_arg (ApplicativeArgMany _ stmts ret pat _) =
- do { expr <- expand_do_stmts do_or_lc $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
+ do_arg (ApplicativeArgOne
+ { xarg_app_arg_one = mb_fail_op
+ , app_arg_pattern = pat@(L loc _)
+ , arg_expr = rhs
+ }) =
+ return ((pat, mb_fail_op), wrapGenSpan (mkExpandedStmt (L loc (BindStmt xbsn pat rhs)) rhs))
+ do_arg (ApplicativeArgMany _ stmts ret pat ctxt) =
+ do { expr <- expand_do_stmts ctxt $ stmts ++ [wrapGenSpan $ mkLastStmt (wrapGenSpan ret)]
; return ((pat, Nothing), expr) }
match_args :: (LPat GhcRn, FailOperator GhcRn) -> LHsExpr GhcRn -> TcM (LHsExpr GhcRn)
@@ -1353,6 +1358,9 @@ expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
SyntaxExprRn op -> mkHsApps (wrapGenSpan op) [l_expr, r_expr]
NoSyntaxExprRn -> pprPanic "expand_do_stmts op:" (ppr op)
+ xbsn :: XBindStmtRn
+ xbsn = XBindStmtRn NoSyntaxExprRn Nothing
+
expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr stmts)
@@ -1374,7 +1382,7 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
; if irrf_pat
-- don't decorate with fail statement if
-- the pattern is irrefutable
- then return $ mkHsLamDoExp [pat] (genPopSrcSpanExpr lexpr)
+ then return $ mkHsLamDoExp [pat] lexpr
else mk_fail_lexpr pat lexpr fail_op
}
@@ -1385,7 +1393,7 @@ mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsEx
mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
do dflags <- getDynFlags
return $ wrapGenSpan (HsLam noExtField $ mkMatchGroup (Generated DoExpansion) -- \
- (wrapGenSpan [ mkHsCaseAltDoExp pat (genPopSrcSpanExpr lexpr) -- pat -> expr
+ (wrapGenSpan [ mkHsCaseAltDoExp pat lexpr -- pat -> expr
, mkHsCaseAlt nlWildPatName -- _ -> fail "fail pattern"
(wrapGenSpan $ genHsApp fail_op (mk_fail_msg_expr dflags pat))
]))
=====================================
testsuite/tests/ghc-api/T18522-dbg-ppr.hs
=====================================
@@ -44,7 +44,7 @@ main = do
forall (a :: k) (b :: j) ->
() |]
let hs_t = fromRight (error "convertToHsType") $
- convertToHsType Generated noSrcSpan th_t
+ convertToHsType (Generated OtherExpansion) noSrcSpan th_t
(messages, mres) <-
tcRnType hsc_env SkolemiseFlexi True hs_t
let (warnings, errors) = partitionMessages messages
=====================================
testsuite/tests/rebindable/pattern-fails deleted
=====================================
Binary files a/testsuite/tests/rebindable/pattern-fails and /dev/null differ
=====================================
testsuite/tests/typecheck/should_run/Typeable1 deleted
=====================================
Binary files a/testsuite/tests/typecheck/should_run/Typeable1 and /dev/null differ
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7c938593d090e67b98efe98c299f512dfd66067
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7c938593d090e67b98efe98c299f512dfd66067
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/20230530/78113a92/attachment-0001.html>
More information about the ghc-commits
mailing list