diff options
| author | Artyom Kuznetsov <hi@wzrd.ht> | 2021-07-29 12:10:29 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-08-10 15:00:42 -0400 |
| commit | 130f94dbd3536bd409621cbaac4659ababf613b3 (patch) | |
| tree | 55809a2f6f91bfecadcc6a1ef7d4f3895cc6c253 /compiler/GHC/Tc | |
| parent | 741fdf0e4f371afbd8ef36f81bbb90a2049b005c (diff) | |
| download | haskell-130f94dbd3536bd409621cbaac4659ababf613b3.tar.gz | |
Refactor HsStmtContext and remove HsDoRn
Parts of HsStmtContext were split into a separate data structure
HsDoFlavour. Before this change HsDo used to have HsStmtContext
inside, but in reality only parts of HsStmtContext were used and other
cases were invariants handled with panics. Separating those parts
into its own data structure helps us to get rid of those panics as
well as HsDoRn type family.
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 4 |
2 files changed, 10 insertions, 11 deletions
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 06118359f1..9b8b68aad6 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -299,7 +299,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs) ************************************************************************ -} -tcDoStmts :: HsStmtContext GhcRn +tcDoStmts :: HsDoFlavour -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo @@ -307,26 +307,25 @@ tcDoStmts ListComp (L l stmts) res_ty = do { res_ty <- expTypeToType res_ty ; (co, elt_ty) <- matchExpectedListTy res_ty ; let list_ty = mkListTy elt_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts + ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts (mkCheckExpType elt_ty) ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty - = do { stmts' <- tcStmts doExpr tcDoStmt stmts res_ty + = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty ; return (HsDo res_ty doExpr (L l stmts')) } tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty - = do { stmts' <- tcStmts mDoExpr tcDoStmt stmts res_ty + = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty ; return (HsDo res_ty mDoExpr (L l stmts')) } tcDoStmts MonadComp (L l stmts) res_ty - = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty ; res_ty <- readExpType res_ty ; return (HsDo res_ty MonadComp (L l stmts')) } - -tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) +tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty @@ -1068,10 +1067,10 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty) = do { (stmts', (ret',pat')) <- - tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ + tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do { ret' <- tcExpr ret res_ty - ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $ return () ; return (ret', pat') } diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index f458605c14..5be998e07a 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2391,7 +2391,7 @@ But for naked expressions, you will have tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do + rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv return (fix_env, emptyFVs) -- Don't try to typecheck if the renamer fails! @@ -2456,7 +2456,7 @@ tcGhciStmts stmts ; ret_id <- tcLookupId returnIOName -- return @ IO ; let ret_ty = mkListTy unitTy io_ret_ty = mkTyConApp ioTyCon [ret_ty] - tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts + tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts (mkCheckExpType io_ret_ty) names = collectLStmtsBinders CollNoDictBinders stmts |