Commit 4c7b8ec3 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Improve error reporting in typechecker

parent 21044c2d
...@@ -25,7 +25,7 @@ import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields, ...@@ -25,7 +25,7 @@ import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp ) mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
import TcHsSyn ( hsLitType ) import TcHsSyn ( hsLitType )
import TcRnMonad import TcRnMonad
import TcUnify ( tcInfer, tcSubExp, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType, import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType, boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, boxySubMatchType,
unBox ) unBox )
import BasicTypes ( Arity, isMarkedStrict ) import BasicTypes ( Arity, isMarkedStrict )
...@@ -688,8 +688,7 @@ tcIdApp fun_name n_args arg_checker res_ty ...@@ -688,8 +688,7 @@ tcIdApp fun_name n_args arg_checker res_ty
; let res_subst = zipOpenTvSubst qtvs qtys'' ; let res_subst = zipOpenTvSubst qtvs qtys''
fun_res_ty'' = substTy res_subst fun_res_ty fun_res_ty'' = substTy res_subst fun_res_ty
res_ty'' = mkFunTys extra_arg_tys'' res_ty res_ty'' = mkFunTys extra_arg_tys'' res_ty
; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_res_ty'') $ ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
tcSubExp fun_res_ty'' res_ty''
-- And pack up the results -- And pack up the results
-- By applying the coercion just to the *function* we can make -- By applying the coercion just to the *function* we can make
...@@ -739,8 +738,7 @@ tcId orig fun_name res_ty ...@@ -739,8 +738,7 @@ tcId orig fun_name res_ty
; let res_subst = zipTopTvSubst qtvs qtv_tys ; let res_subst = zipTopTvSubst qtvs qtv_tys
fun_tau' = substTy res_subst fun_tau fun_tau' = substTy res_subst fun_tau
; co_fn <- addErrCtxtM (checkFunResCtxt fun_name res_ty fun_tau') $ ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
tcSubExp fun_tau' res_ty
-- And pack up the results -- And pack up the results
; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs ; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs
...@@ -895,29 +893,6 @@ tcArg :: LHsExpr Name -- The function (for error messages) ...@@ -895,29 +893,6 @@ tcArg :: LHsExpr Name -- The function (for error messages)
-> TcM (LHsExpr TcId) -- Resulting argument -> TcM (LHsExpr TcId) -- Resulting argument
tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
tcPolyExprNC arg ty tcPolyExprNC arg ty
----------------
-- If an error happens we try to figure out whether the
-- function has been given too many or too few arguments,
-- and say so.
checkFunResCtxt fun expected_res_ty actual_res_ty tidy_env
= zonkTcType expected_res_ty `thenM` \ exp_ty' ->
zonkTcType actual_res_ty `thenM` \ act_ty' ->
let
(env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
(env2, act_ty'') = tidyOpenType env1 act_ty'
(exp_args, _) = tcSplitFunTys exp_ty''
(act_args, _) = tcSplitFunTys act_ty''
len_act_args = length act_args
len_exp_args = length exp_args
message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun
| len_exp_args > len_act_args = wrongArgsCtxt "too many" fun
| otherwise = empty
in
returnM (env2, message)
\end{code} \end{code}
...@@ -1191,11 +1166,6 @@ missingFields con fields ...@@ -1191,11 +1166,6 @@ missingFields con fields
callCtxt fun args callCtxt fun args
= ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args)) = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
wrongArgsCtxt too_many_or_few fun
= ptext SLIT("Probable cause:") <+> quotes (ppr fun)
<+> ptext SLIT("is applied to") <+> text too_many_or_few
<+> ptext SLIT("arguments")
#ifdef GHCI #ifdef GHCI
polySpliceErr :: Id -> SDoc polySpliceErr :: Id -> SDoc
polySpliceErr id polySpliceErr id
......
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment