diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 4 |
2 files changed, 15 insertions, 15 deletions
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index e1a0c2401b..d043b2a352 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -397,7 +397,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts) -- possible to do this with a popErrCtxt in the tcStmt case for -- ApplicativeStmt, but it did something strange and broke a test (ado002). tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside - | ApplicativeStmt{} <- stmt + | XStmtLR ApplicativeStmt{} <- stmt = do { (stmt', (stmts', thing)) <- stmt_chk ctxt stmt res_ty $ \ res_ty' -> tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ @@ -885,18 +885,6 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside } ; return (BindStmt xbstc pat' rhs', thing) } -tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside - = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ - thing_inside . mkCheckExpType - ; ((pairs', body_ty, thing), mb_join') <- case mb_join of - Nothing -> (, Nothing) <$> tc_app_stmts res_ty - Just join_op -> - second Just <$> - (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ - \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) - - ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } - tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty @@ -962,6 +950,18 @@ tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_ret_ty = stmts_ty} }, thing) }} +tcDoStmt ctxt (XStmtLR (ApplicativeStmt _ pairs mb_join)) res_ty thing_inside + = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ + thing_inside . mkCheckExpType + ; ((pairs', body_ty, thing), mb_join') <- case mb_join of + Nothing -> (, Nothing) <$> tc_app_stmts res_ty + Just join_op -> + second Just <$> + (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ + \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty)) + + ; return (XStmtLR $ ApplicativeStmt body_ty pairs' mb_join', thing) } + tcDoStmt _ stmt _ _ = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index f11bc29000..36ad2a985d 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -1220,12 +1220,12 @@ zonkStmt env zBody (BindStmt xbs pat body) -- Scopes: join > ops (in reverse order) > pats (in forward order) -- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) +zonkStmt env _zBody (XStmtLR (ApplicativeStmt body_ty args mb_join)) = do { (env1, new_mb_join) <- zonk_join env mb_join ; (env2, new_args) <- zonk_args env1 args ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty ; return ( env2 - , ApplicativeStmt new_body_ty new_args new_mb_join) } + , XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join) } where zonk_join env Nothing = return (env, Nothing) zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j |