2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcExpr]{Typecheck an expression}
7 #include "HsVersions.h"
9 module TcExpr ( tcExpr, tcId ) where
13 import HsSyn ( HsExpr(..), Stmt(..), DoOrListComp(..),
14 HsBinds(..), Bind(..), MonoBinds(..),
15 ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
16 Match, Fake, InPat, OutPat, HsType, Fixity,
17 pprParendExpr, failureFreePat, collectPatBinders )
18 import RnHsSyn ( SYN_IE(RenamedHsExpr),
19 SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
21 import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcStmt),
22 TcIdOcc(..), SYN_IE(TcRecordBinds),
27 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
28 SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
29 newMethod, newMethodWithGivenTy, newDicts )
30 import TcBinds ( tcBindsAndThen, checkSigTyVars )
31 import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
32 tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
35 import SpecEnv ( SpecEnv )
36 import TcMatches ( tcMatchesCase, tcMatch )
37 import TcMonoType ( tcHsType )
38 import TcPat ( tcPat )
39 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
40 import TcType ( SYN_IE(TcType), TcMaybe(..),
41 tcInstId, tcInstType, tcInstSigTcType,
42 tcInstSigType, tcInstTcType, tcInstTheta,
43 newTyVarTy, zonkTcTyVars, zonkTcType )
44 import TcKind ( TcKind )
46 import Class ( SYN_IE(Class), classSig )
47 import FieldLabel ( fieldLabelName )
48 import Id ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId )
49 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
50 import Name ( Name{-instance Eq-} )
51 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
52 getTyVar_maybe, getFunTy_maybe, instantiateTy,
53 splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
54 isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
55 getAppDataTyCon, maybeAppDataTyCon
57 import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
58 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
59 floatPrimTy, addrPrimTy, realWorldTy
61 import TysWiredIn ( addrTy,
62 boolTy, charTy, stringTy, mkListTy,
63 mkTupleTy, mkPrimIoTy, stDataCon
65 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
66 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
67 enumFromClassOpKey, enumFromThenClassOpKey,
68 enumFromToClassOpKey, enumFromThenToClassOpKey,
69 thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
71 import Outputable ( interpp'SP )
72 import PprType ( GenType, GenTyVar ) -- Instances
73 import Maybes ( maybeToBool )
79 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
82 %************************************************************************
84 \subsection{The TAUT rules for variables}
86 %************************************************************************
90 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
92 -- Check that the result type doesn't have any nested for-alls.
93 -- For example, a "build" on its own is no good; it must be
94 -- applied to something.
95 checkTc (isTauTy res_ty)
96 (lurkingRank2Err name res_ty) `thenTc_`
98 returnTc (expr', lie, res_ty)
101 %************************************************************************
103 \subsection{Literals}
105 %************************************************************************
110 tcExpr (HsLit (HsInt i))
111 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
113 newOverloadedLit (LiteralOrigin (HsInt i))
114 (OverloadedIntegral i)
115 ty `thenNF_Tc` \ (lie, over_lit_id) ->
117 returnTc (HsVar over_lit_id, lie, ty)
119 tcExpr (HsLit (HsFrac f))
120 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
122 newOverloadedLit (LiteralOrigin (HsFrac f))
123 (OverloadedFractional f)
124 ty `thenNF_Tc` \ (lie, over_lit_id) ->
126 returnTc (HsVar over_lit_id, lie, ty)
128 tcExpr (HsLit lit@(HsLitLit s))
129 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
130 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
131 newDicts (LitLitOrigin (_UNPK_ s))
132 [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
133 returnTc (HsLitOut lit ty, dicts, ty)
139 tcExpr (HsLit lit@(HsCharPrim c))
140 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
142 tcExpr (HsLit lit@(HsStringPrim s))
143 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
145 tcExpr (HsLit lit@(HsIntPrim i))
146 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
148 tcExpr (HsLit lit@(HsFloatPrim f))
149 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
151 tcExpr (HsLit lit@(HsDoublePrim d))
152 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
155 Unoverloaded literals:
158 tcExpr (HsLit lit@(HsChar c))
159 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
161 tcExpr (HsLit lit@(HsString str))
162 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
165 %************************************************************************
167 \subsection{Other expression forms}
169 %************************************************************************
172 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
175 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
178 = tcMatch match `thenTc` \ (match',lie,ty) ->
179 returnTc (HsLam match', lie, ty)
181 tcExpr (HsApp e1 e2) = accum e1 [e2]
183 accum (HsApp e1 e2) args = accum e1 (e2:args)
185 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
186 returnTc (foldl HsApp fun' args', lie, res_ty)
188 -- equivalent to (op e1) e2:
189 tcExpr (OpApp arg1 op fix arg2)
190 = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
191 returnTc (OpApp arg1' op' fix arg2', lie, res_ty)
194 Note that the operators in sections are expected to be binary, and
195 a type error will occur if they aren't.
198 -- Left sections, equivalent to
205 tcExpr in_expr@(SectionL arg op)
206 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
208 -- Check that res_ty is a function type
209 -- Without this check we barf in the desugarer on
211 -- because it tries to desugar to
212 -- f op = \r -> 3 op r
213 -- so (3 `op`) had better be a function!
214 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
215 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
216 tcAddErrCtxt (sectionLAppCtxt in_expr) $
217 unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
219 returnTc (SectionL arg' op', lie, res_ty)
221 -- Right sections, equivalent to \ x -> x op expr, or
224 tcExpr in_expr@(SectionR op expr)
225 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
226 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
228 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
229 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
230 tcAddErrCtxt (sectionRAppCtxt in_expr) $
231 unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty `thenTc_`
233 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
236 The interesting thing about @ccall@ is that it is just a template
237 which we instantiate by filling in details about the types of its
238 argument and result (ie minimal typechecking is performed). So, the
239 basic story is that we allocate a load of type variables (to hold the
240 arg/result types); unify them with the args/result; and store them for
244 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
245 = -- Get the callable and returnable classes.
246 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
247 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
250 new_arg_dict (arg, arg_ty)
251 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
252 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
253 returnNF_Tc arg_dicts -- Actually a singleton bag
255 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
259 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
261 -- The argument types can be unboxed or boxed; the result
262 -- type must, however, be boxed since it's an argument to the PrimIO
264 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
266 -- Construct the extra insts, which encode the
267 -- constraints on the argument and result types.
268 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
269 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
271 returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
272 (CCall lbl args' may_gc is_asm result_ty),
273 -- do the wrapping in the newtype constructor here
274 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
275 mkPrimIoTy result_ty)
279 tcExpr (HsSCC label expr)
280 = tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
281 -- No unification. Give SCC the type of expr
282 returnTc (HsSCC label expr', lie, expr_ty)
284 tcExpr (HsLet binds expr)
286 HsLet -- The combiner
287 binds -- Bindings to check
288 (tcExpr expr) -- Typechecker for the expression
290 tcExpr in_expr@(HsCase expr matches src_loc)
291 = tcAddSrcLoc src_loc $
292 tcExpr expr `thenTc` \ (expr',lie1,expr_ty) ->
293 newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
295 tcAddErrCtxt (caseCtxt in_expr) $
296 tcMatchesCase (mkFunTy expr_ty result_ty) matches
297 `thenTc` \ (matches',lie2) ->
299 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
301 tcExpr (HsIf pred b1 b2 src_loc)
302 = tcAddSrcLoc src_loc $
303 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
305 tcAddErrCtxt (predCtxt pred) (
306 unifyTauTy boolTy predTy
309 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
310 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
312 tcAddErrCtxt (branchCtxt b1 b2) $
313 unifyTauTy result_ty b2Ty `thenTc_`
315 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
319 tcExpr expr@(HsDo do_or_lc stmts src_loc)
320 = tcDoStmts do_or_lc stmts src_loc
324 tcExpr (ExplicitList [])
325 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
326 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
329 tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
330 = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
331 tcAddErrCtxt (listCtxt in_expr) $
332 unifyTauTyList tys `thenTc_`
333 returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
335 tcExpr (ExplicitTuple exprs)
336 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
337 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
339 tcExpr (RecordCon (HsVar con) rbinds)
340 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
342 (_, record_ty) = splitFunTy con_tau
344 -- Con is syntactically constrained to be a data constructor
345 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
347 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
349 -- Check that the record bindings match the constructor
350 tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
351 checkTc (checkRecordFields rbinds con_id)
352 (badFieldsCon con rbinds) `thenTc_`
354 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
356 -- One small complication in RecordUpd is that we have to generate some
357 -- dictionaries for the data type context, since we are going to
358 -- do some construction.
360 -- What dictionaries do we need? For the moment we assume that all
361 -- data constructors have the same context, and grab it from the first
362 -- constructor. If they have varying contexts then we'd have to
363 -- union the ones that could participate in the update.
365 tcExpr (RecordUpd record_expr rbinds)
366 = ASSERT( not (null rbinds) )
367 tcAddErrCtxt recordUpdCtxt $
369 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
370 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
372 -- Check that the field names are plausible
373 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
375 (tycon, inst_tys, data_cons) = --trace "TcExpr.getAppDataTyCon" $
376 getAppDataTyCon record_ty'
377 -- The record binds are non-empty (syntax); so at least one field
378 -- label will have been unified with record_ty by tcRecordBinds;
379 -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
380 (tyvars, theta, _, _) = dataConSig (head data_cons)
382 tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
383 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
384 checkTc (any (checkRecordFields rbinds) data_cons)
385 (badFieldsUpd rbinds) `thenTc_`
387 returnTc (RecordUpdOut record_expr' dicts rbinds',
388 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
391 tcExpr (ArithSeqIn seq@(From expr))
392 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
394 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
395 newMethod (ArithSeqOrigin seq)
396 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
398 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
402 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
403 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
404 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
406 tcAddErrCtxt (arithSeqCtxt in_expr) $
407 unifyTauTyList [ty1, ty2] `thenTc_`
409 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
410 newMethod (ArithSeqOrigin seq)
411 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
413 returnTc (ArithSeqOut (HsVar enum_from_then_id)
414 (FromThen expr1' expr2'),
415 lie1 `plusLIE` lie2 `plusLIE` lie3,
418 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
419 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
420 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
422 tcAddErrCtxt (arithSeqCtxt in_expr) $
423 unifyTauTyList [ty1,ty2] `thenTc_`
425 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
426 newMethod (ArithSeqOrigin seq)
427 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
429 returnTc (ArithSeqOut (HsVar enum_from_to_id)
430 (FromTo expr1' expr2'),
431 lie1 `plusLIE` lie2 `plusLIE` lie3,
434 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
435 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
436 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
437 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
439 tcAddErrCtxt (arithSeqCtxt in_expr) $
440 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
442 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
443 newMethod (ArithSeqOrigin seq)
444 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
446 returnTc (ArithSeqOut (HsVar eft_id)
447 (FromThenTo expr1' expr2' expr3'),
448 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
452 %************************************************************************
454 \subsection{Expressions type signatures}
456 %************************************************************************
459 tcExpr in_expr@(ExprWithTySig expr poly_ty)
460 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
461 tcHsType poly_ty `thenTc` \ sigma_sig ->
463 -- Check the tau-type part
464 tcSetErrCtxt (exprSigCtxt in_expr) $
465 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
467 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
469 unifyTauTy sig_tau' tau_ty `thenTc_`
471 -- Check the type variables of the signature
472 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
474 -- Check overloading constraints
475 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
477 (mkTyVarSet sig_tyvars')
478 sig_dicts lie `thenTc_`
480 -- If everything is ok, return the stuff unchanged, except for
481 -- the effect of any substutions etc. We simply discard the
482 -- result of the tcSimplifyAndCheck, except for any default
483 -- resolution it may have done, which is recorded in the
485 returnTc (texpr, lie, tau_ty)
488 %************************************************************************
490 \subsection{@tcApp@ typchecks an application}
492 %************************************************************************
495 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
496 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
498 TcType s) -- Type of the application
501 = -- First type-check the function
502 -- In the HsVar case we go straight to tcId to avoid hitting the
503 -- rank-2 check, which we check later here anyway
505 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
507 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
509 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
511 -- Check that the result type doesn't have any nested for-alls.
512 -- For example, a "build" on its own is no good; it must be applied to something.
513 checkTc (isTauTy res_ty)
514 (lurkingRank2Err fun fun_ty) `thenTc_`
516 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
519 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
520 -> TcType s -- The type of the function
521 -> [RenamedHsExpr] -- Arguments
522 -> TcM s ([TcExpr s], -- Typechecked args
524 TcType s) -- Result type of the application
526 tcApp_help orig_fun arg_no fun_ty []
527 = returnTc ([], emptyLIE, fun_ty)
529 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
530 = -- Expect the function to have type A->B
531 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
533 ) `thenTc` \ (expected_arg_ty, result_ty) ->
535 -- Type check the argument
536 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
537 tcArg expected_arg_ty arg
538 ) `thenTc` \ (arg', lie_arg) ->
541 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
544 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
549 tcArg :: TcType s -- Expected arg type
550 -> RenamedHsExpr -- Actual argument
551 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
553 tcArg expected_arg_ty arg
554 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
555 = -- The ordinary, non-rank-2 polymorphic case
556 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
557 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
558 returnTc (arg', lie_arg)
561 = -- Ha! The argument type of the function is a for-all type,
562 -- An example of rank-2 polymorphism.
564 -- No need to instantiate the argument type... it's must be the result
565 -- of instantiating a function involving rank-2 polymorphism, so there
566 -- isn't any danger of using the same tyvars twice
567 -- The argument type shouldn't be overloaded type (hence ASSERT)
569 -- To ensure that the forall'd type variables don't get unified with each
570 -- other or any other types, we make fresh *signature* type variables
571 -- and unify them with the tyvars.
572 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
574 (sig_theta, sig_tau) = splitRhoTy sig_rho
576 ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
578 -- Type-check the arg and unify with expected type
579 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
580 unifyTauTy sig_tau actual_arg_ty `thenTc_`
582 -- Check that the arg_tyvars havn't been constrained
583 -- The interesting bit here is that we must include the free variables
584 -- of the expected arg ty. Here's an example:
585 -- runST (newVar True)
586 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
587 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
588 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
589 -- So now s' isn't unconstrained because it's linked to a.
590 -- Conclusion: include the free vars of the expected arg type in the
591 -- list of "free vars" for the signature check.
593 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
594 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
595 checkSigTyVars sig_tyvars sig_tau
598 -- Check that there's no overloading involved
599 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
600 -- but which, on simplification, don't actually need a dictionary involving
601 -- the tyvar. So we have to do a proper simplification right here.
602 tcSimplifyRank2 (mkTyVarSet sig_tyvars)
603 lie_arg `thenTc` \ (free_insts, inst_binds) ->
605 -- This HsLet binds any Insts which came out of the simplification.
606 -- It's a bit out of place here, but using AbsBind involves inventing
607 -- a couple of new names which seems worse.
608 returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
612 mk_binds [] = EmptyBinds
613 mk_binds ((inst,rhs):inst_binds)
614 = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
618 %************************************************************************
620 \subsection{@tcId@ typchecks an identifier occurrence}
622 %************************************************************************
625 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
628 = -- Look up the Id and instantiate its type
629 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
632 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
634 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
635 tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
637 (tyvars, rho) = splitForAllTy inst_ty
639 instantiate_it2 (RealId id) tyvars rho
642 -- The instantiate_it loop runs round instantiating the Id.
643 -- It has to be a loop because we are now prepared to entertain
645 -- f:: forall a. Eq a => forall b. Baz b => tau
646 -- We want to instantiate this to
647 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
648 instantiate_it tc_id_occ ty
649 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
650 instantiate_it2 tc_id_occ tyvars rho
652 instantiate_it2 tc_id_occ tyvars rho
653 | null theta -- Is it overloaded?
654 = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
656 | otherwise -- Yes, it's overloaded
657 = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
658 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
659 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
660 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
663 (theta, tau) = splitRhoTy rho
664 arg_tys = mkTyVarTys tyvars
667 %************************************************************************
669 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
671 %************************************************************************
674 tcDoStmts do_or_lc stmts src_loc
675 = -- get the Monad and MonadZero classes
676 -- create type consisting of a fresh monad tyvar
677 tcAddSrcLoc src_loc $
678 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
681 -- Build the then and zero methods in case we need them
682 tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
683 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
684 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
686 (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
688 (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
690 (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
693 -- go :: [RenamedStmt] -> TcM s ([TcStmt s], LIE s, TcType s)
695 go [stmt@(ReturnStmt exp)] -- Must be last statement
696 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
697 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
698 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
699 returnTc ([ReturnStmt exp'], return_lie `plusLIE` exp_lie, mkAppTy m exp_ty)
701 go (stmt@(GuardStmt exp src_loc) : stmts)
702 = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
703 tcAddSrcLoc src_loc (
704 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
705 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
706 unifyTauTy boolTy exp_ty `thenTc_`
707 returnTc (GuardStmt exp' src_loc, exp_lie)
708 )) `thenTc` \ (stmt', stmt_lie) ->
709 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
710 returnTc (stmt' : stmts',
711 stmt_lie `plusLIE` stmts_lie `plusLIE` zero_lie,
714 go (stmt@(ExprStmt exp src_loc) : stmts)
715 = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
716 tcAddSrcLoc src_loc (
717 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
718 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
719 -- Check that exp has type (m tau) for some tau (doesn't matter what)
720 newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
721 unifyTauTy (mkAppTy m tau) exp_ty `thenTc_`
722 returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty, exp_ty)
723 )) `thenTc` \ (stmt', stmt_lie, stmt_ty, result_ty) ->
725 -- This is the last statement
726 returnTc ([stmt'], stmt_lie, result_ty)
728 -- More statments follow
729 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
730 returnTc (stmt' : stmts',
731 stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie,
734 go (stmt@(BindStmt pat exp src_loc) : stmts)
735 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
736 tcAddSrcLoc src_loc (
737 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
738 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
739 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
740 unifyTauTy (mkAppTy m pat_ty) exp_ty `thenTc_`
742 -- NB: the environment has been extended with the new binders
743 -- which the rhs can't "see", but the renamer should have made
744 -- sure that everything is distinct by now, so there's no problem.
745 -- Putting the tcExpr before the newMonoIds messes up the nesting
746 -- of error contexts, so I didn't bother
748 returnTc (BindStmt pat' exp' src_loc, pat', pat_lie `plusLIE` exp_lie)
749 )) `thenTc` \ (stmt', pat', stmt_lie) ->
751 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
753 returnTc (stmt' : stmts',
754 stmt_lie `plusLIE` stmts_lie `plusLIE` then_lie `plusLIE`
755 (if failureFreePat pat' then emptyLIE else zero_lie),
758 go (LetStmt binds : stmts)
759 = tcBindsAndThen -- No error context, but a binding group is
760 combine -- rather a large thing for an error context anyway
764 combine binds' stmts' = LetStmt binds' : stmts'
767 go stmts `thenTc` \ (stmts', final_lie, result_ty) ->
768 returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc,
773 %************************************************************************
775 \subsection{Record bindings}
777 %************************************************************************
779 Game plan for record bindings
780 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783 1. look up "field", to find its selector Id, which must have type
784 forall a1..an. T a1 .. an -> tau
785 where tau is the type of the field.
787 2. Instantiate this type
789 3. Unify the (T a1 .. an) part with the "expected result type", which
790 is passed in. This checks that all the field labels come from the
793 4. Type check the value using tcArg, passing tau as the expected
796 This extends OK when the field types are universally quantified.
798 Actually, to save excessive creation of fresh type variables,
803 :: TcType s -- Expected type of whole record
804 -> RenamedRecordBinds
805 -> TcM s (TcRecordBinds s, LIE s)
807 tcRecordBinds expected_record_ty rbinds
808 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
809 returnTc (rbinds', plusLIEs lies)
811 do_bind (field_label, rhs, pun_flag)
812 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
813 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
815 -- Record selectors all have type
816 -- forall a1..an. T a1 .. an -> tau
817 ASSERT( maybeToBool (getFunTy_maybe tau) )
819 -- Selector must have type RecordType -> FieldType
820 Just (record_ty, field_ty) = getFunTy_maybe tau
822 unifyTauTy expected_record_ty record_ty `thenTc_`
823 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
824 returnTc ((RealId sel_id, rhs', pun_flag), lie)
826 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
827 -- RecordBinds are field of the
828 -- specified constructor
829 checkRecordFields rbinds data_con
832 data_con_fields = dataConFieldLabels data_con
834 ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
836 match field_name field_label = field_name == fieldLabelName field_label
839 %************************************************************************
841 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
843 %************************************************************************
846 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
848 tcExprs [] = returnTc ([], emptyLIE, [])
850 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
851 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
852 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
856 % =================================================
863 pp_nest_hang :: String -> Pretty -> Pretty
864 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
867 Boring and alphabetical:
869 arithSeqCtxt expr sty
870 = ppHang (ppPStr SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
873 = ppSep [ppPStr SLIT("In the branches of a conditional:"),
874 pp_nest_hang "`then' branch:" (ppr sty b1),
875 pp_nest_hang "`else' branch:" (ppr sty b2)]
878 = ppHang (ppPStr SLIT("In a case expression:")) 4 (ppr sty expr)
881 = ppHang (ppPStr SLIT("In an expression with a type signature:"))
885 = ppHang (ppPStr SLIT("In a list expression:")) 4 (ppr sty expr)
888 = ppHang (ppPStr SLIT("In a predicate expression:")) 4 (ppr sty expr)
890 sectionRAppCtxt expr sty
891 = ppHang (ppPStr SLIT("In a right section:")) 4 (ppr sty expr)
893 sectionLAppCtxt expr sty
894 = ppHang (ppPStr SLIT("In a left section:")) 4 (ppr sty expr)
896 funAppCtxt fun arg_no arg sty
897 = ppHang (ppCat [ ppPStr SLIT("In the"), speakNth arg_no, ppPStr SLIT("argument of"),
898 ppr sty fun `ppBeside` ppStr ", namely"])
899 4 (pprParendExpr sty arg)
901 stmtCtxt ListComp stmt sty
902 = ppHang (ppPStr SLIT("In a list-comprehension qualifer:"))
905 stmtCtxt DoStmt stmt sty
906 = ppHang (ppPStr SLIT("In a do statement:"))
909 tooManyArgsCtxt f sty
910 = ppHang (ppPStr SLIT("Too many arguments in an application of the function"))
913 lurkingRank2Err fun fun_ty sty
914 = ppHang (ppCat [ppPStr SLIT("Illegal use of"), ppr sty fun])
915 4 (ppAboves [ppStr "It is applied to too few arguments,",
916 ppPStr SLIT("so that the result type has for-alls in it")])
918 rank2ArgCtxt arg expected_arg_ty sty
919 = ppHang (ppPStr SLIT("In a polymorphic function argument:"))
920 4 (ppSep [ppBeside (ppr sty arg) (ppPStr SLIT(" ::")),
921 ppr sty expected_arg_ty])
923 badFieldsUpd rbinds sty
924 = ppHang (ppPStr SLIT("No constructor has all these fields:"))
925 4 (interpp'SP sty fields)
927 fields = [field | (field, _, _) <- rbinds]
929 recordUpdCtxt sty = ppPStr SLIT("In a record update construct")
931 badFieldsCon con rbinds sty
932 = ppHang (ppBesides [ppPStr SLIT("Inconsistent constructor:"), ppr sty con])
933 4 (ppBesides [ppPStr SLIT("and fields:"), interpp'SP sty fields])
935 fields = [field | (field, _, _) <- rbinds]