diff options
Diffstat (limited to 'compiler/GHC/Tc/Gen/Match.hs')
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 63 |
1 files changed, 31 insertions, 32 deletions
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 339093b47c..45fece68c0 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -37,7 +37,8 @@ where import GhcPrelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRhoNC, tcInferRho - , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) + , tcCheckId, tcLExpr, tcLExprNC, tcExpr + , tcCheckExpr ) import GHC.Types.Basic (LexicalFixity(..)) import GHC.Hs @@ -331,7 +332,7 @@ tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty + ; tcLExpr body res_ty } {- @@ -411,15 +412,15 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) + = do { guard' <- tcLExpr guard (mkCheckExpType boolTy) ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already - ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) - pat (mkCheckExpType rhs_ty) $ + ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) + pat rhs_ty $ thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } @@ -444,21 +445,21 @@ tcLcStmt :: TyCon -- The list type constructor ([]) -> TcExprStmtChecker tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside - = do { body' <- tcMonoExprNC body elt_ty + = do { body' <- tcLExprNC body elt_ty ; thing <- thing_inside (panic "tcLcStmt: thing_inside") ; return (LastStmt x body' noret noSyntaxExpr, thing) } -- A generator, pat <- rhs tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ + ; rhs' <- tcLExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ thing_inside elt_ty ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside - = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) + = do { rhs' <- tcLExpr rhs (mkCheckExpType boolTy) ; thing <- thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -516,7 +517,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts by_arrow $ poly_arg_ty `mkVisFunTy` poly_res_ty - ; using' <- tcPolyExpr using using_poly_ty + ; using' <- tcCheckExpr using using_poly_ty ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' -- 'stmts' returns a result of type (m1_ty tuple_ty), @@ -558,7 +559,7 @@ tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside = do { (body', return_op') <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ \ [a_ty] -> - tcMonoExprNC body (mkCheckExpType a_ty) + tcLExprNC body (mkCheckExpType a_ty) ; thing <- thing_inside (panic "tcMcStmt: thing_inside") ; return (LastStmt x body' noret return_op', thing) } @@ -574,9 +575,8 @@ tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ thing_inside (mkCheckExpType new_res_ty) ; return (rhs', pat', thing, new_res_ty) } @@ -607,7 +607,7 @@ tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside <- tcSyntaxOp MCompOrigin guard_op [SynAny] (mkCheckExpType rhs_ty) $ \ [test_ty] -> - tcMonoExpr rhs (mkCheckExpType test_ty) + tcLExpr rhs (mkCheckExpType test_ty) ; thing <- thing_inside (mkCheckExpType new_res_ty) ; return (thing, rhs', rhs_ty, guard_op') } ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } @@ -667,7 +667,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap (mkCheckExpType using_arg_ty) $ \res_ty' -> do { by' <- case by of Nothing -> return Nothing - Just e -> do { e' <- tcMonoExpr e + Just e -> do { e' <- tcLExpr e (mkCheckExpType by_e_ty) ; return (Just e') } @@ -693,7 +693,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of ThenForm -> return noExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ + _ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $ mkInvForAllTy alphaTyVar $ mkInvForAllTy betaTyVar $ (alphaTy `mkVisFunTy` betaTy) @@ -703,7 +703,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Typecheck the 'using' function ------------- -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) - ; using' <- tcPolyExpr using using_poly_ty + ; using' <- tcCheckExpr using using_poly_ty ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using' --------------- Building the bindersMap ---------------- @@ -765,7 +765,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside (m_ty `mkAppTy` betaTy) `mkVisFunTy` (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty + ; mzip_op' <- unLoc `fmap` tcCheckExpr (noLoc mzip_op) mzip_ty -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) @@ -827,7 +827,7 @@ tcMcStmt _ stmt _ _ tcDoStmt :: TcExprStmtChecker tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside - = do { body' <- tcMonoExprNC body res_ty + = do { body' <- tcLExprNC body res_ty ; thing <- thing_inside (panic "tcDoStmt: thing_inside") ; return (LastStmt x body' noret noSyntaxExpr, thing) } @@ -840,9 +840,8 @@ tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside ((rhs', pat', new_res_ty, thing), bind_op') <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $ \ [rhs_ty, pat_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat - (mkCheckExpType pat_ty) $ + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) + ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ thing_inside (mkCheckExpType new_res_ty) ; return (rhs', pat', new_res_ty, thing) } @@ -874,7 +873,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside ; ((rhs', rhs_ty, thing), then_op') <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $ \ [rhs_ty, new_res_ty] -> - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) + do { rhs' <- tcLExprNC rhs (mkCheckExpType rhs_ty) ; thing <- thing_inside (mkCheckExpType new_res_ty) ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } @@ -890,7 +889,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; tcExtendIdEnv tup_ids $ do { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInferInst $ \ exp_ty -> + <- tcInfer $ \ exp_ty -> tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) @@ -902,7 +901,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) - <- tcInferInst $ \ exp_ty -> + <- tcInfer $ \ exp_ty -> tcSyntaxOp DoOrigin mfix_op [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $ \ _ -> return () @@ -968,7 +967,7 @@ When typechecking do { bar; ... } :: IO () we want to typecheck 'bar' in the knowledge that it should be an IO thing, pushing info from the context into the RHS. To do this, we check the -rebindable syntax first, and push that information into (tcMonoExprNC rhs). +rebindable syntax first, and push that information into (tcLExprNC rhs). Otherwise the error shows up when checking the rebindable syntax, and the expected/inferred stuff is back to front (see #3613). @@ -1000,7 +999,7 @@ tcApplicativeStmts tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpTypeInst + ; ts <- replicateM (arity-1) $ newInferExpType ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; let fun_ty = mkVisFunTys pat_tys body_ty @@ -1044,8 +1043,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside }, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ - do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ + do { rhs' <- tcLExprNC rhs (mkCheckExpType exp_ty) + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ return () ; fail_op' <- fmap join . forM fail_op $ \fail -> tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty @@ -1061,8 +1060,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { (stmts', (ret',pat')) <- tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do - { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty - ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ + { ret' <- tcExpr ret res_ty + ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat pat_ty $ return () ; return (ret', pat') } |