2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcExpr]{Typecheck an expression}
7 #include "HsVersions.h"
9 module TcExpr ( tcExpr ) where
13 import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
14 HsBinds(..), Bind(..), MonoBinds(..),
15 ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
16 Match, Fake, InPat, OutPat, PolyType,
17 irrefutablePat, collectPatBinders )
18 import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
19 RenamedStmt(..), RenamedRecordBinds(..),
20 RnName{-instance Outputable-}
22 import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
23 TcIdOcc(..), TcRecordBinds(..),
27 import TcMonad hiding ( rnMtoTcM )
28 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
29 LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
30 newMethod, newMethodWithGivenTy, newDicts )
31 import TcBinds ( tcBindsAndThen )
32 import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
33 tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars
35 import TcMatches ( tcMatchesCase, tcMatch )
36 import TcMonoType ( tcPolyType )
37 import TcPat ( tcPat )
38 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
39 import TcType ( TcType(..), TcMaybe(..),
40 tcInstId, tcInstType, tcInstTheta, tcInstTyVars,
41 newTyVarTy, zonkTcTyVars, zonkTcType )
42 import TcKind ( TcKind )
44 import Class ( Class(..), classSig )
45 import FieldLabel ( fieldLabelName )
46 import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
47 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
48 import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
49 import Name ( Name{-instance Eq-} )
50 import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
51 floatPrimTy, addrPrimTy, addrTy,
52 boolTy, charTy, stringTy, mkListTy,
53 mkTupleTy, mkPrimIoTy )
54 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
55 getTyVar_maybe, getFunTy_maybe, instantiateTy,
56 splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
57 isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
58 getAppDataTyCon, maybeAppDataTyCon
60 import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
61 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
62 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
63 enumFromClassOpKey, enumFromThenClassOpKey,
64 enumFromToClassOpKey, enumFromThenToClassOpKey,
65 monadClassKey, monadZeroClassKey )
67 --import Name ( Name ) -- Instance
68 import Outputable ( interpp'SP )
69 import PprType ( GenType, GenTyVar ) -- Instances
70 import Maybes ( maybeToBool )
76 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
79 %************************************************************************
81 \subsection{The TAUT rules for variables}
83 %************************************************************************
87 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
89 -- Check that the result type doesn't have any nested for-alls.
90 -- For example, a "build" on its own is no good; it must be
91 -- applied to something.
92 checkTc (isTauTy res_ty)
93 (lurkingRank2Err name res_ty) `thenTc_`
95 returnTc (expr', lie, res_ty)
98 %************************************************************************
100 \subsection{Literals}
102 %************************************************************************
107 tcExpr (HsLit (HsInt i))
108 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
110 newOverloadedLit (LiteralOrigin (HsInt i))
111 (OverloadedIntegral i)
112 ty `thenNF_Tc` \ (lie, over_lit_id) ->
114 returnTc (HsVar over_lit_id, lie, ty)
116 tcExpr (HsLit (HsFrac f))
117 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
119 newOverloadedLit (LiteralOrigin (HsFrac f))
120 (OverloadedFractional f)
121 ty `thenNF_Tc` \ (lie, over_lit_id) ->
123 returnTc (HsVar over_lit_id, lie, ty)
125 tcExpr (HsLit lit@(HsLitLit s))
126 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
127 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
128 newDicts (LitLitOrigin (_UNPK_ s))
129 [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
130 returnTc (HsLitOut lit ty, dicts, ty)
136 tcExpr (HsLit lit@(HsCharPrim c))
137 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
139 tcExpr (HsLit lit@(HsStringPrim s))
140 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
142 tcExpr (HsLit lit@(HsIntPrim i))
143 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
145 tcExpr (HsLit lit@(HsFloatPrim f))
146 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
148 tcExpr (HsLit lit@(HsDoublePrim d))
149 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
152 Unoverloaded literals:
155 tcExpr (HsLit lit@(HsChar c))
156 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
158 tcExpr (HsLit lit@(HsString str))
159 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
162 %************************************************************************
164 \subsection{Other expression forms}
166 %************************************************************************
169 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
172 tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr)
175 = tcMatch match `thenTc` \ (match',lie,ty) ->
176 returnTc (HsLam match', lie, ty)
178 tcExpr (HsApp e1 e2) = accum e1 [e2]
180 accum (HsApp e1 e2) args = accum e1 (e2:args)
182 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
183 returnTc (foldl HsApp fun' args', lie, res_ty)
185 -- equivalent to (op e1) e2:
186 tcExpr (OpApp arg1 op arg2)
187 = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
188 returnTc (OpApp arg1' op' arg2', lie, res_ty)
191 Note that the operators in sections are expected to be binary, and
192 a type error will occur if they aren't.
195 -- Left sections, equivalent to
202 tcExpr in_expr@(SectionL arg op)
203 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
205 -- Check that res_ty is a function type
206 -- Without this check we barf in the desugarer on
208 -- because it tries to desugar to
209 -- f op = \r -> 3 op r
210 -- so (3 `op`) had better be a function!
211 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
212 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
213 tcAddErrCtxt (sectionLAppCtxt in_expr) $
214 unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
216 returnTc (SectionL arg' op', lie, res_ty)
218 -- Right sections, equivalent to \ x -> x op expr, or
221 tcExpr in_expr@(SectionR op expr)
222 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
223 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
225 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
226 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
227 tcAddErrCtxt (sectionRAppCtxt in_expr) $
228 unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
230 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
233 The interesting thing about @ccall@ is that it is just a template
234 which we instantiate by filling in details about the types of its
235 argument and result (ie minimal typechecking is performed). So, the
236 basic story is that we allocate a load of type variables (to hold the
237 arg/result types); unify them with the args/result; and store them for
241 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
242 = -- Get the callable and returnable classes.
243 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
244 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
247 new_arg_dict (arg, arg_ty)
248 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
249 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
250 returnNF_Tc arg_dicts -- Actually a singleton bag
252 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
256 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
258 -- The argument types can be unboxed or boxed; the result
259 -- type must, however, be boxed since it's an argument to the PrimIO
261 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
263 -- Construct the extra insts, which encode the
264 -- constraints on the argument and result types.
265 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
266 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
268 returnTc (CCall lbl args' may_gc is_asm result_ty,
269 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
270 mkPrimIoTy result_ty)
274 tcExpr (HsSCC label expr)
275 = tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
276 -- No unification. Give SCC the type of expr
277 returnTc (HsSCC label expr', lie, expr_ty)
279 tcExpr (HsLet binds expr)
281 HsLet -- The combiner
282 binds -- Bindings to check
283 (tcExpr expr) -- Typechecker for the expression
285 tcExpr in_expr@(HsCase expr matches src_loc)
286 = tcAddSrcLoc src_loc $
287 tcExpr expr `thenTc` \ (expr',lie1,expr_ty) ->
288 newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
290 tcAddErrCtxt (caseCtxt in_expr) $
291 tcMatchesCase (mkFunTy expr_ty result_ty) matches
292 `thenTc` \ (matches',lie2) ->
294 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
296 tcExpr (HsIf pred b1 b2 src_loc)
297 = tcAddSrcLoc src_loc $
298 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
300 tcAddErrCtxt (predCtxt pred) (
301 unifyTauTy predTy boolTy
304 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
305 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
307 tcAddErrCtxt (branchCtxt b1 b2) $
308 unifyTauTy result_ty b2Ty `thenTc_`
310 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
312 tcExpr (ListComp expr quals)
313 = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
314 returnTc (ListComp expr' quals', lie, ty)
318 tcExpr (HsDo stmts src_loc)
319 = -- get the Monad and MonadZero classes
320 -- create type consisting of a fresh monad tyvar
321 tcAddSrcLoc src_loc $
322 newTyVarTy monadKind `thenNF_Tc` \ m ->
323 tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
325 -- create dictionaries for monad and possibly monadzero
327 tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
328 newDicts DoOrigin [(monadClass, m)]
330 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
331 ) `thenNF_Tc` \ (m_lie, [m_id]) ->
333 tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
334 newDicts DoOrigin [(monadZeroClass, m)]
336 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
337 ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
339 returnTc (HsDoOut stmts' m_id mz_id src_loc,
340 lie `plusLIE` m_lie `plusLIE` mz_lie,
343 monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
347 tcExpr (ExplicitList [])
348 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
349 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
352 tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
353 = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
354 tcAddErrCtxt (listCtxt in_expr) $
355 unifyTauTyList tys `thenTc_`
356 returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
358 tcExpr (ExplicitTuple exprs)
359 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
360 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
362 tcExpr (RecordCon (HsVar con) rbinds)
363 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
365 (_, record_ty) = splitFunTy con_tau
367 -- Con is syntactically constrained to be a data constructor
368 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
370 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
372 -- Check that the record bindings match the constructor
373 tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
374 checkTc (checkRecordFields rbinds con_id)
375 (badFieldsCon con rbinds) `thenTc_`
377 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
379 -- One small complication in RecordUpd is that we have to generate some
380 -- dictionaries for the data type context, since we are going to
381 -- do some construction.
383 -- What dictionaries do we need? For the moment we assume that all
384 -- data constructors have the same context, and grab it from the first
385 -- constructor. If they have varying contexts then we'd have to
386 -- union the ones that could participate in the update.
388 tcExpr (RecordUpd record_expr rbinds)
389 = ASSERT( not (null rbinds) )
390 tcAddErrCtxt recordUpdCtxt $
392 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
393 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
395 -- Check that the field names are plausible
396 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
398 (tycon, inst_tys, data_cons) = _trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
399 -- The record binds are non-empty (syntax); so at least one field
400 -- label will have been unified with record_ty by tcRecordBinds;
401 -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
402 (tyvars, theta, _, _) = dataConSig (head data_cons)
404 tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
405 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
406 checkTc (any (checkRecordFields rbinds) data_cons)
407 (badFieldsUpd rbinds) `thenTc_`
409 returnTc (RecordUpdOut record_expr' dicts rbinds',
410 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
413 tcExpr (ArithSeqIn seq@(From expr))
414 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
416 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
417 newMethod (ArithSeqOrigin seq)
418 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
420 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
424 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
425 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
426 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
428 tcAddErrCtxt (arithSeqCtxt in_expr) $
429 unifyTauTyList [ty1, ty2] `thenTc_`
431 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
432 newMethod (ArithSeqOrigin seq)
433 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
435 returnTc (ArithSeqOut (HsVar enum_from_then_id)
436 (FromThen expr1' expr2'),
437 lie1 `plusLIE` lie2 `plusLIE` lie3,
440 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
441 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
442 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
444 tcAddErrCtxt (arithSeqCtxt in_expr) $
445 unifyTauTyList [ty1,ty2] `thenTc_`
447 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
448 newMethod (ArithSeqOrigin seq)
449 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
451 returnTc (ArithSeqOut (HsVar enum_from_to_id)
452 (FromTo expr1' expr2'),
453 lie1 `plusLIE` lie2 `plusLIE` lie3,
456 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
457 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
458 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
459 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
461 tcAddErrCtxt (arithSeqCtxt in_expr) $
462 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
464 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
465 newMethod (ArithSeqOrigin seq)
466 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
468 returnTc (ArithSeqOut (HsVar eft_id)
469 (FromThenTo expr1' expr2' expr3'),
470 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
474 %************************************************************************
476 \subsection{Expressions type signatures}
478 %************************************************************************
481 tcExpr in_expr@(ExprWithTySig expr poly_ty)
482 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
483 tcPolyType poly_ty `thenTc` \ sigma_sig ->
485 -- Check the tau-type part
486 tcSetErrCtxt (exprSigCtxt in_expr) $
487 tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
489 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
491 unifyTauTy tau_ty sig_tau' `thenTc_`
493 -- Check the type variables of the signature
494 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
496 -- Check overloading constraints
497 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
499 (mkTyVarSet sig_tyvars')
500 sig_dicts lie `thenTc_`
502 -- If everything is ok, return the stuff unchanged, except for
503 -- the effect of any substutions etc. We simply discard the
504 -- result of the tcSimplifyAndCheck, except for any default
505 -- resolution it may have done, which is recorded in the
507 returnTc (texpr, lie, tau_ty)
510 %************************************************************************
512 \subsection{@tcApp@ typchecks an application}
514 %************************************************************************
517 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
518 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
520 TcType s) -- Type of the application
523 = -- First type-check the function
524 -- In the HsVar case we go straight to tcId to avoid hitting the
525 -- rank-2 check, which we check later here anyway
527 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
529 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
531 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
533 -- Check that the result type doesn't have any nested for-alls.
534 -- For example, a "build" on its own is no good; it must be applied to something.
535 checkTc (isTauTy res_ty)
536 (lurkingRank2Err fun fun_ty) `thenTc_`
538 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
541 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
542 -> TcType s -- The type of the function
543 -> [RenamedHsExpr] -- Arguments
544 -> TcM s ([TcExpr s], -- Typechecked args
546 TcType s) -- Result type of the application
548 tcApp_help orig_fun arg_no fun_ty []
549 = returnTc ([], emptyLIE, fun_ty)
551 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
552 = -- Expect the function to have type A->B
553 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
555 ) `thenTc` \ (expected_arg_ty, result_ty) ->
557 -- Type check the argument
558 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
559 tcArg expected_arg_ty arg
560 ) `thenTc` \ (arg', lie_arg) ->
563 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
566 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
571 tcArg :: TcType s -- Expected arg type
572 -> RenamedHsExpr -- Actual argument
573 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
575 tcArg expected_arg_ty arg
576 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
577 = -- The ordinary, non-rank-2 polymorphic case
578 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
579 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
580 returnTc (arg', lie_arg)
583 = -- Ha! The argument type of the function is a for-all type,
584 -- An example of rank-2 polymorphism.
586 -- No need to instantiate the argument type... it's must be the result
587 -- of instantiating a function involving rank-2 polymorphism, so there
588 -- isn't any danger of using the same tyvars twice
589 -- The argument type shouldn't be overloaded type (hence ASSERT)
591 (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
593 ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
595 -- Type-check the arg and unify with expected type
596 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
597 unifyTauTy expected_tau actual_arg_ty `thenTc_` (
599 -- Check that the arg_tyvars havn't been constrained
600 -- The interesting bit here is that we must include the free variables
601 -- of the expected arg ty. Here's an example:
602 -- runST (newVar True)
603 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
604 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
605 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
606 -- So now s' isn't unconstrained because it's linked to a.
607 -- Conclusion: include the free vars of the expected arg type in the
608 -- list of "free vars" for the signature check.
609 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
610 tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
611 zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
612 checkSigTyVarsGivenGlobals
613 (env_tyvars `unionTyVarSets` free_tyvars)
614 expected_tyvars expected_tau `thenTc_`
616 -- Check that there's no overloading involved
617 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
618 -- but which, on simplification, don't actually need a dictionary involving
619 -- the tyvar. So we have to do a proper simplification right here.
620 tcSimplifyRank2 (mkTyVarSet expected_tyvars)
621 lie_arg `thenTc` \ (free_insts, inst_binds) ->
623 -- This HsLet binds any Insts which came out of the simplification.
624 -- It's a bit out of place here, but using AbsBind involves inventing
625 -- a couple of new names which seems worse.
626 returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
630 mk_binds [] = EmptyBinds
631 mk_binds ((inst,rhs):inst_binds)
632 = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
636 %************************************************************************
638 \subsection{@tcId@ typchecks an identifier occurrence}
640 %************************************************************************
643 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
646 = -- Look up the Id and instantiate its type
647 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
651 (tyvars, rho) = splitForAllTy (idType tc_id)
653 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) ->
655 rho' = instantiateTy tenv rho
657 returnNF_Tc (TcId tc_id, arg_tys', rho')
659 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
661 (tyvars, rho) = splitForAllTy (idType id)
663 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
664 tcInstType tenv rho `thenNF_Tc` \ rho' ->
665 returnNF_Tc (RealId id, arg_tys, rho')
667 ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
670 case splitRhoTy rho of
671 ([], tau) -> -- Not overloaded, so just make a type application
672 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
674 (theta, tau) -> -- Overloaded, so make a Method inst
675 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
676 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
677 returnNF_Tc (HsVar meth_id, lie, tau)
682 %************************************************************************
684 \subsection{@tcQuals@ typchecks list comprehension qualifiers}
686 %************************************************************************
690 = tcExpr expr `thenTc` \ (expr', lie, ty) ->
691 returnTc ((expr',[]), lie, mkListTy ty)
693 tcListComp expr (qual@(FilterQual filter) : quals)
694 = tcAddErrCtxt (qualCtxt qual) (
695 tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) ->
696 unifyTauTy boolTy filter_ty `thenTc_`
697 returnTc (FilterQual filter', filter_lie)
698 ) `thenTc` \ (qual', qual_lie) ->
700 tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
702 returnTc ((expr', qual' : quals'),
703 qual_lie `plusLIE` rest_lie,
706 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
707 = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
709 tcAddErrCtxt (qualCtxt qual) (
710 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
711 tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
712 -- NB: the environment has been extended with the new binders
713 -- which the rhs can't "see", but the renamer should have made
714 -- sure that everything is distinct by now, so there's no problem.
715 -- Putting the tcExpr before the newMonoIds messes up the nesting
716 -- of error contexts, so I didn't bother
718 unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
719 returnTc (GeneratorQual pat' rhs',
720 lie_pat `plusLIE` lie_rhs)
721 ) `thenTc` \ (qual', lie_qual) ->
723 tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
725 returnTc ((expr', qual' : quals'),
726 lie_qual `plusLIE` lie_rest,
730 binder_names = collectPatBinders pat
732 tcListComp expr (LetQual binds : quals)
733 = tcBindsAndThen -- No error context, but a binding group is
734 combine -- rather a large thing for an error context anyway
736 (tcListComp expr quals)
738 combine binds' (expr',quals') = (expr', LetQual binds' : quals')
742 %************************************************************************
744 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
746 %************************************************************************
749 tcDoStmts :: Bool -- True => require a monad
752 -> TcM s (([TcStmt s],
753 Bool, -- True => Monad
754 Bool), -- True => MonadZero
758 tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
759 = tcAddSrcLoc src_loc $
760 tcSetErrCtxt (stmtCtxt stmt) $
761 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
763 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
764 unifyTauTy (mkAppTy m a) exp_ty
768 returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
770 tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
771 = tcAddSrcLoc src_loc (
772 tcSetErrCtxt (stmtCtxt stmt) (
773 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
774 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
775 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
776 returnTc (ExprStmt exp' src_loc, exp_lie)
777 )) `thenTc` \ (stmt', stmt_lie) ->
778 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
779 returnTc ((stmt':stmts', True, mzero),
780 stmt_lie `plusLIE` stmts_lie,
783 tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
784 = tcAddSrcLoc src_loc (
785 tcSetErrCtxt (stmtCtxt stmt) (
786 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
787 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
788 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
789 unifyTauTy a pat_ty `thenTc_`
790 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
791 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
792 )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
793 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
794 returnTc ((stmt':stmts', True, mzero || not failure_free),
795 stmt_lie `plusLIE` stmts_lie,
798 tcDoStmts monad m (LetStmt binds : stmts)
799 = tcBindsAndThen -- No error context, but a binding group is
800 combine -- rather a large thing for an error context anyway
802 (tcDoStmts monad m stmts)
804 combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
808 Game plan for record bindings
809 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
812 1. look up "field", to find its selector Id, which must have type
813 forall a1..an. T a1 .. an -> tau
814 where tau is the type of the field.
816 2. Instantiate this type
818 3. Unify the (T a1 .. an) part with the "expected result type", which
819 is passed in. This checks that all the field labels come from the
822 4. Type check the value using tcArg, passing tau as the expected
825 This extends OK when the field types are universally quantified.
827 Actually, to save excessive creation of fresh type variables,
832 :: TcType s -- Expected type of whole record
833 -> RenamedRecordBinds
834 -> TcM s (TcRecordBinds s, LIE s)
836 tcRecordBinds expected_record_ty rbinds
837 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
838 returnTc (rbinds', plusLIEs lies)
840 do_bind (field_label, rhs, pun_flag)
841 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
842 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
844 -- Record selectors all have type
845 -- forall a1..an. T a1 .. an -> tau
846 ASSERT( maybeToBool (getFunTy_maybe tau) )
848 -- Selector must have type RecordType -> FieldType
849 Just (record_ty, field_ty) = getFunTy_maybe tau
851 unifyTauTy expected_record_ty record_ty `thenTc_`
852 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
853 returnTc ((RealId sel_id, rhs', pun_flag), lie)
855 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
856 -- RecordBinds are field of the
857 -- specified constructor
858 checkRecordFields rbinds data_con
861 data_con_fields = dataConFieldLabels data_con
863 ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
865 match field_name field_label = field_name == fieldLabelName field_label
868 %************************************************************************
870 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
872 %************************************************************************
875 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
877 tcExprs [] = returnTc ([], emptyLIE, [])
879 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
880 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
881 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
885 % =================================================
892 pp_nest_hang :: String -> Pretty -> Pretty
893 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
896 Boring and alphabetical:
898 arithSeqCtxt expr sty
899 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
902 = ppSep [ppStr "In the branches of a conditional:",
903 pp_nest_hang "`then' branch:" (ppr sty b1),
904 pp_nest_hang "`else' branch:" (ppr sty b2)]
907 = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
910 = ppHang (ppStr "In an expression with a type signature:")
914 = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
917 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
919 sectionRAppCtxt expr sty
920 = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
922 sectionLAppCtxt expr sty
923 = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
925 funAppCtxt fun arg_no arg sty
926 = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
927 4 (ppCat [ppStr "namely", ppr sty arg])
930 = ppHang (ppStr "In a list-comprehension qualifer:")
934 = ppHang (ppStr "In a do statement:")
937 tooManyArgsCtxt f sty
938 = ppHang (ppStr "Too many arguments in an application of the function")
941 lurkingRank2Err fun fun_ty sty
942 = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
943 4 (ppAboves [ppStr "It is applied to too few arguments,",
944 ppStr "so that the result type has for-alls in it"])
946 rank2ArgCtxt arg expected_arg_ty sty
947 = ppHang (ppStr "In a polymorphic function argument:")
948 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
949 ppr sty expected_arg_ty])
951 badFieldsUpd rbinds sty
952 = ppHang (ppStr "No constructor has all these fields:")
953 4 (interpp'SP sty fields)
955 fields = [field | (field, _, _) <- rbinds]
957 recordUpdCtxt sty = ppStr "In a record update construct"
959 badFieldsCon con rbinds sty
960 = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
961 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
963 fields = [field | (field, _, _) <- rbinds]