boolTy, charTy, stringTy, mkListTy,
mkTupleTy, mkPrimIoTy, stDataCon
)
-import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
+import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
+ unifyFunTy, unifyListTy, unifyTupleTy
+ )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
tcExpr expr elt_ty
tcExpr (ExplicitTuple exprs) res_ty
- -- ToDo: more direct way of testing if res_ty is a tuple type (cf. unifyListTy)?
- = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..len] `thenNF_Tc` \ ty_vars ->
- unifyTauTy (mkTupleTy len ty_vars) res_ty `thenTc_`
- mapAndUnzipTc (\ (expr,ty_var) -> tcExpr expr ty_var)
- (exprs `zip` ty_vars) -- we know they're of equal length.
+ = unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
+ mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
+ (exprs `zip` arg_tys) -- we know they're of equal length.
`thenTc` \ (exprs', lies) ->
returnTc (ExplicitTuple exprs', plusLIEs lies)
- where
- len = length exprs
tcExpr (RecordCon con rbinds) res_ty
= tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
tcExpr (ArithSeqIn seq@(From expr)) res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
- tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
+ tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
let
(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
in
- unifyTauTy sig_tau' res_ty `thenTc_`
- -- Type check the expression, *after* we've incorporated the signature
- -- info into res_ty
- tcExpr expr res_ty `thenTc` \ (texpr, lie) ->
+ -- Type check the expression, expecting the signature type
+ tcExpr expr sig_tau' `thenTc` \ (texpr, lie) ->
-- Check the type variables of the signature,
-- *after* typechecking the expression
(mkTyVarSet sig_tyvars')
sig_dicts lie `thenTc_`
+ -- Now match the signature type with res_ty.
+ -- We must not do this earlier, because res_ty might well
+ -- mention variables free in the environment, and we'd get
+ -- bogus complaints about not being able to for-all the
+ -- sig_tyvars
+ unifyTauTy sig_tau' res_ty `thenTc_`
+
-- If everything is ok, return the stuff unchanged, except for
-- the effect of any substutions etc. We simply discard the
-- result of the tcSimplifyAndCheck, except for any default
other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
-
-
---ToDo: move to Unify?
-unifyListTy :: TcType s -- expected list type
- -> TcM s (TcType s) -- list element type
-unifyListTy res_ty
- -- ToDo: more direct way of testing if res_ty is a list type (cf. unifyFunTy)?
- = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy (mkListTy elt_ty) res_ty `thenTc_`
-
- -- This zonking makes the returned type as informative
- -- as possible.
- zonkTcType elt_ty `thenNF_Tc` \ elt_ty' ->
- returnTc elt_ty'
\end{code}
%************************************************************************
tcApp fun args res_ty
= -- First type-check the function
- tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
+ tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
tcAddErrCtxt (tooManyArgsCtxt fun) (
split_fun_ty fun_ty (length args)
- ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
+ ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
-- Unify with expected result before type-checking the args
- unifyTauTy res_ty actual_result_ty `thenTc_`
+ unifyTauTy res_ty actual_result_ty `thenTc_`
-- Now typecheck the args
- mapAndUnzipTc tcArg (zipEqual "tcApp" args expected_arg_tys) `thenTc` \ (args', lie_args_s) ->
+ mapAndUnzipTc (tcArg fun)
+ (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
-- Check that the result type doesn't have any nested for-alls.
-- For example, a "build" on its own is no good; it must be applied to something.
checkTc (isTauTy actual_result_ty)
- (lurkingRank2Err fun fun_ty) `thenTc_`
+ (lurkingRank2Err fun fun_ty) `thenTc_`
returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
\end{code}
\begin{code}
-tcArg :: (RenamedHsExpr, TcType s) -- Actual argument and expected arg type
+tcArg :: RenamedHsExpr -- The function (for error messages)
+ -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
-> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
+tcArg the_fun (arg, expected_arg_ty, arg_no)
+ = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
+ tcPolyExpr arg expected_arg_ty
+
-tcArg (arg,expected_arg_ty)
+-- tcPolyExpr is like tcExpr, except that the expected type
+-- can be a polymorphic one.
+tcPolyExpr arg expected_arg_ty
| not (maybeToBool (getForAllTy_maybe expected_arg_ty))
= -- The ordinary, non-rank-2 polymorphic case
tcExpr arg expected_arg_ty
Just (record_ty, field_ty) = getFunTy_maybe tau
in
unifyTauTy expected_record_ty record_ty `thenTc_`
- tcArg (rhs, field_ty) `thenTc` \ (rhs', lie) ->
+ tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) ->
returnTc ((RealId sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
sectionLAppCtxt expr sty
= hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
-funAppCtxt fun arg_no arg sty
- = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
- ppr sty fun <> text ", namely"])
- 4 (ppr sty arg)
-
stmtCtxt do_or_lc stmt sty
= hang (ptext SLIT("In a") <+> whatever <> colon)
4 (ppr sty stmt)
= hang (ptext SLIT("Too many arguments in an application of the function"))
4 (ppr sty f)
+funAppCtxt fun arg arg_no sty
+ = hang (hsep [ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
+ ppr sty fun <> text ", namely"])
+ 4 (ppr sty arg)
+
lurkingRank2Err fun fun_ty sty
= hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
4 (vcat [text "It is applied to too few arguments,",
projects / ghc-hetmet.git / blobdiff