- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2a) ->
- tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2b) ->
- tcAddErrCtxt (exprCtxt in_expr) $
- tcSub res_ty op_res_ty `thenTc` \ (co_fn, lie3) ->
- returnTc (OpApp arg1' op' fix arg2',
- lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3)
+ = tcExpr_id op `thenM` \ (op', op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
+ tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
+ addErrCtxt (exprCtxt in_expr) $
+ tcSubExp res_ty op_res_ty `thenM` \ co_fn ->
+ returnM (OpApp arg1' op' fix arg2')
+\end{code}
+
+\begin{code}
+tcMonoExpr (HsLet binds expr) res_ty
+ = tcBindsAndThen
+ HsLet
+ binds -- Bindings to check
+ (tcMonoExpr expr res_ty)
+
+tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
+ = addSrcLoc src_loc $
+ addErrCtxt (caseCtxt in_expr) $
+
+ -- Typecheck the case alternatives first.
+ -- The case patterns tend to give good type info to use
+ -- when typechecking the scrutinee. For example
+ -- case (map f) of
+ -- (x:xs) -> ...
+ -- will report that map is applied to too few arguments
+ --
+ -- Not only that, but it's better to check the matches on their
+ -- own, so that we get the expected results for scoped type variables.
+ -- f x = case x of
+ -- (p::a, q::b) -> (q,p)
+ -- The above should work: the match (p,q) -> (q,p) is polymorphic as
+ -- claimed by the pattern signatures. But if we typechecked the
+ -- match with x in scope and x's type as the expected type, we'd be hosed.
+
+ tcMatchesCase matches res_ty `thenM` \ (scrut_ty, matches') ->
+
+ addErrCtxt (caseScrutCtxt scrut) (
+ tcMonoExpr scrut scrut_ty
+ ) `thenM` \ scrut' ->
+
+ returnM (HsCase scrut' matches' src_loc)
+
+tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
+ = addSrcLoc src_loc $
+ addErrCtxt (predCtxt pred) (
+ tcMonoExpr pred boolTy ) `thenM` \ pred' ->
+
+ zapToType res_ty `thenM` \ res_ty' ->
+ -- C.f. the call to zapToType in TcMatches.tcMatches
+
+ tcMonoExpr b1 res_ty' `thenM` \ b1' ->
+ tcMonoExpr b2 res_ty' `thenM` \ b2' ->
+ returnM (HsIf pred' b1' b2' src_loc)
+
+tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty
+ = addSrcLoc src_loc $
+ tcDoStmts do_or_lc stmts method_names res_ty `thenM` \ (binds, stmts', methods') ->
+ returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty src_loc))
+
+tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
+ returnM (ExplicitList elt_ty exprs')
+ where
+ tc_elt elt_ty expr
+ = addErrCtxt (listCtxt expr) $
+ tcMonoExpr expr elt_ty
+
+tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
+ = unifyPArrTy res_ty `thenM` \ elt_ty ->
+ mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
+ returnM (ExplicitPArr elt_ty exprs')
+ where
+ tc_elt elt_ty expr
+ = addErrCtxt (parrCtxt expr) $
+ tcMonoExpr expr elt_ty
+
+tcMonoExpr (ExplicitTuple exprs boxity) res_ty
+ = unifyTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys ->
+ tcMonoExprs exprs arg_tys `thenM` \ exprs' ->
+ returnM (ExplicitTuple exprs' boxity)