[Git][ghc/ghc][wip/expand-do] cleanup
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Mon Aug 14 23:18:31 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
d3adcf0c by Apoorv Ingle at 2023-08-14T18:17:10-05:00
cleanup
- - - - -
4 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -798,15 +798,15 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside
VAExpansionStmt (L _ stmt@(BindStmt {})) loc
| isGeneratedSrcSpan (locA arg_loc) -- This arg is the second argument to generated (>>=)
-> setSrcSpan loc $
- addStmtCtxt ((text "addArgCtxt bind 1")) stmt $
+ addStmtCtxt stmt $
thing_inside
| otherwise -- This arg is the first argument to generated (>>=)
-> setSrcSpanA arg_loc $
- addStmtCtxt ((text "addArgCtxt bind 2")) stmt $
+ addStmtCtxt stmt $
thing_inside
VAExpansionStmt (L loc stmt) _
-> setSrcSpanA loc $
- addStmtCtxt (text "addArgCtxt 2e") stmt $
+ addStmtCtxt stmt $
thing_inside
_ -> setSrcSpanA arg_loc $
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -649,7 +649,7 @@ tcXExpr xe@(ExpandedStmt (HsExpanded stmt@(L loc s) expd_expr)) res_ty
| LetStmt{} <- s
, HsLet x tkLet binds tkIn e <- expd_expr
= do { (binds', e') <- setSrcSpanA loc $
- addStmtCtxt (text "tcExpr let") s $
+ addStmtCtxt s $
tcLocalBinds binds $
tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds
-- a duplicate error context
@@ -657,7 +657,7 @@ tcXExpr xe@(ExpandedStmt (HsExpanded stmt@(L loc s) expd_expr)) res_ty
}
| LastStmt{} <- s
= setSrcSpanA loc $
- addStmtCtxt (text "tcExpr last") s $
+ addStmtCtxt s $
mkExpandedStmtTc stmt <$> tcExpr expd_expr res_ty
-- It is important that we call tcExpr (and not tcApp) here as
-- `e` is just the last statement's body expression
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -84,8 +84,6 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic.Plain
-import qualified GHC.LanguageExtensions as LangExt
-
import GHC.Data.Maybe
import Control.Monad
@@ -907,18 +905,18 @@ tcInferAppHead_maybe fun
addHeadCtxt :: AppCtxt -> TcM a -> TcM a
addHeadCtxt (VAExpansionStmt (L loc stmt) _) thing_inside =
do setSrcSpanA loc $
- addStmtCtxt (text "addHeadCtxt") stmt
+ addStmtCtxt stmt
thing_inside
addHeadCtxt fun_ctxt thing_inside
| not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
= thing_inside -- => context is already set
| otherwise
= setSrcSpan fun_loc $
- do traceTc "addHeadCtxt okay" (ppr fun_ctxt)
- case fun_ctxt of
+ do case fun_ctxt of
VAExpansion orig _ -> addExprCtxt orig thing_inside
- VACall {} -> thing_inside
VAExpansionPat {} -> thing_inside
+ VACall {} -> thing_inside
+
where
fun_loc = appCtxtLoc fun_ctxt
@@ -1590,17 +1588,13 @@ mis-match in the number of value arguments.
* *
********************************************************************* -}
-addStmtCtxt :: SDoc -> ExprStmt GhcRn -> TcRn a -> TcRn a
-addStmtCtxt doc stmt thing_inside
- = do isRebindable <- xoptM LangExt.RebindableSyntax
- let err = pprStmtInCtxt isRebindable (HsDoStmt (DoExpr Nothing)) stmt
- traceTc "addStmtCtxt" (ppr doc)
- addErrCtxt ({- doc <+>-} err) $ debugErrCtxt thing_inside
-
-
+addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a
+addStmtCtxt stmt thing_inside
+ = do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
+ addErrCtxt err_doc thing_inside
where
- pprStmtInCtxt :: Bool -> HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
- pprStmtInCtxt _ ctxt stmt
+ pprStmtInCtxt :: HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ pprStmtInCtxt ctxt stmt
= vcat [ hang (text "In a stmt of"
<+> pprAStmtContext ctxt <> colon) 2 (pprStmt stmt)
]
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -85,7 +85,6 @@ module GHC.Tc.Utils.Monad(
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
- debugErrCtxt,
addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
-- * Diagnostic message generation (type checker)
@@ -1271,7 +1270,7 @@ updCtxt ctxt env
popErrCtxt :: TcM a -> TcM a
popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $
- debugErrCtxt $ thing_inside
+ thing_inside
where
pop [] = []
pop (_:msgs) = msgs
@@ -1304,18 +1303,6 @@ setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
-debugErrCtxt :: TcRn a -> TcRn a
-debugErrCtxt thing_inside
- = do { err_ctxt <- getErrCtxt
- ; env0 <- liftZonkM tcInitTidyEnv
- ; err_info <- mkErrInfo env0 err_ctxt
- ; traceTc "debugErrCtxt" err_info
- ; thing_inside
- }
-
-
-
-
{- *********************************************************************
* *
Error recovery and exceptions
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3adcf0c8636e50afb8472acb7333a734906df66
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d3adcf0c8636e50afb8472acb7333a734906df66
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/20230814/6b3d238f/attachment-0001.html>
More information about the ghc-commits
mailing list