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 (HsVar con) rbinds) res_ty
- = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+tcExpr (RecordCon con rbinds) res_ty
+ = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
+ tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTy con_tau
in
unifyTauTy record_ty res_ty `thenTc_`
-- Check that the record bindings match the constructor
- tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
let
bad_fields = badFields rbinds con_id
in
-- doesn't match the constructor.)
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
- returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie)
+ returnTc (RecordConOut (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
-- The main complication with RecordUpd is that we need to explicitly
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
let
(sig_theta, sig_tau) = splitRhoTy sig_rho
in
- ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
-- Type-check the arg and unify with expected type
tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
- tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
- tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
- checkSigTyVars sig_tyvars sig_tau
- ) `thenTc_`
+ tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
+ tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
- -- Check that there's no overloading involved
- -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
- -- but which, on simplification, don't actually need a dictionary involving
- -- the tyvar. So we have to do a proper simplification right here.
- tcSimplifyRank2 (mkTyVarSet sig_tyvars)
- lie_arg `thenTc` \ (free_insts, inst_binds) ->
+ checkSigTyVars sig_tyvars sig_tau `thenTc_`
+ newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ -- ToDo: better origin
+ tcSimplifyAndCheck
+ (mkTyVarSet sig_tyvars) -- No need to zonk the tyvars because
+ -- they won't be bound to anything
+ sig_dicts lie_arg `thenTc` \ (lie', inst_binds) ->
-- This HsLet binds any Insts which came out of the simplification.
-- It's a bit out of place here, but using AbsBind involves inventing
-- a couple of new names which seems worse.
- returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
- )
+ returnTc ( TyLam sig_tyvars $
+ DictLam dict_ids $
+ HsLet (mk_binds inst_binds) arg'
+ , lie')
where
mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
\end{code}
else
-- Yes, it's overloaded
newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
- instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ tc_id_occ arg_tys theta tau `thenNF_Tc` \ (lie1, meth_id) ->
+ instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
-> TcM s (thing, LIE s)
tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
+ = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
stmt_lie `plusLIE` thing_lie)
tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
+ = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
stmt_lie `plusLIE` thing_lie)
tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
+ = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
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 ListComp stmt sty
- = hang (ptext SLIT("In a list-comprehension qualifer:"))
- 4 (ppr sty stmt)
-
-stmtCtxt DoStmt stmt sty
- = hang (ptext SLIT("In a do statement:"))
+stmtCtxt do_or_lc stmt sty
+ = hang (ptext SLIT("In a") <+> whatever <> colon)
4 (ppr sty stmt)
+ where
+ whatever = case do_or_lc of
+ ListComp -> ptext SLIT("list-comprehension qualifier")
+ DoStmt -> ptext SLIT("do statement")
+ Guard -> ptext SLIT("guard")
tooManyArgsCtxt f sty
= 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,",
ptext SLIT("so that the result type has for-alls in it")])
rank2ArgCtxt arg expected_arg_ty sty
- = hang (ptext SLIT("In a polymorphic function argument:"))
- 4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
- ppr sty expected_arg_ty])
+ = ptext SLIT("In a polymorphic function argument") <+> ppr sty arg
badFieldsUpd rbinds sty
= hang (ptext SLIT("No constructor has all these fields:"))
projects / ghc-hetmet.git / blobdiff