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(..)
21 import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
22 TcIdOcc(..), TcRecordBinds(..),
27 import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
28 LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
29 newMethod, newMethodWithGivenTy, newDicts )
30 import TcBinds ( tcBindsAndThen )
31 import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
32 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 tcInstType, tcInstTcType, tcInstTyVars,
41 newTyVarTy, zonkTcTyVars, zonkTcType )
42 import TcKind ( TcKind )
44 import Class ( Class(..), getClassSig )
45 import FieldLabel ( fieldLabelName )
46 import Id ( Id(..), GenId, idType, dataConFieldLabels )
47 import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
48 import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
49 import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
50 floatPrimTy, addrPrimTy, addrTy,
51 boolTy, charTy, stringTy, mkListTy,
52 mkTupleTy, mkPrimIoTy )
53 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
54 getTyVar_maybe, getFunTy_maybe,
55 splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
56 isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
59 import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
60 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
61 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
62 enumFromClassOpKey, enumFromThenClassOpKey,
63 enumFromToClassOpKey, enumFromThenToClassOpKey,
64 monadClassKey, monadZeroClassKey )
66 import Name ( Name ) -- Instance
67 import Outputable ( interpp'SP )
68 import PprType ( GenType, GenTyVar ) -- Instances
69 import Maybes ( maybeToBool )
75 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
78 %************************************************************************
80 \subsection{The TAUT rules for variables}
82 %************************************************************************
86 = tcId name `thenTc` \ (expr', lie, res_ty) ->
88 -- Check that the result type doesn't have any nested for-alls.
89 -- For example, a "build" on its own is no good; it must be
90 -- applied to something.
91 checkTc (isTauTy res_ty)
92 (lurkingRank2Err name res_ty) `thenTc_`
94 returnTc (expr', lie, res_ty)
97 %************************************************************************
101 %************************************************************************
106 tcExpr (HsLit (HsInt i))
107 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
109 newOverloadedLit (LiteralOrigin (HsInt i))
110 (OverloadedIntegral i)
111 ty `thenNF_Tc` \ (lie, over_lit_id) ->
113 returnTc (HsVar over_lit_id, lie, ty)
115 tcExpr (HsLit (HsFrac f))
116 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
118 newOverloadedLit (LiteralOrigin (HsFrac f))
119 (OverloadedFractional f)
120 ty `thenNF_Tc` \ (lie, over_lit_id) ->
122 returnTc (HsVar over_lit_id, lie, ty)
124 tcExpr (HsLit lit@(HsLitLit s))
125 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
126 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
127 newDicts (LitLitOrigin (_UNPK_ s))
128 [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
129 returnTc (HsLitOut lit ty, dicts, ty)
135 tcExpr (HsLit lit@(HsCharPrim c))
136 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
138 tcExpr (HsLit lit@(HsStringPrim s))
139 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
141 tcExpr (HsLit lit@(HsIntPrim i))
142 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
144 tcExpr (HsLit lit@(HsFloatPrim f))
145 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
147 tcExpr (HsLit lit@(HsDoublePrim d))
148 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
151 Unoverloaded literals:
154 tcExpr (HsLit lit@(HsChar c))
155 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
157 tcExpr (HsLit lit@(HsString str))
158 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
161 %************************************************************************
163 \subsection{Other expression forms}
165 %************************************************************************
169 = tcMatch match `thenTc` \ (match',lie,ty) ->
170 returnTc (HsLam match', lie, ty)
172 tcExpr (HsApp e1 e2) = accum e1 [e2]
174 accum (HsApp e1 e2) args = accum e1 (e2:args)
176 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
177 returnTc (foldl HsApp fun' args', lie, res_ty)
179 -- equivalent to (op e1) e2:
180 tcExpr (OpApp arg1 op arg2)
181 = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
182 returnTc (OpApp arg1' op' arg2', lie, res_ty)
185 Note that the operators in sections are expected to be binary, and
186 a type error will occur if they aren't.
189 -- Left sections, equivalent to
196 tcExpr in_expr@(SectionL arg op)
197 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
199 -- Check that res_ty is a function type
200 -- Without this check we barf in the desugarer on
202 -- because it tries to desugar to
203 -- f op = \r -> 3 op r
204 -- so (3 `op`) had better be a function!
205 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
206 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
207 tcAddErrCtxt (sectionLAppCtxt in_expr) $
208 unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
210 returnTc (SectionL arg' op', lie, res_ty)
212 -- Right sections, equivalent to \ x -> x op expr, or
215 tcExpr in_expr@(SectionR op expr)
216 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
217 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
219 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
220 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
221 tcAddErrCtxt (sectionRAppCtxt in_expr) $
222 unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
224 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
227 The interesting thing about @ccall@ is that it is just a template
228 which we instantiate by filling in details about the types of its
229 argument and result (ie minimal typechecking is performed). So, the
230 basic story is that we allocate a load of type variables (to hold the
231 arg/result types); unify them with the args/result; and store them for
235 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
236 = -- Get the callable and returnable classes.
237 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
238 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
241 new_arg_dict (arg, arg_ty)
242 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
243 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
244 returnNF_Tc arg_dicts -- Actually a singleton bag
246 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
250 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
252 -- The argument types can be unboxed or boxed; the result
253 -- type must, however, be boxed since it's an argument to the PrimIO
255 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
257 -- Construct the extra insts, which encode the
258 -- constraints on the argument and result types.
259 mapNF_Tc new_arg_dict (args `zip` arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
260 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
262 returnTc (CCall lbl args' may_gc is_asm result_ty,
263 foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
264 mkPrimIoTy result_ty)
268 tcExpr (HsSCC label expr)
269 = tcExpr expr `thenTc` \ (expr', lie, expr_ty) ->
270 -- No unification. Give SCC the type of expr
271 returnTc (HsSCC label expr', lie, expr_ty)
273 tcExpr (HsLet binds expr)
275 HsLet -- The combiner
276 binds -- Bindings to check
277 (tcExpr expr) -- Typechecker for the expression
279 tcExpr in_expr@(HsCase expr matches src_loc)
280 = tcAddSrcLoc src_loc $
281 tcExpr expr `thenTc` \ (expr',lie1,expr_ty) ->
282 newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty ->
284 tcAddErrCtxt (caseCtxt in_expr) $
285 tcMatchesCase (mkFunTy expr_ty result_ty) matches
286 `thenTc` \ (matches',lie2) ->
288 returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
290 tcExpr (HsIf pred b1 b2 src_loc)
291 = tcAddSrcLoc src_loc $
292 tcExpr pred `thenTc` \ (pred',lie1,predTy) ->
294 tcAddErrCtxt (predCtxt pred) (
295 unifyTauTy predTy boolTy
298 tcExpr b1 `thenTc` \ (b1',lie2,result_ty) ->
299 tcExpr b2 `thenTc` \ (b2',lie3,b2Ty) ->
301 tcAddErrCtxt (branchCtxt b1 b2) $
302 unifyTauTy result_ty b2Ty `thenTc_`
304 returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
306 tcExpr (ListComp expr quals)
307 = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
308 returnTc (ListComp expr' quals', lie, ty)
312 tcExpr (HsDo stmts src_loc)
313 = -- get the Monad and MonadZero classes
314 -- create type consisting of a fresh monad tyvar
315 tcAddSrcLoc src_loc $
316 newTyVarTy monadKind `thenNF_Tc` \ m ->
317 tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
319 -- create dictionaries for monad and possibly monadzero
321 tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass ->
322 newDicts DoOrigin [(monadClass, m)]
324 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
325 ) `thenNF_Tc` \ (m_lie, [m_id]) ->
327 tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass ->
328 newDicts DoOrigin [(monadZeroClass, m)]
330 returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
331 ) `thenNF_Tc` \ (mz_lie, [mz_id]) ->
333 returnTc (HsDoOut stmts' m_id mz_id src_loc,
334 lie `plusLIE` m_lie `plusLIE` mz_lie,
337 monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
341 tcExpr (ExplicitList [])
342 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
343 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
346 tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
347 = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
348 tcAddErrCtxt (listCtxt in_expr) $
349 unifyTauTyList tys `thenTc_`
350 returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
352 tcExpr (ExplicitTuple exprs)
353 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
354 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
356 tcExpr (RecordCon (HsVar con) rbinds)
357 = tcGlobalOcc con `thenNF_Tc` \ (con_id, arg_tys, con_rho) ->
359 (con_theta, con_tau) = splitRhoTy con_rho
360 (_, record_ty) = splitFunTy con_tau
361 con_expr = mkHsTyApp (HsVar (RealId con_id)) arg_tys
364 ASSERT( null con_theta )
366 -- Con is syntactically constrained to be a data constructor
367 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
369 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
371 checkTc (checkRecordFields rbinds con_id)
372 (badFieldsCon con rbinds) `thenTc_`
374 returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty)
376 tcExpr (RecordUpd record_expr rbinds)
377 = tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
378 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
380 -- Check that the field names are plausible
381 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
383 maybe_tycon_stuff = maybeAppDataTyCon record_ty'
384 Just (tycon, args_tys, data_cons) = maybe_tycon_stuff
386 checkTc (maybeToBool maybe_tycon_stuff)
387 (panic "TcExpr:Records:mystery error message") `thenTc_`
388 checkTc (any (checkRecordFields rbinds) data_cons)
389 (badFieldsUpd rbinds) `thenTc_`
390 returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty)
392 tcExpr (ArithSeqIn seq@(From expr))
393 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
395 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
396 newMethod (ArithSeqOrigin seq)
397 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
399 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
403 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
404 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
405 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
407 tcAddErrCtxt (arithSeqCtxt in_expr) $
408 unifyTauTyList [ty1, ty2] `thenTc_`
410 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
411 newMethod (ArithSeqOrigin seq)
412 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
414 returnTc (ArithSeqOut (HsVar enum_from_then_id)
415 (FromThen expr1' expr2'),
416 lie1 `plusLIE` lie2 `plusLIE` lie3,
419 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
420 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
421 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
423 tcAddErrCtxt (arithSeqCtxt in_expr) $
424 unifyTauTyList [ty1,ty2] `thenTc_`
426 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
427 newMethod (ArithSeqOrigin seq)
428 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
430 returnTc (ArithSeqOut (HsVar enum_from_to_id)
431 (FromTo expr1' expr2'),
432 lie1 `plusLIE` lie2 `plusLIE` lie3,
435 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
436 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
437 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
438 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
440 tcAddErrCtxt (arithSeqCtxt in_expr) $
441 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
443 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
444 newMethod (ArithSeqOrigin seq)
445 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
447 returnTc (ArithSeqOut (HsVar eft_id)
448 (FromThenTo expr1' expr2' expr3'),
449 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
453 %************************************************************************
455 \subsection{Expressions type signatures}
457 %************************************************************************
460 tcExpr in_expr@(ExprWithTySig expr poly_ty)
461 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
462 tcPolyType poly_ty `thenTc` \ sigma_sig ->
464 -- Check the tau-type part
465 tcSetErrCtxt (exprSigCtxt in_expr) $
466 tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' ->
468 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
470 unifyTauTy tau_ty sig_tau' `thenTc_`
472 -- Check the type variables of the signature
473 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
475 -- Check overloading constraints
476 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
478 (mkTyVarSet sig_tyvars')
479 sig_dicts lie `thenTc_`
481 -- If everything is ok, return the stuff unchanged, except for
482 -- the effect of any substutions etc. We simply discard the
483 -- result of the tcSimplifyAndCheck, except for any default
484 -- resolution it may have done, which is recorded in the
486 returnTc (texpr, lie, tau_ty)
489 %************************************************************************
491 \subsection{@tcApp@ typchecks an application}
493 %************************************************************************
496 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
497 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
499 TcType s) -- Type of the application
502 = -- First type-check the function
503 -- In the HsVar case we go straight to tcId to avoid hitting the
504 -- rank-2 check, which we check later here anyway
506 HsVar name -> tcId name
508 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
510 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
512 -- Check that the result type doesn't have any nested for-alls.
513 -- For example, a "build" on its own is no good; it must be applied to something.
514 checkTc (isTauTy res_ty)
515 (lurkingRank2Err fun fun_ty) `thenTc_`
517 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
520 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
521 -> TcType s -- The type of the function
522 -> [RenamedHsExpr] -- Arguments
523 -> TcM s ([TcExpr s], -- Typechecked args
525 TcType s) -- Result type of the application
527 tcApp_help orig_fun arg_no fun_ty []
528 = returnTc ([], emptyLIE, fun_ty)
530 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
531 = -- Expect the function to have type A->B
532 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
534 ) `thenTc` \ (expected_arg_ty, result_ty) ->
536 -- Type check the argument
537 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
538 tcArg expected_arg_ty arg
539 ) `thenTc` \ (arg', lie_arg) ->
542 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
545 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
550 tcArg :: TcType s -- Expected arg type
551 -> RenamedHsExpr -- Actual argument
552 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
554 tcArg expected_arg_ty arg
555 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
556 = -- The ordinary, non-rank-2 polymorphic case
557 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
558 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
559 returnTc (arg', lie_arg)
562 = -- Ha! The argument type of the function is a for-all type,
563 -- An example of rank-2 polymorphism.
565 -- No need to instantiate the argument type... it's must be the result
566 -- of instantiating a function involving rank-2 polymorphism, so there
567 -- isn't any danger of using the same tyvars twice
568 -- The argument type shouldn't be overloaded type (hence ASSERT)
570 (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
572 ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things
574 -- Type-check the arg and unify with expected type
575 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
576 unifyTauTy expected_tau actual_arg_ty `thenTc_` (
578 -- Check that the arg_tyvars havn't been constrained
579 -- The interesting bit here is that we must include the free variables
580 -- of the expected arg ty. Here's an example:
581 -- runST (newVar True)
582 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
583 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
584 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
585 -- So now s' isn't unconstrained because it's linked to a.
586 -- Conclusion: include the free vars of the expected arg type in the
587 -- list of "free vars" for the signature check.
588 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
589 tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars ->
590 zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars ->
591 checkSigTyVarsGivenGlobals
592 (env_tyvars `unionTyVarSets` free_tyvars)
593 expected_tyvars expected_tau `thenTc_`
595 -- Check that there's no overloading involved
596 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
597 -- but which, on simplification, don't actually need a dictionary involving
598 -- the tyvar. So we have to do a proper simplification right here.
599 tcSimplifyRank2 (mkTyVarSet expected_tyvars)
600 lie_arg `thenTc` \ (free_insts, inst_binds) ->
602 -- This HsLet binds any Insts which came out of the simplification.
603 -- It's a bit out of place here, but using AbsBind involves inventing
604 -- a couple of new names which seems worse.
605 returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
611 mk_binds ((inst,rhs):inst_binds)
612 = (SingleBind (NonRecBind (VarMonoBind inst rhs)))
617 %************************************************************************
619 \subsection{@tcId@ typchecks an identifier occurrence}
621 %************************************************************************
624 tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s)
626 = -- Look up the Id and instantiate its type
627 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
631 (tyvars, rho) = splitForAllTy (idType tc_id)
633 tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) ->
634 tcInstTcType tenv rho `thenNF_Tc` \ rho' ->
635 returnNF_Tc (TcId tc_id, arg_tys', rho')
637 Nothing -> tcGlobalOcc name `thenNF_Tc` \ (id, arg_tys, rho) ->
638 returnNF_Tc (RealId id, arg_tys, rho)
640 ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
643 case splitRhoTy rho of
644 ([], tau) -> -- Not overloaded, so just make a type application
645 returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
647 (theta, tau) -> -- Overloaded, so make a Method inst
648 newMethodWithGivenTy (OccurrenceOf tc_id_occ)
649 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) ->
650 returnTc (HsVar meth_id, lie, tau)
655 %************************************************************************
657 \subsection{@tcQuals@ typchecks list comprehension qualifiers}
659 %************************************************************************
663 = tcExpr expr `thenTc` \ (expr', lie, ty) ->
664 returnTc ((expr',[]), lie, mkListTy ty)
666 tcListComp expr (qual@(FilterQual filter) : quals)
667 = tcAddErrCtxt (qualCtxt qual) (
668 tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) ->
669 unifyTauTy boolTy filter_ty `thenTc_`
670 returnTc (FilterQual filter', filter_lie)
671 ) `thenTc` \ (qual', qual_lie) ->
673 tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
675 returnTc ((expr', qual' : quals'),
676 qual_lie `plusLIE` rest_lie,
679 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
680 = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
682 tcAddErrCtxt (qualCtxt qual) (
683 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
684 tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
685 unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
686 returnTc (GeneratorQual pat' rhs',
687 lie_pat `plusLIE` lie_rhs)
688 ) `thenTc` \ (qual', lie_qual) ->
690 tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
692 returnTc ((expr', qual' : quals'),
693 lie_qual `plusLIE` lie_rest,
697 binder_names = collectPatBinders pat
699 tcListComp expr (LetQual binds : quals)
700 = tcBindsAndThen -- No error context, but a binding group is
701 combine -- rather a large thing for an error context anyway
703 (tcListComp expr quals)
705 combine binds' (expr',quals') = (expr', LetQual binds' : quals')
709 %************************************************************************
711 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
713 %************************************************************************
716 tcDoStmts :: Bool -- True => require a monad
719 -> TcM s (([TcStmt s],
720 Bool, -- True => Monad
721 Bool), -- True => MonadZero
725 tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
726 = tcAddSrcLoc src_loc $
727 tcSetErrCtxt (stmtCtxt stmt) $
728 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
730 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
731 unifyTauTy (mkAppTy m a) exp_ty
735 returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
737 tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
738 = tcAddSrcLoc src_loc (
739 tcSetErrCtxt (stmtCtxt stmt) (
740 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
741 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
742 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
743 returnTc (ExprStmt exp' src_loc, exp_lie)
744 )) `thenTc` \ (stmt', stmt_lie) ->
745 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
746 returnTc ((stmt':stmts', True, mzero),
747 stmt_lie `plusLIE` stmts_lie,
750 tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
751 = tcAddSrcLoc src_loc (
752 tcSetErrCtxt (stmtCtxt stmt) (
753 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
754 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
755 newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
756 unifyTauTy a pat_ty `thenTc_`
757 unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
758 returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
759 )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
760 tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
761 returnTc ((stmt':stmts', True, mzero || not failure_free),
762 stmt_lie `plusLIE` stmts_lie,
765 tcDoStmts monad m (LetStmt binds : stmts)
766 = tcBindsAndThen -- No error context, but a binding group is
767 combine -- rather a large thing for an error context anyway
769 (tcDoStmts monad m stmts)
771 combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
775 Game plan for record bindings
776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
779 1. look up "field", to find its selector Id, which must have type
780 forall a1..an. T a1 .. an -> tau
781 where tau is the type of the field.
783 2. Instantiate this type
785 3. Unify the (T a1 .. an) part with the "expected result type", which
786 is passed in. This checks that all the field labels come from the
789 4. Type check the value using tcArg, passing tau as the expected
792 This extends OK when the field types are universally quantified.
794 Actually, to save excessive creation of fresh type variables,
799 :: TcType s -- Expected type of whole record
800 -> RenamedRecordBinds
801 -> TcM s (TcRecordBinds s, LIE s)
803 tcRecordBinds expected_record_ty rbinds
804 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
805 returnTc (rbinds', plusLIEs lies)
807 do_bind (field_label, rhs, pun_flag)
808 = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) ->
810 -- Record selectors all have type
811 -- forall a1..an. T a1 .. an -> tau
812 ASSERT( maybeToBool (getFunTy_maybe tau) )
814 -- Selector must have type RecordType -> FieldType
815 Just (record_ty, field_ty) = getFunTy_maybe tau
817 unifyTauTy expected_record_ty record_ty `thenTc_`
818 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
819 returnTc ((RealId sel_id, rhs', pun_flag), lie)
821 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
822 -- RecordBinds are field of the
823 -- specified constructor
824 checkRecordFields rbinds data_con
827 data_con_fields = dataConFieldLabels data_con
829 ok (field_name, _, _) = any (match field_name) data_con_fields
831 match field_name field_label = field_name == fieldLabelName field_label
834 %************************************************************************
836 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
838 %************************************************************************
841 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
843 tcExprs [] = returnTc ([], emptyLIE, [])
845 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
846 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
847 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
851 % =================================================
858 pp_nest_hang :: String -> Pretty -> Pretty
859 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
862 Boring and alphabetical:
864 arithSeqCtxt expr sty
865 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
868 = ppSep [ppStr "In the branches of a conditional:",
869 pp_nest_hang "`then' branch:" (ppr sty b1),
870 pp_nest_hang "`else' branch:" (ppr sty b2)]
873 = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
876 = ppHang (ppStr "In an expression with a type signature:")
880 = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
883 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
885 sectionRAppCtxt expr sty
886 = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
888 sectionLAppCtxt expr sty
889 = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
891 funAppCtxt fun arg_no arg sty
892 = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
893 4 (ppCat [ppStr "namely", ppr sty arg])
896 = ppHang (ppStr "In a list-comprehension qualifer:")
900 = ppHang (ppStr "In a do statement:")
903 tooManyArgsCtxt f sty
904 = ppHang (ppStr "Too many arguments in an application of the function")
907 lurkingRank2Err fun fun_ty sty
908 = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
909 4 (ppAboves [ppStr "It is applied to too few arguments,",
910 ppStr "so that the result type has for-alls in it"])
912 rank2ArgCtxt arg expected_arg_ty sty
913 = ppHang (ppStr "In a polymorphic function argument:")
914 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
915 ppr sty expected_arg_ty])
917 badFieldsUpd rbinds sty
918 = ppHang (ppStr "In a record update construct, no constructor has all these fields:")
919 4 (interpp'SP sty fields)
921 fields = [field | (field, _, _) <- rbinds]
923 badFieldsCon con rbinds sty
924 = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
925 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
927 fields = [field | (field, _, _) <- rbinds]