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(..), Qualifier(..), Stmt(..),
14 HsBinds(..), Bind(..), MonoBinds(..),
15 ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
16 Match, Fake, InPat, OutPat, PolyType,
17 failureFreePat, 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,
36 import TcMatches ( tcMatchesCase, tcMatch )
37 import TcMonoType ( tcPolyType )
38 import TcPat ( tcPat )
39 import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
40 import TcType ( 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 GenSpecEtc ( checkSigTyVars )
51 import Name ( Name{-instance Eq-} )
52 import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
53 getTyVar_maybe, getFunTy_maybe, instantiateTy,
54 splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
55 isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
56 getAppDataTyCon, maybeAppDataTyCon
58 import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet )
59 import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
60 floatPrimTy, addrPrimTy
62 import TysWiredIn ( addrTy,
63 boolTy, charTy, stringTy, mkListTy,
64 mkTupleTy, mkPrimIoTy, primIoDataCon
66 import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
67 import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
68 enumFromClassOpKey, enumFromThenClassOpKey,
69 enumFromToClassOpKey, enumFromThenToClassOpKey,
70 thenMClassOpKey, zeroClassOpKey
72 import Outputable ( interpp'SP )
73 import PprType ( GenType, GenTyVar ) -- Instances
74 import Maybes ( maybeToBool )
80 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
83 %************************************************************************
85 \subsection{The TAUT rules for variables}
87 %************************************************************************
91 = tcId name `thenNF_Tc` \ (expr', lie, res_ty) ->
93 -- Check that the result type doesn't have any nested for-alls.
94 -- For example, a "build" on its own is no good; it must be
95 -- applied to something.
96 checkTc (isTauTy res_ty)
97 (lurkingRank2Err name res_ty) `thenTc_`
99 returnTc (expr', lie, res_ty)
102 %************************************************************************
104 \subsection{Literals}
106 %************************************************************************
111 tcExpr (HsLit (HsInt i))
112 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
114 newOverloadedLit (LiteralOrigin (HsInt i))
115 (OverloadedIntegral i)
116 ty `thenNF_Tc` \ (lie, over_lit_id) ->
118 returnTc (HsVar over_lit_id, lie, ty)
120 tcExpr (HsLit (HsFrac f))
121 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
123 newOverloadedLit (LiteralOrigin (HsFrac f))
124 (OverloadedFractional f)
125 ty `thenNF_Tc` \ (lie, over_lit_id) ->
127 returnTc (HsVar over_lit_id, lie, ty)
129 tcExpr (HsLit lit@(HsLitLit s))
130 = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
131 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ ty ->
132 newDicts (LitLitOrigin (_UNPK_ s))
133 [(cCallableClass, ty)] `thenNF_Tc` \ (dicts, _) ->
134 returnTc (HsLitOut lit ty, dicts, ty)
140 tcExpr (HsLit lit@(HsCharPrim c))
141 = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
143 tcExpr (HsLit lit@(HsStringPrim s))
144 = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
146 tcExpr (HsLit lit@(HsIntPrim i))
147 = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
149 tcExpr (HsLit lit@(HsFloatPrim f))
150 = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
152 tcExpr (HsLit lit@(HsDoublePrim d))
153 = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
156 Unoverloaded literals:
159 tcExpr (HsLit lit@(HsChar c))
160 = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
162 tcExpr (HsLit lit@(HsString str))
163 = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
166 %************************************************************************
168 \subsection{Other expression forms}
170 %************************************************************************
173 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
176 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
179 = tcMatch match `thenTc` \ (match',lie,ty) ->
180 returnTc (HsLam match', lie, ty)
182 tcExpr (HsApp e1 e2) = accum e1 [e2]
184 accum (HsApp e1 e2) args = accum e1 (e2:args)
186 = tcApp fun args `thenTc` \ (fun', args', lie, res_ty) ->
187 returnTc (foldl HsApp fun' args', lie, res_ty)
189 -- equivalent to (op e1) e2:
190 tcExpr (OpApp arg1 op arg2)
191 = tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
192 returnTc (OpApp arg1' op' arg2', lie, res_ty)
195 Note that the operators in sections are expected to be binary, and
196 a type error will occur if they aren't.
199 -- Left sections, equivalent to
206 tcExpr in_expr@(SectionL arg op)
207 = tcApp op [arg] `thenTc` \ (op', [arg'], lie, res_ty) ->
209 -- Check that res_ty is a function type
210 -- Without this check we barf in the desugarer on
212 -- because it tries to desugar to
213 -- f op = \r -> 3 op r
214 -- so (3 `op`) had better be a function!
215 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
216 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
217 tcAddErrCtxt (sectionLAppCtxt in_expr) $
218 unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
220 returnTc (SectionL arg' op', lie, res_ty)
222 -- Right sections, equivalent to \ x -> x op expr, or
225 tcExpr in_expr@(SectionR op expr)
226 = tcExpr op `thenTc` \ (op', lie1, op_ty) ->
227 tcExpr expr `thenTc` \ (expr',lie2, expr_ty) ->
229 newTyVarTy mkTypeKind `thenNF_Tc` \ ty1 ->
230 newTyVarTy mkTypeKind `thenNF_Tc` \ ty2 ->
231 tcAddErrCtxt (sectionRAppCtxt in_expr) $
232 unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2) `thenTc_`
234 returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
237 The interesting thing about @ccall@ is that it is just a template
238 which we instantiate by filling in details about the types of its
239 argument and result (ie minimal typechecking is performed). So, the
240 basic story is that we allocate a load of type variables (to hold the
241 arg/result types); unify them with the args/result; and store them for
245 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
246 = -- Get the callable and returnable classes.
247 tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
248 tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
251 new_arg_dict (arg, arg_ty)
252 = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
253 [(cCallableClass, arg_ty)] `thenNF_Tc` \ (arg_dicts, _) ->
254 returnNF_Tc arg_dicts -- Actually a singleton bag
256 result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
260 tcExprs args `thenTc` \ (args', args_lie, arg_tys) ->
262 -- The argument types can be unboxed or boxed; the result
263 -- type must, however, be boxed since it's an argument to the PrimIO
265 newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
267 -- Construct the extra insts, which encode the
268 -- constraints on the argument and result types.
269 mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
270 newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
272 returnTc (HsCon primIoDataCon [result_ty] [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 predTy boolTy
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)
317 tcExpr (ListComp expr quals)
318 = tcListComp expr quals `thenTc` \ ((expr',quals'), lie, ty) ->
319 returnTc (ListComp expr' quals', lie, ty)
323 tcExpr expr@(HsDo stmts src_loc)
324 = tcDoStmts stmts src_loc
328 tcExpr (ExplicitList [])
329 = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty ->
330 returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
333 tcExpr in_expr@(ExplicitList exprs) -- Non-empty list
334 = tcExprs exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
335 tcAddErrCtxt (listCtxt in_expr) $
336 unifyTauTyList tys `thenTc_`
337 returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
339 tcExpr (ExplicitTuple exprs)
340 = tcExprs exprs `thenTc` \ (exprs', lie, tys) ->
341 returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
343 tcExpr (RecordCon (HsVar con) rbinds)
344 = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
346 (_, record_ty) = splitFunTy con_tau
348 -- Con is syntactically constrained to be a data constructor
349 ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
351 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
353 -- Check that the record bindings match the constructor
354 tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
355 checkTc (checkRecordFields rbinds con_id)
356 (badFieldsCon con rbinds) `thenTc_`
358 returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
360 -- One small complication in RecordUpd is that we have to generate some
361 -- dictionaries for the data type context, since we are going to
362 -- do some construction.
364 -- What dictionaries do we need? For the moment we assume that all
365 -- data constructors have the same context, and grab it from the first
366 -- constructor. If they have varying contexts then we'd have to
367 -- union the ones that could participate in the update.
369 tcExpr (RecordUpd record_expr rbinds)
370 = ASSERT( not (null rbinds) )
371 tcAddErrCtxt recordUpdCtxt $
373 tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) ->
374 tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
376 -- Check that the field names are plausible
377 zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
379 (tycon, inst_tys, data_cons) = trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty'
380 -- The record binds are non-empty (syntax); so at least one field
381 -- label will have been unified with record_ty by tcRecordBinds;
382 -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
383 (tyvars, theta, _, _) = dataConSig (head data_cons)
385 tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' ->
386 newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
387 checkTc (any (checkRecordFields rbinds) data_cons)
388 (badFieldsUpd rbinds) `thenTc_`
390 returnTc (RecordUpdOut record_expr' dicts rbinds',
391 con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
394 tcExpr (ArithSeqIn seq@(From expr))
395 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
397 tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
398 newMethod (ArithSeqOrigin seq)
399 (RealId sel_id) [ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
401 returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
405 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
406 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
407 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
409 tcAddErrCtxt (arithSeqCtxt in_expr) $
410 unifyTauTyList [ty1, ty2] `thenTc_`
412 tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
413 newMethod (ArithSeqOrigin seq)
414 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
416 returnTc (ArithSeqOut (HsVar enum_from_then_id)
417 (FromThen expr1' expr2'),
418 lie1 `plusLIE` lie2 `plusLIE` lie3,
421 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
422 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
423 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
425 tcAddErrCtxt (arithSeqCtxt in_expr) $
426 unifyTauTyList [ty1,ty2] `thenTc_`
428 tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
429 newMethod (ArithSeqOrigin seq)
430 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
432 returnTc (ArithSeqOut (HsVar enum_from_to_id)
433 (FromTo expr1' expr2'),
434 lie1 `plusLIE` lie2 `plusLIE` lie3,
437 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
438 = tcExpr expr1 `thenTc` \ (expr1',lie1,ty1) ->
439 tcExpr expr2 `thenTc` \ (expr2',lie2,ty2) ->
440 tcExpr expr3 `thenTc` \ (expr3',lie3,ty3) ->
442 tcAddErrCtxt (arithSeqCtxt in_expr) $
443 unifyTauTyList [ty1,ty2,ty3] `thenTc_`
445 tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
446 newMethod (ArithSeqOrigin seq)
447 (RealId sel_id) [ty1] `thenNF_Tc` \ (lie4, eft_id) ->
449 returnTc (ArithSeqOut (HsVar eft_id)
450 (FromThenTo expr1' expr2' expr3'),
451 lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
455 %************************************************************************
457 \subsection{Expressions type signatures}
459 %************************************************************************
462 tcExpr in_expr@(ExprWithTySig expr poly_ty)
463 = tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
464 tcPolyType poly_ty `thenTc` \ sigma_sig ->
466 -- Check the tau-type part
467 tcSetErrCtxt (exprSigCtxt in_expr) $
468 tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
470 (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
472 unifyTauTy tau_ty sig_tau' `thenTc_`
474 -- Check the type variables of the signature
475 checkSigTyVars sig_tyvars' sig_tau' `thenTc_`
477 -- Check overloading constraints
478 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
480 (mkTyVarSet sig_tyvars')
481 sig_dicts lie `thenTc_`
483 -- If everything is ok, return the stuff unchanged, except for
484 -- the effect of any substutions etc. We simply discard the
485 -- result of the tcSimplifyAndCheck, except for any default
486 -- resolution it may have done, which is recorded in the
488 returnTc (texpr, lie, tau_ty)
491 %************************************************************************
493 \subsection{@tcApp@ typchecks an application}
495 %************************************************************************
498 tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
499 -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
501 TcType s) -- Type of the application
504 = -- First type-check the function
505 -- In the HsVar case we go straight to tcId to avoid hitting the
506 -- rank-2 check, which we check later here anyway
508 HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
510 ) `thenTc` \ (fun', lie_fun, fun_ty) ->
512 tcApp_help fun 1 fun_ty args `thenTc` \ (args', lie_args, res_ty) ->
514 -- Check that the result type doesn't have any nested for-alls.
515 -- For example, a "build" on its own is no good; it must be applied to something.
516 checkTc (isTauTy res_ty)
517 (lurkingRank2Err fun fun_ty) `thenTc_`
519 returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
522 tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error message(s)
523 -> TcType s -- The type of the function
524 -> [RenamedHsExpr] -- Arguments
525 -> TcM s ([TcExpr s], -- Typechecked args
527 TcType s) -- Result type of the application
529 tcApp_help orig_fun arg_no fun_ty []
530 = returnTc ([], emptyLIE, fun_ty)
532 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
533 = -- Expect the function to have type A->B
534 tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
536 ) `thenTc` \ (expected_arg_ty, result_ty) ->
538 -- Type check the argument
539 tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
540 tcArg expected_arg_ty arg
541 ) `thenTc` \ (arg', lie_arg) ->
544 tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) ->
547 returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
552 tcArg :: TcType s -- Expected arg type
553 -> RenamedHsExpr -- Actual argument
554 -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
556 tcArg expected_arg_ty arg
557 | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
558 = -- The ordinary, non-rank-2 polymorphic case
559 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
560 unifyTauTy expected_arg_ty actual_arg_ty `thenTc_`
561 returnTc (arg', lie_arg)
564 = -- Ha! The argument type of the function is a for-all type,
565 -- An example of rank-2 polymorphism.
567 -- No need to instantiate the argument type... it's must be the result
568 -- of instantiating a function involving rank-2 polymorphism, so there
569 -- isn't any danger of using the same tyvars twice
570 -- The argument type shouldn't be overloaded type (hence ASSERT)
572 -- To ensure that the forall'd type variables don't get unified with each
573 -- other or any other types, we make fresh *signature* type variables
574 -- and unify them with the tyvars.
575 tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
577 (sig_theta, sig_tau) = splitRhoTy sig_rho
579 ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things
581 -- Type-check the arg and unify with expected type
582 tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
583 unifyTauTy sig_tau actual_arg_ty `thenTc_`
585 -- Check that the arg_tyvars havn't been constrained
586 -- The interesting bit here is that we must include the free variables
587 -- of the expected arg ty. Here's an example:
588 -- runST (newVar True)
589 -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
590 -- for (newVar True), with s fresh. Then we unify with the runST's arg type
591 -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
592 -- So now s' isn't unconstrained because it's linked to a.
593 -- Conclusion: include the free vars of the expected arg type in the
594 -- list of "free vars" for the signature check.
596 tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
597 tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
598 checkSigTyVars sig_tyvars sig_tau
601 -- Check that there's no overloading involved
602 -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
603 -- but which, on simplification, don't actually need a dictionary involving
604 -- the tyvar. So we have to do a proper simplification right here.
605 tcSimplifyRank2 (mkTyVarSet sig_tyvars)
606 lie_arg `thenTc` \ (free_insts, inst_binds) ->
608 -- This HsLet binds any Insts which came out of the simplification.
609 -- It's a bit out of place here, but using AbsBind involves inventing
610 -- a couple of new names which seems worse.
611 returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
615 mk_binds [] = EmptyBinds
616 mk_binds ((inst,rhs):inst_binds)
617 = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds`
621 %************************************************************************
623 \subsection{@tcId@ typchecks an identifier occurrence}
625 %************************************************************************
628 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
631 = -- Look up the Id and instantiate its type
632 tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
635 Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
637 Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
638 tcInstType [] (idType id) `thenNF_Tc` \ inst_ty ->
640 (tyvars, rho) = splitForAllTy inst_ty
642 instantiate_it2 (RealId id) tyvars rho
645 -- The instantiate_it loop runs round instantiating the Id.
646 -- It has to be a loop because we are now prepared to entertain
648 -- f:: forall a. Eq a => forall b. Baz b => tau
649 -- We want to instantiate this to
650 -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
651 instantiate_it tc_id_occ ty
652 = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
653 instantiate_it2 tc_id_occ tyvars rho
655 instantiate_it2 tc_id_occ tyvars rho
656 | null theta -- Is it overloaded?
657 = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
659 | otherwise -- Yes, it's overloaded
660 = newMethodWithGivenTy (OccurrenceOf tc_id_occ)
661 tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) ->
662 instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
663 returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
666 (theta, tau) = splitRhoTy rho
667 arg_tys = mkTyVarTys tyvars
670 %************************************************************************
672 \subsection{@tcQuals@ typechecks list-comprehension qualifiers}
674 %************************************************************************
678 = tcExpr expr `thenTc` \ (expr', lie, ty) ->
679 returnTc ((expr',[]), lie, mkListTy ty)
681 tcListComp expr (qual@(FilterQual filter) : quals)
682 = tcAddErrCtxt (qualCtxt qual) (
683 tcExpr filter `thenTc` \ (filter', filter_lie, filter_ty) ->
684 unifyTauTy boolTy filter_ty `thenTc_`
685 returnTc (FilterQual filter', filter_lie)
686 ) `thenTc` \ (qual', qual_lie) ->
688 tcListComp expr quals `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
690 returnTc ((expr', qual' : quals'),
691 qual_lie `plusLIE` rest_lie,
694 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
695 = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
697 tcAddErrCtxt (qualCtxt qual) (
698 tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
699 tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
700 -- NB: the environment has been extended with the new binders
701 -- which the rhs can't "see", but the renamer should have made
702 -- sure that everything is distinct by now, so there's no problem.
703 -- Putting the tcExpr before the newMonoIds messes up the nesting
704 -- of error contexts, so I didn't bother
706 unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
707 returnTc (GeneratorQual pat' rhs',
708 lie_pat `plusLIE` lie_rhs)
709 ) `thenTc` \ (qual', lie_qual) ->
711 tcListComp expr quals `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
713 returnTc ((expr', qual' : quals'),
714 lie_qual `plusLIE` lie_rest,
718 binder_names = collectPatBinders pat
720 tcListComp expr (LetQual binds : quals)
721 = tcBindsAndThen -- No error context, but a binding group is
722 combine -- rather a large thing for an error context anyway
724 (tcListComp expr quals)
726 combine binds' (expr',quals') = (expr', LetQual binds' : quals')
730 %************************************************************************
732 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
734 %************************************************************************
737 tcDoStmts stmts src_loc
738 = -- get the Monad and MonadZero classes
739 -- create type consisting of a fresh monad tyvar
740 tcAddSrcLoc src_loc $
741 newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
744 -- Build the then and zero methods in case we need them
745 tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
746 tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
748 (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
750 (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
754 = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
755 unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
758 go [stmt@(ExprStmt exp src_loc)]
759 = tcAddSrcLoc src_loc $
760 tcSetErrCtxt (stmtCtxt stmt) $
761 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
762 returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
764 go (stmt@(ExprStmt exp src_loc) : stmts)
765 = tcAddSrcLoc src_loc (
766 tcSetErrCtxt (stmtCtxt stmt) (
767 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
768 get_m_arg exp_ty `thenTc` \ a ->
769 returnTc (a, exp', exp_lie)
770 )) `thenTc` \ (a, exp', exp_lie) ->
771 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
772 get_m_arg stmts_ty `thenTc` \ b ->
773 returnTc (ExprStmtOut exp' src_loc a b : stmts',
774 exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
777 go (stmt@(BindStmt pat exp src_loc) : stmts)
778 = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
779 tcAddSrcLoc src_loc (
780 tcSetErrCtxt (stmtCtxt stmt) (
781 tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
782 tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
783 -- See comments with tcListComp on GeneratorQual
785 get_m_arg exp_ty `thenTc` \ a ->
786 unifyTauTy a pat_ty `thenTc_`
787 returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
788 )) `thenTc` \ (a, pat', exp', stmt_lie) ->
789 go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
790 get_m_arg stmts_ty `thenTc` \ b ->
791 returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
792 stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
793 (if failureFreePat pat' then emptyLIE else mz_lie),
796 go (LetStmt binds : stmts)
797 = tcBindsAndThen -- No error context, but a binding group is
798 combine -- rather a large thing for an error context anyway
802 combine binds' stmts' = LetStmt binds' : stmts'
805 go stmts `thenTc` \ (stmts', final_lie, final_ty) ->
806 returnTc (HsDoOut stmts' then_id zero_id src_loc,
811 Game plan for record bindings
812 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
815 1. look up "field", to find its selector Id, which must have type
816 forall a1..an. T a1 .. an -> tau
817 where tau is the type of the field.
819 2. Instantiate this type
821 3. Unify the (T a1 .. an) part with the "expected result type", which
822 is passed in. This checks that all the field labels come from the
825 4. Type check the value using tcArg, passing tau as the expected
828 This extends OK when the field types are universally quantified.
830 Actually, to save excessive creation of fresh type variables,
835 :: TcType s -- Expected type of whole record
836 -> RenamedRecordBinds
837 -> TcM s (TcRecordBinds s, LIE s)
839 tcRecordBinds expected_record_ty rbinds
840 = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
841 returnTc (rbinds', plusLIEs lies)
843 do_bind (field_label, rhs, pun_flag)
844 = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
845 tcInstId sel_id `thenNF_Tc` \ (_, _, tau) ->
847 -- Record selectors all have type
848 -- forall a1..an. T a1 .. an -> tau
849 ASSERT( maybeToBool (getFunTy_maybe tau) )
851 -- Selector must have type RecordType -> FieldType
852 Just (record_ty, field_ty) = getFunTy_maybe tau
854 unifyTauTy expected_record_ty record_ty `thenTc_`
855 tcArg field_ty rhs `thenTc` \ (rhs', lie) ->
856 returnTc ((RealId sel_id, rhs', pun_flag), lie)
858 checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in
859 -- RecordBinds are field of the
860 -- specified constructor
861 checkRecordFields rbinds data_con
864 data_con_fields = dataConFieldLabels data_con
866 ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
868 match field_name field_label = field_name == fieldLabelName field_label
871 %************************************************************************
873 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
875 %************************************************************************
878 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
880 tcExprs [] = returnTc ([], emptyLIE, [])
882 = tcExpr expr `thenTc` \ (expr', lie1, ty) ->
883 tcExprs exprs `thenTc` \ (exprs', lie2, tys) ->
884 returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
888 % =================================================
895 pp_nest_hang :: String -> Pretty -> Pretty
896 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
899 Boring and alphabetical:
901 arithSeqCtxt expr sty
902 = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
905 = ppSep [ppStr "In the branches of a conditional:",
906 pp_nest_hang "`then' branch:" (ppr sty b1),
907 pp_nest_hang "`else' branch:" (ppr sty b2)]
910 = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
913 = ppHang (ppStr "In an expression with a type signature:")
917 = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
920 = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
922 sectionRAppCtxt expr sty
923 = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
925 sectionLAppCtxt expr sty
926 = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
928 funAppCtxt fun arg_no arg sty
929 = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
930 4 (ppCat [ppStr "namely", ppr sty arg])
933 = ppHang (ppStr "In a list-comprehension qualifer:")
937 = ppHang (ppStr "In a do statement:")
940 tooManyArgsCtxt f sty
941 = ppHang (ppStr "Too many arguments in an application of the function")
944 lurkingRank2Err fun fun_ty sty
945 = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
946 4 (ppAboves [ppStr "It is applied to too few arguments,",
947 ppStr "so that the result type has for-alls in it"])
949 rank2ArgCtxt arg expected_arg_ty sty
950 = ppHang (ppStr "In a polymorphic function argument:")
951 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
952 ppr sty expected_arg_ty])
954 badFieldsUpd rbinds sty
955 = ppHang (ppStr "No constructor has all these fields:")
956 4 (interpp'SP sty fields)
958 fields = [field | (field, _, _) <- rbinds]
960 recordUpdCtxt sty = ppStr "In a record update construct"
962 badFieldsCon con rbinds sty
963 = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
964 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
966 fields = [field | (field, _, _) <- rbinds]