import HsSyn
import TcRnMonad
-import Inst
import TcEnv
import TcPat
import TcMType
import TcUnify
import Name
import TysWiredIn
-import PrelNames
import Id
import TyCon
import TysPrim
import Coercion ( mkSymCoI )
import Outputable
-import VarSet
import BasicTypes ( Arity )
import Util
import SrcLoc
; checkArgs fun_name matches
; (wrap_gen, (wrap_fun, group))
- <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho ->
+ <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho ->
-- Note [Polymorphic expected type for tcMatchesFun]
matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
where
tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
= add_match_ctxt match $
- do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
+ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
; return (Match pats' Nothing grhss') }
tcBody body
; return (HsDo DoExpr stmts' body' res_ty) }
-tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
- = do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty
- ; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty
- tc_rhs rhs = tcInfer $ \ pat_ty ->
- tcMonoExpr rhs (mkAppTy m_ty pat_ty)
-
- ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
+tcDoStmts MDoExpr stmts body res_ty
+ = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
tcBody body
-
- ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
- ; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names
- ; return $ mkHsWrapCoI coi $
- HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' }
+ ; return (HsDo MDoExpr stmts' body' res_ty) }
tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
- , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing)
+ , recS_rec_rets = tup_rets }, thing)
}}
tcDoStmt _ stmt _ _
-> TcStmtChecker
tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
-tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
+tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
+ , recS_rec_ids = recNames }) res_ty thing_inside
= do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
--- Need the bindLocalMethods if we re-add Method constraints
--- ; lie_binds <- bindLocalMethods lie later_ids
- ; let lie_binds = emptyTcEvBinds
-
- ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
+ ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
}}
tcMDoStmt _ _ stmt _ _