import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
HsBinds(..), Stmt(..), DoOrListComp(..),
- pprParendExpr, failureFreePat, collectPatBinders
+ failureFreePat, collectPatBinders
)
import RnHsSyn ( RenamedHsExpr,
RenamedStmt, RenamedRecordBinds
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
-import TcBinds ( tcBindsAndThen, checkSigTyVars, sigThetaCtxt )
+import TcBinds ( tcBindsAndThen, checkSigTyVars )
import TcEnv ( TcIdOcc(..), tcInstId,
tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
+ tcLookupGlobalValueByKey, newMonoIds,
tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
tcLookupTyCon
)
import TcType ( TcType, TcMaybe(..),
tcInstType, tcInstSigTcType, tcInstTyVars,
tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
- newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
+ newTyVarTy, newTyVarTys, zonkTcType )
import TcKind ( TcKind )
import Class ( Class )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
isRecordSelector,
- Id, GenId
+ Id
)
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( Name{-instance Eq-} )
-import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
+import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
splitFunTy_maybe, splitFunTys,
mkTyConApp,
splitForAllTys, splitRhoTy, splitSigmaTy,
- isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes,
+ isTauTy, tyVarsOfType, tyVarsOfTypes,
splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe
)
-import TyVar ( TyVarSet, emptyTyVarEnv, zipTyVarEnv,
- unionTyVarSets, elementOfTyVarSet, mkTyVarSet, tyVarSetToList
+import TyVar ( emptyTyVarEnv, zipTyVarEnv,
+ elementOfTyVarSet, mkTyVarSet, tyVarSetToList
)
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy, realWorldTy
- )
-import TysWiredIn ( addrTy, mkTupleTy,
- boolTy, charTy, stringTy, mkListTy
+ floatPrimTy, addrPrimTy
)
+import TysWiredIn ( boolTy, charTy, stringTy )
import PrelInfo ( ioTyCon_NAME )
-import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
- unifyFunTy, unifyListTy, unifyTupleTy
- )
+import Unify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
)
import Outputable
-import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
import ListSetOps ( minusList )
import Util
\begin{code}
tcExpr (HsVar name) res_ty
= tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
- unifyTauTy id_ty res_ty `thenTc_`
+ unifyTauTy res_ty id_ty `thenTc_`
-- 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
\begin{code}
tcExpr (HsLit lit@(HsCharPrim c)) res_ty
- = unifyTauTy charPrimTy res_ty `thenTc_`
+ = unifyTauTy res_ty charPrimTy `thenTc_`
returnTc (HsLitOut lit charPrimTy, emptyLIE)
tcExpr (HsLit lit@(HsStringPrim s)) res_ty
- = unifyTauTy addrPrimTy res_ty `thenTc_`
+ = unifyTauTy res_ty addrPrimTy `thenTc_`
returnTc (HsLitOut lit addrPrimTy, emptyLIE)
tcExpr (HsLit lit@(HsIntPrim i)) res_ty
- = unifyTauTy intPrimTy res_ty `thenTc_`
+ = unifyTauTy res_ty intPrimTy `thenTc_`
returnTc (HsLitOut lit intPrimTy, emptyLIE)
tcExpr (HsLit lit@(HsFloatPrim f)) res_ty
- = unifyTauTy floatPrimTy res_ty `thenTc_`
+ = unifyTauTy res_ty floatPrimTy `thenTc_`
returnTc (HsLitOut lit floatPrimTy, emptyLIE)
tcExpr (HsLit lit@(HsDoublePrim d)) res_ty
- = unifyTauTy doublePrimTy res_ty `thenTc_`
+ = unifyTauTy res_ty doublePrimTy `thenTc_`
returnTc (HsLitOut lit doublePrimTy, emptyLIE)
\end{code}
\begin{code}
tcExpr (HsLit lit@(HsChar c)) res_ty
- = unifyTauTy charTy res_ty `thenTc_`
+ = unifyTauTy res_ty charTy `thenTc_`
returnTc (HsLitOut lit charTy, emptyLIE)
tcExpr (HsLit lit@(HsString str)) res_ty
- = unifyTauTy stringTy res_ty `thenTc_`
+ = unifyTauTy res_ty stringTy `thenTc_`
returnTc (HsLitOut lit stringTy, emptyLIE)
\end{code}
tcExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
= tcExpr expr res_ty
-tcExpr (NegApp expr neg) res_ty = tcExpr (HsApp neg expr) res_ty
+-- perform the negate *before* overloading the integer, since the case
+-- of minBound on Ints fails otherwise. Could be done elsewhere, but
+-- convenient to do it here.
+
+tcExpr (NegApp (HsLit (HsInt i)) neg) res_ty
+ = tcExpr (HsLit (HsInt (-i))) res_ty
+
+tcExpr (NegApp expr neg) res_ty
+ = tcExpr (HsApp neg expr) res_ty
tcExpr (HsLam match) res_ty
= tcMatchExpected [] res_ty match `thenTc` \ (match',lie) ->
tcAddErrCtxt (sectionRAppCtxt in_expr) $
split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
tcExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
- unifyTauTy (mkFunTy arg1_ty op_res_ty) res_ty `thenTc_`
+ unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
\end{code}
io_result_ty = mkTyConApp ioTyCon [result_ty]
in
case tyConDataCons ioTyCon of { [ioDataCon] ->
- unifyTauTy io_result_ty res_ty `thenTc_`
+ unifyTauTy res_ty io_result_ty `thenTc_`
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
returnTc (expr', lie)
combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
-tcExpr in_expr@(HsCase expr matches src_loc) res_ty
- = tcAddSrcLoc src_loc $
- newTyVarTy mkTypeKind `thenNF_Tc` \ expr_ty ->
- tcExpr expr expr_ty `thenTc` \ (expr',lie1) ->
+tcExpr in_expr@(HsCase scrut matches src_loc) res_ty
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (caseCtxt in_expr) $
- tcAddErrCtxt (caseCtxt in_expr) $
- tcMatchesCase (mkFunTy expr_ty res_ty) matches
- `thenTc` \ (matches',lie2) ->
+ -- 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
- returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2)
+ tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
+
+ tcAddErrCtxt (caseScrutCtxt scrut) (
+ tcExpr scrut scrut_ty
+ ) `thenTc` \ (scrut',lie1) ->
+
+ returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
tcExpr (HsIf pred b1 b2 src_loc) res_ty
= tcAddSrcLoc src_loc $
in
-- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
- unifyTauTy record_ty res_ty `thenTc_`
+ unifyTauTy res_ty record_ty `thenTc_`
-- Check that the record bindings match the constructor
let
let
result_record_ty = mkTyConApp tycon result_inst_tys
in
- unifyTauTy result_record_ty res_ty `thenTc_`
+ unifyTauTy res_ty result_record_ty `thenTc_`
tcRecordBinds result_record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
-- STEP 4
-- Check overloading constraints
newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
- tcAddErrCtxtM (sigThetaCtxt sig_dicts) (
- tcSimplifyAndCheck
- (text "expr ty sig")
+ tcSimplifyAndCheck
+ (ptext SLIT("the type signature") <+> quotes (ppr sigma_sig))
(mkTyVarSet zonked_sig_tyvars)
sig_dicts lie
- ) `thenTc_`
+ `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_`
+ unifyTauTy res_ty sig_tau' `thenTc_`
-- If everything is ok, return the stuff unchanged, except for
-- the effect of any substutions etc. We simply discard the
tcArg the_fun (arg, expected_arg_ty, arg_no)
= tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
- tcPolyExpr arg expected_arg_ty
+ tcPolyExpr (ptext SLIT("argument type of") <+> quotes (ppr the_fun))
+ arg expected_arg_ty
-- tcPolyExpr is like tcExpr, except that the expected type
-- can be a polymorphic one.
-tcPolyExpr arg expected_arg_ty
+tcPolyExpr :: SDoc -- Just for error messages
+ -> RenamedHsExpr
+ -> TcType s -- Expected type
+ -> TcM s (TcExpr s, LIE s) -- Resulting type and LIE
+
+tcPolyExpr str arg expected_arg_ty
| not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
= -- The ordinary, non-rank-2 polymorphic case
tcExpr arg expected_arg_ty
-- 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 (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
- newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
- tcAddErrCtxtM (sigThetaCtxt sig_dicts) $
- tcSimplifyAndCheck (text "rank2")
+ tcSimplifyAndCheck
+ str
(mkTyVarSet zonked_sig_tyvars)
sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
HsLet (MonoBind inst_binds [] Recursive)
arg'
, free_insts
- )
+ )
\end{code}
%************************************************************************
combine_stmts stmt _ (stmts, ty) = (stmt:stmts, ty)
in
tc_stmts stmts `thenTc` \ ((stmts', result_ty), final_lie) ->
- unifyTauTy result_ty res_ty `thenTc_`
+ unifyTauTy res_ty result_ty `thenTc_`
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
Just (record_ty, field_ty) = splitFunTy_maybe tau
in
unifyTauTy expected_record_ty record_ty `thenTc_`
- tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie) ->
+ tcPolyExpr (ptext SLIT("type of field") <+> quotes (ppr field_label))
+ rhs field_ty `thenTc` \ (rhs', lie) ->
returnTc ((RealId sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
caseCtxt expr
= hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
+caseScrutCtxt expr
+ = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
+
exprSigCtxt expr
= hang (ptext SLIT("In an expression with a type signature:"))
4 (ppr expr)
= hang (ptext SLIT("Probable cause:") <+> ppr fun
<+> ptext SLIT("is applied to") <+> text too_many_or_few
<+> ptext SLIT("arguments in the call"))
- 4 (ppr the_app)
+ 4 (parens (ppr the_app))
where
the_app = foldl HsApp fun args -- Used in error messages
projects / ghc-hetmet.git / blobdiff